lib/Hcompta/Calc/Balance.hs

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