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