lib/Hcompta/Calc/Balance.hs

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