1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
10 module Hcompta.Balance where
12 -- import Control.Applicative (Const(..))
13 import Control.Exception (assert)
15 import qualified Data.Foldable
16 -- import Data.Foldable (Foldable(..))
17 import qualified Data.Map.Strict as Data.Map
18 import Data.Map.Strict (Map)
19 import qualified Data.Strict.Maybe as Strict
20 import Data.Typeable ()
22 -- import Hcompta.Lib.Consable (Consable(..))
23 import qualified Hcompta.Lib.Foldable as Lib.Foldable
24 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
25 import Hcompta.Lib.TreeMap (TreeMap)
26 import qualified Hcompta.Account as Account
27 import Hcompta.Account (Account)
29 -- * Requirements' interface
33 ( Data (Amount_Unit a)
35 , Show (Amount_Unit a)
36 , 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 {- NOTE: not needed so far.
54 instance (Amount amount, unit ~ Amount_Unit amount)
55 => Posting (Account, Map unit amount)
57 type Posting_Amount (Account, Map unit amount) = amount
60 posting_set_amounts amounts (acct, _) = (acct, amounts)
63 instance (Amount amount)
64 => Posting (Account, Account_Sum amount)
66 type Posting_Amount (Account, Account_Sum amount) = amount
68 posting_amounts (_, Account_Sum x) = x
69 posting_set_amounts amounts (acct, _) = (acct, Account_Sum amounts)
73 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
75 -- NOTE: to reduce memory consumption when 'cons'ing iteratively,
76 -- the fields are explicitely stricts.
80 { balance_by_account :: !(Balance_by_Account amount)
81 , balance_by_unit :: !(Balance_by_Unit amount)
83 deriving instance ( Amount amount
85 ) => Data (Balance amount)
86 deriving instance ( Amount amount
88 ) => Eq (Balance amount)
89 deriving instance ( Amount amount
91 ) => Show (Balance amount)
92 deriving instance Typeable1 Balance
93 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
95 instance Amount amount => Monoid (Balance amount) where
99 -- ** Type 'Balance_by_Account'
100 type Balance_by_Account amount
101 = TreeMap Account.Name
104 -- *** Type 'Account_Sum'
105 -- | A sum of 'amount's,
106 -- concerning a single 'Account'.
107 newtype Amount amount
108 => Account_Sum amount
109 = Account_Sum (Map (Amount_Unit amount) amount)
110 get_Account_Sum :: Amount amount => Account_Sum amount -> Map (Amount_Unit amount) amount
111 get_Account_Sum (Account_Sum m) = m
112 deriving instance ( Amount amount
114 ) => Data (Account_Sum amount)
115 deriving instance ( Amount amount
117 ) => Eq (Account_Sum amount)
118 deriving instance ( Amount amount
120 ) => Show (Account_Sum amount)
121 deriving instance Typeable1 Account_Sum
122 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
124 instance Amount amount
125 => Monoid (Account_Sum amount) where
126 mempty = Account_Sum mempty
130 Account_Sum $ Data.Map.unionWith amount_add a0 a1
132 -- ** Type 'Balance_by_Unit'
133 newtype Amount amount
134 => Balance_by_Unit amount
135 = Balance_by_Unit (Map (Amount_Unit amount) (Unit_Sum amount))
136 deriving instance ( Amount amount
138 ) => Data (Balance_by_Unit amount)
139 deriving instance ( Amount amount
141 ) => Eq (Balance_by_Unit amount)
142 deriving instance ( Amount amount
144 ) => Show (Balance_by_Unit amount)
145 deriving instance Typeable1 Balance_by_Unit
146 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
148 instance Amount amount
149 => Monoid (Balance_by_Unit amount) where
150 mempty = Balance_by_Unit mempty
151 mappend = union_by_unit
153 -- *** Type 'Unit_Sum'
155 -- | A sum of 'amount's with their 'Account's involved,
156 -- concerning a single 'unit'.
159 { unit_sum_amount :: !amount -- ^ The sum of 'amount's for a single 'unit'.
160 , unit_sum_accounts :: !(Map Account ()) -- ^ The 'Account's involved to build 'unit_sum_amount'.
161 } deriving (Data, Eq, Show, Typeable)
165 empty :: Amount amount => Balance amount
168 { balance_by_account = mempty
169 , balance_by_unit = mempty
172 -- | Return the given 'Balance'
173 -- updated by the given 'Posting'.
176 , balance ~ Balance (Posting_Amount posting) )
177 => posting -> balance -> balance
180 { balance_by_account = cons_by_account post (balance_by_account bal)
181 , balance_by_unit = cons_by_unit post (balance_by_unit bal)
184 -- | Return the given 'Balance'
185 -- updated by the given 'Posting's.
188 , balance ~ Balance (Posting_Amount posting)
189 , Foldable foldable )
190 => foldable posting -> balance -> balance
191 postings = flip (Data.Foldable.foldr cons)
193 -- | Return the first given 'Balance'
194 -- updated by the second given 'Balance'.
195 union :: Amount amount
196 => Balance amount -> Balance amount -> Balance amount
201 { balance_by_account = union_by_account b0a b1a
202 , balance_by_unit = union_by_unit b0u b1u
205 -- | Return the given 'Balance_by_Account'
206 -- updated by the given 'Posting'.
209 , amount ~ Posting_Amount posting
210 , unit ~ Amount_Unit amount
213 -> Balance_by_Account amount
214 -> Balance_by_Account amount
215 cons_by_account post =
216 Lib.TreeMap.insert mappend
217 (posting_account post)
218 (Account_Sum $ posting_amounts post)
220 -- | Return the given 'Balance_by_Unit'
221 -- updated by the given 'Posting'.
224 , amount ~ Posting_Amount posting
225 , unit ~ Amount_Unit amount )
227 -> Balance_by_Unit amount
228 -> Balance_by_Unit amount
234 { unit_sum_amount = amount
235 , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
237 (posting_amounts post)
239 -- | Return a 'Balance_by_Unit'
240 -- derived from the given 'Balance_by_Account'.
241 by_unit_of_by_account ::
243 , unit ~ Amount_Unit amount
245 => Balance_by_Account amount
246 -> Balance_by_Unit amount
247 -> Balance_by_Unit amount
248 by_unit_of_by_account =
249 flip $ Lib.TreeMap.foldr_with_Path $ curry cons_by_unit
251 -- | Return the first given 'Balance_by_Account'
252 -- updated by the second given 'Balance_by_Account'.
253 union_by_account :: Amount amount
254 => Balance_by_Account amount
255 -> Balance_by_Account amount
256 -> Balance_by_Account amount
257 union_by_account = Lib.TreeMap.union mappend
259 -- | Return the first given 'Balance_by_Unit'
260 -- updated by the second given 'Balance_by_Unit'.
261 union_by_unit :: (Amount amount, unit ~ Amount_Unit amount)
262 => Balance_by_Unit amount
263 -> Balance_by_Unit amount
264 -> Balance_by_Unit amount
267 (Balance_by_Unit a1) =
270 (\new old -> Unit_Sum
271 { unit_sum_amount = amount_add
272 (unit_sum_amount old)
273 (unit_sum_amount new)
274 , unit_sum_accounts = Data.Map.unionWith
276 (unit_sum_accounts old)
277 (unit_sum_accounts new)
281 -- * Type 'Deviation'
283 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
284 -- is not zero and possible 'Account' to 'infer_equilibrium'.
285 newtype Amount amount
287 = Deviation (Balance_by_Unit amount)
288 deriving instance ( Amount amount
290 ) => Data (Deviation amount)
291 deriving instance ( Amount amount
293 ) => Eq (Deviation amount)
294 deriving instance ( Amount amount
296 ) => Show (Deviation amount)
297 deriving instance Typeable1 Deviation
298 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
300 -- | Return the 'balance_by_unit' of the given 'Balance' with:
302 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
304 -- * and remaining 'unit's having their 'unit_sum_accounts'
305 -- complemented with the 'balance_by_account' of the given 'Balance'
306 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
312 { balance_by_account=ba
313 , balance_by_unit=Balance_by_Unit bu
315 let all_accounts = Lib.TreeMap.flatten (const ()) ba
316 let max_accounts = Data.Map.size all_accounts
318 Data.Map.foldlWithKey
319 (\(Balance_by_Unit m) unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
321 if amount_null unit_sum_amount
324 case Data.Map.size unit_sum_accounts of
325 n | n == max_accounts ->
326 Data.Map.insert unit Unit_Sum
328 , unit_sum_accounts = Data.Map.empty
331 let diff = Data.Map.difference all_accounts unit_sum_accounts
332 Data.Map.insert unit Unit_Sum
334 , unit_sum_accounts = diff
340 -- ** The equilibrium
342 -- | Return the 'Balance' (adjusted by inferred 'Amount's)
343 -- of the given 'Posting's and either:
345 -- * 'Left': the 'Posting's that cannot be inferred.
346 -- * 'Right': the given 'Posting's with inferred 'Amount's inserted.
349 => Map Account [posting]
350 -> ( Balance (Posting_Amount posting)
351 , Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
353 infer_equilibrium posts = do
354 let bal_initial = Data.Foldable.foldr postings empty posts
355 let Deviation (Balance_by_Unit dev) = deviation bal_initial
356 let (bal_adjusted, eithers) =
357 Data.Map.foldrWithKey
358 (\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
360 case Data.Map.size unit_sum_accounts of
362 let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
363 let amt = amount_negate unit_sum_amount in
364 let amts = Data.Map.singleton unit amt in
365 ( cons (acct, Account_Sum amts) bal
366 , Right (acct, unit, amt) : lr
368 _ -> (bal, Left [unit_sum] : lr))
371 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
372 (\(acct, unit, amt) ->
374 (\_new_ps -> insert_amount (unit, amt))
375 acct (assert False []))
378 [] -> (bal_adjusted, Right r)
379 _ -> (bal_adjusted, Left l)
383 => (Amount_Unit (Posting_Amount posting), Posting_Amount posting)
384 -> [posting] -> [posting]
385 insert_amount p@(unit, amt) ps =
387 [] -> assert False []
388 (x:xs) | Data.Map.null (posting_amounts x) ->
389 posting_set_amounts (Data.Map.singleton unit amt) x:xs
390 | Data.Map.notMember unit (posting_amounts x) ->
391 let amts = Data.Map.insertWith
392 (assert False undefined)
393 unit amt (posting_amounts x) in
394 posting_set_amounts amts x:xs
395 (x:xs) -> x:insert_amount p xs
397 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
398 is_at_equilibrium :: Amount amount => Deviation amount -> Bool
399 is_at_equilibrium (Deviation (Balance_by_Unit dev)) = Data.Map.null dev
401 -- | Return 'True' if and only if the given 'Deviation'
402 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
403 -- maps exactly one 'Account'.
404 is_equilibrium_inferrable :: Amount amount => Deviation amount -> Bool
405 is_equilibrium_inferrable (Deviation (Balance_by_Unit dev)) =
407 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
410 -- | Return 'True' if and only if the given 'Deviation'
411 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
412 -- maps more than one 'Account'.
413 is_equilibrium_non_inferrable :: Amount amount => Deviation amount -> Bool
414 is_equilibrium_non_inferrable (Deviation (Balance_by_Unit dev)) =
416 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
421 -- | Descending propagation of 'Amount's accross 'Account's.
423 = TreeMap Account.Name (Account_Sum_Expanded amount)
424 data Amount amount => Account_Sum_Expanded amount
425 = Account_Sum_Expanded
426 { exclusive :: !(Account_Sum amount)
427 , inclusive :: !(Account_Sum amount) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
429 deriving instance ( Amount amount
431 ) => Data (Account_Sum_Expanded amount)
432 deriving instance ( Amount amount
434 ) => Eq (Account_Sum_Expanded amount)
435 deriving instance ( Amount amount
437 ) => Show (Account_Sum_Expanded amount)
438 deriving instance Typeable1 Account_Sum_Expanded
439 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
441 instance Amount amount => Monoid (Account_Sum_Expanded amount) where
442 mempty = Account_Sum_Expanded mempty mempty
444 (Account_Sum_Expanded e0 i0)
445 (Account_Sum_Expanded e1 i1) =
450 -- | Return the given 'Balance_by_Account' with:
452 -- * all missing 'Account.ascending' 'Account's inserted,
454 -- * and every mapped 'Amount'
455 -- added with any 'Amount'
456 -- of the 'Account's for which it is 'Account.ascending'.
459 => Balance_by_Account amount
462 Lib.TreeMap.map_by_depth_first
463 (\descendants value ->
464 let exclusive = Strict.fromMaybe mempty value in
469 ( flip $ mappend . inclusive
470 . Strict.fromMaybe (assert False undefined)
471 . Lib.TreeMap.node_value)
473 Lib.TreeMap.nodes descendants
476 -- | Return a 'Balance_by_Unit'
477 -- derived from the given 'Expanded' balance.
479 -- NOTE: also correct if the 'Expanded' has been filtered.
480 by_unit_of_expanded ::
482 , unit ~ Amount_Unit amount
485 -> Balance_by_Unit amount
486 -> Balance_by_Unit amount
487 by_unit_of_expanded =
490 go p (Lib.TreeMap.TreeMap m) bal =
491 Data.Map.foldrWithKey
492 (\k Lib.TreeMap.Node{Lib.TreeMap.node_value, Lib.TreeMap.node_descendants} acc ->
494 Strict.Nothing -> go (k:p) node_descendants acc
496 let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
497 cons_by_unit (account, inclusive a) acc)