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  ) =>  Transaction          t where
  64         type Transaction_Posting  t
  65         type Transaction_Postings t :: * -> *
  66         transaction_date          :: t -> Date
  67         transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
  68         transaction_postings_size :: t -> Int
  69         transaction_postings_size = foldr (const $ (+) 1) 0 . transaction_postings
  70         transaction_tags          :: t -> Transaction_Tags
  71
  72 -- * Type 'Stats'
  73
  74 data Transaction t
  75  => Stats t
  76  =  Stats
  77  { stats_accounts          :: Map (Posting_Account (Transaction_Posting t)) ()
  78  , stats_tags              :: Map Tag.Path (Map Text Integer)
  79  , stats_transactions      :: Integer
  80  , stats_transactions_span :: Maybe (Interval Date)
  81  , stats_units             :: Map (Posting_Unit (Transaction_Posting t)) ()
  82  }
  83 deriving instance ( Transaction    transaction
  84                   , Data           transaction
  85                   ) => Data (Stats transaction)
  86 deriving instance ( Transaction  transaction
  87                   , Eq           transaction
  88                   ) => Eq (Stats transaction)
  89 deriving instance ( Transaction    transaction
  90                   , Show           transaction
  91                   ) => Show (Stats transaction)
  92 deriving instance Typeable1 Stats
  93 instance
  94  ( NFData t
  95  , Transaction t
  96  ) => NFData (Stats t) where
  97         rnf
  98          (Stats
  99          { stats_accounts
 100          , stats_tags
 101          , stats_transactions
 102          , stats_transactions_span
 103          , stats_units
 104          }) =
 105                 rnf stats_accounts `seq`
 106                 rnf stats_tags `seq`
 107                 rnf stats_transactions `seq`
 108                 rnf stats_transactions_span `seq`
 109                 rnf stats_units
 110
 111 empty :: Transaction t => Stats t
 112 empty =
 113         Stats
 114          { stats_accounts          = mempty
 115          , stats_tags              = mempty
 116          , stats_transactions      = 0
 117          , stats_transactions_span = Nothing
 118          , stats_units             = mempty
 119          }
 120
 121 stats_accounts_depths :: Transaction t => Stats t -> Interval Integer
 122 stats_accounts_depths s =
 123         case Map.keys $ stats_accounts s of
 124          [] -> Interval.point 0
 125          a:as ->
 126                 foldr
 127                  (Interval.span . Interval.point . Account.depth)
 128                  (Interval.point $ Account.depth a) as
 129
 130 -- | Return the given 'Stats'
 131 --   updated by the given 'Transaction'.
 132 --
 133 -- NOTE: to reduce memory consumption when 'cons'ing iteratively,
 134 --       the given 'Stats' is matched strictly.
 135 cons :: Transaction t => t -> Stats t -> Stats t
 136 cons t !s =
 137         Stats
 138          { stats_accounts =
 139                 foldl'
 140                  (flip $ (\p -> Map.insert (posting_account p) ()))
 141                  (stats_accounts s)
 142                  (transaction_postings t)
 143          , stats_tags =
 144                 Map.mergeWithKey
 145                  (\_k x1 x2 -> Just $
 146                         Map.unionWith (+) x1 $
 147                         Map.fromListWith (+) $ (, 1) <$> x2)
 148                  id ((Map.fromListWith (+) . ((, 1) <$>)) <$>)
 149                  (stats_tags s)                    -- Map Text (Map Text Integer)
 150                  (let Transaction_Tags (Tags tags) = transaction_tags t in tags) -- Map Text [Text]
 151          , stats_transactions = 1 + (stats_transactions s)
 152          , stats_transactions_span =
 153                 let i = Interval.point $ transaction_date t in
 154                 maybe (Just i) (Just . Interval.span i)
 155                  (stats_transactions_span s)
 156          , stats_units =
 157                 foldl' (\su ->
 158                         Map.foldlWithKey -- TODO: merge rather than insert
 159                          (\acc unit _qty -> 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                 Map.unionWith
 170                  (const::()->()->())
 171                  (stats_accounts s0)
 172                  (stats_accounts s1)
 173          , stats_tags =
 174                 Map.unionWith
 175                  (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 =
 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                 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 instance Transaction t => Consable t (Stats t) where
 202         mcons = cons