lib/Hcompta/Stats.hs

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