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
42 amount_positive :: a -> Maybe a
43 amount_negative :: a -> Maybe a
45 instance (Amount a, unit ~ Amount_Unit a)
46 => Amount (Map unit a) where
47 type Amount_Unit (Map unit a) = Amount_Unit a
48 amount_null = Data.Foldable.all amount_null
49 amount_add = Data.Map.unionWith amount_add
50 amount_negate = Data.Map.map amount_negate
52 let m = Data.Map.mapMaybe amount_negative a in
57 let m = Data.Map.mapMaybe amount_positive a in
64 -- | A 'posting' used to produce a 'Balance'
65 -- must be an instance of this class.
66 class Amount (Posting_Amount p) => Posting p where
68 posting_account :: p -> Account
69 posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
70 posting_set_amounts :: Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p) -> p -> p
72 instance (Amount amount, unit ~ Amount_Unit amount)
73 => Posting (Account, Map unit amount)
75 type Posting_Amount (Account, Map unit amount) = amount
78 posting_set_amounts amounts (acct, _) = (acct, amounts)
82 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
83 data Amount amount => Balance amount
85 { balance_by_account :: Balance_by_Account amount (Amount_Unit amount)
86 , balance_by_unit :: Balance_by_Unit amount (Amount_Unit amount)
88 deriving instance Amount amount => Data (Balance amount)
89 deriving instance Amount amount => Eq (Balance amount)
90 deriving instance Amount amount => Show (Balance amount)
91 deriving instance Typeable1 Balance -- FIXME: use 'Typeable' when dropping GHC-7.6 support
93 type Balance_by_Account amount unit
94 = TreeMap Account.Name
95 (Account_Sum amount unit)
97 -- | A sum of 'amount's,
98 -- concerning a single 'Account'.
99 type Account_Sum amount unit
100 = Data.Map.Map unit amount
102 type Balance_by_Unit amount unit
103 = Map unit (Unit_Sum amount)
105 -- | A sum of 'amount's with their 'Account's involved,
106 -- concerning a single 'unit'.
109 { unit_sum_amount :: amount -- ^ The sum of 'amount's for a single 'unit'.
110 , unit_sum_accounts :: Map Account () -- ^ The 'Account's involved to build 'unit_sum_amount'.
111 } deriving (Data, Eq, Show, Typeable)
115 nil :: Amount amount => Balance amount
118 { balance_by_account = Lib.TreeMap.empty
119 , balance_by_unit = Data.Map.empty
122 -- | Return the given 'Balance'
123 -- updated by the given 'Posting'.
126 , balance ~ Balance (Posting_Amount posting) )
127 => posting -> balance -> balance
130 { balance_by_account = by_account post (balance_by_account bal)
131 , balance_by_unit = by_unit post (balance_by_unit bal)
134 -- | Return the given 'Balance'
135 -- updated by the given 'Posting's.
138 , balance ~ Balance (Posting_Amount posting)
139 , Foldable foldable )
140 => foldable posting -> balance -> balance
141 postings = flip (Data.Foldable.foldr balance)
143 -- | Return the first given 'Balance'
144 -- updated by the second given 'Balance'.
145 union :: Amount amount
146 => Balance amount -> Balance amount -> Balance amount
149 { balance_by_account = union_by_account
150 (balance_by_account b0)
151 (balance_by_account b1)
152 , balance_by_unit = union_by_unit
157 -- | Return the given 'Balance_by_Account'
158 -- updated by the given 'Posting'.
161 , amount ~ Posting_Amount posting
162 , unit ~ Amount_Unit amount )
164 -> Balance_by_Account amount unit
165 -> Balance_by_Account amount unit
168 (Data.Map.unionWith (flip amount_add))
169 (posting_account post)
170 (posting_amounts post)
172 -- | Return the given 'Balance_by_Unit'
173 -- updated by the given 'Posting'.
176 , amount ~ Posting_Amount posting
177 , unit ~ Amount_Unit amount )
179 -> Balance_by_Unit amount unit
180 -> Balance_by_Unit amount unit
183 (\new old -> Unit_Sum
186 (unit_sum_amount old)
187 (unit_sum_amount new)
188 , unit_sum_accounts =
191 (unit_sum_accounts old)
192 (unit_sum_accounts new)
197 { unit_sum_amount = amount
198 , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
200 (posting_amounts post)
202 -- | Return a 'Balance_by_Unit'
203 -- derived from the given 'Balance_by_Account'.
204 by_unit_of_by_account ::
206 , unit ~ Amount_Unit amount
208 => Balance_by_Account amount unit
209 -> Balance_by_Unit amount unit
210 -> Balance_by_Unit amount unit
211 by_unit_of_by_account =
212 flip $ Lib.TreeMap.foldr_with_Path $ curry by_unit
214 -- | Return the first given 'Balance_by_Account'
215 -- updated by the second given 'Balance_by_Account'.
216 union_by_account :: (Amount amount, unit ~ Amount_Unit amount)
217 => Balance_by_Account amount unit
218 -> Balance_by_Account amount unit
219 -> Balance_by_Account amount unit
222 (Data.Map.unionWith (flip amount_add))
224 -- | Return the first given 'Balance_by_Unit'
225 -- updated by the second given 'Balance_by_Unit'.
226 union_by_unit :: (Amount amount, unit ~ Amount_Unit amount)
227 => Balance_by_Unit amount unit
228 -> Balance_by_Unit amount unit
229 -> Balance_by_Unit amount unit
232 (\new old -> Unit_Sum
233 { unit_sum_amount = amount_add
234 (unit_sum_amount old)
235 (unit_sum_amount new)
236 , unit_sum_accounts = Data.Map.unionWith
238 (unit_sum_accounts old)
239 (unit_sum_accounts new)
242 -- * Type 'Deviation'
244 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
245 -- is not zero and possible 'Account' to 'infer_equilibrium'.
246 newtype Amount amount
248 = Deviation (Balance_by_Unit amount (Amount_Unit amount))
249 deriving instance Amount amount => Data (Deviation amount)
250 deriving instance Amount amount => Eq (Deviation amount)
251 deriving instance Amount amount => Show (Deviation amount)
252 deriving instance Typeable1 Deviation -- FIXME: use 'Typeable' when dropping GHC-7.6 support
254 -- | Return the 'balance_by_unit' of the given 'Balance' with:
256 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
258 -- * and remaining 'unit's having their 'unit_sum_accounts'
259 -- complemented with the 'balance_by_account' of the given 'Balance'
260 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
266 let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
267 let max_accounts = Data.Map.size all_accounts
269 Data.Map.foldlWithKey
270 (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
271 if amount_null unit_sum_amount
274 case Data.Map.size unit_sum_accounts of
275 n | n == max_accounts ->
276 Data.Map.insert unit Unit_Sum
278 , unit_sum_accounts = Data.Map.empty
281 let diff = Data.Map.difference all_accounts unit_sum_accounts
282 Data.Map.insert unit Unit_Sum
284 , unit_sum_accounts = diff
288 (balance_by_unit bal)
290 -- ** The equilibrium
292 -- | Return the 'Balance' (adjusted by inferred 'Amount's)
293 -- of the given 'Posting's and either:
295 -- * 'Left': the 'Posting's that cannot be inferred.
296 -- * 'Right': the given 'Posting's with inferred 'Amount's inserted.
299 => Map Account [posting]
300 -> ( Balance (Posting_Amount posting)
301 , Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
303 infer_equilibrium posts = do
304 let bal_initial = Data.Foldable.foldr postings nil posts
305 let Deviation dev = deviation bal_initial
306 let (bal_adjusted, eithers) =
307 Data.Map.foldrWithKey
308 (\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
310 case Data.Map.size unit_sum_accounts of
312 let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
313 let amt = amount_negate unit_sum_amount in
314 let amts = Data.Map.singleton unit amt in
315 ( balance (acct, amts) bal
316 , Right (acct, unit, amt) : lr
318 _ -> (bal, Left [unit_sum] : lr))
321 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
322 (\(acct, unit, amt) ->
324 (\_new_ps -> insert_amount (unit, amt))
325 acct (assert False []))
328 [] -> (bal_adjusted, Right r)
329 _ -> (bal_adjusted, Left l)
333 => (Amount_Unit (Posting_Amount posting), Posting_Amount posting)
334 -> [posting] -> [posting]
335 insert_amount p@(unit, amt) ps =
337 [] -> assert False []
338 (x:xs) | Data.Map.null (posting_amounts x) ->
339 posting_set_amounts (Data.Map.singleton unit amt) x:xs
340 | Data.Map.notMember unit (posting_amounts x) ->
341 let amts = Data.Map.insertWith
342 (assert False undefined)
343 unit amt (posting_amounts x) in
344 posting_set_amounts amts x:xs
345 (x:xs) -> x:insert_amount p xs
347 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
348 is_at_equilibrium :: Amount amount => Deviation amount -> Bool
349 is_at_equilibrium (Deviation dev) = Data.Map.null dev
351 -- | Return 'True' if and only if the given 'Deviation'
352 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
353 -- maps exactly one 'Account'.
354 is_equilibrium_inferrable :: Amount amount => Deviation amount -> Bool
355 is_equilibrium_inferrable (Deviation dev) =
357 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
360 -- | Return 'True' if and only if the given 'Deviation'
361 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
362 -- maps more than one 'Account'.
363 is_equilibrium_non_inferrable :: Amount amount => Deviation amount -> Bool
364 is_equilibrium_non_inferrable (Deviation dev) =
366 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
371 -- | Descending propagation of 'Amount's accross 'Account's.
373 = TreeMap Account.Name (Account_Sum_Expanded amount)
374 data Amount amount => Account_Sum_Expanded amount
375 = Account_Sum_Expanded
376 { exclusive :: Map (Amount_Unit amount) amount
377 , inclusive :: Map (Amount_Unit amount) amount -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
379 deriving instance Amount amount => Data (Account_Sum_Expanded amount)
380 deriving instance Amount amount => Eq (Account_Sum_Expanded amount)
381 deriving instance Amount amount => Show (Account_Sum_Expanded amount)
382 deriving instance Typeable1 Account_Sum_Expanded -- FIXME: use 'Typeable' when dropping GHC-7.6 support
384 -- | Return the given 'Balance_by_Account' with:
386 -- * all missing 'Account.ascending' 'Account's inserted,
388 -- * and every mapped 'Amount'
389 -- added with any 'Amount'
390 -- of the 'Account's for which it is 'Account.ascending'.
393 => Balance_by_Account amount (Amount_Unit amount)
396 let from_value = fromMaybe (assert False undefined) . Lib.TreeMap.node_value in
397 Lib.TreeMap.map_by_depth_first
398 (\descendants value ->
399 let nodes = Lib.TreeMap.nodes descendants in
400 let exclusive = fromMaybe Data.Map.empty value in
405 (Data.Map.unionWith amount_add . inclusive . from_value)
409 -- | Return a 'Balance_by_Unit'
410 -- derived from the given 'Expanded' balance.
412 -- NOTE: also correct if the 'Expanded' has been filtered.
413 by_unit_of_expanded ::
415 , unit ~ Amount_Unit amount
418 -> Balance_by_Unit amount unit
419 -> Balance_by_Unit amount unit
420 by_unit_of_expanded =
423 go p (Lib.TreeMap.TreeMap m) bal =
424 Data.Map.foldrWithKey
425 (\k Lib.TreeMap.Node{Lib.TreeMap.node_value, Lib.TreeMap.node_descendants} acc ->
427 Nothing -> go (k:p) node_descendants acc
429 let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
430 by_unit (account, inclusive a) acc)
433 -- * Type 'Amount_Sum'
435 -- | Sum separately keeping track of negative and positive 'amount's.
438 = Amount_Sum_Negative amount
439 | Amount_Sum_Positive amount
440 | Amount_Sum_Both amount amount
441 deriving (Data, Eq, Show, Typeable)
443 instance Amount a => Amount (Amount_Sum a) where
444 type Amount_Unit (Amount_Sum a) = Amount_Unit a
447 Amount_Sum_Negative n -> amount_null n
448 Amount_Sum_Positive p -> amount_null p
449 Amount_Sum_Both n p -> amount_null (amount_add n p)
452 (Amount_Sum_Negative n0, Amount_Sum_Negative n1) -> Amount_Sum_Negative (amount_add n0 n1)
453 (Amount_Sum_Negative n , Amount_Sum_Positive p) -> Amount_Sum_Both n p
454 (Amount_Sum_Negative n0, Amount_Sum_Both n1 p) -> Amount_Sum_Both (amount_add n0 n1) p
456 (Amount_Sum_Positive p , Amount_Sum_Negative n) -> Amount_Sum_Both n p
457 (Amount_Sum_Positive p0, Amount_Sum_Positive p1) -> Amount_Sum_Positive (amount_add p0 p1)
458 (Amount_Sum_Positive p , Amount_Sum_Both n1 p1) -> Amount_Sum_Both n1 (amount_add p p1)
460 (Amount_Sum_Both n0 p0, Amount_Sum_Negative p1) -> Amount_Sum_Both n0 (amount_add p0 p1)
461 (Amount_Sum_Both n0 p0, Amount_Sum_Positive p1) -> Amount_Sum_Both n0 (amount_add p0 p1)
462 (Amount_Sum_Both n0 p0, Amount_Sum_Both n1 p1) -> Amount_Sum_Both (amount_add n0 n1) (amount_add p0 p1)
465 Amount_Sum_Negative n -> Amount_Sum_Positive $ amount_negate n
466 Amount_Sum_Positive p -> Amount_Sum_Negative $ amount_negate p
467 Amount_Sum_Both n p -> Amount_Sum_Both (amount_negate p) (amount_negate n)
468 amount_negative amt =
470 Amount_Sum_Negative _ -> Just $ amt
471 Amount_Sum_Positive _ -> Nothing
472 Amount_Sum_Both n _ -> Just $ Amount_Sum_Negative n
473 amount_positive amt =
475 Amount_Sum_Negative _ -> Nothing
476 Amount_Sum_Positive _ -> Just $ amt
477 Amount_Sum_Both _ p -> Just $ Amount_Sum_Positive p
481 => amount -> Amount_Sum amount
483 case (amount_negative amt, amount_positive amt) of
484 (Just n, Nothing) -> Amount_Sum_Negative n
485 (Nothing, Just p) -> Amount_Sum_Positive p
486 (Just n, Just p) -> Amount_Sum_Both n p
487 (Nothing, Nothing) -> Amount_Sum_Both amt amt
491 => Amount_Sum amount -> Maybe amount
492 amount_sum_negative amt =
494 Amount_Sum_Negative n -> Just n
495 Amount_Sum_Positive _ -> Nothing
496 Amount_Sum_Both n _ -> Just n
500 => Amount_Sum amount -> Maybe amount
501 amount_sum_positive amt =
503 Amount_Sum_Negative _ -> Nothing
504 Amount_Sum_Positive p -> Just p
505 Amount_Sum_Both _ p -> Just p
509 => Amount_Sum amount -> amount
510 amount_sum_balance amt =
512 Amount_Sum_Negative n -> n
513 Amount_Sum_Positive p -> p
514 Amount_Sum_Both n p -> amount_add n p