lib/Hcompta/Calc/Balance.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 module Hcompta.Calc.Balance where
   4
   5 import           Data.Data
   6 import qualified Data.Foldable
   7 import qualified Data.List
   8 import qualified Data.Map.Strict as Data.Map
   9 import           Data.Map.Strict (Map)
  10 import           Data.Typeable ()
  11 import qualified GHC.Num
  12
  13 import qualified Hcompta.Model as Model ()
  14 import qualified Hcompta.Model.Account as Account
  15 import           Hcompta.Model.Account (Account)
  16 import qualified Hcompta.Model.Amount as Amount
  17 import           Hcompta.Model.Amount (Amount, Unit)
  18 import qualified Hcompta.Model.Transaction as Transaction
  19 import           Hcompta.Model.Transaction (Transaction, Posting)
  20 import qualified Hcompta.Model.Transaction.Posting as Posting
  21 import qualified Hcompta.Model.Journal as Journal
  22 import           Hcompta.Model.Journal (Journal)
  23
  24 -- * The 'Balance' type
  25
  26 -- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
  27 data Balance
  28  =   Balance
  29  { by_account :: By_Account
  30  , by_unit    :: By_Unit
  31  } deriving (Data, Eq, Read, Show, Typeable)
  32 type By_Account
  33  = Map Account Sum_by_Account
  34 type By_Unit
  35  = Map Amount.Unit Sum_by_Unit
  36
  37
  38 -- | A sum by 'Account' of the 'Amount's of some 'Posting's.
  39 type Sum_by_Account
  40  = Amount.By_Unit
  41
  42 -- | A sum by 'Unit' of the 'Amount's of some 'Posting's,
  43 --   with the 'Account's involved to build that sum.
  44 data Sum_by_Unit
  45  =   Sum_by_Unit
  46  { accounts :: Map Account () -- ^ The 'Account's involved to build 'amount'.
  47  , amount   :: Amount -- ^ The sum of 'Amount's for a same 'Unit'.
  48  } deriving (Data, Eq, Read, Show, Typeable)
  49
  50 -- ** Constructors
  51
  52 nil :: Balance
  53 nil =
  54         Balance
  55          { by_account = Data.Map.empty
  56          , by_unit    = Data.Map.empty
  57          }
  58
  59 nil_By_Account :: By_Account
  60 nil_By_Account =
  61         Data.Map.empty
  62
  63 nil_By_Unit :: By_Unit
  64 nil_By_Unit =
  65         Data.Map.empty
  66
  67 nil_Sum_by_Account :: Sum_by_Account
  68 nil_Sum_by_Account =
  69         Data.Map.empty
  70
  71 nil_Sum_by_Unit :: Sum_by_Unit
  72 nil_Sum_by_Unit =
  73         Sum_by_Unit
  74          { accounts = Data.Map.empty
  75          , amount = Amount.nil
  76          }
  77
  78 -- | Return a tuple associating the given 'Sum_by_Unit' with its 'Unit'.
  79 assoc_by_amount_unit :: Sum_by_Unit -> (Unit, Sum_by_Unit)
  80 assoc_by_amount_unit s = (Amount.unit $ amount s, s)
  81
  82 -- | Return a 'Map' associating the given 'Sum_by_Unit' with their respective 'Unit'.
  83 by_Unit_from_List :: [Sum_by_Unit] -> By_Unit
  84 by_Unit_from_List balances =
  85         Data.Map.fromListWith
  86          (\x y -> Sum_by_Unit
  87                  { amount=(GHC.Num.+) (amount x) (amount y)
  88                  , accounts=Data.Map.union (accounts x) (accounts y)
  89                  }) $
  90         Data.List.map assoc_by_amount_unit balances
  91
  92 -- ** Incremental constructors
  93
  94 -- | Return the given 'Balance'
  95 --   updated by the given 'Posting'.
  96 posting :: Posting -> Balance -> Balance
  97 posting post balance =
  98         balance
  99          { by_account =
 100                 Data.Map.insertWith
 101                  (Data.Map.unionWith (GHC.Num.+))
 102                  (Posting.account post)
 103                  (Posting.amounts post)
 104                  (by_account balance)
 105          , by_unit =
 106                 Data.Map.unionWith
 107                  (\x y -> Sum_by_Unit
 108                          { amount = (GHC.Num.+) (amount x) (amount y)
 109                          , accounts = Data.Map.union (accounts x) (accounts y)
 110                          })
 111                  (by_unit balance) $
 112                 Data.Map.map
 113                  (\amt -> Sum_by_Unit
 114                          { amount=amt
 115                          , accounts=Data.Map.singleton (Posting.account post) ()
 116                          })
 117                  (Posting.amounts post)
 118          }
 119
 120 -- | Return the given 'Balance'
 121 --   updated by the 'Transaction.postings' of the given 'Transaction'.
 122 transaction :: Transaction -> Balance -> Balance
 123 transaction tran balance =
 124         Data.Map.foldr
 125          (flip (Data.List.foldl (flip posting)))
 126          balance
 127          (Transaction.postings tran)
 128
 129 -- | Return the given 'Balance'
 130 --   updated by the 'Journal.transactions' of the given 'Journal'.
 131 journal :: Journal -> Balance -> Balance
 132 journal jour balance =
 133         Data.Map.foldl
 134          (Data.List.foldl (flip transaction))
 135          balance
 136          (Journal.transactions jour)
 137
 138 -- | Return the first given 'Balance'
 139 --   updated by the second given 'Balance'.
 140 union :: Balance -> Balance -> Balance
 141 union b0 b1 =
 142         b0
 143          { by_account =
 144                 Data.Map.unionWith
 145                  (Data.Map.unionWith (GHC.Num.+))
 146                  (by_account b0)
 147                  (by_account b1)
 148          , by_unit =
 149                 Data.Map.unionWith
 150                  (\x y -> Sum_by_Unit
 151                          { amount = (GHC.Num.+) (amount x) (amount y)
 152                          , accounts = Data.Map.union (accounts x) (accounts y)
 153                          })
 154                  (by_unit b0)
 155                  (by_unit b1)
 156          }
 157
 158 -- ** Tests
 159
 160 -- | Return 'True' if and only if the 'Balance'
 161 --   has all its 'by_unit' 'amount's verify 'Amount.is_zero'
 162 --   or exactly one 'Account' of the 'by_unit' 'accounts' is not in 'by_account'.
 163 is_equilibrated :: Balance -> Bool
 164 is_equilibrated balance =
 165         Data.Foldable.all
 166          (\s ->
 167                 (Amount.is_zero $ amount s) ||
 168                 (Data.Map.size (accounts s) ==
 169                 (Data.Map.size (by_account balance) - 1))) -- NOTE: Data.Map.size is O(1)
 170          (by_unit balance)
 171
 172 -- * The 'Expanded' type
 173
 174 newtype Expanded
 175  =      Expanded By_Account
 176  deriving (Data, Eq, Read, Show, Typeable)
 177
 178 -- | Return the given 'By_Account'
 179 --   with all missing 'Account.ascending' 'Account's inserted,
 180 --   and every mapped Amount.'Amount.By_Unit'
 181 --   added with any 'Account's Amount.'Amount.By_Unit'
 182 --   to which it is 'Account.ascending'.
 183 expand :: By_Account -> Expanded
 184 expand balance =
 185         -- TODO: because (+) is associative
 186         --       the complexity could be improved a bit
 187         --       by only adding to the longest 'Account.ascending'
 188         --       and reuse this result thereafter,
 189         --       but coding this requires access
 190         --       to the hidden constructors of 'Data.Map.Map',
 191         --       which could be done through TemplateHaskell and lens:
 192         --       https://stackoverflow.com/questions/24153577/pattern-matching-on-data-map-for-implementing-map
 193         --
 194         -- a0' = a0 + a1 + a2 + a3   <-- current calculus
 195         --     = a0 + a1'            <-- improved calculus todo
 196         -- a1' =      a1 + a2 + a3
 197         --     =      a1 + a2'
 198         -- a2' =           a2 + a3
 199         -- a3' =                a3
 200         Expanded $
 201                 Data.Map.foldrWithKey
 202                  (\account amt ->
 203                         Account.fold (Account.ascending account)
 204                          (\prefix -> Data.Map.insertWith (+) prefix amt))
 205                  balance
 206                  balance