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