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