lib/Hcompta/Stats.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TupleSections #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Hcompta.Stats where
  12
  13 -- import           Control.Applicative (Const(..))
  14 import           Data.Data
  15 import           Data.Eq (Eq(..))
  16 import           Data.Foldable (Foldable(..))
  17 import           Data.Functor ((<$>))
  18 import           Data.Map.Strict (Map)
  19 import qualified Data.Map.Strict as Data.Map
  20 import           Data.Maybe (Maybe(..), maybe)
  21 import           Data.Monoid (Monoid(..))
  22 import           Data.Ord (Ord(..))
  23 import           Data.Text (Text)
  24 import           Data.Typeable ()
  25 import           Prelude (($), (.), Int, Integer, Num(..), Show(..), const, flip, id)
  26
  27 import           Hcompta.Account (Account)
  28 import qualified Hcompta.Account as Account
  29 import qualified Hcompta.Amount as Amount
  30 import qualified Hcompta.Amount.Unit as Amount.Unit
  31 import           Hcompta.Date (Date)
  32 import           Hcompta.Lib.Consable (Consable(..))
  33 import           Hcompta.Lib.Interval (Interval)
  34 import qualified Hcompta.Lib.Interval as Interval
  35 import qualified Hcompta.Tag as Tag
  36
  37 -- * Requirements' interface
  38
  39 -- ** Class 'Unit'
  40
  41 class Unit a where
  42         unit_text :: a -> Text
  43
  44 instance Unit Amount.Unit where
  45         unit_text = Amount.Unit.text
  46
  47 -- ** Class 'Amount'
  48
  49 class
  50  ( Data (Amount_Unit a)
  51  , Ord  (Amount_Unit a)
  52  , Show (Amount_Unit a)
  53  , Unit (Amount_Unit a)
  54  )
  55  =>    Amount      a where
  56         type Amount_Unit a
  57         amount_unit :: a -> Amount_Unit a
  58
  59 instance Amount    Amount.Amount where
  60         type Amount_Unit Amount.Amount = Amount.Unit
  61         amount_unit = Amount.unit
  62
  63 -- ** Class 'Posting'
  64
  65 class Amount (Posting_Amount p)
  66  =>    Posting        p where
  67         type Posting_Amount p
  68         posting_account :: p -> Account
  69         posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
  70
  71 -- ** Class 'Transaction'
  72
  73 class
  74  ( Posting  (Transaction_Posting  t)
  75  , Foldable (Transaction_Postings t)
  76  )
  77  =>    Transaction          t where
  78         type Transaction_Posting  t
  79         type Transaction_Postings t :: * -> *
  80         transaction_date          :: t -> Date
  81         transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
  82         transaction_postings_size :: t -> Int
  83         transaction_postings_size = Data.Foldable.foldr (const $ (+) 1) 0 . transaction_postings
  84         transaction_tags          :: t -> Tag.Tags
  85
  86 -- * Type 'Stats'
  87
  88 data Transaction t => Stats t
  89  = Stats
  90  { stats_accounts          :: !(Map Account ())
  91  , stats_tags              :: !(Map Tag.Path (Map Text Integer))
  92  , stats_transactions      :: !Integer
  93  , stats_transactions_span :: !(Maybe (Interval Date))
  94  , stats_units             :: !(Map (Amount_Unit (Posting_Amount (Transaction_Posting t))) ())
  95  }
  96 deriving instance ( Transaction    transaction
  97                   , Data           transaction
  98                   ) => Data (Stats transaction)
  99 deriving instance ( Transaction  transaction
 100                   , Eq           transaction
 101                   ) => Eq (Stats transaction)
 102 deriving instance ( Transaction    transaction
 103                   , Show           transaction
 104                   ) => Show (Stats transaction)
 105 deriving instance Typeable1 Stats
 106
 107 empty :: Transaction t => Stats t
 108 empty =
 109         Stats
 110          { stats_accounts = mempty
 111          , stats_tags = mempty
 112          , stats_transactions = 0
 113          , stats_transactions_span = Nothing
 114          , stats_units = mempty
 115          }
 116
 117 stats_accounts_depths :: Transaction t => Stats t -> Interval Integer
 118 stats_accounts_depths s =
 119         case Data.Map.keys $ stats_accounts s of
 120          [] -> Interval.point 0
 121          a:as ->
 122                 Data.Foldable.foldr
 123                  (Interval.span . Interval.point . Account.depth)
 124                  (Interval.point $ Account.depth a) as
 125
 126 -- | Return the given 'Stats'
 127 --   updated by the given 'Transaction'.
 128 --
 129 -- NOTE: to reduce memory consumption when 'cons'ing iteratively,
 130 --       the given 'Stats' is matched strictly.
 131 cons :: Transaction t => t -> Stats t -> Stats t
 132 cons t !s =
 133         Stats
 134          { stats_accounts =
 135                 Data.Foldable.foldl'
 136                  (flip $ (\p -> Data.Map.insert (posting_account p) ()))
 137                  (stats_accounts s)
 138                  (transaction_postings t)
 139          , stats_tags =
 140                 Data.Map.mergeWithKey
 141                  (\_k x1 x2 -> Just $
 142                         Data.Map.unionWith (+) x1 $
 143                         Data.Map.fromListWith (+) $ (, 1) <$> x2)
 144                  id ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
 145                  (stats_tags s)       -- Map Text (Map Text Integer)
 146                  (Tag.unTags $ transaction_tags t) -- Map Text [Text]
 147          , stats_transactions = 1 + (stats_transactions s)
 148          , stats_transactions_span =
 149                 let i = Interval.point $ transaction_date t in
 150                 maybe (Just i) (Just . Interval.span i)
 151                  (stats_transactions_span s)
 152          , stats_units =
 153                 Data.Foldable.foldl'
 154                  (\su ->
 155                         Data.Foldable.foldl'
 156                          (flip $ (\a -> Data.Map.insert (amount_unit a) ()))
 157                          su . posting_amounts)
 158                  (stats_units s)
 159                  (transaction_postings t)
 160          }
 161
 162 union :: Transaction t => Stats t -> Stats t -> Stats t
 163 union s0 s1 =
 164         Stats
 165          { stats_accounts =
 166                 Data.Map.unionWith
 167                  (const::()->()->())
 168                  (stats_accounts s0)
 169                  (stats_accounts s1)
 170          , stats_tags =
 171                 Data.Map.unionWith
 172                  (Data.Map.unionWith (+))
 173                  (stats_tags s0)
 174                  (stats_tags s1)
 175          , stats_transactions =
 176                 (+)
 177                  (stats_transactions s0)
 178                  (stats_transactions s1)
 179          , stats_transactions_span = do
 180                 case
 181                  ( stats_transactions_span s0
 182                  , stats_transactions_span s1
 183                  ) of
 184                  (Nothing, Nothing) -> Nothing
 185                  (Just i0, Nothing) -> Just i0
 186                  (Nothing, Just i1) -> Just i1
 187                  (Just i0, Just i1) -> Just $ Interval.span i0 i1
 188          , stats_units =
 189                 Data.Map.unionWith
 190                  (const::()->()->())
 191                  (stats_units s0)
 192                  (stats_units s1)
 193          }
 194
 195 instance Transaction t => Monoid (Stats t) where
 196         mempty  = empty
 197         mappend = union
 198
 199 instance Transaction t => Consable () (Stats) t where
 200         mcons () t !s = cons t s