lib/Hcompta/Balance.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE RecordWildCards #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Hcompta.Balance where
  12
  13 import           Control.DeepSeq (NFData(..))
  14 import           Control.Exception (assert)
  15 import           Data.Bool
  16 import           Data.Data
  17 import           Data.Either (Either(..))
  18 import           Data.Eq (Eq(..))
  19 import qualified Data.Foldable as Foldable
  20 import           Data.Function (($), (.), const, flip)
  21 import           Data.Map.Strict (Map)
  22 import qualified Data.Map.Strict as Map
  23 import           Data.Monoid (Monoid(..))
  24 import qualified Data.MonoTraversable as MT
  25 import           Data.Ord (Ord(..))
  26 import qualified Data.Sequences as Seqs
  27 import qualified Data.Strict.Maybe as Strict
  28 import           Data.TreeMap.Strict (TreeMap(..))
  29 import qualified Data.TreeMap.Strict as TreeMap
  30 import           Data.Tuple (curry, fst, snd)
  31 import           Data.Typeable ()
  32 import           Prelude (seq, undefined)
  33 import           Text.Show (Show(..))
  34
  35 import           Hcompta.Has
  36 import qualified Hcompta.Lib.Foldable as Foldable
  37 import qualified Hcompta.Lib.Strict as Strict
  38 import           Hcompta.Quantity
  39
  40 -- * Type 'Balance_Account'
  41 -- | 'Balance' operations works on this type of 'Account'.
  42 type Balance_Account = TreeMap.Path
  43 instance Get (Balance_Account acct_sect)
  44              (Balance_Account acct_sect
  45              ,Balance_Amounts unit qty) where get = fst
  46
  47 -- * Type 'Balance_Amounts'
  48 -- | 'Balance' operations works on this type of 'Amounts'.
  49 type Balance_Amounts = Map
  50 instance Get (Balance_Amounts unit qty)
  51              (Balance_Account acct_sect
  52              ,Balance_Amounts unit qty) where get = snd
  53 instance Set (Balance_Amounts unit qty)
  54              (Balance_Account acct_sect
  55              ,Balance_Amounts unit qty) where set x (a, _) = (a, x)
  56
  57 -- * Type 'Balance'
  58
  59 -- | 'Balance_Account' and 'BalByUnit' of some @post@s.
  60 --
  61 -- NOTE: to reduce memory consumption
  62 --       when applying 'balance_cons' incrementally,
  63 --       the fields are explicitely stricts.
  64 data Balance acct_sect unit qty
  65  =   Balance
  66  {   balByAccount :: !(BalByAccount acct_sect unit qty)
  67  ,   balByUnit    :: !(BalByUnit    acct_sect unit qty)
  68  } deriving (Data, Eq, Show, Typeable)
  69 instance -- NFData
  70  ( NFData acct_sect
  71  , NFData unit
  72  , NFData qty
  73  , Ord acct_sect
  74  ) => NFData (Balance acct_sect unit qty) where
  75         rnf (Balance a u) = rnf a `seq` rnf u
  76 instance -- Monoid
  77  ( Addable qty
  78  , Ord     unit
  79  , Ord     acct_sect
  80  ) => Monoid (Balance acct_sect unit qty) where
  81         mempty  = balance_empty
  82         mappend = balance_union
  83
  84 balance_empty :: Balance acct_sect unit qty
  85 balance_empty =
  86         Balance
  87          { balByAccount = TreeMap.empty
  88          , balByUnit    = BalByUnit Map.empty
  89          }
  90
  91 -- | Return the first given 'Balance'
  92 --   updated by the second given 'Balance'.
  93 balance_union ::
  94  (Addable qty, Ord acct_sect, Ord unit)
  95  => Balance acct_sect unit qty
  96  -> Balance acct_sect unit qty
  97  -> Balance acct_sect unit qty
  98 balance_union
  99  (Balance b0a b0u)
 100  (Balance b1a b1u) =
 101         Balance
 102          { balByAccount = balByAccount_union b0a b1a
 103          , balByUnit    = balByUnit_union    b0u b1u
 104          }
 105
 106 -- | Return the given 'Balance'
 107 --   updated by the given @post@.
 108 balance_cons ::
 109  ( Get (Balance_Account acct_sect) post
 110  , Get (Balance_Amounts unit qty)  post
 111  , Addable qty, Ord acct_sect, Ord unit )
 112  => post
 113  -> Balance acct_sect unit qty
 114  -> Balance acct_sect unit qty
 115 balance_cons post bal =
 116         bal
 117          { balByAccount = balByAccount_cons post (balByAccount bal)
 118          , balByUnit    = balByUnit_cons    post (balByUnit    bal)
 119          }
 120
 121 -- | Return the given 'Balance'
 122 --   updated by the given @post@s.
 123 balance_postings ::
 124  ( post ~ MT.Element posts
 125  , MT.MonoFoldable posts
 126  , Get (Balance_Account acct_sect) post
 127  , Get (Balance_Amounts unit qty)  post
 128  , Addable qty, Ord acct_sect, Ord unit )
 129  => posts
 130  -> Balance acct_sect unit qty
 131  -> Balance acct_sect unit qty
 132 balance_postings = flip (MT.ofoldr balance_cons)
 133
 134 -- ** Type 'BalByAccount'
 135 type BalByAccount acct_sect unit qty
 136  = TreeMap acct_sect (SumByAccount unit qty)
 137
 138 -- | Return the first given 'BalByAccount'
 139 --   updated by the second given 'BalByAccount'.
 140 balByAccount_union ::
 141  ( Addable qty
 142  , Ord acct_sect
 143  , Ord unit )
 144  => BalByAccount acct_sect unit qty
 145  -> BalByAccount acct_sect unit qty
 146  -> BalByAccount acct_sect unit qty
 147 balByAccount_union = TreeMap.union mappend
 148
 149 -- | Return the given 'BalByAccount'
 150 --   updated by the given @post@.
 151 balByAccount_cons ::
 152  ( Get (Balance_Account acct_sect) post
 153  , Get (Balance_Amounts unit qty)  post
 154  , Ord acct_sect
 155  , Ord unit
 156  , Addable qty
 157  ) => post
 158  -> BalByAccount acct_sect unit qty
 159  -> BalByAccount acct_sect unit qty
 160 balByAccount_cons post =
 161         TreeMap.insert mappend (get post) (SumByAccount $ get post)
 162
 163 -- *** Type 'SumByAccount'
 164 -- | A sum of @qty@s, concerning a single 'Balance_Account'.
 165 newtype SumByAccount unit qty
 166  =      SumByAccount (Balance_Amounts unit qty)
 167  deriving (Data, Eq, NFData, Show, Typeable)
 168 instance -- Monoid
 169  (Addable qty, Ord unit) =>
 170  Monoid (SumByAccount unit qty) where
 171         mempty = SumByAccount mempty
 172         mappend (SumByAccount x) (SumByAccount y) =
 173                 SumByAccount $ Map.unionWith (flip quantity_add) x y
 174
 175 unSumByAccount
 176  :: SumByAccount unit qty
 177  -> Map unit qty
 178 unSumByAccount (SumByAccount m) = m
 179
 180 -- ** Type 'BalByUnit'
 181 newtype BalByUnit acct_sect unit qty
 182  =      BalByUnit (Map unit (SumByUnit (Balance_Account acct_sect) qty))
 183  deriving (Data, Eq, NFData, Show, Typeable)
 184 instance -- Monoid
 185  (Addable qty, Ord acct_sect, Ord unit) =>
 186  Monoid (BalByUnit acct_sect unit qty) where
 187         mempty  = BalByUnit mempty
 188         mappend = balByUnit_union
 189
 190 -- | Return the first given 'BalByUnit'
 191 --   updated by the second given 'BalByUnit'.
 192 balByUnit_union
 193  :: (Addable qty, Ord acct_sect, Ord unit)
 194  => BalByUnit acct_sect unit qty
 195  -> BalByUnit acct_sect unit qty
 196  -> BalByUnit acct_sect unit qty
 197 balByUnit_union
 198  (BalByUnit a0)
 199  (BalByUnit a1) =
 200         BalByUnit $
 201         Map.unionWith
 202          (\new old -> SumByUnit
 203                  { sumByUnit_quantity = quantity_add
 204                          (sumByUnit_quantity old)
 205                          (sumByUnit_quantity new)
 206                  , sumByUnit_accounts = Map.unionWith
 207                          (const::()->()->())
 208                          (sumByUnit_accounts old)
 209                          (sumByUnit_accounts new)
 210                  })
 211          a0 a1
 212
 213 -- | Return the given 'BalByUnit'
 214 --   updated by the given @post@.
 215 balByUnit_cons ::
 216  ( Get (Balance_Account acct_sect) post
 217  , Get (Balance_Amounts unit qty)  post
 218  , Addable qty
 219  , Ord acct_sect
 220  , Ord unit
 221  ) => post
 222  -> BalByUnit acct_sect unit qty
 223  -> BalByUnit acct_sect unit qty
 224 balByUnit_cons post =
 225         balByUnit_union $
 226         BalByUnit $
 227         (`Map.map` get post) $
 228          \qty -> SumByUnit
 229                  { sumByUnit_quantity = qty
 230                  , sumByUnit_accounts = Map.singleton (get post) ()
 231                  }
 232
 233 -- | Return the given 'BalByUnit'
 234 --   updated by the given 'BalByAccount'.
 235 balByUnit_of_BalByAccount
 236  :: (Addable qty, Ord acct_sect, Ord unit)
 237  => BalByAccount acct_sect unit qty
 238  -> BalByUnit    acct_sect unit qty
 239  -> BalByUnit    acct_sect unit qty
 240 balByUnit_of_BalByAccount =
 241         flip $ TreeMap.foldr_with_Path $ curry balByUnit_cons
 242
 243 instance Get ( Balance_Account acct_sect )
 244              ( Balance_Account acct_sect
 245              , SumByAccount unit qty )
 246  where get = fst
 247 instance Get ( Balance_Amounts unit qty )
 248              ( Balance_Account acct_sect
 249              , SumByAccount unit qty )
 250  where get = unSumByAccount . snd
 251
 252 -- *** Type 'SumByUnit'
 253 -- | A sum of @qty@s with their 'Account's involved,
 254 -- concerning a single @unit@.
 255 data SumByUnit acct qty
 256  =   SumByUnit
 257  {   sumByUnit_quantity :: !qty
 258      -- ^ The sum of @qty@s for a single @unit@.
 259  ,   sumByUnit_accounts :: !(Map acct ())
 260      -- ^ The 'Balance_Account's involved to build 'sumByUnit_quantity'.
 261  } deriving (Data, Eq, Show, Typeable)
 262 instance -- NFData
 263  ( NFData acct
 264  , NFData qty
 265  ) => NFData (SumByUnit acct qty) where
 266         rnf (SumByUnit q a) = rnf q `seq` rnf a
 267
 268 -- * Type 'DeviationByUnit'
 269 -- | The 'BalByUnit' whose 'sumByUnit_quantity'
 270 --   is not zero and possible 'Balance_Account' to 'equilibrium'.
 271 newtype DeviationByUnit            acct_sect unit qty
 272  =      DeviationByUnit (BalByUnit acct_sect unit qty)
 273  deriving (Data, Eq, NFData, Show, Typeable)
 274
 275 -- | Return the 'balByUnit' of the given 'Balance' with:
 276 --
 277 -- * @unit@s whose 'sumByUnit_quantity' verifying 'quantity_null' are removed,
 278 --
 279 -- * and remaining @unit@s have their 'sumByUnit_accounts'
 280 --   complemented with the 'balByAccount' of the given 'Balance'
 281 --   (i.e. now mapping to the 'Balance_Account's __not__ involved to build the 'SumByUnit').
 282 deviationByUnit
 283  :: (Zero qty, Addable qty, Ord acct_sect, Ord unit)
 284  => Balance         acct_sect unit qty
 285  -> DeviationByUnit acct_sect unit qty
 286 deviationByUnit Balance
 287  { balByAccount
 288  , balByUnit=BalByUnit balByUnit
 289  } =
 290         let all_accounts = TreeMap.flatten (const ()) balByAccount in
 291         let max_accounts = Map.size all_accounts in
 292         DeviationByUnit $
 293                 Map.foldlWithKey
 294                  (\(BalByUnit m) unit SumByUnit{..} ->
 295                         BalByUnit $
 296                         if quantity_null sumByUnit_quantity
 297                         then m
 298                         else
 299                                 case Map.size sumByUnit_accounts of
 300                                  n | n == max_accounts ->
 301                                         Map.insert unit SumByUnit
 302                                          { sumByUnit_quantity
 303                                          , sumByUnit_accounts = Map.empty
 304                                          } m
 305                                  _ ->
 306                                         let diff = Map.difference all_accounts sumByUnit_accounts in
 307                                         Map.insert unit SumByUnit
 308                                          { sumByUnit_quantity
 309                                          , sumByUnit_accounts = diff
 310                                          } m
 311                  )
 312                  mempty
 313                  balByUnit
 314
 315 -- ** Balance equilibrium
 316 -- | Return the 'Balance' (adjusted by inferred @qty@s)
 317 --   of the given @post@s and either:
 318 --
 319 --   * 'Left': the @unit@s which have a non null 'SumByUnit'
 320 --             and for which no equibrating 'Balance_Account' can be inferred.
 321 --   * 'Right': the given @post@s with inferred @qty@s inserted.
 322 equilibrium ::
 323  ( post ~ MT.Element posts
 324  , Seqs.IsSequence posts
 325  , Get (Balance_Account acct_sect) post
 326  , Has (Balance_Amounts unit qty)  post
 327  , Zero qty, Addable qty, Negable qty
 328  , Ord acct, Ord acct_sect, Ord unit
 329  , Get acct (Balance_Account acct_sect)
 330  ) => Map acct posts
 331    -> ( Balance acct_sect unit qty
 332       , Either [(unit, SumByUnit (Balance_Account acct_sect) qty)]
 333                (Map acct posts) )
 334 equilibrium posts =
 335         let bal_initial = MT.ofoldr balance_postings balance_empty posts in
 336         let DeviationByUnit (BalByUnit dev) = deviationByUnit bal_initial in
 337         let (bal_adjusted, eithers) =
 338                 Map.foldrWithKey
 339                  (\unit unit_sum@SumByUnit{..} (bal, lr) ->
 340                         case Map.size sumByUnit_accounts of
 341                          1 ->
 342                                 let acct = fst $ Map.elemAt 0 sumByUnit_accounts in
 343                                 let qty  = quantity_neg sumByUnit_quantity in
 344                                 let amts = Map.singleton unit qty in
 345                                 ( balance_cons (acct, SumByAccount amts) bal
 346                                 , Right (acct, unit, qty) : lr
 347                                 )
 348                          _ -> (bal, Left [(unit, unit_sum)] : lr))
 349                  (bal_initial, [])
 350                  dev in
 351         let (l, r) = Foldable.accumLeftsAndFoldrRights
 352                  (\(acct, unit, qty) ->
 353                         Map.insertWith
 354                          (\_new_ps -> Seqs.fromList . insert_amount (unit, qty) . MT.otoList)
 355                          (get acct) (assert False undefined))
 356                          -- NOTE: acct is within bal_initial,
 357                          -- hence posts already has a mapping for acct.
 358                  posts eithers in
 359         case l of
 360          [] -> (bal_adjusted, Right r)
 361          _  -> (bal_adjusted, Left  l)
 362         where
 363                 insert_amount
 364                  :: forall post unit qty.
 365                  ( Ord unit
 366                  , Has (Balance_Amounts unit qty) post
 367                  ) => (unit, qty) -> [post] -> [post]
 368                 insert_amount amt@(unit, qty) l =
 369                         case l of
 370                          [] -> assert False []
 371                                 -- NOTE: the acct being in bal_initial,
 372                                 -- hence there was at least one post for this acct.
 373                          p:ps ->
 374                                 let amts :: Balance_Amounts unit qty = get p in
 375                                 if Map.notMember unit amts
 376                                 then set (Map.insert unit qty amts) p:ps
 377                                 else p:insert_amount amt ps
 378
 379 -- | Return 'True' if and only if the given 'DeviationByUnit' maps no @unit@.
 380 is_equilibrium :: DeviationByUnit acct_sect unit qty -> Bool
 381 is_equilibrium (DeviationByUnit (BalByUnit dev)) = Map.null dev
 382
 383 -- | Return 'True' if and only if the given 'DeviationByUnit'
 384 -- maps only to 'SumByUnit's whose 'sumByUnit_accounts'
 385 -- maps exactly one 'Balance_Account'.
 386 is_equilibrium_inferrable :: DeviationByUnit acct_sect unit qty -> Bool
 387 is_equilibrium_inferrable (DeviationByUnit (BalByUnit dev)) =
 388         Foldable.all ((== 1) . Map.size . sumByUnit_accounts) dev
 389
 390 -- * Type 'ClusiveBalByAccount'
 391
 392 -- | {Ex,In}clusive 'BalByAccount':
 393 -- descending propagation of @qty@s accross 'Account's.
 394 type ClusiveBalByAccount acct_sect unit qty
 395  = TreeMap acct_sect (ClusiveSumByAccount unit qty)
 396
 397 -- ** Type 'ClusiveSumByAccount'
 398 -- |
 399 -- * 'Strict.exclusive': contains the original 'SumByAccount'.
 400 -- * 'Strict.inclusive': contains 'quantity_add' folded
 401 --   over 'Strict.exclusive' and 'Strict.inclusive'
 402 --   of 'TreeMap.node_descendants'
 403 type ClusiveSumByAccount unit qty
 404  = Strict.Clusive (SumByAccount unit qty)
 405
 406 -- | Return the given 'BalByAccount' with:
 407 --
 408 -- * all missing 'Account.parent' 'Account's inserted;
 409 -- * and every mapped @qty@ added with any @qty@
 410 --   of the 'Account's for which it is 'Account.parent'.
 411 clusiveBalByAccount
 412  :: (Addable qty, Ord acct_sect, Ord unit)
 413  => BalByAccount    acct_sect unit qty
 414  -> ClusiveBalByAccount acct_sect unit qty
 415 clusiveBalByAccount =
 416         TreeMap.map_by_depth_first
 417          (\descendants value ->
 418                 let exclusive = Strict.fromMaybe mempty value in
 419                 Strict.Clusive
 420                  { Strict.exclusive
 421                  , Strict.inclusive =
 422                         Map.foldl'
 423                          ( flip $ mappend . Strict.inclusive
 424                          . Strict.fromMaybe (assert False undefined)
 425                          . TreeMap.node_value )
 426                          exclusive $
 427                         TreeMap.nodes descendants
 428                  })
 429
 430 -- | Return a 'BalByUnit'
 431 --   derived from the given 'ClusiveBalByAccount' balance.
 432 --
 433 --   NOTE: also correct if the 'ClusiveBalByAccount' has been filtered.
 434 balByUnit_of_ClusiveBalByAccount
 435  :: (Addable qty, Ord acct_sect, Ord unit)
 436  => ClusiveBalByAccount acct_sect unit qty
 437  -> BalByUnit acct_sect unit qty
 438  -> BalByUnit acct_sect unit qty
 439 balByUnit_of_ClusiveBalByAccount =
 440         go []
 441         where
 442         go p (TreeMap nodes) bal =
 443                 Map.foldrWithKey
 444                  (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
 445                         case node_value of
 446                          Strict.Nothing -> go (k:p) node_descendants acc
 447                          Strict.Just a  ->
 448                                 let acct = TreeMap.reverse $ TreeMap.path k p in
 449                                 balByUnit_cons (acct, Strict.inclusive a) acc)
 450                  bal nodes