lib/Hcompta/Calc/Balance.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Hcompta.Calc.Balance where
   6
   7 import           Control.Exception (assert)
   8 import           Data.Data
   9 import qualified Data.Foldable
  10 import           Data.Foldable (Foldable(..))
  11 import qualified Data.List
  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  ( Ord (Posting_Unit p)
  77  , Amount (Posting_Amount 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_make    :: Account -> Map (Posting_Unit p) (Posting_Amount p) -> p
  85
  86 -- * The 'Balance' type
  87
  88 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
  89 data Balance amount unit
  90  =   Balance
  91  { balance_by_account :: Balance_by_Account amount unit
  92  , balance_by_unit    :: Balance_by_Unit amount unit
  93  } deriving (Data, Eq, Show, Typeable)
  94
  95 type Balance_by_Account amount unit
  96  = TreeMap Account.Name
  97            (Account_Sum amount unit)
  98
  99 -- | A sum of 'amount's,
 100 -- concerning a single 'Account'.
 101 type Account_Sum amount unit
 102  = Data.Map.Map unit amount
 103
 104 type Balance_by_Unit amount unit
 105  = Map unit (Unit_Sum amount)
 106
 107 -- | A sum of 'amount's with their 'Account's involved,
 108 -- concerning a single 'unit'.
 109 data Unit_Sum amount
 110  =   Unit_Sum
 111  { unit_sum_amount   :: Amount_Sum amount () -- ^ The sum of 'amount's for a single 'unit'.
 112  , unit_sum_accounts :: Map Account () -- ^ The 'Account's involved to build 'unit_sum_amount'.
 113  } deriving (Data, Eq, Show, Typeable)
 114
 115 -- ** Constructors
 116
 117 balance :: (Amount amount, Ord unit) => Balance amount unit
 118 balance =
 119         Balance
 120          { balance_by_account = Lib.TreeMap.empty
 121          , balance_by_unit    = Data.Map.empty
 122          }
 123
 124 -- | Return the given 'Balance'
 125 --   updated by the given 'Posting'.
 126 posting ::
 127  ( Posting posting
 128  , Amount amount
 129  , unit   ~ Posting_Unit posting
 130  , amount ~ Posting_Amount posting
 131  ) => posting -> Balance amount unit -> Balance amount unit
 132 posting post bal =
 133         bal
 134          { balance_by_account =
 135                 Lib.TreeMap.insert
 136                  (Data.Map.unionWith (flip (+)))
 137                  (posting_account post)
 138                  (posting_amounts post)
 139                  (balance_by_account bal)
 140          , balance_by_unit =
 141                 Data.Map.unionWith
 142                  (\new old -> Unit_Sum
 143                          { unit_sum_amount = amount_sum_add
 144                                  (unit_sum_amount old)
 145                                  (unit_sum_amount new)
 146                          , unit_sum_accounts = Data.Map.unionWith
 147                                  (const::()->()->())
 148                                  (unit_sum_accounts old)
 149                                  (unit_sum_accounts new)
 150                          })
 151                  (balance_by_unit bal) $
 152                 Data.Map.map
 153                  (\amount -> Unit_Sum
 154                          { unit_sum_amount   = amount_sum $ Data.Map.singleton () amount
 155                          , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
 156                          })
 157                  (posting_amounts post)
 158          }
 159
 160 -- | Return the given 'Balance'
 161 --   updated by the given 'Posting's.
 162 postings ::
 163  ( Posting posting
 164  , Amount amount
 165  , unit   ~ Posting_Unit   posting
 166  , amount ~ Posting_Amount posting
 167  , Foldable foldable )
 168  => foldable posting
 169  -> Balance amount unit
 170  -> Balance amount unit
 171 postings = flip (Data.Foldable.foldr posting)
 172
 173 -- | Return the first given 'Balance'
 174 --   updated by the second given 'Balance'.
 175 union
 176  :: (Amount amount, Ord unit)
 177  => Balance amount unit
 178  -> Balance amount unit
 179  -> Balance amount unit
 180 union b0 b1 =
 181         b0
 182          { balance_by_account =
 183                 Lib.TreeMap.union
 184                  (Data.Map.unionWith (flip (+)))
 185                  (balance_by_account b0)
 186                  (balance_by_account b1)
 187          , balance_by_unit =
 188                 Data.Map.unionWith
 189                  (\new old -> Unit_Sum
 190                          { unit_sum_amount = amount_sum_add
 191                                  (unit_sum_amount old)
 192                                  (unit_sum_amount new)
 193                          , unit_sum_accounts = Data.Map.unionWith
 194                                  (const::()->()->())
 195                                  (unit_sum_accounts old)
 196                                  (unit_sum_accounts new)
 197                          })
 198                  (balance_by_unit b0)
 199                  (balance_by_unit b1)
 200          }
 201
 202 -- * The 'Deviation' type
 203
 204 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
 205 --   is not zero and possible 'Account' to 'infer_equilibrium'.
 206 newtype Deviation amount unit
 207  =      Deviation (Balance_by_Unit amount unit)
 208  deriving (Data, Eq, Show, Typeable)
 209
 210 -- | Return the 'balance_by_unit' of the given 'Balance' with:
 211 --
 212 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
 213 --
 214 -- * and remaining 'unit's having their 'unit_sum_accounts'
 215 -- complemented with the 'balance_by_account' of the given 'Balance'
 216 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
 217 deviation
 218  :: (Amount amount, Ord unit)
 219  => Balance amount unit
 220  -> Deviation amount unit
 221 deviation bal = do
 222         let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
 223         let max_accounts = Data.Map.size all_accounts
 224         Deviation $
 225                 Data.Map.foldlWithKey
 226                  (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
 227                         if EQ == amount_sign (amount_sum_balance unit_sum_amount Data.Map.! ())
 228                         then m
 229                         else
 230                                 case Data.Map.size unit_sum_accounts of
 231                                  n | n == max_accounts ->
 232                                         Data.Map.insert unit Unit_Sum
 233                                          { unit_sum_amount
 234                                          , unit_sum_accounts = Data.Map.empty
 235                                          } m
 236                                  _ -> do
 237                                         let diff = Data.Map.difference all_accounts unit_sum_accounts
 238                                         Data.Map.insert unit Unit_Sum
 239                                          { unit_sum_amount
 240                                          , unit_sum_accounts = diff
 241                                          } m
 242                  )
 243                  Data.Map.empty
 244                  (balance_by_unit bal)
 245
 246 -- ** The equilibrium
 247
 248 -- | Return the 'Balance' (adjusted by inferred 'amount's)
 249 --   of the given 'Posting's and either:
 250 --
 251 --   * 'Left': the 'Posting's that cannot be inferred.
 252 --   * 'Right': the given 'Posting's with inferred 'amount's inserted.
 253 infer_equilibrium ::
 254  ( Posting posting
 255  , Amount amount
 256  , Ord unit
 257  , amount ~ Posting_Amount posting
 258  , unit   ~ Posting_Unit   posting )
 259  => Map Account [posting]
 260  -> ( Balance amount unit
 261     , Either [Unit_Sum amount] (Map Account [posting])
 262     )
 263 infer_equilibrium ps = do
 264         let bal_initial = Data.Foldable.foldr postings balance ps
 265         let Deviation dev = deviation bal_initial
 266         let (bal_adjusted, eithers) =
 267                 Data.Map.foldrWithKey
 268                  (\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
 269                  (bal, lr) ->
 270                         case Data.Map.size unit_sum_accounts of
 271                          1 ->
 272                                 let post =
 273                                         posting_make
 274                                          (fst $ Data.Map.elemAt 0 unit_sum_accounts)
 275                                          (Data.Map.mapKeys (\() -> unit) $
 276                                                 amount_sum_balance $
 277                                                 amount_sum_negate unit_sum_amount) in
 278                                 ( posting post bal
 279                                 , Right post : lr
 280                                 )
 281                          _ -> (bal, Left [unit_sum] : lr))
 282                  (bal_initial, [])
 283                  dev
 284         let (l, r) =
 285                 Lib.Foldable.accumLeftsAndFoldrRights
 286                  (\p -> Data.Map.insertWith
 287                          (\pn -> (++) pn . Data.List.filter (not . Data.Map.null . posting_amounts))
 288                          (posting_account p) [p])
 289                  ps
 290                  eithers
 291         case l of
 292          [] -> (bal_adjusted, Right r)
 293          _  -> (bal_adjusted, Left  l)
 294
 295 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
 296 is_at_equilibrium :: Deviation amount unit -> Bool
 297 is_at_equilibrium (Deviation dev) = Data.Map.null dev
 298
 299 -- | Return 'True' if and only if the given 'Deviation'
 300 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
 301 -- maps exactly one 'Account'.
 302 is_equilibrium_inferrable :: Deviation amount unit -> Bool
 303 is_equilibrium_inferrable (Deviation dev) =
 304         Data.Foldable.all
 305          (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
 306          dev
 307
 308 -- | Return 'True' if and only if the given 'Deviation'
 309 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
 310 -- maps more than one 'Account'.
 311 is_equilibrium_non_inferrable :: Deviation amount unit -> Bool
 312 is_equilibrium_non_inferrable (Deviation dev) =
 313         Data.Foldable.any
 314          (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
 315          dev
 316
 317 -- * The 'Expanded' type
 318
 319 -- | Descending propagation of 'amount's accross 'Account's.
 320 type Expanded amount unit
 321  = TreeMap Account.Name
 322            (Account_Sum_Expanded amount unit)
 323 data Account_Sum_Expanded amount unit
 324  =   Account_Sum_Expanded
 325  { exclusive :: Map unit amount
 326  , inclusive :: Amount_Sum amount unit -- ^ 'amount_sum_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
 327  }
 328  deriving (Data, Eq, Show, Typeable)
 329
 330 -- | Return the given 'Balance_by_Account' with:
 331 --
 332 -- * all missing 'Account.ascending' 'Account's inserted,
 333 --
 334 -- * and every mapped 'amount'
 335 -- added with any 'amount'
 336 -- of the 'Account's’ for which it is 'Account.ascending'.
 337 expanded ::
 338  ( Amount amount, Ord unit )
 339  => Balance_by_Account amount unit
 340  -> Expanded amount unit
 341 expanded =
 342         let from_value = fromMaybe (assert False undefined) . Lib.TreeMap.node_value in
 343         Lib.TreeMap.map_by_depth_first
 344          (\descendants value ->
 345                 let nodes = Lib.TreeMap.nodes descendants in
 346                 let exclusive = fromMaybe Data.Map.empty value in
 347                 Account_Sum_Expanded
 348                  { exclusive
 349                  , inclusive =
 350                         Data.Map.foldr
 351                          (amount_sum_add . inclusive . from_value)
 352                          (amount_sum exclusive) nodes
 353                  })