lib/Hcompta/Balance.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE StandaloneDeriving #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# OPTIONS_GHC -fno-warn-deprecations #-}
  10  -- FIXME: to be removed when dropping GHC-7.6 support
  11
  12 -- | Balance
  13 module Hcompta.Balance where
  14
  15 -- import           Control.Applicative (Const(..))
  16 -- import           Control.Arrow (second)
  17 import           Control.DeepSeq (NFData(..))
  18 import           Control.Exception (assert)
  19 import           Data.Bool
  20 import           Data.Data
  21 import           Data.Either (Either(..))
  22 import           Data.Eq (Eq(..))
  23 import           Data.Foldable (Foldable(..))
  24 import qualified Data.Foldable as Foldable
  25 import           Data.Function (($), (.), const, flip)
  26 -- import           Data.Functor.Identity (Identity(..))
  27 import           Data.Map.Strict (Map)
  28 import qualified Data.Map.Strict as Map
  29 -- import qualified Data.MonoTraversable as MT
  30 import           Data.Monoid (Monoid(..))
  31 import           Data.Ord (Ord(..))
  32 import qualified Data.Strict.Maybe as Strict
  33 import           Data.TreeMap.Strict (TreeMap(..))
  34 import qualified Data.TreeMap.Strict as TreeMap
  35 import           Data.Tuple (curry, fst, snd)
  36 import           Data.Typeable ()
  37 import           Prelude (undefined)
  38 import           Text.Show (Show(..))
  39
  40 import           Hcompta.Account
  41 import           Hcompta.Amount
  42 import qualified Hcompta.Lib.Foldable as Foldable
  43 import qualified Hcompta.Lib.Strict as Strict
  44 import           Hcompta.Posting
  45 import           Hcompta.Quantity
  46
  47 -- * Class 'Balance_Posting'
  48
  49 -- | A 'posting' used to produce a 'Balance'
  50 --   must be an instance of this class.
  51 class Posting p => Balance_Posting p where
  52         -- | 'Balance_Posting_Quantity'
  53         -- enables to build a 'Balance' with some quantity
  54         -- other than: 'Amount_Quantity' ('Posting_Amount' @p@);
  55         -- it's useful to 'polarize' it.
  56         type Balance_Posting_Quantity p
  57         balance_posting_amounts
  58          :: p -> Balance_Posting_Amounts p
  59         balance_posting_amounts_set
  60          :: Balance_Posting_Amounts p
  61          -> p -> p
  62
  63 -- ** Type 'Balance_Posting_Amounts'
  64
  65 -- | 'Balance' operations works on this type of 'Amount's.
  66 type Balance_Posting_Amounts p
  67  = Map (Amount_Unit (Posting_Amount p))
  68        (Balance_Posting_Quantity p)
  69
  70 instance -- (account, Map unit quantity)
  71  ( Account account
  72  , Amount (unit, quantity)
  73  -- , Amount (MT.Element amounts)
  74  -- , MT.MonoFoldable amounts
  75  ) => Balance_Posting (account, Map unit quantity) where
  76         type Balance_Posting_Quantity (account, Map unit quantity) = quantity
  77         balance_posting_amounts          (_, amts) = amts
  78         balance_posting_amounts_set amts (acct, _) = (acct, amts)
  79
  80 -- * Type 'Balance'
  81
  82 -- | 'Balance_Account' and 'Balance_by_Unit' of some 'Balance_Posting's.
  83 --
  84 -- NOTE: to reduce memory consumption
  85 --       when applying 'balance_cons' incrementally,
  86 --       the fields are explicitely stricts.
  87 data Balance account_section unit quantity
  88  =   Balance
  89  {   balance_by_account :: !(Balance_by_Account account_section unit quantity)
  90  ,   balance_by_unit    :: !(Balance_by_Unit    account_section unit quantity)
  91  }
  92  --deriving (Data, Eq, Show, Typeable)
  93 deriving instance -- Data
  94  ( Data    account_section
  95  , Data     unit
  96  , Data     quantity
  97  , Ord      unit
  98  , Ord account_section
  99  , Typeable unit
 100  , Typeable quantity
 101  ) => Data (Balance account_section unit quantity)
 102 deriving instance -- Eq
 103  ( Eq      account_section
 104  , Eq      unit
 105  , Eq      quantity
 106  ) => Eq (Balance account_section unit quantity)
 107 deriving instance -- Show
 108  ( Show    account_section
 109  , Show    unit
 110  , Show    quantity
 111  ) => Show (Balance account_section unit quantity)
 112 deriving instance -- Typeable
 113  Typeable3 Balance
 114  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 115
 116 instance -- Monoid
 117  ( Addable quantity
 118  , Ord     unit
 119  , Ord     account_section
 120  ) => Monoid (Balance account_section unit quantity) where
 121         mempty  = balance_empty
 122         mappend = balance_union
 123
 124 -- ** Type 'Balance_by_Account'
 125 type Balance_by_Account account_section unit quantity
 126  = TreeMap account_section
 127            (Balance_by_Account_Sum unit quantity)
 128
 129 -- *** Type 'Balance_by_Account_Sum'
 130 -- | A sum of 'quantity's, concerning a single 'account'.
 131 newtype Balance_by_Account_Sum unit quantity
 132  =      Balance_by_Account_Sum (Map unit quantity)
 133  deriving (Data, Eq, Foldable, Show, Typeable)
 134 unBalance_by_Account_Sum
 135  :: Balance_by_Account_Sum unit quantity
 136  -> Map unit quantity
 137 unBalance_by_Account_Sum (Balance_by_Account_Sum m) = m
 138 instance -- Monoid
 139  ( Addable quantity
 140  , Ord unit
 141  ) => Monoid (Balance_by_Account_Sum unit quantity) where
 142         mempty = Balance_by_Account_Sum mempty
 143         mappend (Balance_by_Account_Sum x) (Balance_by_Account_Sum y) =
 144                 Balance_by_Account_Sum $ Map.unionWith quantity_add x y
 145 instance -- NFData
 146  ( NFData unit
 147  , NFData quantity
 148  ) => NFData (Balance_by_Account_Sum unit quantity) where
 149         rnf (Balance_by_Account_Sum m) = rnf m
 150 instance -- Posting
 151  ( Account account
 152  , Amount (unit, quantity)
 153  ) => Posting          (account, Balance_by_Account_Sum unit quantity) where
 154         type Posting_Account (account, Balance_by_Account_Sum unit quantity) = account
 155         type Posting_Amount  (account, Balance_by_Account_Sum unit quantity) = (unit, quantity)
 156         type Posting_Amounts (account, Balance_by_Account_Sum unit quantity) = Map unit quantity
 157         posting_account = fst
 158         posting_amounts = unBalance_by_Account_Sum . snd
 159 instance -- Balance_Posting
 160  ( Account account
 161  , Amount (unit, quantity)
 162  ) => Balance_Posting (account, Balance_by_Account_Sum unit quantity) where
 163         type Balance_Posting_Quantity (account, Balance_by_Account_Sum unit quantity) = quantity
 164         balance_posting_amounts (_, Balance_by_Account_Sum x) = x
 165         balance_posting_amounts_set amounts (acct, _) = (acct, Balance_by_Account_Sum amounts)
 166
 167 -- ** Type 'Balance_by_Unit'
 168 newtype Balance_by_Unit account_section unit quantity
 169  =      Balance_by_Unit (Map unit (Balance_by_Unit_Sum account_section quantity))
 170 deriving instance -- Data
 171  ( Data     account_section
 172  , Data     unit
 173  , Data     quantity
 174  , Ord      unit
 175  , Ord      account_section
 176  , Typeable unit
 177  , Typeable quantity
 178  ) => Data (Balance_by_Unit account_section unit quantity)
 179 deriving instance -- Eq
 180  ( Eq account_section
 181  , Eq unit
 182  , Eq quantity
 183  ) => Eq (Balance_by_Unit account_section unit quantity)
 184 instance -- Monoid
 185  ( Addable quantity
 186  , Ord     unit
 187  , Ord     account_section
 188  ) => Monoid (Balance_by_Unit account_section unit quantity) where
 189         mempty  = Balance_by_Unit mempty
 190         mappend = balance_by_unit_union
 191 deriving instance -- Show
 192  ( Show account_section
 193  , Show unit
 194  , Show quantity
 195  ) => Show (Balance_by_Unit account_section unit quantity)
 196 deriving instance -- Typeable
 197  Typeable3 Balance_by_Unit
 198  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 199
 200 -- *** Type 'Balance_by_Unit_Sum'
 201
 202 -- | A sum of 'quantity's with their 'Account's involved,
 203 -- concerning a single 'unit'.
 204 data Balance_by_Unit_Sum account_section quantity
 205  =   Balance_by_Unit_Sum
 206  {   balance_by_unit_sum_quantity :: !quantity
 207      -- ^ The sum of 'quantity's for a single 'unit'.
 208  ,   balance_by_unit_sum_accounts :: !(Map (Account_Path account_section) ())
 209      -- ^ The 'account's involved to build 'balance_by_unit_sum_quantity'.
 210  }
 211 deriving instance -- Data
 212  ( Data account_section
 213  , Data quantity
 214  , Ord  account_section
 215  ) => Data (Balance_by_Unit_Sum account_section quantity)
 216 deriving instance -- Eq
 217  ( Eq account_section
 218  , Eq quantity
 219  ) => Eq (Balance_by_Unit_Sum account_section quantity)
 220 deriving instance -- Show
 221  ( Show account_section
 222  , Show quantity
 223  ) => Show (Balance_by_Unit_Sum account_section quantity)
 224 deriving instance -- Typeable
 225  Typeable2 Balance_by_Unit_Sum
 226  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 227
 228 -- ** Constructors
 229
 230 balance_empty
 231  :: ( Addable quantity
 232     , Ord     unit
 233     , Ord     account_section
 234     )
 235  => Balance account_section unit quantity
 236 balance_empty =
 237         Balance
 238          { balance_by_account = mempty
 239          , balance_by_unit    = mempty
 240          }
 241
 242 -- | Return the given 'Balance'
 243 --   updated by the given 'Balance_Posting'.
 244 balance_cons
 245  :: ( Balance_Posting posting
 246     , balance ~ Balance (Account_Section (Posting_Account posting))
 247                         (Amount_Unit     (Posting_Amount  posting))
 248                         (Balance_Posting_Quantity posting)
 249     , Addable (Balance_Posting_Quantity posting)
 250     , Ord     (Amount_Unit (Posting_Amount posting))
 251     )
 252  => posting -> balance -> balance
 253 balance_cons post bal =
 254         bal
 255          { balance_by_account = balance_by_account_cons post (balance_by_account bal)
 256          , balance_by_unit    = balance_by_unit_cons    post (balance_by_unit    bal)
 257          }
 258
 259 -- | Return the given 'Balance'
 260 --   updated by the given 'Balance_Posting's.
 261 balance_postings
 262  :: ( Balance_Posting posting
 263     , balance ~ Balance (Account_Section (Posting_Account posting))
 264                         (Amount_Unit     (Posting_Amount  posting))
 265                         (Balance_Posting_Quantity posting)
 266     , Foldable foldable
 267     , Addable (Balance_Posting_Quantity posting)
 268     , Ord     (Amount_Unit (Posting_Amount posting))
 269     , Posting posting
 270     )
 271  => foldable posting -> balance -> balance
 272 balance_postings = flip (Foldable.foldr balance_cons)
 273
 274 -- | Return the first given 'Balance'
 275 --   updated by the second given 'Balance'.
 276 balance_union
 277  :: ( Addable quantity
 278     , Ord unit
 279     , Ord account_section
 280     , balance ~ Balance account_section unit quantity
 281     )
 282  => balance -> balance -> balance
 283 balance_union
 284  (Balance b0a b0u)
 285  (Balance b1a b1u) =
 286         Balance
 287          { balance_by_account = balance_by_account_union b0a b1a
 288          , balance_by_unit    = balance_by_unit_union    b0u b1u
 289          }
 290
 291 -- | Return the given 'Balance_by_Account'
 292 --   updated by the given 'Balance_Posting'.
 293 balance_by_account_cons
 294  :: ( Posting posting
 295     , Balance_Posting posting
 296     , account  ~ Posting_Account  posting
 297     , quantity ~ Balance_Posting_Quantity posting
 298     , unit     ~ Amount_Unit     (Posting_Amount posting)
 299     , Addable quantity
 300     , Ord unit
 301     )
 302  => posting
 303  -> Balance_by_Account (Account_Section account) unit quantity
 304  -> Balance_by_Account (Account_Section account) unit quantity
 305 balance_by_account_cons post =
 306         TreeMap.insert mappend
 307          (account_path $ posting_account post)
 308          (Balance_by_Account_Sum $ balance_posting_amounts post)
 309
 310 -- | Return the given 'Balance_by_Unit'
 311 --   updated by the given 'Balance_Posting'.
 312 balance_by_unit_cons
 313  :: ( Balance_Posting posting
 314     , account_section ~ Account_Section (Posting_Account posting)
 315     , quantity ~ Balance_Posting_Quantity posting
 316     , unit ~ Amount_Unit (Posting_Amount  posting)
 317     , Addable quantity
 318     , Ord unit
 319     )
 320  => posting
 321  -> Balance_by_Unit account_section unit quantity
 322  -> Balance_by_Unit account_section unit quantity
 323 balance_by_unit_cons post =
 324         balance_by_unit_union $
 325         Balance_by_Unit $
 326         (`Map.map` balance_posting_amounts post) $
 327          \quantity -> Balance_by_Unit_Sum
 328                  { balance_by_unit_sum_quantity = quantity
 329                  , balance_by_unit_sum_accounts = Map.singleton (account_path $ posting_account post) ()
 330                  }
 331
 332 -- | Return a 'Balance_by_Unit'
 333 --   derived from the given 'Balance_by_Account'.
 334 balance_by_unit_of_by_account ::
 335  ( Amount (unit, quantity)
 336  , Addable quantity
 337  , Data    account_section
 338  , NFData  account_section
 339  , Ord     account_section
 340  , Ord     unit
 341  , Show    account_section
 342  )
 343  => Balance_by_Account account_section unit quantity
 344  -> Balance_by_Unit account_section unit quantity
 345  -> Balance_by_Unit account_section unit quantity
 346 balance_by_unit_of_by_account =
 347         flip $ TreeMap.foldr_with_Path $ curry balance_by_unit_cons
 348
 349 -- | Return the first given 'Balance_by_Account'
 350 --   updated by the second given 'Balance_by_Account'.
 351 balance_by_account_union
 352  :: ( Addable quantity
 353     , Ord account_section
 354     , Ord unit
 355     )
 356  => Balance_by_Account account_section unit quantity
 357  -> Balance_by_Account account_section unit quantity
 358  -> Balance_by_Account account_section unit quantity
 359 balance_by_account_union = TreeMap.union mappend
 360
 361 -- | Return the first given 'Balance_by_Unit'
 362 --   updated by the second given 'Balance_by_Unit'.
 363 balance_by_unit_union
 364  :: ( Addable quantity
 365     , Ord unit
 366     , Ord account_section
 367     )
 368  => Balance_by_Unit account_section unit quantity
 369  -> Balance_by_Unit account_section unit quantity
 370  -> Balance_by_Unit account_section unit quantity
 371 balance_by_unit_union
 372  (Balance_by_Unit a0)
 373  (Balance_by_Unit a1) =
 374         Balance_by_Unit $
 375         Map.unionWith
 376          (\new old -> Balance_by_Unit_Sum
 377                  { balance_by_unit_sum_quantity = quantity_add
 378                          (balance_by_unit_sum_quantity old)
 379                          (balance_by_unit_sum_quantity new)
 380                  , balance_by_unit_sum_accounts = Map.unionWith
 381                          (const::()->()->())
 382                          (balance_by_unit_sum_accounts old)
 383                          (balance_by_unit_sum_accounts new)
 384                  })
 385          a0 a1
 386
 387 -- * Type 'Balance_Deviation'
 388
 389 -- | The 'Balance_by_Unit' whose 'balance_by_unit_sum_quantity'
 390 --   is not zero and possible 'account' to 'balance_infer_equilibrium'.
 391 newtype Balance_Deviation                  account_section unit quantity
 392  =      Balance_Deviation (Balance_by_Unit account_section unit quantity)
 393 deriving instance -- Data
 394  ( Data     account_section
 395  , Data     unit
 396  , Data     quantity
 397  , Ord      unit
 398  , Ord      account_section
 399  , Typeable unit
 400  , Typeable quantity
 401  ) => Data (Balance_Deviation account_section unit quantity)
 402 deriving instance -- Eq
 403  ( Eq      account_section
 404  , Eq      unit
 405  , Eq      quantity
 406  ) => Eq (Balance_Deviation account_section unit quantity)
 407 deriving instance -- Show
 408  ( Show    account_section
 409  , Show    unit
 410  , Show    quantity
 411  ) => Show (Balance_Deviation account_section unit quantity)
 412 deriving instance -- Typeable
 413  Typeable3 Balance_Deviation
 414  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 415
 416 -- | Return the 'balance_by_unit' of the given 'Balance' with:
 417 --
 418 -- * 'unit's whose 'balance_by_unit_sum_quantity' is verifying 'quantity_null' removed,
 419 --
 420 -- * and remaining 'unit's having their 'balance_by_unit_sum_accounts'
 421 --   complemented with the 'balance_by_account' of the given 'Balance'
 422 --   (i.e. now mapping to 'account's __not__ involved to build the 'Balance_by_Unit_Sum').
 423 balance_deviation
 424  :: ( Zero    quantity
 425     , Addable quantity
 426     , Ord     account_section
 427     , Ord     unit
 428     )
 429  => Balance           account_section unit quantity
 430  -> Balance_Deviation account_section unit quantity
 431 balance_deviation Balance
 432  { balance_by_account
 433  , balance_by_unit=Balance_by_Unit balance_by_unit
 434  } =
 435         let all_accounts = TreeMap.flatten (const ()) balance_by_account in
 436         let max_accounts = Map.size all_accounts in
 437         Balance_Deviation $
 438                 Map.foldlWithKey
 439                  (\(Balance_by_Unit m) unit Balance_by_Unit_Sum{..} ->
 440                         Balance_by_Unit $
 441                         if quantity_null balance_by_unit_sum_quantity
 442                         then m
 443                         else
 444                                 case Map.size balance_by_unit_sum_accounts of
 445                                  n | n == max_accounts ->
 446                                         Map.insert unit Balance_by_Unit_Sum
 447                                          { balance_by_unit_sum_quantity
 448                                          , balance_by_unit_sum_accounts = Map.empty
 449                                          } m
 450                                  _ ->
 451                                         let diff = Map.difference all_accounts balance_by_unit_sum_accounts in
 452                                         Map.insert unit Balance_by_Unit_Sum
 453                                          { balance_by_unit_sum_quantity
 454                                          , balance_by_unit_sum_accounts = diff
 455                                          } m
 456                  )
 457                  mempty
 458                  balance_by_unit
 459
 460 -- ** Balance equilibrium
 461
 462 -- | Return the 'Balance' (adjusted by inferred 'quantity's)
 463 --   of the given 'Balance_Posting's and either:
 464 --
 465 --   * 'Left': the 'Balance_Posting's that cannot be inferred.
 466 --   * 'Right': the given 'Balance_Posting's with inferred 'quantity's inserted.
 467 balance_infer_equilibrium
 468  :: ( Balance_Posting posting
 469     , account  ~ Posting_Account  posting
 470     , unit     ~ Amount_Unit     (Posting_Amount posting)
 471     , quantity ~ Balance_Posting_Quantity posting
 472     , account  ~ Account_Path (Account_Section account)
 473     , account_section ~ Account_Section account
 474     , Addable quantity
 475     , Eq      quantity
 476     , Negable quantity
 477     , Zero    quantity
 478     , Ord     account_section
 479     , Ord     unit
 480     )
 481  => Map account [posting]
 482  -> ( Balance account_section unit quantity
 483     , Either [(unit, Balance_by_Unit_Sum account_section quantity)]
 484              (Map account [posting])
 485     )
 486 balance_infer_equilibrium posts =
 487         let bal_initial = Foldable.foldr balance_postings balance_empty posts in
 488         let Balance_Deviation (Balance_by_Unit dev) = balance_deviation bal_initial in
 489         let (bal_adjusted, eithers) =
 490                 Map.foldrWithKey
 491                  (\unit unit_sum@Balance_by_Unit_Sum{..} (bal, lr) ->
 492                         case Map.size balance_by_unit_sum_accounts of
 493                          1 ->
 494                                 let acct = fst $ Map.elemAt 0 balance_by_unit_sum_accounts in
 495                                 let qty  = quantity_neg balance_by_unit_sum_quantity in
 496                                 let amts = Map.singleton unit qty in
 497                                 ( balance_cons (acct, Balance_by_Account_Sum amts) bal
 498                                 , Right (acct, unit, qty) : lr
 499                                 )
 500                          _ -> (bal, Left [(unit, unit_sum)] : lr))
 501                  (bal_initial, [])
 502                  dev in
 503         let (l, r) = Foldable.accumLeftsAndFoldrRights
 504                  (\(acct, unit, qty) ->
 505                         Map.insertWith
 506                          (\_new_ps -> insert_amount (unit, qty))
 507                          acct (assert False []))
 508                  posts eithers in
 509         case l of
 510          [] -> (bal_adjusted, Right r)
 511          _  -> (bal_adjusted, Left  l)
 512         where
 513                 insert_amount
 514                  :: Balance_Posting posting
 515                  => ( Amount_Unit     (Posting_Amount posting)
 516                     , Balance_Posting_Quantity posting
 517                     )
 518                  -> [posting]
 519                  -> [posting]
 520                 insert_amount p@(unit, qty) ps =
 521                         case ps of
 522                          [] -> assert False []
 523                          (x:xs) | Map.null (balance_posting_amounts x) ->
 524                                 balance_posting_amounts_set (Map.singleton unit qty) x:xs
 525                                 | Map.notMember unit (balance_posting_amounts x) ->
 526                                 let amts = Map.insertWith
 527                                          (assert False undefined)
 528                                          unit qty (balance_posting_amounts x) in
 529                                 balance_posting_amounts_set amts x:xs
 530                          (x:xs) -> x:insert_amount p xs
 531
 532 -- | Return 'True' if and only if the given 'Balance_Deviation' maps no 'unit'.
 533 is_balance_at_equilibrium
 534  :: Balance_Deviation account_section unit quantity
 535  -> Bool
 536 is_balance_at_equilibrium (Balance_Deviation (Balance_by_Unit dev)) = Map.null dev
 537
 538 -- | Return 'True' if and only if the given 'Balance_Deviation'
 539 -- maps only to 'Balance_by_Unit_Sum's whose 'balance_by_unit_sum_accounts'
 540 -- maps exactly one 'account'.
 541 is_balance_equilibrium_inferrable
 542  :: Balance_Deviation account_section unit quantity
 543  -> Bool
 544 is_balance_equilibrium_inferrable (Balance_Deviation (Balance_by_Unit dev)) =
 545         Foldable.all
 546          (\s -> Map.size (balance_by_unit_sum_accounts s) == 1)
 547          dev
 548
 549 -- | Return 'True' if and only if the given 'Balance_Deviation'
 550 -- maps to at least one 'Balance_by_Unit_Sum' whose 'balance_by_unit_sum_accounts'
 551 -- maps more than one 'Account'.
 552 is_balance_equilibrium_non_inferrable
 553  :: Balance_Deviation account_section unit quantity
 554  -> Bool
 555 is_balance_equilibrium_non_inferrable (Balance_Deviation (Balance_by_Unit dev)) =
 556         Foldable.any
 557          (\s -> Map.size (balance_by_unit_sum_accounts s) > 1)
 558          dev
 559
 560 -- * Type 'Balance_Expanded'
 561
 562 -- | Descending propagation of 'quantity's accross 'Account's.
 563 type Balance_Expanded account_section unit quantity
 564  = TreeMap account_section (Balance_by_Account_Sum_Expanded unit quantity)
 565
 566 -- ** Type 'Balance_by_Account_Sum_Expanded'
 567
 568 -- |
 569 -- * 'Strict.exclusive': contains the original 'Balance_by_Account_Sum'.
 570 -- * 'Strict.inclusive': contains 'quantity_add' folded
 571 --   over 'Strict.exclusive' and 'Strict.inclusive'
 572 --   of 'TreeMap.node_descendants'
 573 type Balance_by_Account_Sum_Expanded unit quantity
 574  = Strict.Clusive (Balance_by_Account_Sum unit quantity)
 575
 576 -- | Return the given 'Balance_by_Account' with:
 577 --
 578 -- * all missing 'Account.parent' 'Account's inserted;
 579 -- * and every mapped 'quantity' added with any 'quantity'
 580 --   of the 'Account's for which it is 'Account.parent'.
 581 balance_expanded ::
 582  ( Addable quantity
 583  , Ord account_section
 584  , Ord unit
 585  ) => Balance_by_Account account_section unit quantity
 586  -> Balance_Expanded account_section unit quantity
 587 balance_expanded =
 588         TreeMap.map_by_depth_first
 589          (\descendants value ->
 590                 let exclusive = Strict.fromMaybe mempty value in
 591                 Strict.Clusive
 592                  { Strict.exclusive
 593                  , Strict.inclusive =
 594                         Map.foldl'
 595                          ( flip $ mappend . Strict.inclusive
 596                          . Strict.fromMaybe (assert False undefined)
 597                          . TreeMap.node_value )
 598                          exclusive $
 599                         TreeMap.nodes descendants
 600                  })
 601
 602 -- | Return a 'Balance_by_Unit'
 603 --   derived from the given 'Balance_Expanded' balance.
 604 --
 605 --   NOTE: also correct if the 'Balance_Expanded' has been filtered.
 606 balance_by_unit_of_expanded
 607  :: ( Amount (unit, quantity)
 608     , Addable quantity
 609     , Data    account_section
 610     , NFData  account_section
 611     , Ord     account_section
 612     , Ord     unit
 613     , Show    account_section
 614     )
 615  => Balance_Expanded account_section unit quantity
 616  -> Balance_by_Unit  account_section unit quantity
 617  -> Balance_by_Unit  account_section unit quantity
 618 balance_by_unit_of_expanded =
 619         go []
 620         where
 621                 go p (TreeMap nodes) bal =
 622                         Map.foldrWithKey
 623                          (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
 624                                 case node_value of
 625                                  Strict.Nothing -> go (k:p) node_descendants acc
 626                                  Strict.Just a  ->
 627                                         let acct = TreeMap.reverse $ TreeMap.path k p in
 628                                         balance_by_unit_cons (acct, Strict.inclusive a) acc)
 629                          bal nodes