lib/Hcompta/Calc/Balance.hs

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