1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 module Hcompta.Calc.Balance where
6 import qualified Data.Foldable
7 import qualified Data.List
8 import qualified Data.Map
10 import Data.Typeable ()
11 import qualified GHC.Num
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
22 -- * The 'Balance' type
24 -- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
27 { by_account :: By_Account
29 } deriving (Data, Eq, Read, Show, Typeable)
31 = Map Account Sum_by_Account
33 = Map Amount.Unit Sum_by_Unit
36 -- | A sum by 'Account' of the 'Amount's of some 'Posting's.
40 -- | A sum by 'Unit' of the 'Amount's of some 'Posting's,
41 -- with the 'Account's involved to build that sum.
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)
53 { by_account = Data.Map.empty
54 , by_unit = Data.Map.empty
57 nil_By_Account :: By_Account
61 nil_By_Unit :: By_Unit
65 nil_Sum_by_Account :: Sum_by_Account
69 nil_Sum_by_Unit :: Sum_by_Unit
72 { accounts = Data.Map.empty
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)
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 =
85 { amount=(GHC.Num.+) (amount x) (amount y)
86 , accounts=Data.Map.union (accounts x) (accounts y)
88 Data.List.map assoc_by_amount_unit balances
90 -- ** Incremental constructors
92 -- | Return the given 'Balance'
93 -- updated by the given 'Posting'.
94 posting :: Posting -> Balance -> Balance
95 posting post balance =
99 (Data.Map.unionWith (GHC.Num.+))
100 (Posting.account post)
101 (Posting.amounts post)
106 { amount = (GHC.Num.+) (amount x) (amount y)
107 , accounts = Data.Map.union (accounts x) (accounts y)
113 , accounts=Data.Map.singleton (Posting.account post) ()
115 (Posting.amounts post)
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)
125 -- | Return the first given 'Balance'
126 -- updated by the second given 'Balance'.
127 union :: Balance -> Balance -> Balance
132 (Data.Map.unionWith (GHC.Num.+))
138 { amount = (GHC.Num.+) (amount x) (amount y)
139 , accounts = Data.Map.union (accounts x) (accounts y)
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 =
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)
159 -- * The 'Expanded' type
162 = Expanded By_Account
163 deriving (Data, Eq, Read, Show, Typeable)
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
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
181 -- a0' = a0 + a1 + a2 + a3 <-- current calculus
182 -- = a0 + a1' <-- improved calculus todo
183 -- a1' = a1 + a2 + a3
188 Data.Map.foldrWithKey
190 Account.fold (Account.ascending account)
191 (\prefix -> Data.Map.insertWith (+) prefix amount))