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