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