lib/Hcompta/Stats.hs

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