1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
8 module Hcompta.Balance where
10 import Control.Exception (assert)
12 import qualified Data.Foldable
13 import Data.Foldable (Foldable(..))
14 import qualified Data.Map.Strict as Data.Map
15 import Data.Map.Strict (Map)
16 import Data.Maybe (fromMaybe)
17 import Data.Typeable ()
19 import qualified Hcompta.Lib.Foldable as Lib.Foldable
20 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
21 import Hcompta.Lib.TreeMap (TreeMap)
22 import qualified Hcompta.Account as Account
23 import Hcompta.Account (Account)
25 -- * Requirements' interface
29 ( Data (Amount_Unit a)
33 , Show (Amount_Unit a)
35 , Typeable (Amount_Unit a)
39 amount_null :: a -> Bool
40 amount_add :: a -> a -> a
41 amount_negate :: a -> a
45 -- | A 'posting' used to produce a 'Balance'
46 -- must be an instance of this class.
47 class Amount (Posting_Amount p) => Posting p where
49 posting_account :: p -> Account
50 posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
51 posting_set_amounts :: Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p) -> p -> p
53 instance (Amount amount, unit ~ Amount_Unit amount)
54 => Posting (Account, Map unit amount)
56 type Posting_Amount (Account, Map unit amount) = amount
59 posting_set_amounts amounts (acct, _) = (acct, amounts)
63 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
64 data Amount amount => Balance amount
66 { balance_by_account :: Balance_by_Account amount (Amount_Unit amount)
67 , balance_by_unit :: Balance_by_Unit amount (Amount_Unit amount)
69 deriving instance Amount amount => Data (Balance amount)
70 deriving instance Amount amount => Eq (Balance amount)
71 deriving instance Amount amount => Show (Balance amount)
72 deriving instance Typeable1 Balance -- FIXME: use 'Typeable' when dropping GHC-7.6 support
74 type Balance_by_Account amount unit
75 = TreeMap Account.Name
76 (Account_Sum amount unit)
78 -- | A sum of 'amount's,
79 -- concerning a single 'Account'.
80 type Account_Sum amount unit
81 = Data.Map.Map unit amount
83 type Balance_by_Unit amount unit
84 = Map unit (Unit_Sum amount)
86 -- | A sum of 'amount's with their 'Account's involved,
87 -- concerning a single 'unit'.
90 { unit_sum_amount :: amount -- ^ The sum of 'amount's for a single 'unit'.
91 , unit_sum_accounts :: Map Account () -- ^ The 'Account's involved to build 'unit_sum_amount'.
92 } deriving (Data, Eq, Show, Typeable)
96 nil :: Amount amount => Balance amount
99 { balance_by_account = Lib.TreeMap.empty
100 , balance_by_unit = Data.Map.empty
103 -- | Return the given 'Balance'
104 -- updated by the given 'Posting'.
107 , balance ~ Balance (Posting_Amount posting) )
108 => posting -> balance -> balance
111 { balance_by_account = by_account post (balance_by_account bal)
112 , balance_by_unit = by_unit post (balance_by_unit bal)
115 -- | Return the given 'Balance'
116 -- updated by the given 'Posting's.
119 , balance ~ Balance (Posting_Amount posting)
120 , Foldable foldable )
121 => foldable posting -> balance -> balance
122 postings = flip (Data.Foldable.foldr balance)
124 -- | Return the first given 'Balance'
125 -- updated by the second given 'Balance'.
126 union :: Amount amount
127 => Balance amount -> Balance amount -> Balance amount
130 { balance_by_account = union_by_account
131 (balance_by_account b0)
132 (balance_by_account b1)
133 , balance_by_unit = union_by_unit
138 -- | Return the given 'Balance_by_Account'
139 -- updated by the given 'Posting'.
142 , amount ~ Posting_Amount posting
143 , unit ~ Amount_Unit amount )
145 -> Balance_by_Account amount unit
146 -> Balance_by_Account amount unit
149 (Data.Map.unionWith (flip amount_add))
150 (posting_account post)
151 (posting_amounts post)
153 -- | Return the given 'Balance_by_Unit'
154 -- updated by the given 'Posting'.
157 , amount ~ Posting_Amount posting
158 , unit ~ Amount_Unit amount )
160 -> Balance_by_Unit amount unit
161 -> Balance_by_Unit amount unit
164 (\new old -> Unit_Sum
167 (unit_sum_amount old)
168 (unit_sum_amount new)
169 , unit_sum_accounts =
172 (unit_sum_accounts old)
173 (unit_sum_accounts new)
178 { unit_sum_amount = amount
179 , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
181 (posting_amounts post)
183 -- | Return a 'Balance_by_Unit'
184 -- derived from the given 'Balance_by_Account'.
185 by_unit_of_by_account ::
187 , unit ~ Amount_Unit amount
189 => Balance_by_Account amount unit
190 -> Balance_by_Unit amount unit
191 -> Balance_by_Unit amount unit
192 by_unit_of_by_account =
193 flip $ Lib.TreeMap.foldr_with_Path $ curry by_unit
195 -- | Return the first given 'Balance_by_Account'
196 -- updated by the second given 'Balance_by_Account'.
197 union_by_account :: (Amount amount, unit ~ Amount_Unit amount)
198 => Balance_by_Account amount unit
199 -> Balance_by_Account amount unit
200 -> Balance_by_Account amount unit
203 (Data.Map.unionWith (flip amount_add))
205 -- | Return the first given 'Balance_by_Unit'
206 -- updated by the second given 'Balance_by_Unit'.
207 union_by_unit :: (Amount amount, unit ~ Amount_Unit amount)
208 => Balance_by_Unit amount unit
209 -> Balance_by_Unit amount unit
210 -> Balance_by_Unit amount unit
213 (\new old -> Unit_Sum
214 { unit_sum_amount = amount_add
215 (unit_sum_amount old)
216 (unit_sum_amount new)
217 , unit_sum_accounts = Data.Map.unionWith
219 (unit_sum_accounts old)
220 (unit_sum_accounts new)
223 -- * Type 'Deviation'
225 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
226 -- is not zero and possible 'Account' to 'infer_equilibrium'.
227 newtype Amount amount
229 = Deviation (Balance_by_Unit amount (Amount_Unit amount))
230 deriving instance Amount amount => Data (Deviation amount)
231 deriving instance Amount amount => Eq (Deviation amount)
232 deriving instance Amount amount => Show (Deviation amount)
233 deriving instance Typeable1 Deviation -- FIXME: use 'Typeable' when dropping GHC-7.6 support
235 -- | Return the 'balance_by_unit' of the given 'Balance' with:
237 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
239 -- * and remaining 'unit's having their 'unit_sum_accounts'
240 -- complemented with the 'balance_by_account' of the given 'Balance'
241 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
247 let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
248 let max_accounts = Data.Map.size all_accounts
250 Data.Map.foldlWithKey
251 (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
252 if amount_null unit_sum_amount
255 case Data.Map.size unit_sum_accounts of
256 n | n == max_accounts ->
257 Data.Map.insert unit Unit_Sum
259 , unit_sum_accounts = Data.Map.empty
262 let diff = Data.Map.difference all_accounts unit_sum_accounts
263 Data.Map.insert unit Unit_Sum
265 , unit_sum_accounts = diff
269 (balance_by_unit bal)
271 -- ** The equilibrium
273 -- | Return the 'Balance' (adjusted by inferred 'Amount's)
274 -- of the given 'Posting's and either:
276 -- * 'Left': the 'Posting's that cannot be inferred.
277 -- * 'Right': the given 'Posting's with inferred 'Amount's inserted.
280 => Map Account [posting]
281 -> ( Balance (Posting_Amount posting)
282 , Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
284 infer_equilibrium posts = do
285 let bal_initial = Data.Foldable.foldr postings nil posts
286 let Deviation dev = deviation bal_initial
287 let (bal_adjusted, eithers) =
288 Data.Map.foldrWithKey
289 (\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
291 case Data.Map.size unit_sum_accounts of
293 let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
294 let amt = amount_negate unit_sum_amount in
295 let amts = Data.Map.singleton unit amt in
296 ( balance (acct, amts) bal
297 , Right (acct, unit, amt) : lr
299 _ -> (bal, Left [unit_sum] : lr))
302 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
303 (\(acct, unit, amt) ->
305 (\_new_ps -> insert_amount (unit, amt))
306 acct (assert False []))
309 [] -> (bal_adjusted, Right r)
310 _ -> (bal_adjusted, Left l)
314 => (Amount_Unit (Posting_Amount posting), Posting_Amount posting)
315 -> [posting] -> [posting]
316 insert_amount p@(unit, amt) ps =
318 [] -> assert False []
319 (x:xs) | Data.Map.null (posting_amounts x) ->
320 posting_set_amounts (Data.Map.singleton unit amt) x:xs
321 | Data.Map.notMember unit (posting_amounts x) ->
322 let amts = Data.Map.insertWith
323 (assert False undefined)
324 unit amt (posting_amounts x) in
325 posting_set_amounts amts x:xs
326 (x:xs) -> x:insert_amount p xs
328 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
329 is_at_equilibrium :: Amount amount => Deviation amount -> Bool
330 is_at_equilibrium (Deviation dev) = Data.Map.null dev
332 -- | Return 'True' if and only if the given 'Deviation'
333 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
334 -- maps exactly one 'Account'.
335 is_equilibrium_inferrable :: Amount amount => Deviation amount -> Bool
336 is_equilibrium_inferrable (Deviation dev) =
338 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
341 -- | Return 'True' if and only if the given 'Deviation'
342 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
343 -- maps more than one 'Account'.
344 is_equilibrium_non_inferrable :: Amount amount => Deviation amount -> Bool
345 is_equilibrium_non_inferrable (Deviation dev) =
347 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
352 -- | Descending propagation of 'Amount's accross 'Account's.
354 = TreeMap Account.Name (Account_Sum_Expanded amount)
355 data Amount amount => Account_Sum_Expanded amount
356 = Account_Sum_Expanded
357 { exclusive :: Map (Amount_Unit amount) amount
358 , inclusive :: Map (Amount_Unit amount) amount -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
360 deriving instance Amount amount => Data (Account_Sum_Expanded amount)
361 deriving instance Amount amount => Eq (Account_Sum_Expanded amount)
362 deriving instance Amount amount => Show (Account_Sum_Expanded amount)
363 deriving instance Typeable1 Account_Sum_Expanded -- FIXME: use 'Typeable' when dropping GHC-7.6 support
365 -- | Return the given 'Balance_by_Account' with:
367 -- * all missing 'Account.ascending' 'Account's inserted,
369 -- * and every mapped 'Amount'
370 -- added with any 'Amount'
371 -- of the 'Account's for which it is 'Account.ascending'.
374 => Balance_by_Account amount (Amount_Unit amount)
377 let from_value = fromMaybe (assert False undefined) . Lib.TreeMap.node_value in
378 Lib.TreeMap.map_by_depth_first
379 (\descendants value ->
380 let nodes = Lib.TreeMap.nodes descendants in
381 let exclusive = fromMaybe Data.Map.empty value in
386 (Data.Map.unionWith amount_add . inclusive . from_value)
390 -- | Return a 'Balance_by_Unit'
391 -- derived from the given 'Expanded' balance.
393 -- NOTE: also correct if the 'Expanded' has been filtered.
394 by_unit_of_expanded ::
396 , unit ~ Amount_Unit amount
399 -> Balance_by_Unit amount unit
400 -> Balance_by_Unit amount unit
401 by_unit_of_expanded =
404 go p (Lib.TreeMap.TreeMap m) bal =
405 Data.Map.foldrWithKey
406 (\k Lib.TreeMap.Node{Lib.TreeMap.node_value, Lib.TreeMap.node_descendants} acc ->
408 Nothing -> go (k:p) node_descendants acc
410 let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
411 by_unit (account, inclusive a) acc)