1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 module Hcompta.Calc.Balance where
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
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)
25 -- * The 'Balance' type
27 -- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
30 { by_account :: By_Account
32 } deriving (Data, Eq, Read, Show, Typeable)
34 = Map Account Sum_by_Account
36 = Map Amount.Unit Sum_by_Unit
39 -- | A sum by 'Account' of the 'Amount's of some 'Posting's.
43 -- | A sum by 'Unit' of the 'Amount's of some 'Posting's,
44 -- with the 'Account's involved to build that sum.
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)
56 { by_account = Data.Map.empty
57 , by_unit = Data.Map.empty
60 nil_By_Account :: By_Account
64 nil_By_Unit :: By_Unit
68 nil_Sum_by_Account :: Sum_by_Account
72 nil_Sum_by_Unit :: Sum_by_Unit
75 { accounts = Data.Map.empty
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)
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 =
88 { amount=(GHC.Num.+) (amount x) (amount y)
89 , accounts=Data.Map.union (accounts x) (accounts y)
91 Data.List.map assoc_by_amount_unit balances
93 -- ** Incremental constructors
95 -- | Return the given 'Balance'
96 -- updated by the given 'Posting'.
97 posting :: Posting -> Balance -> Balance
98 posting post balance =
102 (Data.Map.unionWith (GHC.Num.+))
103 (Posting.account post)
104 (Posting.amounts post)
109 { amount = (GHC.Num.+) (amount x) (amount y)
110 , accounts = Data.Map.union (accounts x) (accounts y)
114 (\amount -> Sum_by_Unit
116 , accounts = Data.Map.singleton (Posting.account post) ()
118 (Posting.amounts post)
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 =
127 (flip (Data.List.foldl (flip posting)))
129 (Transaction.postings tran)
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 =
139 (flip (Data.List.foldl (flip posting)))
141 (Transaction.postings tran)
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 =
148 (flip (Data.List.foldl (flip posting)))
150 (Transaction.balanced_virtual_postings tran)
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 =
159 (Data.List.foldl (flip transaction))
161 (Journal.transactions jour)
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 =
170 (Data.List.foldl (flip transaction_with_virtual))
172 (Journal.transactions jour)
174 -- | Return the first given 'Balance'
175 -- updated by the second given 'Balance'.
176 union :: Balance -> Balance -> Balance
181 (Data.Map.unionWith (GHC.Num.+))
187 { amount = (GHC.Num.+) (amount x) (amount y)
188 , accounts = Data.Map.union (accounts x) (accounts y)
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 =
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)
208 -- * The 'Expanded' type
211 = Expanded By_Account
212 deriving (Data, Eq, Read, Show, Typeable)
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
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
230 -- a0' = a0 + a1 + a2 + a3 <-- current calculus
231 -- = a0 + a1' <-- improved calculus todo
232 -- a1' = a1 + a2 + a3
237 Data.Map.foldrWithKey
239 Account.fold (Account.ascending account)
240 (\prefix -> Data.Map.insertWith (+) prefix amt))