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