lib/Hcompta/Balance.hs

   1 module Hcompta.Balance where
   2
   3 import Control.DeepSeq (NFData(..))
   4 import Control.Exception (assert)
   5 import Data.Bool
   6 import Data.Data
   7 import Data.Either (Either(..))
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.), const, flip)
  10 import Data.Map.Strict (Map)
  11 import Data.Ord (Ord(..))
  12 import Data.TreeMap.Strict (TreeMap(..))
  13 import Data.Tuple (fst)
  14 import Data.Typeable ()
  15 import Prelude (seq, undefined)
  16 import Text.Show (Show(..))
  17 import qualified Data.Foldable as Fold
  18 import qualified Data.Map.Strict as Map
  19 import qualified Data.MonoTraversable as MT
  20 import qualified Data.Sequences as Seqs
  21 import qualified Data.Strict.Maybe as Strict
  22 import qualified Data.TreeMap.Strict as TM
  23
  24 import Hcompta.Data
  25 import Hcompta.Quantity
  26 import qualified Hcompta.Lib.Foldable as Fold
  27 import qualified Hcompta.Lib.Strict as Strict
  28
  29 -- * Type 'Balance'
  30
  31 -- | 'BalByAccount' and 'BalByUnit' of some @post@s.
  32 --
  33 -- NOTE: to reduce memory consumption
  34 --       when applying ('+=') incrementally,
  35 --       the fields are explicitely stricts.
  36 data Balance name unit qty
  37  =   Balance
  38  {   balByAccount :: !(BalByAccount name unit qty)
  39  ,   balByUnit    :: !(BalByUnit    name unit qty)
  40  } deriving (Data, Eq, Show, Typeable)
  41
  42 instance (NFData name, NFData unit, NFData qty, Ord name) => NFData (Balance name unit qty) where
  43         rnf (Balance a u) = rnf a `seq` rnf u
  44 instance Zeroable (Balance name unit qty) where
  45         zero = Balance TM.empty Map.empty
  46 instance Nullable qty => Nullable (Balance name unit qty) where
  47         null (Balance a u) = TM.null a && null u
  48 instance (Ord name, Ord unit, Addable qty) =>
  49          Addable (Balance name unit qty) where
  50         Balance xa xu + Balance ya yu = Balance (xa + ya) (xu + yu)
  51 instance (Ord name, Ord unit, Addable qty) =>
  52          Sumable (Balance name unit qty)
  53                  (TM.Path name, SumByAccount unit qty) where
  54         Balance a u += x = Balance (a += x) (u += x)
  55
  56 -- * Type 'BalByAccount'
  57 type BalByAccount name unit qty
  58  =   TreeMap name (SumByAccount unit qty)
  59
  60 -- ** Type 'SumByAccount'
  61 -- | A sum of quantities, concerning a single account.
  62 type SumByAccount = Map
  63
  64 -- * Type 'BalByUnit'
  65 type BalByUnit name unit qty
  66  =   Map unit (SumByUnit (TM.Path name) qty)
  67
  68 -- ** Type 'SumByUnit'
  69 -- | A sum of quantities with their accounts involved,
  70 -- concerning a single @unit@.
  71 data SumByUnit acct qty
  72  =   SumByUnit
  73  {   sumByUnit_quantity :: !qty
  74      -- ^ The sum of quantities for a single @unit@.
  75  ,   sumByUnit_accounts :: !(Map acct ())
  76      -- ^ The accounts involved to build 'sumByUnit_quantity'.
  77  } deriving (Data, Eq, Ord, Show, Typeable)
  78 instance (NFData acct, NFData qty) => NFData (SumByUnit acct qty) where
  79         rnf (SumByUnit q a) = rnf q `seq` rnf a
  80 instance Zeroable qty => Zeroable (SumByUnit acct qty) where
  81         zero = SumByUnit zero zero
  82 instance Nullable qty => Nullable (SumByUnit acct qty) where
  83         null (SumByUnit q a) = null q && Map.null a
  84 instance (Ord acct, Addable qty) => Addable (SumByUnit acct qty) where
  85         x + y = SumByUnit
  86          (sumByUnit_quantity x + sumByUnit_quantity y)
  87          (sumByUnit_accounts x + sumByUnit_accounts y)
  88 instance (Ord name, Ord unit, Addable qty) =>
  89          Sumable (BalByUnit name unit qty)
  90                  (TM.Path name, Map unit qty) where
  91         bal += (acct, amts) =
  92                 (+) ((`Map.map` amts) $ \qty ->
  93                 SumByUnit
  94                  { sumByUnit_quantity = qty
  95                  , sumByUnit_accounts = Map.singleton acct ()
  96                  }) bal
  97
  98 -- * Type 'DeviationByUnit'
  99 -- | The 'BalByUnit' whose 'sumByUnit_quantity'
 100 --   is not zero and possible account to 'equilibrium'.
 101 newtype DeviationByUnit            name unit qty
 102  =      DeviationByUnit (BalByUnit name unit qty)
 103  deriving (Data, Eq, NFData, Show, Typeable)
 104
 105 -- | Return the 'balByUnit' of the given 'Balance' with:
 106 --
 107 -- * @unit@s whose 'sumByUnit_quantity' verifying 'zero' are removed,
 108 --
 109 -- * and remaining @unit@s have their 'sumByUnit_accounts'
 110 --   complemented with the 'balByAccount' of the given 'Balance'
 111 --   (i.e. now mapping to the accounts __not__ involved to build the 'SumByUnit').
 112 deviationByUnit ::
 113  (Ord name, Ord unit, Addable qty, Nullable qty) =>
 114  Balance         name unit qty ->
 115  DeviationByUnit name unit qty
 116 deviationByUnit Balance{balByAccount, balByUnit} =
 117         let all_accounts = TM.flatten (const ()) balByAccount in
 118         let max_accounts = Map.size all_accounts in
 119         DeviationByUnit $
 120                 Map.foldlWithKey
 121                  (\m unit SumByUnit{..} ->
 122                         if null sumByUnit_quantity
 123                         then m
 124                         else
 125                                 case Map.size sumByUnit_accounts of
 126                                  n | n == max_accounts ->
 127                                         Map.insert unit SumByUnit
 128                                          { sumByUnit_quantity
 129                                          , sumByUnit_accounts = Map.empty
 130                                          } m
 131                                  _ ->
 132                                         let diff = all_accounts `Map.difference` sumByUnit_accounts in
 133                                         Map.insert unit SumByUnit
 134                                          { sumByUnit_quantity
 135                                          , sumByUnit_accounts = diff
 136                                          } m
 137                  )
 138                  zero
 139                  balByUnit
 140
 141 -- ** Balance 'equilibrium'
 142 -- | Return the 'Balance' (adjusted by inferred quantities)
 143 --   of the given @post@s and either:
 144 --
 145 --   * 'Left': the @unit@s which have a non null 'SumByUnit'
 146 --             and for which no equibrating account can be inferred.
 147 --   * 'Right': the given @post@s with inferred quantities inserted.
 148 equilibrium ::
 149  ( post ~ MT.Element posts
 150
 151  , Seqs.IsSequence posts
 152  , Sumable (Balance name unit qty) post
 153
 154  , Get acct post
 155  , Has (Map unit qty) post
 156  , To acct (TM.Path name)
 157
 158  , Ord acct
 159  , Ord name, Ord unit, Addable qty
 160  , Nullable qty, Negable qty
 161  ) =>
 162  Map acct posts ->
 163  ( Balance name unit qty
 164  , Either [(unit, SumByUnit (TM.Path name) qty)]
 165           (Map acct posts)
 166  )
 167 equilibrium postsByAcct =
 168         let bal_initial = Fold.foldr (flip $ MT.ofoldr (flip (+=))) zero postsByAcct in
 169         let DeviationByUnit dev = deviationByUnit bal_initial in
 170         let (bal_adjusted, eithers) =
 171                 Map.foldrWithKey
 172                  (\unit sbu@SumByUnit{..} (bal, lr) ->
 173                         case Map.size $ sumByUnit_accounts of
 174                          1 ->
 175                                 let acct = fst $ Map.elemAt 0 sumByUnit_accounts in
 176                                 let qty  = neg sumByUnit_quantity in
 177                                 let amts = Map.singleton unit qty in
 178                                 ( bal += (acct, amts)
 179                                 , Right (acct, unit, qty) : lr
 180                                 )
 181                          _ -> (bal, Left [(unit, sbu)] : lr))
 182                  (bal_initial, [])
 183                  dev in
 184         let (l, r) = Fold.accumLeftsAndFoldrRights
 185                  (\(acct, unit, qty) ->
 186                         Map.adjust (Seqs.fromList . insAmount (unit, qty) . MT.otoList) (to acct))
 187                          -- NOTE: acct is within bal_initial,
 188                          -- hence postsByAcct already has a mapping for acct.
 189                  postsByAcct eithers in
 190         case l of
 191          [] -> (bal_adjusted, Right r)
 192          _  -> (bal_adjusted, Left  l)
 193         where
 194         insAmount ::
 195          forall post unit qty.
 196          (Ord unit, Has (Map unit qty) post) =>
 197          (unit, qty) -> [post] -> [post]
 198         insAmount amt@(unit, qty) l =
 199                 case l of
 200                  [] -> assert False []
 201                         -- NOTE: the acct being in bal_initial,
 202                         -- hence there was at least one post for this acct.
 203                  p:ps ->
 204                         let amts :: Map unit qty = get p in
 205                         if unit `Map.notMember` amts
 206                         then set (Map.insert unit qty amts) p:ps
 207                         else p:insAmount amt ps
 208
 209 -- | Return 'True' if and only if the given 'DeviationByUnit' maps no @unit@.
 210 isEquilibrium :: DeviationByUnit name unit qty -> Bool
 211 isEquilibrium (DeviationByUnit dev) = Map.null dev
 212
 213 -- | Return 'True' if and only if the given 'DeviationByUnit'
 214 -- maps only to 'SumByUnit's whose 'sumByUnit_accounts'
 215 -- maps exactly one account.
 216 isEquilibriumInferrable :: DeviationByUnit name unit qty -> Bool
 217 isEquilibriumInferrable (DeviationByUnit dev) =
 218         Fold.all ((== 1) . Map.size . sumByUnit_accounts) dev
 219
 220 -- * Type 'ClusiveBalByAccount'
 221
 222 -- | {Ex,In}clusive 'BalByAccount':
 223 -- descending propagation of quantities accross accounts.
 224 type ClusiveBalByAccount name unit qty
 225  = TreeMap name (ClusiveSumByAccount unit qty)
 226
 227 -- ** Type 'ClusiveSumByAccount'
 228 -- |
 229 -- * 'Strict.exclusive': contains the original 'SumByAccount'.
 230 -- * 'Strict.inclusive': contains ('+') folded
 231 --   over 'Strict.exclusive' and 'Strict.inclusive'
 232 --   of 'TM.node_descendants'
 233 type ClusiveSumByAccount unit qty
 234  = Strict.Clusive (SumByAccount unit qty)
 235
 236 -- | Return the given 'BalByAccount' with:
 237 --
 238 -- * all missing parent accounts inserted;
 239 -- * and every mapped @qty@ added with any @qty@
 240 --   of the account for which it is a parent.
 241 clusiveBalByAccount ::
 242  (Addable qty, Ord name, Ord unit) =>
 243  BalByAccount        name unit qty ->
 244  ClusiveBalByAccount name unit qty
 245 clusiveBalByAccount =
 246         TM.mapByDepthFirst
 247          (\descendants value ->
 248                 let exclusive = Strict.fromMaybe Map.empty value in
 249                 Strict.Clusive
 250                  { Strict.exclusive
 251                  , Strict.inclusive =
 252                         Map.foldl'
 253                          ( flip $ (+) . Strict.inclusive
 254                          . Strict.fromMaybe (assert False undefined)
 255                          . TM.node_value )
 256                          exclusive $
 257                         TM.nodes descendants
 258                  })
 259
 260 -- | NOTE: also correct if the 'ClusiveBalByAccount' has been filtered.
 261 instance (Ord name, Ord unit, Addable qty) =>
 262          Sumable (BalByUnit name unit qty)
 263                  (ClusiveBalByAccount name unit qty) where
 264         (+=) = go []
 265                 where
 266                 go p bal (TreeMap nodes) =
 267                         Map.foldrWithKey
 268                          (\k TM.Node{TM.node_value, TM.node_descendants} acc ->
 269                                 case node_value of
 270                                  Strict.Nothing -> go (k:p) acc node_descendants
 271                                  Strict.Just Strict.Clusive{Strict.inclusive=amts}  ->
 272                                         let acct = Seqs.reverse $ TM.path k p in
 273                                         acc += (acct, amts))
 274                          bal nodes