]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Calc/Balance.hs
Ajout : Model.Filter : Test_Amount.
[comptalang.git] / lib / Hcompta / Calc / Balance.hs
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
9
10 import Control.Exception (assert)
11 import Data.Data
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 ()
18
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)
24
25 -- * Requirements' interface
26
27 -- ** Class 'Amount'
28 class
29 ( Data (Amount_Unit a)
30 , Data a
31 , Eq a
32 , Ord (Amount_Unit a)
33 , Show (Amount_Unit a)
34 , Show a
35 , Typeable (Amount_Unit a)
36 , Typeable a
37 ) => Amount a where
38 type 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
44
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
51 amount_negative a =
52 let m = Data.Map.mapMaybe amount_negative a in
53 if Data.Map.null m
54 then Nothing
55 else Just m
56 amount_positive a =
57 let m = Data.Map.mapMaybe amount_positive a in
58 if Data.Map.null m
59 then Nothing
60 else Just m
61
62 -- ** Class 'Posting'
63
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
67 type Posting_Amount p
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
71
72 instance (Amount amount, unit ~ Amount_Unit amount)
73 => Posting (Account, Map unit amount)
74 where
75 type Posting_Amount (Account, Map unit amount) = amount
76 posting_account = fst
77 posting_amounts = snd
78 posting_set_amounts amounts (acct, _) = (acct, amounts)
79
80 -- * Type 'Balance'
81
82 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
83 data Amount amount => Balance amount
84 = Balance
85 { balance_by_account :: Balance_by_Account amount (Amount_Unit amount)
86 , balance_by_unit :: Balance_by_Unit amount (Amount_Unit amount)
87 }
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
92
93 type Balance_by_Account amount unit
94 = TreeMap Account.Name
95 (Account_Sum amount unit)
96
97 -- | A sum of 'amount's,
98 -- concerning a single 'Account'.
99 type Account_Sum amount unit
100 = Data.Map.Map unit amount
101
102 type Balance_by_Unit amount unit
103 = Map unit (Unit_Sum amount)
104
105 -- | A sum of 'amount's with their 'Account's involved,
106 -- concerning a single 'unit'.
107 data Unit_Sum amount
108 = Unit_Sum
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)
112
113 -- ** Constructors
114
115 nil :: Amount amount => Balance amount
116 nil =
117 Balance
118 { balance_by_account = Lib.TreeMap.empty
119 , balance_by_unit = Data.Map.empty
120 }
121
122 -- | Return the given 'Balance_by_Account'
123 -- updated by the given 'Posting'.
124 by_account ::
125 ( Posting posting
126 , amount ~ Posting_Amount posting
127 , unit ~ Amount_Unit amount )
128 => posting
129 -> Balance_by_Account amount unit
130 -> Balance_by_Account amount unit
131 by_account post =
132 Lib.TreeMap.insert
133 (Data.Map.unionWith (flip amount_add))
134 (posting_account post)
135 (posting_amounts post)
136
137 -- | Return the given 'Balance_by_Unit'
138 -- updated by the given 'Posting'.
139 by_unit ::
140 ( Posting posting
141 , amount ~ Posting_Amount posting
142 , unit ~ Amount_Unit amount )
143 => posting
144 -> Balance_by_Unit amount unit
145 -> Balance_by_Unit amount unit
146 by_unit post bal =
147 Data.Map.unionWith
148 (\new old -> Unit_Sum
149 { unit_sum_amount =
150 amount_add
151 (unit_sum_amount old)
152 (unit_sum_amount new)
153 , unit_sum_accounts =
154 Data.Map.unionWith
155 (const::()->()->())
156 (unit_sum_accounts old)
157 (unit_sum_accounts new)
158 })
159 bal $
160 Data.Map.map
161 (\amount -> Unit_Sum
162 { unit_sum_amount = amount
163 , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
164 })
165 (posting_amounts post)
166
167 -- | Return a 'Balance_by_Unit'
168 -- derived from the given 'Balance_by_Account'.
169 by_unit_of_by_account ::
170 ( Amount amount
171 , unit ~ Amount_Unit amount
172 )
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
178
179 -- | Return the given 'Balance'
180 -- updated by the given 'Posting'.
181 balance ::
182 ( Posting posting
183 , balance ~ Balance (Posting_Amount posting) )
184 => posting -> balance -> balance
185 balance post bal =
186 bal
187 { balance_by_account = by_account post (balance_by_account bal)
188 , balance_by_unit = by_unit post (balance_by_unit bal)
189 }
190
191 -- | Return the given 'Balance'
192 -- updated by the given 'Posting's.
193 postings ::
194 ( Posting posting
195 , balance ~ Balance (Posting_Amount posting)
196 , Foldable foldable )
197 => foldable posting -> balance -> balance
198 postings = flip (Data.Foldable.foldr balance)
199
200 -- | Return the first given 'Balance'
201 -- updated by the second given 'Balance'.
202 union :: Amount amount
203 => Balance amount -> Balance amount -> Balance amount
204 union b0 b1 =
205 b0
206 { balance_by_account =
207 Lib.TreeMap.union
208 (Data.Map.unionWith (flip amount_add))
209 (balance_by_account b0)
210 (balance_by_account b1)
211 , balance_by_unit =
212 Data.Map.unionWith
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
218 (const::()->()->())
219 (unit_sum_accounts old)
220 (unit_sum_accounts new)
221 })
222 (balance_by_unit b0)
223 (balance_by_unit b1)
224 }
225
226 -- * Type 'Deviation'
227
228 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
229 -- is not zero and possible 'Account' to 'infer_equilibrium'.
230 newtype Amount amount
231 => Deviation 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
237
238 -- | Return the 'balance_by_unit' of the given 'Balance' with:
239 --
240 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
241 --
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').
245 deviation
246 :: Amount amount
247 => Balance amount
248 -> Deviation amount
249 deviation bal = do
250 let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
251 let max_accounts = Data.Map.size all_accounts
252 Deviation $
253 Data.Map.foldlWithKey
254 (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
255 if amount_null unit_sum_amount
256 then m
257 else
258 case Data.Map.size unit_sum_accounts of
259 n | n == max_accounts ->
260 Data.Map.insert unit Unit_Sum
261 { unit_sum_amount
262 , unit_sum_accounts = Data.Map.empty
263 } m
264 _ -> do
265 let diff = Data.Map.difference all_accounts unit_sum_accounts
266 Data.Map.insert unit Unit_Sum
267 { unit_sum_amount
268 , unit_sum_accounts = diff
269 } m
270 )
271 Data.Map.empty
272 (balance_by_unit bal)
273
274 -- ** The equilibrium
275
276 -- | Return the 'Balance' (adjusted by inferred 'Amount's)
277 -- of the given 'Posting's and either:
278 --
279 -- * 'Left': the 'Posting's that cannot be inferred.
280 -- * 'Right': the given 'Posting's with inferred 'Amount's inserted.
281 infer_equilibrium ::
282 ( Posting posting )
283 => Map Account [posting]
284 -> ( Balance (Posting_Amount posting)
285 , Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
286 )
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})
293 (bal, lr) ->
294 case Data.Map.size unit_sum_accounts of
295 1 ->
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
301 )
302 _ -> (bal, Left [unit_sum] : lr))
303 (bal_initial, [])
304 dev
305 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
306 (\(acct, unit, amt) ->
307 Data.Map.insertWith
308 (\_new_ps -> insert_amount (unit, amt))
309 acct (assert False []))
310 posts eithers
311 case l of
312 [] -> (bal_adjusted, Right r)
313 _ -> (bal_adjusted, Left l)
314 where
315 insert_amount
316 :: Posting posting
317 => (Amount_Unit (Posting_Amount posting), Posting_Amount posting)
318 -> [posting] -> [posting]
319 insert_amount p@(unit, amt) ps =
320 case ps of
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
330
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
334
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) =
340 Data.Foldable.all
341 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
342 dev
343
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) =
349 Data.Foldable.any
350 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
351 dev
352
353 -- * Type 'Expanded'
354
355 -- | Descending propagation of 'Amount's accross 'Account's.
356 type Expanded amount
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'
362 }
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
367
368 -- | Return the given 'Balance_by_Account' with:
369 --
370 -- * all missing 'Account.ascending' 'Account's inserted,
371 --
372 -- * and every mapped 'Amount'
373 -- added with any 'Amount'
374 -- of the 'Account's for which it is 'Account.ascending'.
375 expanded
376 :: Amount amount
377 => Balance_by_Account amount (Amount_Unit amount)
378 -> Expanded amount
379 expanded =
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
385 Account_Sum_Expanded
386 { exclusive
387 , inclusive =
388 Data.Map.foldr
389 (Data.Map.unionWith amount_add . inclusive . from_value)
390 exclusive nodes
391 })
392
393 -- | Return a 'Balance_by_Unit'
394 -- derived from the given 'Expanded' balance.
395 --
396 -- NOTE: also correct if the 'Expanded' has been filtered.
397 by_unit_of_expanded ::
398 ( Amount amount
399 , unit ~ Amount_Unit amount
400 )
401 => Expanded amount
402 -> Balance_by_Unit amount unit
403 -> Balance_by_Unit amount unit
404 by_unit_of_expanded =
405 go []
406 where
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 ->
410 case node_value of
411 Nothing -> go (k:p) node_descendants acc
412 Just a ->
413 let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
414 by_unit (account, inclusive a) acc)
415 bal m
416
417 -- * Type 'Amount_Sum'
418
419 -- | Sum keeping track of negative and positive 'Amount's.
420 data Amount amount
421 => Amount_Sum amount
422 = Amount_Sum
423 { amount_sum_negative :: Maybe amount
424 , amount_sum_positive :: Maybe amount
425 , amount_sum_balance :: amount
426 } deriving (Data, Eq, Show, Typeable)
427
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
431 amount_add a0 a1 =
432 let add get =
433 case (get a0, get a1) of
434 (Nothing, a) -> a
435 (a, Nothing) -> a
436 (Just x0, Just x1) -> Just $ amount_add x0 x1 in
437 Amount_Sum
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)
441 }
442 amount_negate a =
443 Amount_Sum
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
447 }
448 amount_negative a =
449 maybe Nothing
450 (\amt -> Just $ Amount_Sum
451 { amount_sum_negative = Just amt
452 , amount_sum_positive = Nothing
453 , amount_sum_balance = amt
454 })
455 (amount_sum_negative a)
456 amount_positive a =
457 maybe Nothing
458 (\amt -> Just $ Amount_Sum
459 { amount_sum_negative = Nothing
460 , amount_sum_positive = Just amt
461 , amount_sum_balance = amt
462 })
463 (amount_sum_positive a)
464
465 amount_sum
466 :: Amount amount
467 => amount -> Amount_Sum amount
468 amount_sum a =
469 Amount_Sum
470 { amount_sum_negative = amount_negative a
471 , amount_sum_positive = amount_positive a
472 , amount_sum_balance = a
473 }