lib/Hcompta/Balance.hs

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