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