1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Hcompta.Balance where
4 import Control.DeepSeq (NFData(..))
5 import Control.Exception (assert)
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(..))
28 import qualified Hcompta.Lib.Foldable as Foldable
29 import qualified Hcompta.Lib.Strict as Strict
30 import Hcompta.Quantity
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
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)
51 -- | 'Balance_Account' and 'BalByUnit' of some @post@s.
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
58 { balByAccount :: !(BalByAccount acct_sect unit qty)
59 , balByUnit :: !(BalByUnit acct_sect unit qty)
60 } deriving (Data, Eq, Show, Typeable)
66 ) => NFData (Balance acct_sect unit qty) where
67 rnf (Balance a u) = rnf a `seq` rnf u
72 ) => Semigroup (Balance acct_sect unit qty) where
78 ) => Monoid (Balance acct_sect unit qty) where
79 mempty = balance_empty
82 balance_empty :: Balance acct_sect unit qty
85 { balByAccount = TreeMap.empty
86 , balByUnit = BalByUnit Map.empty
89 -- | Return the first given 'Balance'
90 -- updated by the second given 'Balance'.
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
100 { balByAccount = balByAccount_union b0a b1a
101 , balByUnit = balByUnit_union b0u b1u
104 -- | Return the given 'Balance'
105 -- updated by the given @post@.
107 ( Get (Balance_Account acct_sect) post
108 , Get (Balance_Amounts unit qty) post
109 , Addable qty, Ord acct_sect, Ord unit )
111 -> Balance acct_sect unit qty
112 -> Balance acct_sect unit qty
113 balance_cons post bal =
115 { balByAccount = balByAccount_cons post (balByAccount bal)
116 , balByUnit = balByUnit_cons post (balByUnit bal)
119 -- | Return the given 'Balance'
120 -- updated by the given @post@s.
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 )
128 -> Balance acct_sect unit qty
129 -> Balance acct_sect unit qty
130 balance_postings = flip (MT.ofoldr balance_cons)
132 -- ** Type 'BalByAccount'
133 type BalByAccount acct_sect unit qty
134 = TreeMap acct_sect (SumByAccount unit qty)
136 -- | Return the first given 'BalByAccount'
137 -- updated by the second given 'BalByAccount'.
138 balByAccount_union ::
142 => BalByAccount acct_sect unit qty
143 -> BalByAccount acct_sect unit qty
144 -> BalByAccount acct_sect unit qty
145 balByAccount_union = TreeMap.union (<>)
147 -- | Return the given 'BalByAccount'
148 -- updated by the given @post@.
150 ( Get (Balance_Account acct_sect) post
151 , Get (Balance_Amounts unit qty) 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)
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
172 (Addable qty, Ord unit) =>
173 Monoid (SumByAccount unit qty) where
174 mempty = SumByAccount mempty
178 :: SumByAccount unit qty
180 unSumByAccount (SumByAccount m) = m
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
191 (Addable qty, Ord acct_sect, Ord unit) =>
192 Monoid (BalByUnit acct_sect unit qty) where
193 mempty = BalByUnit mempty
196 -- | Return the first given 'BalByUnit'
197 -- updated by the second given 'BalByUnit'.
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
208 (\new old -> SumByUnit
209 { sumByUnit_quantity = quantity_add
210 (sumByUnit_quantity old)
211 (sumByUnit_quantity new)
212 , sumByUnit_accounts = Map.unionWith
214 (sumByUnit_accounts old)
215 (sumByUnit_accounts new)
219 -- | Return the given 'BalByUnit'
220 -- updated by the given @post@.
222 ( Get (Balance_Account acct_sect) post
223 , Get (Balance_Amounts unit qty) post
228 -> BalByUnit acct_sect unit qty
229 -> BalByUnit acct_sect unit qty
230 balByUnit_cons post =
233 (`Map.map` get post) $
235 { sumByUnit_quantity = qty
236 , sumByUnit_accounts = Map.singleton (get post) ()
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
249 instance Get ( Balance_Account acct_sect )
250 ( Balance_Account acct_sect
251 , SumByAccount unit qty )
253 instance Get ( Balance_Amounts unit qty )
254 ( Balance_Account acct_sect
255 , SumByAccount unit qty )
256 where get = unSumByAccount . snd
258 -- *** Type 'SumByUnit'
259 -- | A sum of @qty@s with their 'Account's involved,
260 -- concerning a single @unit@.
261 data SumByUnit acct qty
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)
271 ) => NFData (SumByUnit acct qty) where
272 rnf (SumByUnit q a) = rnf q `seq` rnf a
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)
281 -- | Return the 'balByUnit' of the given 'Balance' with:
283 -- * @unit@s whose 'sumByUnit_quantity' verifying 'quantity_null' are removed,
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').
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
294 , balByUnit=BalByUnit balByUnit
296 let all_accounts = TreeMap.flatten (const ()) balByAccount in
297 let max_accounts = Map.size all_accounts in
300 (\(BalByUnit m) unit SumByUnit{..} ->
302 if quantity_null sumByUnit_quantity
305 case Map.size sumByUnit_accounts of
306 n | n == max_accounts ->
307 Map.insert unit SumByUnit
309 , sumByUnit_accounts = Map.empty
312 let diff = Map.difference all_accounts sumByUnit_accounts in
313 Map.insert unit SumByUnit
315 , sumByUnit_accounts = diff
321 -- ** Balance equilibrium
322 -- | Return the 'Balance' (adjusted by inferred @qty@s)
323 -- of the given @post@s and either:
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.
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)
337 -> ( Balance acct_sect unit qty
338 , Either [(unit, SumByUnit (Balance_Account acct_sect) qty)]
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) =
345 (\unit unit_sum@SumByUnit{..} (bal, lr) ->
346 case Map.size sumByUnit_accounts of
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
354 _ -> (bal, Left [(unit, unit_sum)] : lr))
357 let (l, r) = Foldable.accumLeftsAndFoldrRights
358 (\(acct, unit, qty) ->
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.
366 [] -> (bal_adjusted, Right r)
367 _ -> (bal_adjusted, Left l)
370 :: forall post unit qty.
372 , Has (Balance_Amounts unit qty) post
373 ) => (unit, qty) -> [post] -> [post]
374 insert_amount amt@(unit, qty) l =
376 [] -> assert False []
377 -- NOTE: the acct being in bal_initial,
378 -- hence there was at least one post for this acct.
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
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
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
396 -- * Type 'ClusiveBalByAccount'
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)
403 -- ** Type 'ClusiveSumByAccount'
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)
412 -- | Return the given 'BalByAccount' with:
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'.
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
429 ( flip $ (<>) . Strict.inclusive
430 . Strict.fromMaybe (assert False undefined)
431 . TreeMap.node_value )
433 TreeMap.nodes descendants
436 -- | Return a 'BalByUnit'
437 -- derived from the given 'ClusiveBalByAccount' balance.
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 =
448 go p (TreeMap nodes) bal =
450 (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
452 Strict.Nothing -> go (k:p) node_descendants acc
454 let acct = TreeMap.reverse $ TreeMap.path k p in
455 balByUnit_cons (acct, Strict.inclusive a) acc)