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.Calc.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.Model.Account as Account
23 import Hcompta.Model.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_by_Account'
123 -- updated by the given 'Posting'.
126 , amount ~ Posting_Amount posting
127 , unit ~ Amount_Unit amount )
129 -> Balance_by_Account amount unit
130 -> Balance_by_Account amount unit
133 (Data.Map.unionWith (flip amount_add))
134 (posting_account post)
135 (posting_amounts post)
137 -- | Return the given 'Balance_by_Unit'
138 -- updated by the given 'Posting'.
141 , amount ~ Posting_Amount posting
142 , unit ~ Amount_Unit amount )
144 -> Balance_by_Unit amount unit
145 -> Balance_by_Unit amount unit
148 (\new old -> Unit_Sum
151 (unit_sum_amount old)
152 (unit_sum_amount new)
153 , unit_sum_accounts =
156 (unit_sum_accounts old)
157 (unit_sum_accounts new)
162 { unit_sum_amount = amount
163 , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
165 (posting_amounts post)
167 -- | Return a 'Balance_by_Unit'
168 -- derived from the given 'Balance_by_Account'.
169 by_unit_of_by_account ::
171 , unit ~ Amount_Unit amount
173 => Balance_by_Account amount unit
174 -> Balance_by_Unit amount unit
175 -> Balance_by_Unit amount unit
176 by_unit_of_by_account =
177 flip $ Lib.TreeMap.foldr_with_Path $ curry by_unit
179 -- | Return the given 'Balance'
180 -- updated by the given 'Posting'.
183 , balance ~ Balance (Posting_Amount posting) )
184 => posting -> balance -> balance
187 { balance_by_account = by_account post (balance_by_account bal)
188 , balance_by_unit = by_unit post (balance_by_unit bal)
191 -- | Return the given 'Balance'
192 -- updated by the given 'Posting's.
195 , balance ~ Balance (Posting_Amount posting)
196 , Foldable foldable )
197 => foldable posting -> balance -> balance
198 postings = flip (Data.Foldable.foldr balance)
200 -- | Return the first given 'Balance'
201 -- updated by the second given 'Balance'.
202 union :: Amount amount
203 => Balance amount -> Balance amount -> Balance amount
206 { balance_by_account =
208 (Data.Map.unionWith (flip amount_add))
209 (balance_by_account b0)
210 (balance_by_account b1)
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)
226 -- * Type 'Deviation'
228 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
229 -- is not zero and possible 'Account' to 'infer_equilibrium'.
230 newtype Amount amount
232 = Deviation (Balance_by_Unit amount (Amount_Unit amount))
233 deriving instance Amount amount => Data (Deviation amount)
234 deriving instance Amount amount => Eq (Deviation amount)
235 deriving instance Amount amount => Show (Deviation amount)
236 deriving instance Typeable1 Deviation -- FIXME: use 'Typeable' when dropping GHC-7.6 support
238 -- | Return the 'balance_by_unit' of the given 'Balance' with:
240 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
242 -- * and remaining 'unit's having their 'unit_sum_accounts'
243 -- complemented with the 'balance_by_account' of the given 'Balance'
244 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
250 let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
251 let max_accounts = Data.Map.size all_accounts
253 Data.Map.foldlWithKey
254 (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
255 if amount_null unit_sum_amount
258 case Data.Map.size unit_sum_accounts of
259 n | n == max_accounts ->
260 Data.Map.insert unit Unit_Sum
262 , unit_sum_accounts = Data.Map.empty
265 let diff = Data.Map.difference all_accounts unit_sum_accounts
266 Data.Map.insert unit Unit_Sum
268 , unit_sum_accounts = diff
272 (balance_by_unit bal)
274 -- ** The equilibrium
276 -- | Return the 'Balance' (adjusted by inferred 'Amount's)
277 -- of the given 'Posting's and either:
279 -- * 'Left': the 'Posting's that cannot be inferred.
280 -- * 'Right': the given 'Posting's with inferred 'Amount's inserted.
283 => Map Account [posting]
284 -> ( Balance (Posting_Amount posting)
285 , Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
287 infer_equilibrium posts = do
288 let bal_initial = Data.Foldable.foldr postings nil posts
289 let Deviation dev = deviation bal_initial
290 let (bal_adjusted, eithers) =
291 Data.Map.foldrWithKey
292 (\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
294 case Data.Map.size unit_sum_accounts of
296 let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
297 let amt = amount_negate unit_sum_amount in
298 let amts = Data.Map.singleton unit amt in
299 ( balance (acct, amts) bal
300 , Right (acct, unit, amt) : lr
302 _ -> (bal, Left [unit_sum] : lr))
305 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
306 (\(acct, unit, amt) ->
308 (\_new_ps -> insert_amount (unit, amt))
309 acct (assert False []))
312 [] -> (bal_adjusted, Right r)
313 _ -> (bal_adjusted, Left l)
317 => (Amount_Unit (Posting_Amount posting), Posting_Amount posting)
318 -> [posting] -> [posting]
319 insert_amount p@(unit, amt) ps =
321 [] -> assert False []
322 (x:xs) | Data.Map.null (posting_amounts x) ->
323 posting_set_amounts (Data.Map.singleton unit amt) x:xs
324 | Data.Map.notMember unit (posting_amounts x) ->
325 let amts = Data.Map.insertWith
326 (assert False undefined)
327 unit amt (posting_amounts x) in
328 posting_set_amounts amts x:xs
329 (x:xs) -> x:insert_amount p xs
331 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
332 is_at_equilibrium :: Amount amount => Deviation amount -> Bool
333 is_at_equilibrium (Deviation dev) = Data.Map.null dev
335 -- | Return 'True' if and only if the given 'Deviation'
336 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
337 -- maps exactly one 'Account'.
338 is_equilibrium_inferrable :: Amount amount => Deviation amount -> Bool
339 is_equilibrium_inferrable (Deviation dev) =
341 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
344 -- | Return 'True' if and only if the given 'Deviation'
345 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
346 -- maps more than one 'Account'.
347 is_equilibrium_non_inferrable :: Amount amount => Deviation amount -> Bool
348 is_equilibrium_non_inferrable (Deviation dev) =
350 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
355 -- | Descending propagation of 'Amount's accross 'Account's.
357 = TreeMap Account.Name (Account_Sum_Expanded amount)
358 data Amount amount => Account_Sum_Expanded amount
359 = Account_Sum_Expanded
360 { exclusive :: Map (Amount_Unit amount) amount
361 , inclusive :: Map (Amount_Unit amount) amount -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
363 deriving instance Amount amount => Data (Account_Sum_Expanded amount)
364 deriving instance Amount amount => Eq (Account_Sum_Expanded amount)
365 deriving instance Amount amount => Show (Account_Sum_Expanded amount)
366 deriving instance Typeable1 Account_Sum_Expanded -- FIXME: use 'Typeable' when dropping GHC-7.6 support
368 -- | Return the given 'Balance_by_Account' with:
370 -- * all missing 'Account.ascending' 'Account's inserted,
372 -- * and every mapped 'Amount'
373 -- added with any 'Amount'
374 -- of the 'Account's for which it is 'Account.ascending'.
377 => Balance_by_Account amount (Amount_Unit amount)
380 let from_value = fromMaybe (assert False undefined) . Lib.TreeMap.node_value in
381 Lib.TreeMap.map_by_depth_first
382 (\descendants value ->
383 let nodes = Lib.TreeMap.nodes descendants in
384 let exclusive = fromMaybe Data.Map.empty value in
389 (Data.Map.unionWith amount_add . inclusive . from_value)
393 -- | Return a 'Balance_by_Unit'
394 -- derived from the given 'Expanded' balance.
396 -- NOTE: also correct if the 'Expanded' has been filtered.
397 by_unit_of_expanded ::
399 , unit ~ Amount_Unit amount
402 -> Balance_by_Unit amount unit
403 -> Balance_by_Unit amount unit
404 by_unit_of_expanded =
407 go p (Lib.TreeMap.TreeMap m) bal =
408 Data.Map.foldrWithKey
409 (\k Lib.TreeMap.Node{Lib.TreeMap.node_value, Lib.TreeMap.node_descendants} acc ->
411 Nothing -> go (k:p) node_descendants acc
413 let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
414 by_unit (account, inclusive a) acc)
417 -- * Type 'Amount_Sum'
419 -- | Sum keeping track of negative and positive 'Amount's.
423 { amount_sum_negative :: Maybe amount
424 , amount_sum_positive :: Maybe amount
425 , amount_sum_balance :: amount
426 } deriving (Data, Eq, Show, Typeable)
428 instance Amount a => Amount (Amount_Sum a) where
429 type Amount_Unit (Amount_Sum a) = Amount_Unit a
430 amount_null = amount_null . amount_sum_balance
433 case (get a0, get a1) of
436 (Just x0, Just x1) -> Just $ amount_add x0 x1 in
438 { amount_sum_negative = add amount_sum_negative
439 , amount_sum_positive = add amount_sum_positive
440 , amount_sum_balance = amount_add (amount_sum_balance a0) (amount_sum_balance a1)
444 { amount_sum_negative = amount_sum_positive a
445 , amount_sum_positive = amount_sum_negative a
446 , amount_sum_balance = amount_negate $ amount_sum_balance a
450 (\amt -> Just $ Amount_Sum
451 { amount_sum_negative = Just amt
452 , amount_sum_positive = Nothing
453 , amount_sum_balance = amt
455 (amount_sum_negative a)
458 (\amt -> Just $ Amount_Sum
459 { amount_sum_negative = Nothing
460 , amount_sum_positive = Just amt
461 , amount_sum_balance = amt
463 (amount_sum_positive a)
467 => amount -> Amount_Sum amount
470 { amount_sum_negative = amount_negative a
471 , amount_sum_positive = amount_positive a
472 , amount_sum_balance = a