lib/Hcompta/Balance.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
   8 module Hcompta.Balance where
   9
  10 import           Control.Exception (assert)
  11 import           Data.Data
  12 import qualified Data.Foldable
  13 -- import           Data.Foldable (Foldable(..))
  14 import qualified Data.Map.Strict as Data.Map
  15 import           Data.Map.Strict (Map)
  16 import           Data.Maybe (fromMaybe)
  17 import           Data.Typeable ()
  18
  19 import qualified Hcompta.Lib.Foldable as Lib.Foldable
  20 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  21 import           Hcompta.Lib.TreeMap (TreeMap)
  22 import qualified Hcompta.Account as Account
  23 import           Hcompta.Account (Account)
  24
  25 -- * Requirements' interface
  26
  27 -- ** Class 'Amount'
  28 class
  29  ( Data     (Amount_Unit a)
  30  , Ord      (Amount_Unit a)
  31  , Show     (Amount_Unit a)
  32  , Typeable (Amount_Unit a)
  33  ) => Amount a where
  34         type Amount_Unit a
  35         amount_null   :: a -> Bool
  36         amount_add    :: a -> a -> a
  37         amount_negate :: a -> a
  38
  39 -- ** Class 'Posting'
  40
  41 -- | A 'posting' used to produce a 'Balance'
  42 --   must be an instance of this class.
  43 class Amount (Posting_Amount p) => Posting p where
  44         type Posting_Amount p
  45         posting_account     :: p -> Account
  46         posting_amounts     :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
  47         posting_set_amounts ::      Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p) -> p -> p
  48
  49 instance (Amount amount, unit ~ Amount_Unit amount)
  50  => Posting (Account, Map unit amount)
  51  where
  52         type Posting_Amount (Account, Map unit amount) = amount
  53         posting_account = fst
  54         posting_amounts = snd
  55         posting_set_amounts amounts (acct, _) = (acct, amounts)
  56
  57 -- * Type 'Balance'
  58
  59 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
  60 data Amount amount => Balance amount
  61  =   Balance
  62  { balance_by_account :: Balance_by_Account amount (Amount_Unit amount)
  63  , balance_by_unit    :: Balance_by_Unit    amount (Amount_Unit amount)
  64  }
  65 deriving instance ( Amount amount
  66                   , Data   amount
  67                   ) => Data (Balance amount)
  68 deriving instance ( Amount amount
  69                   , Eq     amount
  70                   ) => Eq (Balance amount)
  71 deriving instance ( Amount amount
  72                   , Show   amount
  73                   ) => Show (Balance amount)
  74 deriving instance Typeable1 Balance
  75  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
  76
  77 type Balance_by_Account amount unit
  78  = TreeMap Account.Name
  79            (Account_Sum amount unit)
  80
  81 -- | A sum of 'amount's,
  82 -- concerning a single 'Account'.
  83 type Account_Sum amount unit
  84  = Data.Map.Map unit amount
  85
  86 type Balance_by_Unit amount unit
  87  = Map unit (Unit_Sum amount)
  88
  89 -- | A sum of 'amount's with their 'Account's involved,
  90 -- concerning a single 'unit'.
  91 data Unit_Sum amount
  92  =   Unit_Sum
  93  { unit_sum_amount   :: amount -- ^ The sum of 'amount's for a single 'unit'.
  94  , unit_sum_accounts :: Map Account () -- ^ The 'Account's involved to build 'unit_sum_amount'.
  95  } deriving (Data, Eq, Show, Typeable)
  96
  97 -- ** Constructors
  98
  99 nil :: Amount amount => Balance amount
 100 nil =
 101         Balance
 102          { balance_by_account = Lib.TreeMap.empty
 103          , balance_by_unit    = Data.Map.empty
 104          }
 105
 106 -- | Return the given 'Balance'
 107 --   updated by the given 'Posting'.
 108 balance ::
 109  ( Posting posting
 110  , balance ~ Balance (Posting_Amount posting) )
 111  => posting -> balance -> balance
 112 balance post bal =
 113         bal
 114          { balance_by_account = by_account post (balance_by_account bal)
 115          , balance_by_unit    = by_unit    post (balance_by_unit    bal)
 116          }
 117
 118 -- | Return the given 'Balance'
 119 --   updated by the given 'Posting's.
 120 postings ::
 121  ( Posting posting
 122  , balance ~ Balance (Posting_Amount posting)
 123  , Foldable foldable )
 124  => foldable posting -> balance -> balance
 125 postings = flip (Data.Foldable.foldr balance)
 126
 127 -- | Return the first given 'Balance'
 128 --   updated by the second given 'Balance'.
 129 union :: Amount amount
 130  => Balance amount -> Balance amount -> Balance amount
 131 union b0 b1 =
 132         b0
 133          { balance_by_account = union_by_account
 134                  (balance_by_account b0)
 135                  (balance_by_account b1)
 136          , balance_by_unit = union_by_unit
 137                  (balance_by_unit b0)
 138                  (balance_by_unit b1)
 139          }
 140
 141 -- | Return the given 'Balance_by_Account'
 142 --   updated by the given 'Posting'.
 143 by_account ::
 144  ( Posting posting
 145  , amount ~ Posting_Amount posting
 146  , unit   ~ Amount_Unit amount )
 147  => posting
 148  -> Balance_by_Account amount unit
 149  -> Balance_by_Account amount unit
 150 by_account post =
 151         Lib.TreeMap.insert
 152          (Data.Map.unionWith (flip amount_add))
 153          (posting_account post)
 154          (posting_amounts post)
 155
 156 -- | Return the given 'Balance_by_Unit'
 157 --   updated by the given 'Posting'.
 158 by_unit ::
 159  ( Posting posting
 160  , amount ~ Posting_Amount posting
 161  , unit   ~ Amount_Unit amount )
 162  => posting
 163  -> Balance_by_Unit amount unit
 164  -> Balance_by_Unit amount unit
 165 by_unit post bal =
 166         Data.Map.unionWith
 167          (\new old -> Unit_Sum
 168                  { unit_sum_amount =
 169                         amount_add
 170                          (unit_sum_amount old)
 171                          (unit_sum_amount new)
 172                  , unit_sum_accounts =
 173                         Data.Map.unionWith
 174                          (const::()->()->())
 175                          (unit_sum_accounts old)
 176                          (unit_sum_accounts new)
 177                  })
 178          bal $
 179         Data.Map.map
 180          (\amount -> Unit_Sum
 181                  { unit_sum_amount   = amount
 182                  , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
 183                  })
 184          (posting_amounts post)
 185
 186 -- | Return a 'Balance_by_Unit'
 187 --   derived from the given 'Balance_by_Account'.
 188 by_unit_of_by_account ::
 189  ( Amount amount
 190  , unit ~ Amount_Unit amount
 191  )
 192  => Balance_by_Account amount unit
 193  -> Balance_by_Unit    amount unit
 194  -> Balance_by_Unit    amount unit
 195 by_unit_of_by_account =
 196         flip $ Lib.TreeMap.foldr_with_Path $ curry by_unit
 197
 198 -- | Return the first given 'Balance_by_Account'
 199 --   updated by the second given 'Balance_by_Account'.
 200 union_by_account :: (Amount amount, unit ~ Amount_Unit amount)
 201  => Balance_by_Account amount unit
 202  -> Balance_by_Account amount unit
 203  -> Balance_by_Account amount unit
 204 union_by_account =
 205         Lib.TreeMap.union
 206          (Data.Map.unionWith (flip amount_add))
 207
 208 -- | Return the first given 'Balance_by_Unit'
 209 --   updated by the second given 'Balance_by_Unit'.
 210 union_by_unit :: (Amount amount, unit ~ Amount_Unit amount)
 211  => Balance_by_Unit amount unit
 212  -> Balance_by_Unit amount unit
 213  -> Balance_by_Unit amount unit
 214 union_by_unit =
 215         Data.Map.unionWith
 216          (\new old -> Unit_Sum
 217                  { unit_sum_amount = amount_add
 218                          (unit_sum_amount old)
 219                          (unit_sum_amount new)
 220                  , unit_sum_accounts = Data.Map.unionWith
 221                          (const::()->()->())
 222                          (unit_sum_accounts old)
 223                          (unit_sum_accounts new)
 224                  })
 225
 226 -- * Type 'Deviation'
 227
 228 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
 229 --   is not zero and possible 'Account' to 'infer_equilibrium'.
 230 newtype Amount amount
 231  => Deviation amount
 232  =  Deviation (Balance_by_Unit amount (Amount_Unit amount))
 233 deriving instance ( Amount amount
 234                   , Data amount
 235                   ) => Data (Deviation amount)
 236 deriving instance ( Amount amount
 237                   , Eq amount
 238                   ) => Eq (Deviation amount)
 239 deriving instance ( Amount amount
 240                   , Show amount
 241                   ) => Show (Deviation amount)
 242 deriving instance Typeable1 Deviation
 243  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 244
 245 -- | Return the 'balance_by_unit' of the given 'Balance' with:
 246 --
 247 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
 248 --
 249 -- * and remaining 'unit's having their 'unit_sum_accounts'
 250 -- complemented with the 'balance_by_account' of the given 'Balance'
 251 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
 252 deviation
 253  :: Amount amount
 254  => Balance amount
 255  -> Deviation amount
 256 deviation bal = do
 257         let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
 258         let max_accounts = Data.Map.size all_accounts
 259         Deviation $
 260                 Data.Map.foldlWithKey
 261                  (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
 262                         if amount_null unit_sum_amount
 263                         then m
 264                         else
 265                                 case Data.Map.size unit_sum_accounts of
 266                                  n | n == max_accounts ->
 267                                         Data.Map.insert unit Unit_Sum
 268                                          { unit_sum_amount
 269                                          , unit_sum_accounts = Data.Map.empty
 270                                          } m
 271                                  _ -> do
 272                                         let diff = Data.Map.difference all_accounts unit_sum_accounts
 273                                         Data.Map.insert unit Unit_Sum
 274                                          { unit_sum_amount
 275                                          , unit_sum_accounts = diff
 276                                          } m
 277                  )
 278                  Data.Map.empty
 279                  (balance_by_unit bal)
 280
 281 -- ** The equilibrium
 282
 283 -- | Return the 'Balance' (adjusted by inferred 'Amount's)
 284 --   of the given 'Posting's and either:
 285 --
 286 --   * 'Left': the 'Posting's that cannot be inferred.
 287 --   * 'Right': the given 'Posting's with inferred 'Amount's inserted.
 288 infer_equilibrium ::
 289  ( Posting posting )
 290  => Map Account [posting]
 291  -> ( Balance (Posting_Amount posting)
 292     , Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
 293     )
 294 infer_equilibrium posts = do
 295         let bal_initial = Data.Foldable.foldr postings nil posts
 296         let Deviation dev = deviation bal_initial
 297         let (bal_adjusted, eithers) =
 298                 Data.Map.foldrWithKey
 299                  (\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
 300                  (bal, lr) ->
 301                         case Data.Map.size unit_sum_accounts of
 302                          1 ->
 303                                 let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
 304                                 let amt = amount_negate unit_sum_amount in
 305                                 let amts = Data.Map.singleton unit amt in
 306                                 ( balance (acct, amts) bal
 307                                 , Right (acct, unit, amt) : lr
 308                                 )
 309                          _ -> (bal, Left [unit_sum] : lr))
 310                  (bal_initial, [])
 311                  dev
 312         let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
 313                  (\(acct, unit, amt) ->
 314                         Data.Map.insertWith
 315                          (\_new_ps -> insert_amount (unit, amt))
 316                          acct (assert False []))
 317                  posts eithers
 318         case l of
 319          [] -> (bal_adjusted, Right r)
 320          _  -> (bal_adjusted, Left  l)
 321         where
 322                 insert_amount
 323                  :: Posting posting
 324                  => (Amount_Unit (Posting_Amount posting), Posting_Amount posting)
 325                  -> [posting] -> [posting]
 326                 insert_amount p@(unit, amt) ps =
 327                         case ps of
 328                          [] -> assert False []
 329                          (x:xs) | Data.Map.null (posting_amounts x) ->
 330                                 posting_set_amounts (Data.Map.singleton unit amt) x:xs
 331                                 | Data.Map.notMember unit (posting_amounts x) ->
 332                                 let amts = Data.Map.insertWith
 333                                          (assert False undefined)
 334                                          unit amt (posting_amounts x) in
 335                                 posting_set_amounts amts x:xs
 336                          (x:xs) -> x:insert_amount p xs
 337
 338 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
 339 is_at_equilibrium :: Amount amount => Deviation amount -> Bool
 340 is_at_equilibrium (Deviation dev) = Data.Map.null dev
 341
 342 -- | Return 'True' if and only if the given 'Deviation'
 343 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
 344 -- maps exactly one 'Account'.
 345 is_equilibrium_inferrable :: Amount amount => Deviation amount -> Bool
 346 is_equilibrium_inferrable (Deviation dev) =
 347         Data.Foldable.all
 348          (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
 349          dev
 350
 351 -- | Return 'True' if and only if the given 'Deviation'
 352 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
 353 -- maps more than one 'Account'.
 354 is_equilibrium_non_inferrable :: Amount amount => Deviation amount -> Bool
 355 is_equilibrium_non_inferrable (Deviation dev) =
 356         Data.Foldable.any
 357          (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
 358          dev
 359
 360 -- * Type 'Expanded'
 361
 362 -- | Descending propagation of 'Amount's accross 'Account's.
 363 type Expanded amount
 364  = TreeMap Account.Name (Account_Sum_Expanded amount)
 365 data Amount amount => Account_Sum_Expanded amount
 366  =   Account_Sum_Expanded
 367  { exclusive :: Map (Amount_Unit amount) amount
 368  , inclusive :: Map (Amount_Unit amount) amount -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
 369  }
 370 deriving instance ( Amount amount
 371                   , Data   amount
 372                   ) => Data (Account_Sum_Expanded amount)
 373 deriving instance ( Amount amount
 374                   , Eq     amount
 375                   ) => Eq (Account_Sum_Expanded amount)
 376 deriving instance ( Amount amount
 377                   , Show   amount
 378                   ) => Show (Account_Sum_Expanded amount)
 379 deriving instance Typeable1 Account_Sum_Expanded
 380  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 381
 382 -- | Return the given 'Balance_by_Account' with:
 383 --
 384 -- * all missing 'Account.ascending' 'Account's inserted,
 385 --
 386 -- * and every mapped 'Amount'
 387 -- added with any 'Amount'
 388 -- of the 'Account's for which it is 'Account.ascending'.
 389 expanded
 390  :: Amount amount
 391  => Balance_by_Account amount (Amount_Unit amount)
 392  -> Expanded amount
 393 expanded =
 394         let from_value = fromMaybe (assert False undefined) . Lib.TreeMap.node_value in
 395         Lib.TreeMap.map_by_depth_first
 396          (\descendants value ->
 397                 let nodes = Lib.TreeMap.nodes descendants in
 398                 let exclusive = fromMaybe Data.Map.empty value in
 399                 Account_Sum_Expanded
 400                  { exclusive
 401                  , inclusive =
 402                         Data.Map.foldr
 403                          (Data.Map.unionWith amount_add . inclusive . from_value)
 404                          exclusive nodes
 405                  })
 406
 407 -- | Return a 'Balance_by_Unit'
 408 --   derived from the given 'Expanded' balance.
 409 --
 410 --   NOTE: also correct if the 'Expanded' has been filtered.
 411 by_unit_of_expanded ::
 412  ( Amount amount
 413  , unit ~ Amount_Unit amount
 414  )
 415  => Expanded amount
 416  -> Balance_by_Unit amount unit
 417  -> Balance_by_Unit amount unit
 418 by_unit_of_expanded =
 419         go []
 420         where
 421                 go p (Lib.TreeMap.TreeMap m) bal =
 422                         Data.Map.foldrWithKey
 423                          (\k Lib.TreeMap.Node{Lib.TreeMap.node_value, Lib.TreeMap.node_descendants} acc ->
 424                                 case node_value of
 425                                  Nothing -> go (k:p) node_descendants acc
 426                                  Just a  ->
 427                                         let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
 428                                         by_unit (account, inclusive a) acc)
 429                          bal m