]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Balance.hs
Correction : rétro support de GHC 7.6.3 (Debian/jessie).
[comptalang.git] / lib / Hcompta / Balance.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE NamedFieldPuns #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
9 module Hcompta.Balance where
10
11 -- import Control.Applicative (Const(..))
12 import Control.DeepSeq (NFData(..))
13 import Control.Exception (assert)
14 import Data.Bool
15 import Data.Data
16 import Data.Either (Either(..))
17 import Data.Eq (Eq(..))
18 import Data.Ord (Ord(..))
19 import qualified Data.Foldable
20 import Data.Foldable (Foldable(..))
21 import qualified Data.Map.Strict as Data.Map
22 import Data.Map.Strict (Map)
23 import Data.Monoid (Monoid(..))
24 import qualified Data.Strict.Maybe as Strict
25 import Data.Tuple (fst, snd)
26 import Data.Typeable ()
27 import Text.Show (Show(..))
28 import Prelude (($), (.), const, curry, flip, undefined)
29
30 import Hcompta.Quantity (Zero(..), Addable(..), Negable(..))
31 import Hcompta.Account (Account(..), Account_Path)
32 import qualified Hcompta.Lib.Foldable as Lib.Foldable
33 import Hcompta.Lib.TreeMap (TreeMap)
34 import qualified Hcompta.Lib.TreeMap as TreeMap
35
36 -- * Requirements' interface
37
38 -- ** Class 'Posting'
39
40 -- | A 'posting' used to produce a 'Balance'
41 -- must be an instance of this class.
42 class
43 ( Account (Posting_Account p)
44 ) => Posting p where
45 type Posting_Account p
46 type Posting_Quantity p
47 type Posting_Unit p
48 posting_account :: p -> Posting_Account p
49 posting_amounts :: p -> Map (Posting_Unit p) (Posting_Quantity p)
50 posting_set_amounts :: Map (Posting_Unit p) (Posting_Quantity p) -> p -> p
51 instance
52 ( Account account
53 ) => Posting (account, Map unit quantity)
54 where
55 type Posting_Account (account, Map unit quantity) = account
56 type Posting_Quantity (account, Map unit quantity) = quantity
57 type Posting_Unit (account, Map unit quantity) = unit
58 posting_account = fst
59 posting_amounts = snd
60 posting_set_amounts amounts (acct, _) = (acct, amounts)
61 instance
62 ( Account account
63 ) => Posting (account, Account_Sum unit quantity) where
64 type Posting_Account (account, Account_Sum unit quantity) = account
65 type Posting_Quantity (account, Account_Sum unit quantity) = quantity
66 type Posting_Unit (account, Account_Sum unit quantity) = unit
67 posting_account = fst
68 posting_amounts (_, Account_Sum x) = x
69 posting_set_amounts amounts (acct, _) = (acct, Account_Sum amounts)
70
71 -- * Type 'Balance'
72
73 -- | 'Balance_Account' and 'Balance_by_Unit' of some 'Posting's.
74 --
75 -- NOTE: to reduce memory consumption when 'cons'ing iteratively,
76 -- the fields are explicitely stricts.
77 data
78 ( Account account
79 ) => Balance account unit quantity
80 = Balance
81 { balance_by_account :: !(Balance_by_Account (Account_Section account) unit quantity)
82 , balance_by_unit :: !(Balance_by_Unit account unit quantity)
83 }
84 --deriving (Data, Eq, Show, Typeable)
85 deriving instance ( Account account
86 , Data account
87 , Data unit
88 , Data quantity
89 , Ord unit
90 , Typeable unit
91 , Typeable quantity
92 , Data (Account_Section account)
93 ) => Data (Balance account unit quantity)
94 deriving instance ( Account account
95 , Eq account
96 , Eq unit
97 , Eq quantity
98 ) => Eq (Balance account unit quantity)
99 deriving instance ( Account account
100 , Show account
101 , Show unit
102 , Show quantity
103 , Show (Account_Section account)
104 ) => Show (Balance account unit quantity)
105 deriving instance Typeable3 Balance
106 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
107
108 instance
109 ( Account account
110 , Addable quantity
111 , Ord unit
112 ) => Monoid (Balance account unit quantity) where
113 mempty = empty
114 mappend = union
115
116 -- ** Type 'Balance_by_Account'
117 type Balance_by_Account account_section unit quantity
118 = TreeMap account_section
119 (Account_Sum unit quantity)
120
121 -- *** Type 'Account_Sum'
122 -- | A sum of 'quantity's, concerning a single 'account'.
123 newtype Account_Sum unit quantity
124 = Account_Sum (Map unit quantity)
125 deriving (Data, Eq, Show, Typeable)
126 get_Account_Sum
127 :: Account_Sum unit quantity
128 -> Map unit quantity
129 get_Account_Sum (Account_Sum m) = m
130
131 instance
132 ( NFData unit
133 , NFData quantity
134 ) => NFData (Account_Sum unit quantity) where
135 rnf (Account_Sum m) = rnf m
136 instance
137 ( Addable quantity
138 , Ord unit
139 ) => Monoid (Account_Sum unit quantity) where
140 mempty = Account_Sum mempty
141 mappend
142 (Account_Sum a0)
143 (Account_Sum a1) =
144 Account_Sum $ Data.Map.unionWith quantity_add a0 a1
145
146 -- ** Type 'Balance_by_Unit'
147 newtype
148 ( Account account
149 ) => Balance_by_Unit account unit quantity
150 = Balance_by_Unit (Map unit (Unit_Sum account quantity))
151 deriving instance ( Account account
152 , Data account
153 , Data unit
154 , Data quantity
155 , Ord unit
156 , Typeable unit
157 , Typeable quantity
158 , Data (Account_Section account)
159 ) => Data (Balance_by_Unit account unit quantity)
160 deriving instance ( Account account
161 , Eq account
162 , Eq unit
163 , Eq quantity
164 ) => Eq (Balance_by_Unit account unit quantity)
165 deriving instance ( Account account
166 , Show account
167 , Show unit
168 , Show quantity
169 , Show (Account_Section account)
170 ) => Show (Balance_by_Unit account unit quantity)
171 deriving instance Typeable3 Balance_by_Unit
172 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
173
174 instance
175 ( Account account
176 , Addable quantity
177 , Ord unit
178 ) => Monoid (Balance_by_Unit account unit quantity) where
179 mempty = Balance_by_Unit mempty
180 mappend = union_by_unit
181
182 -- *** Type 'Unit_Sum'
183
184 -- | A sum of 'quantity's with their 'Account's involved,
185 -- concerning a single 'unit'.
186 data (Account account)
187 => Unit_Sum account quantity
188 = Unit_Sum
189 { unit_sum_quantity :: !quantity -- ^ The sum of 'quantity's for a single 'unit'.
190 , unit_sum_accounts :: !(Map (Account_Path (Account_Section account))
191 ()) -- ^ The 'account's involved to build 'unit_sum_quantity'.
192 }
193 deriving instance ( Account account
194 , Data account
195 , Data (Account_Section account)
196 , Data quantity
197 ) => Data (Unit_Sum account quantity)
198 deriving instance ( Account account
199 , Eq account
200 , Eq quantity
201 ) => Eq (Unit_Sum account quantity)
202 deriving instance ( Account account
203 , Show account
204 , Show (Account_Section account)
205 , Show quantity
206 ) => Show (Unit_Sum account quantity)
207 deriving instance Typeable2 Unit_Sum
208 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
209
210 -- ** Constructors
211
212 empty ::
213 ( Account account
214 , Ord unit
215 , Addable quantity
216 ) => Balance account unit quantity
217 empty =
218 Balance
219 { balance_by_account = mempty
220 , balance_by_unit = mempty
221 }
222
223 -- | Return the given 'Balance'
224 -- updated by the given 'Posting'.
225 cons ::
226 ( Posting posting
227 , balance ~ Balance (Posting_Account posting)
228 (Posting_Unit posting)
229 (Posting_Quantity posting)
230 , Addable (Posting_Quantity posting)
231 , Ord (Posting_Unit posting)
232 ) => posting -> balance -> balance
233 cons post bal =
234 bal
235 { balance_by_account = cons_by_account post (balance_by_account bal)
236 , balance_by_unit = cons_by_unit post (balance_by_unit bal)
237 }
238
239 -- | Return the given 'Balance'
240 -- updated by the given 'Posting's.
241 postings ::
242 ( Posting posting
243 , balance ~ Balance (Posting_Account posting)
244 (Posting_Unit posting)
245 (Posting_Quantity posting)
246 , Foldable foldable
247 , Addable (Posting_Quantity posting)
248 , Ord (Posting_Unit posting)
249 ) => foldable posting -> balance -> balance
250 postings = flip (Data.Foldable.foldr cons)
251
252 -- | Return the first given 'Balance'
253 -- updated by the second given 'Balance'.
254 union ::
255 ( Account account
256 , Addable quantity
257 , Ord unit
258 , balance ~ Balance account unit quantity
259 ) => balance -> balance -> balance
260 union
261 (Balance b0a b0u)
262 (Balance b1a b1u) =
263 Balance
264 { balance_by_account = union_by_account b0a b1a
265 , balance_by_unit = union_by_unit b0u b1u
266 }
267
268 -- | Return the given 'Balance_by_Account'
269 -- updated by the given 'Posting'.
270 cons_by_account ::
271 ( Posting posting
272 , account ~ Posting_Account posting
273 , quantity ~ Posting_Quantity posting
274 , unit ~ Posting_Unit posting
275 , Addable (Posting_Quantity posting)
276 , Ord unit
277 )
278 => posting
279 -> Balance_by_Account (Account_Section account) unit quantity
280 -> Balance_by_Account (Account_Section account) unit quantity
281 cons_by_account post =
282 TreeMap.insert mappend
283 (account_path $ posting_account post)
284 (Account_Sum $ posting_amounts post)
285
286 -- | Return the given 'Balance_by_Unit'
287 -- updated by the given 'Posting'.
288 cons_by_unit ::
289 ( Posting posting
290 , account ~ Posting_Account posting
291 , quantity ~ Posting_Quantity posting
292 , unit ~ Posting_Unit posting
293 , Addable quantity
294 , Ord unit
295 ) => posting
296 -> Balance_by_Unit account unit quantity
297 -> Balance_by_Unit account unit quantity
298 cons_by_unit post =
299 union_by_unit $
300 Balance_by_Unit $
301 Data.Map.map
302 (\quantity -> Unit_Sum
303 { unit_sum_quantity = quantity
304 , unit_sum_accounts = Data.Map.singleton (account_path $ posting_account post) ()
305 })
306 (posting_amounts post)
307
308 -- | Return a 'Balance_by_Unit'
309 -- derived from the given 'Balance_by_Account'.
310 by_unit_of_by_account ::
311 ( Account account
312 , account ~ Account_Path (Account_Section account)
313 , Addable quantity
314 , Ord unit
315 )
316 => Balance_by_Account (Account_Section account) unit quantity
317 -> Balance_by_Unit account unit quantity
318 -> Balance_by_Unit account unit quantity
319 by_unit_of_by_account =
320 flip $ TreeMap.foldr_with_Path $ curry cons_by_unit
321
322 -- | Return the first given 'Balance_by_Account'
323 -- updated by the second given 'Balance_by_Account'.
324 union_by_account ::
325 ( Addable quantity
326 , Ord account_section
327 , Ord unit
328 ) => Balance_by_Account account_section unit quantity
329 -> Balance_by_Account account_section unit quantity
330 -> Balance_by_Account account_section unit quantity
331 union_by_account = TreeMap.union mappend
332
333 -- | Return the first given 'Balance_by_Unit'
334 -- updated by the second given 'Balance_by_Unit'.
335 union_by_unit ::
336 ( Account account
337 , Addable quantity
338 , Ord unit
339 ) => Balance_by_Unit account unit quantity
340 -> Balance_by_Unit account unit quantity
341 -> Balance_by_Unit account unit quantity
342 union_by_unit
343 (Balance_by_Unit a0)
344 (Balance_by_Unit a1) =
345 Balance_by_Unit $
346 Data.Map.unionWith
347 (\new old -> Unit_Sum
348 { unit_sum_quantity = quantity_add
349 (unit_sum_quantity old)
350 (unit_sum_quantity new)
351 , unit_sum_accounts = Data.Map.unionWith
352 (const::()->()->())
353 (unit_sum_accounts old)
354 (unit_sum_accounts new)
355 })
356 a0 a1
357
358 -- * Type 'Deviation'
359
360 -- | The 'Balance_by_Unit' whose 'unit_sum_quantity'
361 -- is not zero and possible 'account' to 'infer_equilibrium'.
362 newtype
363 ( Account account
364 ) => Deviation account unit quantity
365 = Deviation (Balance_by_Unit account unit quantity)
366 deriving instance ( Account account
367 , Data account
368 , Data unit
369 , Data quantity
370 , Ord unit
371 , Typeable unit
372 , Typeable quantity
373 , Data (Account_Section account)
374 ) => Data (Deviation account unit quantity)
375 deriving instance ( Account account
376 , Eq account
377 , Eq unit
378 , Eq quantity
379 ) => Eq (Deviation account unit quantity)
380 deriving instance ( Account account
381 , Show account
382 , Show (Account_Section account)
383 , Show unit
384 , Show quantity
385 ) => Show (Deviation account unit quantity)
386 deriving instance Typeable3 Deviation
387 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
388
389 -- | Return the 'balance_by_unit' of the given 'Balance' with:
390 --
391 -- * 'unit's whose 'unit_sum_quantity' is verifying 'quantity_null' removed,
392 --
393 -- * and remaining 'unit's having their 'unit_sum_accounts'
394 -- complemented with the 'balance_by_account' of the given 'Balance'
395 -- (i.e. now mapping to 'account's __not__ involved to build the 'Unit_Sum').
396 deviation ::
397 ( Account account
398 , Zero quantity
399 , Addable quantity
400 , Ord unit
401 ) => Balance account unit quantity
402 -> Deviation account unit quantity
403 deviation Balance
404 { balance_by_account=ba
405 , balance_by_unit=Balance_by_Unit bu
406 } = do
407 let all_accounts = TreeMap.flatten (const ()) ba
408 let max_accounts = Data.Map.size all_accounts
409 Deviation $
410 Data.Map.foldlWithKey
411 (\(Balance_by_Unit m) unit Unit_Sum{unit_sum_quantity, unit_sum_accounts} ->
412 Balance_by_Unit $
413 if quantity_null unit_sum_quantity
414 then m
415 else
416 case Data.Map.size unit_sum_accounts of
417 n | n == max_accounts ->
418 Data.Map.insert unit Unit_Sum
419 { unit_sum_quantity
420 , unit_sum_accounts = Data.Map.empty
421 } m
422 _ -> do
423 let diff = Data.Map.difference all_accounts unit_sum_accounts
424 Data.Map.insert unit Unit_Sum
425 { unit_sum_quantity
426 , unit_sum_accounts = diff
427 } m
428 )
429 mempty
430 bu
431
432 -- ** The equilibrium
433
434 -- | Return the 'Balance' (adjusted by inferred 'quantity's)
435 -- of the given 'Posting's and either:
436 --
437 -- * 'Left': the 'Posting's that cannot be inferred.
438 -- * 'Right': the given 'Posting's with inferred 'quantity's inserted.
439 infer_equilibrium ::
440 ( Posting posting
441 , account ~ Posting_Account posting
442 , unit ~ Posting_Unit posting
443 , quantity ~ Posting_Quantity posting
444 , account ~ Account_Path (Account_Section account)
445 , Addable quantity
446 , Negable quantity
447 , Zero quantity
448 , Ord unit
449 ) => Map account [posting]
450 -> ( Balance account unit quantity
451 , Either [(unit, Unit_Sum account quantity)]
452 (Map account [posting])
453 )
454 infer_equilibrium posts = do
455 let bal_initial = Data.Foldable.foldr postings empty posts
456 let Deviation (Balance_by_Unit dev) = deviation bal_initial
457 let (bal_adjusted, eithers) =
458 Data.Map.foldrWithKey
459 (\unit unit_sum@(Unit_Sum{unit_sum_quantity, unit_sum_accounts})
460 (bal, lr) ->
461 case Data.Map.size unit_sum_accounts of
462 1 ->
463 let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
464 let qty = quantity_neg unit_sum_quantity in
465 let amts = Data.Map.singleton unit qty in
466 ( cons (acct, Account_Sum amts) bal
467 , Right (acct, unit, qty) : lr
468 )
469 _ -> (bal, Left [(unit, unit_sum)] : lr))
470 (bal_initial, [])
471 dev
472 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
473 (\(acct, unit, qty) ->
474 Data.Map.insertWith
475 (\_new_ps -> insert_amount (unit, qty))
476 acct (assert False []))
477 posts eithers
478 case l of
479 [] -> (bal_adjusted, Right r)
480 _ -> (bal_adjusted, Left l)
481 where
482 insert_amount ::
483 ( Posting posting
484 , Ord (Posting_Unit posting)
485 ) => ( Posting_Unit posting
486 , Posting_Quantity posting )
487 -> [posting] -> [posting]
488 insert_amount p@(unit, qty) ps =
489 case ps of
490 [] -> assert False []
491 (x:xs) | Data.Map.null (posting_amounts x) ->
492 posting_set_amounts (Data.Map.singleton unit qty) x:xs
493 | Data.Map.notMember unit (posting_amounts x) ->
494 let amts = Data.Map.insertWith
495 (assert False undefined)
496 unit qty (posting_amounts x) in
497 posting_set_amounts amts x:xs
498 (x:xs) -> x:insert_amount p xs
499
500 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
501 is_at_equilibrium :: (Account account) => Deviation account unit quantity -> Bool
502 is_at_equilibrium (Deviation (Balance_by_Unit dev)) = Data.Map.null dev
503
504 -- | Return 'True' if and only if the given 'Deviation'
505 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
506 -- maps exactly one 'account'.
507 is_equilibrium_inferrable :: (Account account) => Deviation account unit quantity -> Bool
508 is_equilibrium_inferrable (Deviation (Balance_by_Unit dev)) =
509 Data.Foldable.all
510 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
511 dev
512
513 -- | Return 'True' if and only if the given 'Deviation'
514 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
515 -- maps more than one 'Account'.
516 is_equilibrium_non_inferrable :: (Account account) => Deviation account unit quantity -> Bool
517 is_equilibrium_non_inferrable (Deviation (Balance_by_Unit dev)) =
518 Data.Foldable.any
519 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
520 dev
521
522 -- * Type 'Expanded'
523
524 -- | Descending propagation of 'quantity's accross 'Account's.
525 type Expanded account_section unit quantity
526 = TreeMap account_section (Account_Sum_Expanded unit quantity)
527 data Account_Sum_Expanded unit quantity
528 = Account_Sum_Expanded
529 { exclusive :: !(Account_Sum unit quantity)
530 , inclusive :: !(Account_Sum unit quantity) -- ^ 'quantity_add' folded over 'exclusive' and 'inclusive' of 'TreeMap.node_descendants'
531 } deriving (Data, Eq, Show, Typeable)
532
533 instance
534 ( Addable quantity
535 , Ord unit
536 ) => Monoid (Account_Sum_Expanded unit quantity) where
537 mempty = Account_Sum_Expanded mempty mempty
538 mappend
539 (Account_Sum_Expanded e0 i0)
540 (Account_Sum_Expanded e1 i1) =
541 Account_Sum_Expanded
542 (mappend e0 e1)
543 (mappend i0 i1)
544
545 -- | Return the given 'Balance_by_Account' with:
546 --
547 -- * all missing 'Account.ascending' 'Account's inserted,
548 --
549 -- * and every mapped 'quantity' added with any 'quantity'
550 -- of the 'Account's for which it is 'Account.ascending'.
551 expanded ::
552 ( Addable quantity
553 , Ord account_section
554 , Ord unit
555 ) => Balance_by_Account account_section unit quantity
556 -> Expanded account_section unit quantity
557 expanded =
558 TreeMap.map_by_depth_first
559 (\descendants value ->
560 let exclusive = Strict.fromMaybe mempty value in
561 Account_Sum_Expanded
562 { exclusive
563 , inclusive =
564 Data.Map.foldl'
565 ( flip $ mappend . inclusive
566 . Strict.fromMaybe (assert False undefined)
567 . TreeMap.node_value )
568 exclusive $
569 TreeMap.nodes descendants
570 })
571
572 -- | Return a 'Balance_by_Unit'
573 -- derived from the given 'Expanded' balance.
574 --
575 -- NOTE: also correct if the 'Expanded' has been filtered.
576 by_unit_of_expanded ::
577 ( Account account
578 , account ~ Account_Path (Account_Section account)
579 , Addable quantity
580 , Ord unit
581 ) => Expanded (Account_Section account) unit quantity
582 -> Balance_by_Unit account unit quantity
583 -> Balance_by_Unit account unit quantity
584 by_unit_of_expanded =
585 go []
586 where
587 go p (TreeMap.TreeMap nodes) bal =
588 Data.Map.foldrWithKey
589 (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
590 case node_value of
591 Strict.Nothing -> go (k:p) node_descendants acc
592 Strict.Just a ->
593 let account = TreeMap.reverse $ TreeMap.path k p in
594 cons_by_unit (account, inclusive a) acc)
595 bal nodes