]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Balance.hs
Ajout : GNUmakefile : stats.
[comptalang.git] / lib / Hcompta / Balance.hs
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
11
12 import Control.Applicative (Const(..))
13 import Control.Exception (assert)
14 import Data.Data
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 ()
21
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)
28
29 -- * Requirements' interface
30
31 -- ** Class 'Amount'
32 class
33 ( Data (Amount_Unit a)
34 , Ord (Amount_Unit a)
35 , Show (Amount_Unit a)
36 , Typeable (Amount_Unit 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
43 -- ** Class 'Posting'
44
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
48 type Posting_Amount p
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
52
53 {-
54 instance (Amount amount, unit ~ Amount_Unit amount)
55 => Posting (Account, Map unit amount)
56 where
57 type Posting_Amount (Account, Map unit amount) = amount
58 posting_account = fst
59 posting_amounts = snd
60 posting_set_amounts amounts (acct, _) = (acct, amounts)
61 -}
62
63 instance (Amount amount)
64 => Posting (Account, Account_Sum amount)
65 where
66 type Posting_Amount (Account, Account_Sum amount) = amount
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 -- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
74 data Amount amount
75 => Balance amount
76 = Balance
77 { balance_by_account :: !(Balance_by_Account amount)
78 , balance_by_unit :: !(Balance_by_Unit amount)
79 }
80 deriving instance ( Amount amount
81 , Data amount
82 ) => Data (Balance amount)
83 deriving instance ( Amount amount
84 , Eq amount
85 ) => Eq (Balance amount)
86 deriving instance ( Amount amount
87 , Show amount
88 ) => Show (Balance amount)
89 deriving instance Typeable1 Balance
90 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
91
92 instance Amount amount => Monoid (Balance amount) where
93 mempty = empty
94 mappend = union
95
96 -- ** Type 'Balance_by_Account'
97 type Balance_by_Account amount
98 = TreeMap Account.Name
99 (Account_Sum amount)
100
101 -- *** Type 'Account_Sum'
102 -- | A sum of 'amount's,
103 -- concerning a single 'Account'.
104 newtype Amount amount
105 => Account_Sum amount
106 = Account_Sum (Map (Amount_Unit amount) amount)
107 get_Account_Sum :: Amount amount => Account_Sum amount -> Map (Amount_Unit amount) amount
108 get_Account_Sum (Account_Sum m) = m
109 deriving instance ( Amount amount
110 , Data amount
111 ) => Data (Account_Sum amount)
112 deriving instance ( Amount amount
113 , Eq amount
114 ) => Eq (Account_Sum amount)
115 deriving instance ( Amount amount
116 , Show amount
117 ) => Show (Account_Sum amount)
118 deriving instance Typeable1 Account_Sum
119 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
120
121 instance Amount amount
122 => Monoid (Account_Sum amount) where
123 mempty = Account_Sum mempty
124 mappend
125 (Account_Sum a0)
126 (Account_Sum a1) =
127 Account_Sum $ Data.Map.unionWith amount_add a0 a1
128
129 instance
130 ( Posting posting
131 , amount ~ Posting_Amount posting
132 )
133 => Consable (Const (Balance_by_Account amount)) posting where
134 mcons p (Const !bal) = Const $ cons_by_account p bal
135 instance
136 ( Foldable foldable
137 , Posting posting
138 , amount ~ Posting_Amount posting
139 )
140 => Consable (Const (Balance_by_Account amount))
141 (foldable posting) where
142 mcons ps (Const !bal) =
143 Const $ Data.Foldable.foldr cons_by_account bal ps
144
145 -- ** Type 'Balance_by_Unit'
146 newtype Amount amount
147 => Balance_by_Unit amount
148 = Balance_by_Unit (Map (Amount_Unit amount) (Unit_Sum amount))
149 deriving instance ( Amount amount
150 , Data amount
151 ) => Data (Balance_by_Unit amount)
152 deriving instance ( Amount amount
153 , Eq amount
154 ) => Eq (Balance_by_Unit amount)
155 deriving instance ( Amount amount
156 , Show amount
157 ) => Show (Balance_by_Unit amount)
158 deriving instance Typeable1 Balance_by_Unit
159 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
160
161 instance Amount amount
162 => Monoid (Balance_by_Unit amount) where
163 mempty = Balance_by_Unit mempty
164 mappend = union_by_unit
165
166 -- *** Type 'Unit_Sum'
167
168 -- | A sum of 'amount's with their 'Account's involved,
169 -- concerning a single 'unit'.
170 data Unit_Sum amount
171 = Unit_Sum
172 { unit_sum_amount :: !amount -- ^ The sum of 'amount's for a single 'unit'.
173 , unit_sum_accounts :: !(Map Account ()) -- ^ The 'Account's involved to build 'unit_sum_amount'.
174 } deriving (Data, Eq, Show, Typeable)
175
176 -- ** Constructors
177
178 empty :: Amount amount => Balance amount
179 empty =
180 Balance
181 { balance_by_account = mempty
182 , balance_by_unit = mempty
183 }
184
185 -- | Return the given 'Balance'
186 -- updated by the given 'Posting'.
187 cons ::
188 ( Posting posting
189 , balance ~ Balance (Posting_Amount posting) )
190 => posting -> balance -> balance
191 cons post bal =
192 bal
193 { balance_by_account = cons_by_account post (balance_by_account bal)
194 , balance_by_unit = cons_by_unit post (balance_by_unit bal)
195 }
196
197 -- | Return the given 'Balance'
198 -- updated by the given 'Posting's.
199 postings ::
200 ( Posting posting
201 , balance ~ Balance (Posting_Amount posting)
202 , Foldable foldable )
203 => foldable posting -> balance -> balance
204 postings = flip (Data.Foldable.foldr cons)
205
206 -- | Return the first given 'Balance'
207 -- updated by the second given 'Balance'.
208 union :: Amount amount
209 => Balance amount -> Balance amount -> Balance amount
210 union
211 (Balance b0a b0u)
212 (Balance b1a b1u) =
213 Balance
214 { balance_by_account = union_by_account b0a b1a
215 , balance_by_unit = union_by_unit b0u b1u
216 }
217
218 -- | Return the given 'Balance_by_Account'
219 -- updated by the given 'Posting'.
220 cons_by_account ::
221 ( Posting posting
222 , amount ~ Posting_Amount posting
223 , unit ~ Amount_Unit amount
224 )
225 => posting
226 -> Balance_by_Account amount
227 -> Balance_by_Account amount
228 cons_by_account post =
229 Lib.TreeMap.insert mappend
230 (posting_account post)
231 (Account_Sum $ posting_amounts post)
232
233 -- | Return the given 'Balance_by_Unit'
234 -- updated by the given 'Posting'.
235 cons_by_unit ::
236 ( Posting posting
237 , amount ~ Posting_Amount posting
238 , unit ~ Amount_Unit amount )
239 => posting
240 -> Balance_by_Unit amount
241 -> Balance_by_Unit amount
242 cons_by_unit post =
243 union_by_unit $
244 Balance_by_Unit $
245 Data.Map.map
246 (\amount -> Unit_Sum
247 { unit_sum_amount = amount
248 , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
249 })
250 (posting_amounts post)
251
252 -- | Return a 'Balance_by_Unit'
253 -- derived from the given 'Balance_by_Account'.
254 by_unit_of_by_account ::
255 ( Amount amount
256 , unit ~ Amount_Unit amount
257 )
258 => Balance_by_Account amount
259 -> Balance_by_Unit amount
260 -> Balance_by_Unit amount
261 by_unit_of_by_account =
262 flip $ Lib.TreeMap.foldr_with_Path $ curry cons_by_unit
263
264 -- | Return the first given 'Balance_by_Account'
265 -- updated by the second given 'Balance_by_Account'.
266 union_by_account :: Amount amount
267 => Balance_by_Account amount
268 -> Balance_by_Account amount
269 -> Balance_by_Account amount
270 union_by_account = Lib.TreeMap.union mappend
271
272 -- | Return the first given 'Balance_by_Unit'
273 -- updated by the second given 'Balance_by_Unit'.
274 union_by_unit :: (Amount amount, unit ~ Amount_Unit amount)
275 => Balance_by_Unit amount
276 -> Balance_by_Unit amount
277 -> Balance_by_Unit amount
278 union_by_unit
279 (Balance_by_Unit a0)
280 (Balance_by_Unit a1) =
281 Balance_by_Unit $
282 Data.Map.unionWith
283 (\new old -> Unit_Sum
284 { unit_sum_amount = amount_add
285 (unit_sum_amount old)
286 (unit_sum_amount new)
287 , unit_sum_accounts = Data.Map.unionWith
288 (const::()->()->())
289 (unit_sum_accounts old)
290 (unit_sum_accounts new)
291 })
292 a0 a1
293
294 -- * Type 'Deviation'
295
296 -- | The 'Balance_by_Unit' whose 'unit_sum_amount'
297 -- is not zero and possible 'Account' to 'infer_equilibrium'.
298 newtype Amount amount
299 => Deviation amount
300 = Deviation (Balance_by_Unit amount)
301 deriving instance ( Amount amount
302 , Data amount
303 ) => Data (Deviation amount)
304 deriving instance ( Amount amount
305 , Eq amount
306 ) => Eq (Deviation amount)
307 deriving instance ( Amount amount
308 , Show amount
309 ) => Show (Deviation amount)
310 deriving instance Typeable1 Deviation
311 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
312
313 -- | Return the 'balance_by_unit' of the given 'Balance' with:
314 --
315 -- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
316 --
317 -- * and remaining 'unit's having their 'unit_sum_accounts'
318 -- complemented with the 'balance_by_account' of the given 'Balance'
319 -- (i.e. now mapping to 'Account's __not__ involved to build the 'Unit_Sum').
320 deviation
321 :: Amount amount
322 => Balance amount
323 -> Deviation amount
324 deviation Balance
325 { balance_by_account=ba
326 , balance_by_unit=Balance_by_Unit bu
327 } = do
328 let all_accounts = Lib.TreeMap.flatten (const ()) ba
329 let max_accounts = Data.Map.size all_accounts
330 Deviation $
331 Data.Map.foldlWithKey
332 (\(Balance_by_Unit m) unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
333 Balance_by_Unit $
334 if amount_null unit_sum_amount
335 then m
336 else
337 case Data.Map.size unit_sum_accounts of
338 n | n == max_accounts ->
339 Data.Map.insert unit Unit_Sum
340 { unit_sum_amount
341 , unit_sum_accounts = Data.Map.empty
342 } m
343 _ -> do
344 let diff = Data.Map.difference all_accounts unit_sum_accounts
345 Data.Map.insert unit Unit_Sum
346 { unit_sum_amount
347 , unit_sum_accounts = diff
348 } m
349 )
350 mempty
351 bu
352
353 -- ** The equilibrium
354
355 -- | Return the 'Balance' (adjusted by inferred 'Amount's)
356 -- of the given 'Posting's and either:
357 --
358 -- * 'Left': the 'Posting's that cannot be inferred.
359 -- * 'Right': the given 'Posting's with inferred 'Amount's inserted.
360 infer_equilibrium ::
361 ( Posting posting )
362 => Map Account [posting]
363 -> ( Balance (Posting_Amount posting)
364 , Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
365 )
366 infer_equilibrium posts = do
367 let bal_initial = Data.Foldable.foldr postings empty posts
368 let Deviation (Balance_by_Unit dev) = deviation bal_initial
369 let (bal_adjusted, eithers) =
370 Data.Map.foldrWithKey
371 (\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
372 (bal, lr) ->
373 case Data.Map.size unit_sum_accounts of
374 1 ->
375 let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
376 let amt = amount_negate unit_sum_amount in
377 let amts = Data.Map.singleton unit amt in
378 ( cons (acct, Account_Sum amts) bal
379 , Right (acct, unit, amt) : lr
380 )
381 _ -> (bal, Left [unit_sum] : lr))
382 (bal_initial, [])
383 dev
384 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
385 (\(acct, unit, amt) ->
386 Data.Map.insertWith
387 (\_new_ps -> insert_amount (unit, amt))
388 acct (assert False []))
389 posts eithers
390 case l of
391 [] -> (bal_adjusted, Right r)
392 _ -> (bal_adjusted, Left l)
393 where
394 insert_amount
395 :: Posting posting
396 => (Amount_Unit (Posting_Amount posting), Posting_Amount posting)
397 -> [posting] -> [posting]
398 insert_amount p@(unit, amt) ps =
399 case ps of
400 [] -> assert False []
401 (x:xs) | Data.Map.null (posting_amounts x) ->
402 posting_set_amounts (Data.Map.singleton unit amt) x:xs
403 | Data.Map.notMember unit (posting_amounts x) ->
404 let amts = Data.Map.insertWith
405 (assert False undefined)
406 unit amt (posting_amounts x) in
407 posting_set_amounts amts x:xs
408 (x:xs) -> x:insert_amount p xs
409
410 -- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
411 is_at_equilibrium :: Amount amount => Deviation amount -> Bool
412 is_at_equilibrium (Deviation (Balance_by_Unit dev)) = Data.Map.null dev
413
414 -- | Return 'True' if and only if the given 'Deviation'
415 -- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
416 -- maps exactly one 'Account'.
417 is_equilibrium_inferrable :: Amount amount => Deviation amount -> Bool
418 is_equilibrium_inferrable (Deviation (Balance_by_Unit dev)) =
419 Data.Foldable.all
420 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
421 dev
422
423 -- | Return 'True' if and only if the given 'Deviation'
424 -- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
425 -- maps more than one 'Account'.
426 is_equilibrium_non_inferrable :: Amount amount => Deviation amount -> Bool
427 is_equilibrium_non_inferrable (Deviation (Balance_by_Unit dev)) =
428 Data.Foldable.any
429 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
430 dev
431
432 -- * Type 'Expanded'
433
434 -- | Descending propagation of 'Amount's accross 'Account's.
435 type Expanded amount
436 = TreeMap Account.Name (Account_Sum_Expanded amount)
437 data Amount amount => Account_Sum_Expanded amount
438 = Account_Sum_Expanded
439 { exclusive :: !(Account_Sum amount)
440 , inclusive :: !(Account_Sum amount) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
441 }
442 deriving instance ( Amount amount
443 , Data amount
444 ) => Data (Account_Sum_Expanded amount)
445 deriving instance ( Amount amount
446 , Eq amount
447 ) => Eq (Account_Sum_Expanded amount)
448 deriving instance ( Amount amount
449 , Show amount
450 ) => Show (Account_Sum_Expanded amount)
451 deriving instance Typeable1 Account_Sum_Expanded
452 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
453
454 instance Amount amount => Monoid (Account_Sum_Expanded amount) where
455 mempty = Account_Sum_Expanded mempty mempty
456 mappend
457 (Account_Sum_Expanded e0 i0)
458 (Account_Sum_Expanded e1 i1) =
459 Account_Sum_Expanded
460 (mappend e0 e1)
461 (mappend i0 i1)
462
463 -- | Return the given 'Balance_by_Account' with:
464 --
465 -- * all missing 'Account.ascending' 'Account's inserted,
466 --
467 -- * and every mapped 'Amount'
468 -- added with any 'Amount'
469 -- of the 'Account's for which it is 'Account.ascending'.
470 expanded
471 :: Amount amount
472 => Balance_by_Account amount
473 -> Expanded amount
474 expanded =
475 Lib.TreeMap.map_by_depth_first
476 (\descendants value ->
477 let exclusive = Strict.fromMaybe mempty value in
478 Account_Sum_Expanded
479 { exclusive
480 , inclusive =
481 Data.Map.foldl'
482 ( flip $ mappend . inclusive
483 . Strict.fromMaybe (assert False undefined)
484 . Lib.TreeMap.node_value)
485 exclusive $
486 Lib.TreeMap.nodes descendants
487 })
488
489 -- | Return a 'Balance_by_Unit'
490 -- derived from the given 'Expanded' balance.
491 --
492 -- NOTE: also correct if the 'Expanded' has been filtered.
493 by_unit_of_expanded ::
494 ( Amount amount
495 , unit ~ Amount_Unit amount
496 )
497 => Expanded amount
498 -> Balance_by_Unit amount
499 -> Balance_by_Unit amount
500 by_unit_of_expanded =
501 go []
502 where
503 go p (Lib.TreeMap.TreeMap m) bal =
504 Data.Map.foldrWithKey
505 (\k Lib.TreeMap.Node{Lib.TreeMap.node_value, Lib.TreeMap.node_descendants} acc ->
506 case node_value of
507 Strict.Nothing -> go (k:p) node_descendants acc
508 Strict.Just a ->
509 let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
510 cons_by_unit (account, inclusive a) acc)
511 bal m