]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Balance.hs
Sync with symantic.
[comptalang.git] / lib / Hcompta / Balance.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Hcompta.Balance where
3
4 import Control.DeepSeq (NFData(..))
5 import Control.Exception (assert)
6 import Data.Bool
7 import Data.Data
8 import Data.Either (Either(..))
9 import Data.Eq (Eq(..))
10 import Data.Function (($), (.), const, flip)
11 import Data.Map.Strict (Map)
12 import Data.Monoid (Monoid(..))
13 import Data.NonNull (NonNull(..))
14 import Data.Ord (Ord(..))
15 import Data.Semigroup (Semigroup(..))
16 import Data.TreeMap.Strict (TreeMap(..))
17 import Data.Tuple (curry, fst, snd)
18 import Data.Typeable ()
19 import Prelude (seq, undefined)
20 import Text.Show (Show(..))
21 import qualified Data.Foldable as Foldable
22 import qualified Data.Map.Strict as Map
23 import qualified Data.MonoTraversable as MT
24 import qualified Data.Sequences as Seqs
25 import qualified Data.Strict.Maybe as Strict
26 import qualified Data.TreeMap.Strict as TreeMap
27
28 import Hcompta.Has
29 import qualified Hcompta.Lib.Foldable as Foldable
30 import qualified Hcompta.Lib.Strict as Strict
31 import Hcompta.Quantity
32
33 -- * Type 'Balance_Account'
34 -- | 'Balance' operations works on this type of 'Account'.
35 type Balance_Account a = TreeMap.Path a
36 instance Get (Balance_Account acct_sect)
37 (Balance_Account acct_sect
38 ,Balance_Amounts unit qty) where get = fst
39
40 -- * Type 'Balance_Amounts'
41 -- | 'Balance' operations works on this type of 'Amounts'.
42 type Balance_Amounts = Map
43 instance Get (Balance_Amounts unit qty)
44 (Balance_Account acct_sect
45 ,Balance_Amounts unit qty) where get = snd
46 instance Set (Balance_Amounts unit qty)
47 (Balance_Account acct_sect
48 ,Balance_Amounts unit qty) where set x (a, _) = (a, x)
49
50 -- * Type 'Balance'
51
52 -- | 'Balance_Account' and 'BalByUnit' of some @post@s.
53 --
54 -- NOTE: to reduce memory consumption
55 -- when applying 'balance_cons' incrementally,
56 -- the fields are explicitely stricts.
57 data Balance acct_sect unit qty
58 = Balance
59 { balByAccount :: !(BalByAccount acct_sect unit qty)
60 , balByUnit :: !(BalByUnit acct_sect unit qty)
61 } deriving (Data, Eq, Show, Typeable)
62 instance -- NFData
63 ( NFData acct_sect
64 , NFData unit
65 , NFData qty
66 , Ord acct_sect
67 ) => NFData (Balance acct_sect unit qty) where
68 rnf (Balance a u) = rnf a `seq` rnf u
69 instance -- Semigroup
70 ( Addable qty
71 , Ord unit
72 , Ord acct_sect
73 ) => Semigroup (Balance acct_sect unit qty) where
74 (<>) = balance_union
75 instance -- Monoid
76 ( Addable qty
77 , Ord unit
78 , Ord acct_sect
79 ) => Monoid (Balance acct_sect unit qty) where
80 mempty = balance_empty
81 mappend = (<>)
82
83 balance_empty :: Balance acct_sect unit qty
84 balance_empty =
85 Balance
86 { balByAccount = TreeMap.empty
87 , balByUnit = BalByUnit Map.empty
88 }
89
90 -- | Return the first given 'Balance'
91 -- updated by the second given 'Balance'.
92 balance_union ::
93 (Addable qty, Ord acct_sect, Ord unit)
94 => Balance acct_sect unit qty
95 -> Balance acct_sect unit qty
96 -> Balance acct_sect unit qty
97 balance_union
98 (Balance b0a b0u)
99 (Balance b1a b1u) =
100 Balance
101 { balByAccount = balByAccount_union b0a b1a
102 , balByUnit = balByUnit_union b0u b1u
103 }
104
105 -- | Return the given 'Balance'
106 -- updated by the given @post@.
107 balance_cons ::
108 ( Get (Balance_Account acct_sect) post
109 , Get (Balance_Amounts unit qty) post
110 , Addable qty, Ord acct_sect, Ord unit )
111 => post
112 -> Balance acct_sect unit qty
113 -> Balance acct_sect unit qty
114 balance_cons post bal =
115 bal
116 { balByAccount = balByAccount_cons post (balByAccount bal)
117 , balByUnit = balByUnit_cons post (balByUnit bal)
118 }
119
120 -- | Return the given 'Balance'
121 -- updated by the given @post@s.
122 balance_postings ::
123 ( post ~ MT.Element posts
124 , MT.MonoFoldable posts
125 , Get (Balance_Account acct_sect) post
126 , Get (Balance_Amounts unit qty) post
127 , Addable qty, Ord acct_sect, Ord unit )
128 => posts
129 -> Balance acct_sect unit qty
130 -> Balance acct_sect unit qty
131 balance_postings = flip (MT.ofoldr balance_cons)
132
133 -- ** Type 'BalByAccount'
134 type BalByAccount acct_sect unit qty
135 = TreeMap acct_sect (SumByAccount unit qty)
136
137 -- | Return the first given 'BalByAccount'
138 -- updated by the second given 'BalByAccount'.
139 balByAccount_union ::
140 ( Addable qty
141 , Ord acct_sect
142 , Ord unit )
143 => BalByAccount acct_sect unit qty
144 -> BalByAccount acct_sect unit qty
145 -> BalByAccount acct_sect unit qty
146 balByAccount_union = TreeMap.union (<>)
147
148 -- | Return the given 'BalByAccount'
149 -- updated by the given @post@.
150 balByAccount_cons ::
151 ( Get (Balance_Account acct_sect) post
152 , Get (Balance_Amounts unit qty) post
153 , Ord acct_sect
154 , Ord unit
155 , Addable qty
156 ) => post
157 -> BalByAccount acct_sect unit qty
158 -> BalByAccount acct_sect unit qty
159 balByAccount_cons post =
160 TreeMap.insert (<>) (get post) (SumByAccount $ get post)
161
162 -- *** Type 'SumByAccount'
163 -- | A sum of @qty@s, concerning a single 'Balance_Account'.
164 newtype SumByAccount unit qty
165 = SumByAccount (Balance_Amounts unit qty)
166 deriving (Data, Eq, NFData, Show, Typeable)
167 instance -- Semigroup
168 (Addable qty, Ord unit) =>
169 Semigroup (SumByAccount unit qty) where
170 SumByAccount x <> SumByAccount y =
171 SumByAccount $ Map.unionWith (flip quantity_add) x y
172 instance -- Monoid
173 (Addable qty, Ord unit) =>
174 Monoid (SumByAccount unit qty) where
175 mempty = SumByAccount mempty
176 mappend = (<>)
177
178 unSumByAccount
179 :: SumByAccount unit qty
180 -> Map unit qty
181 unSumByAccount (SumByAccount m) = m
182
183 -- ** Type 'BalByUnit'
184 newtype BalByUnit acct_sect unit qty
185 = BalByUnit (Map unit (SumByUnit (Balance_Account acct_sect) qty))
186 deriving (Data, Eq, NFData, Show, Typeable)
187 instance -- Semigroup
188 (Addable qty, Ord acct_sect, Ord unit) =>
189 Semigroup (BalByUnit acct_sect unit qty) where
190 (<>) = balByUnit_union
191 instance -- Monoid
192 (Addable qty, Ord acct_sect, Ord unit) =>
193 Monoid (BalByUnit acct_sect unit qty) where
194 mempty = BalByUnit mempty
195 mappend = (<>)
196
197 -- | Return the first given 'BalByUnit'
198 -- updated by the second given 'BalByUnit'.
199 balByUnit_union
200 :: (Addable qty, Ord acct_sect, Ord unit)
201 => BalByUnit acct_sect unit qty
202 -> BalByUnit acct_sect unit qty
203 -> BalByUnit acct_sect unit qty
204 balByUnit_union
205 (BalByUnit a0)
206 (BalByUnit a1) =
207 BalByUnit $
208 Map.unionWith
209 (\new old -> SumByUnit
210 { sumByUnit_quantity = quantity_add
211 (sumByUnit_quantity old)
212 (sumByUnit_quantity new)
213 , sumByUnit_accounts = Map.unionWith
214 (const::()->()->())
215 (sumByUnit_accounts old)
216 (sumByUnit_accounts new)
217 })
218 a0 a1
219
220 -- | Return the given 'BalByUnit'
221 -- updated by the given @post@.
222 balByUnit_cons ::
223 ( Get (Balance_Account acct_sect) post
224 , Get (Balance_Amounts unit qty) post
225 , Addable qty
226 , Ord acct_sect
227 , Ord unit
228 ) => post
229 -> BalByUnit acct_sect unit qty
230 -> BalByUnit acct_sect unit qty
231 balByUnit_cons post =
232 balByUnit_union $
233 BalByUnit $
234 (`Map.map` get post) $
235 \qty -> SumByUnit
236 { sumByUnit_quantity = qty
237 , sumByUnit_accounts = Map.singleton (get post) ()
238 }
239
240 -- | Return the given 'BalByUnit'
241 -- updated by the given 'BalByAccount'.
242 balByUnit_of_BalByAccount
243 :: (Addable qty, Ord acct_sect, Ord unit)
244 => BalByAccount acct_sect unit qty
245 -> BalByUnit acct_sect unit qty
246 -> BalByUnit acct_sect unit qty
247 balByUnit_of_BalByAccount =
248 flip $ TreeMap.foldr_with_Path $ curry balByUnit_cons
249
250 instance Get ( Balance_Account acct_sect )
251 ( Balance_Account acct_sect
252 , SumByAccount unit qty )
253 where get = fst
254 instance Get ( Balance_Amounts unit qty )
255 ( Balance_Account acct_sect
256 , SumByAccount unit qty )
257 where get = unSumByAccount . snd
258
259 -- *** Type 'SumByUnit'
260 -- | A sum of @qty@s with their 'Account's involved,
261 -- concerning a single @unit@.
262 data SumByUnit acct qty
263 = SumByUnit
264 { sumByUnit_quantity :: !qty
265 -- ^ The sum of @qty@s for a single @unit@.
266 , sumByUnit_accounts :: !(Map acct ())
267 -- ^ The 'Balance_Account's involved to build 'sumByUnit_quantity'.
268 } deriving (Data, Eq, Ord, Show, Typeable)
269 instance -- NFData
270 ( NFData acct
271 , NFData qty
272 ) => NFData (SumByUnit acct qty) where
273 rnf (SumByUnit q a) = rnf q `seq` rnf a
274
275 -- * Type 'DeviationByUnit'
276 -- | The 'BalByUnit' whose 'sumByUnit_quantity'
277 -- is not zero and possible 'Balance_Account' to 'equilibrium'.
278 newtype DeviationByUnit acct_sect unit qty
279 = DeviationByUnit (BalByUnit acct_sect unit qty)
280 deriving (Data, Eq, NFData, Show, Typeable)
281
282 -- | Return the 'balByUnit' of the given 'Balance' with:
283 --
284 -- * @unit@s whose 'sumByUnit_quantity' verifying 'quantity_null' are removed,
285 --
286 -- * and remaining @unit@s have their 'sumByUnit_accounts'
287 -- complemented with the 'balByAccount' of the given 'Balance'
288 -- (i.e. now mapping to the 'Balance_Account's __not__ involved to build the 'SumByUnit').
289 deviationByUnit
290 :: (Zero qty, Addable qty, Ord acct_sect, Ord unit)
291 => Balance acct_sect unit qty
292 -> DeviationByUnit acct_sect unit qty
293 deviationByUnit Balance
294 { balByAccount
295 , balByUnit=BalByUnit balByUnit
296 } =
297 let all_accounts = TreeMap.flatten (const ()) balByAccount in
298 let max_accounts = Map.size all_accounts in
299 DeviationByUnit $
300 Map.foldlWithKey
301 (\(BalByUnit m) unit SumByUnit{..} ->
302 BalByUnit $
303 if quantity_null sumByUnit_quantity
304 then m
305 else
306 case Map.size sumByUnit_accounts of
307 n | n == max_accounts ->
308 Map.insert unit SumByUnit
309 { sumByUnit_quantity
310 , sumByUnit_accounts = Map.empty
311 } m
312 _ ->
313 let diff = Map.difference all_accounts sumByUnit_accounts in
314 Map.insert unit SumByUnit
315 { sumByUnit_quantity
316 , sumByUnit_accounts = diff
317 } m
318 )
319 mempty
320 balByUnit
321
322 -- ** Balance equilibrium
323 -- | Return the 'Balance' (adjusted by inferred @qty@s)
324 -- of the given @post@s and either:
325 --
326 -- * 'Left': the @unit@s which have a non null 'SumByUnit'
327 -- and for which no equibrating 'Balance_Account' can be inferred.
328 -- * 'Right': the given @post@s with inferred @qty@s inserted.
329 equilibrium ::
330 ( post ~ MT.Element posts
331 , Seqs.IsSequence posts
332 , Get (Balance_Account acct_sect) post
333 , Has (Balance_Amounts unit qty) post
334 , Zero qty, Addable qty, Negable qty
335 , Ord acct, Ord acct_sect, Ord unit
336 , Get acct (Balance_Account acct_sect)
337 ) => Map acct posts
338 -> ( Balance acct_sect unit qty
339 , Either [(unit, SumByUnit (Balance_Account acct_sect) qty)]
340 (Map acct posts) )
341 equilibrium posts =
342 let bal_initial = MT.ofoldr balance_postings balance_empty posts in
343 let DeviationByUnit (BalByUnit dev) = deviationByUnit bal_initial in
344 let (bal_adjusted, eithers) =
345 Map.foldrWithKey
346 (\unit unit_sum@SumByUnit{..} (bal, lr) ->
347 case Map.size sumByUnit_accounts of
348 1 ->
349 let acct = fst $ Map.elemAt 0 sumByUnit_accounts in
350 let qty = quantity_neg sumByUnit_quantity in
351 let amts = Map.singleton unit qty in
352 ( balance_cons (acct, SumByAccount amts) bal
353 , Right (acct, unit, qty) : lr
354 )
355 _ -> (bal, Left [(unit, unit_sum)] : lr))
356 (bal_initial, [])
357 dev in
358 let (l, r) = Foldable.accumLeftsAndFoldrRights
359 (\(acct, unit, qty) ->
360 Map.insertWith
361 (\_new_ps -> Seqs.fromList . insert_amount (unit, qty) . MT.otoList)
362 (get acct) (assert False undefined))
363 -- NOTE: acct is within bal_initial,
364 -- hence posts already has a mapping for acct.
365 posts eithers in
366 case l of
367 [] -> (bal_adjusted, Right r)
368 _ -> (bal_adjusted, Left l)
369 where
370 insert_amount
371 :: forall post unit qty.
372 ( Ord unit
373 , Has (Balance_Amounts unit qty) post
374 ) => (unit, qty) -> [post] -> [post]
375 insert_amount amt@(unit, qty) l =
376 case l of
377 [] -> assert False []
378 -- NOTE: the acct being in bal_initial,
379 -- hence there was at least one post for this acct.
380 p:ps ->
381 let amts :: Balance_Amounts unit qty = get p in
382 if Map.notMember unit amts
383 then set (Map.insert unit qty amts) p:ps
384 else p:insert_amount amt ps
385
386 -- | Return 'True' if and only if the given 'DeviationByUnit' maps no @unit@.
387 is_equilibrium :: DeviationByUnit acct_sect unit qty -> Bool
388 is_equilibrium (DeviationByUnit (BalByUnit dev)) = Map.null dev
389
390 -- | Return 'True' if and only if the given 'DeviationByUnit'
391 -- maps only to 'SumByUnit's whose 'sumByUnit_accounts'
392 -- maps exactly one 'Balance_Account'.
393 is_equilibrium_inferrable :: DeviationByUnit acct_sect unit qty -> Bool
394 is_equilibrium_inferrable (DeviationByUnit (BalByUnit dev)) =
395 Foldable.all ((== 1) . Map.size . sumByUnit_accounts) dev
396
397 -- * Type 'ClusiveBalByAccount'
398
399 -- | {Ex,In}clusive 'BalByAccount':
400 -- descending propagation of @qty@s accross 'Account's.
401 type ClusiveBalByAccount acct_sect unit qty
402 = TreeMap acct_sect (ClusiveSumByAccount unit qty)
403
404 -- ** Type 'ClusiveSumByAccount'
405 -- |
406 -- * 'Strict.exclusive': contains the original 'SumByAccount'.
407 -- * 'Strict.inclusive': contains 'quantity_add' folded
408 -- over 'Strict.exclusive' and 'Strict.inclusive'
409 -- of 'TreeMap.node_descendants'
410 type ClusiveSumByAccount unit qty
411 = Strict.Clusive (SumByAccount unit qty)
412
413 -- | Return the given 'BalByAccount' with:
414 --
415 -- * all missing 'Account.parent' 'Account's inserted;
416 -- * and every mapped @qty@ added with any @qty@
417 -- of the 'Account's for which it is 'Account.parent'.
418 clusiveBalByAccount
419 :: (Addable qty, Ord acct_sect, Ord unit)
420 => BalByAccount acct_sect unit qty
421 -> ClusiveBalByAccount acct_sect unit qty
422 clusiveBalByAccount =
423 TreeMap.map_by_depth_first
424 (\descendants value ->
425 let exclusive = Strict.fromMaybe mempty value in
426 Strict.Clusive
427 { Strict.exclusive
428 , Strict.inclusive =
429 Map.foldl'
430 ( flip $ (<>) . Strict.inclusive
431 . Strict.fromMaybe (assert False undefined)
432 . TreeMap.node_value )
433 exclusive $
434 TreeMap.nodes descendants
435 })
436
437 -- | Return a 'BalByUnit'
438 -- derived from the given 'ClusiveBalByAccount' balance.
439 --
440 -- NOTE: also correct if the 'ClusiveBalByAccount' has been filtered.
441 balByUnit_of_ClusiveBalByAccount
442 :: (Addable qty, Ord acct_sect, Ord unit)
443 => ClusiveBalByAccount acct_sect unit qty
444 -> BalByUnit acct_sect unit qty
445 -> BalByUnit acct_sect unit qty
446 balByUnit_of_ClusiveBalByAccount =
447 go []
448 where
449 go p (TreeMap nodes) bal =
450 Map.foldrWithKey
451 (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
452 case node_value of
453 Strict.Nothing -> go (k:p) node_descendants acc
454 Strict.Just a ->
455 let acct = Seqs.reverse $ TreeMap.path k p in
456 balByUnit_cons (acct, Strict.inclusive a) acc)
457 bal nodes