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