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
11 -- import Control.Applicative (Const(..))
12 import Control.DeepSeq (NFData(..))
13 import Control.Exception (assert)
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)
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
36 -- * Requirements' interface
40 -- | A 'posting' used to produce a 'Balance'
41 -- must be an instance of this class.
43 ( Account (Posting_Account p)
45 type Posting_Account p
46 type Posting_Quantity 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
53 ) => Posting (account, Map unit quantity)
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
60 posting_set_amounts amounts (acct, _) = (acct, amounts)
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
68 posting_amounts (_, Account_Sum x) = x
69 posting_set_amounts amounts (acct, _) = (acct, Account_Sum amounts)
73 -- | 'Balance_Account' and 'Balance_by_Unit' of some 'Posting's.
75 -- NOTE: to reduce memory consumption when 'cons'ing iteratively,
76 -- the fields are explicitely stricts.
79 ) => Balance account unit quantity
81 { balance_by_account :: !(Balance_by_Account (Account_Section account) unit quantity)
82 , balance_by_unit :: !(Balance_by_Unit account unit quantity)
84 --deriving (Data, Eq, Show, Typeable)
85 deriving instance ( Account account
92 , Data (Account_Section account)
93 ) => Data (Balance account unit quantity)
94 deriving instance ( Account account
98 ) => Eq (Balance account unit quantity)
99 deriving instance ( Account account
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
112 ) => Monoid (Balance account unit quantity) where
116 -- ** Type 'Balance_by_Account'
117 type Balance_by_Account account_section unit quantity
118 = TreeMap account_section
119 (Account_Sum unit quantity)
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)
127 :: Account_Sum unit quantity
129 get_Account_Sum (Account_Sum m) = m
134 ) => NFData (Account_Sum unit quantity) where
135 rnf (Account_Sum m) = rnf m
139 ) => Monoid (Account_Sum unit quantity) where
140 mempty = Account_Sum mempty
144 Account_Sum $ Data.Map.unionWith quantity_add a0 a1
146 -- ** Type 'Balance_by_Unit'
149 ) => Balance_by_Unit account unit quantity
150 = Balance_by_Unit (Map unit (Unit_Sum account quantity))
151 deriving instance ( Account account
158 , Data (Account_Section account)
159 ) => Data (Balance_by_Unit account unit quantity)
160 deriving instance ( Account account
164 ) => Eq (Balance_by_Unit account unit quantity)
165 deriving instance ( Account account
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
178 ) => Monoid (Balance_by_Unit account unit quantity) where
179 mempty = Balance_by_Unit mempty
180 mappend = union_by_unit
182 -- *** Type 'Unit_Sum'
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
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'.
193 deriving instance ( Account account
195 , Data (Account_Section account)
197 ) => Data (Unit_Sum account quantity)
198 deriving instance ( Account account
201 ) => Eq (Unit_Sum account quantity)
202 deriving instance ( Account account
204 , Show (Account_Section account)
206 ) => Show (Unit_Sum account quantity)
207 deriving instance Typeable2 Unit_Sum
208 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
216 ) => Balance account unit quantity
219 { balance_by_account = mempty
220 , balance_by_unit = mempty
223 -- | Return the given 'Balance'
224 -- updated by the given '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
235 { balance_by_account = cons_by_account post (balance_by_account bal)
236 , balance_by_unit = cons_by_unit post (balance_by_unit bal)
239 -- | Return the given 'Balance'
240 -- updated by the given 'Posting's.
243 , balance ~ Balance (Posting_Account posting)
244 (Posting_Unit posting)
245 (Posting_Quantity posting)
247 , Addable (Posting_Quantity posting)
248 , Ord (Posting_Unit posting)
249 ) => foldable posting -> balance -> balance
250 postings = flip (Data.Foldable.foldr cons)
252 -- | Return the first given 'Balance'
253 -- updated by the second given 'Balance'.
258 , balance ~ Balance account unit quantity
259 ) => balance -> balance -> balance
264 { balance_by_account = union_by_account b0a b1a
265 , balance_by_unit = union_by_unit b0u b1u
268 -- | Return the given 'Balance_by_Account'
269 -- updated by the given 'Posting'.
272 , account ~ Posting_Account posting
273 , quantity ~ Posting_Quantity posting
274 , unit ~ Posting_Unit posting
275 , Addable (Posting_Quantity 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)
286 -- | Return the given 'Balance_by_Unit'
287 -- updated by the given 'Posting'.
290 , account ~ Posting_Account posting
291 , quantity ~ Posting_Quantity posting
292 , unit ~ Posting_Unit posting
296 -> Balance_by_Unit account unit quantity
297 -> Balance_by_Unit account unit quantity
302 (\quantity -> Unit_Sum
303 { unit_sum_quantity = quantity
304 , unit_sum_accounts = Data.Map.singleton (account_path $ posting_account post) ()
306 (posting_amounts post)
308 -- | Return a 'Balance_by_Unit'
309 -- derived from the given 'Balance_by_Account'.
310 by_unit_of_by_account ::
312 , account ~ Account_Path (Account_Section account)
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
322 -- | Return the first given 'Balance_by_Account'
323 -- updated by the second given 'Balance_by_Account'.
326 , Ord account_section
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
333 -- | Return the first given 'Balance_by_Unit'
334 -- updated by the second given 'Balance_by_Unit'.
339 ) => Balance_by_Unit account unit quantity
340 -> Balance_by_Unit account unit quantity
341 -> Balance_by_Unit account unit quantity
344 (Balance_by_Unit a1) =
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
353 (unit_sum_accounts old)
354 (unit_sum_accounts new)
358 -- * Type 'Deviation'
360 -- | The 'Balance_by_Unit' whose 'unit_sum_quantity'
361 -- is not zero and possible 'account' to 'infer_equilibrium'.
364 ) => Deviation account unit quantity
365 = Deviation (Balance_by_Unit account unit quantity)
366 deriving instance ( Account account
373 , Data (Account_Section account)
374 ) => Data (Deviation account unit quantity)
375 deriving instance ( Account account
379 ) => Eq (Deviation account unit quantity)
380 deriving instance ( Account account
382 , Show (Account_Section account)
385 ) => Show (Deviation account unit quantity)
386 deriving instance Typeable3 Deviation
387 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
389 -- | Return the 'balance_by_unit' of the given 'Balance' with:
391 -- * 'unit's whose 'unit_sum_quantity' is verifying 'quantity_null' removed,
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').
401 ) => Balance account unit quantity
402 -> Deviation account unit quantity
404 { balance_by_account=ba
405 , balance_by_unit=Balance_by_Unit bu
407 let all_accounts = TreeMap.flatten (const ()) ba
408 let max_accounts = Data.Map.size all_accounts
410 Data.Map.foldlWithKey
411 (\(Balance_by_Unit m) unit Unit_Sum{unit_sum_quantity, unit_sum_accounts} ->
413 if quantity_null unit_sum_quantity
416 case Data.Map.size unit_sum_accounts of
417 n | n == max_accounts ->
418 Data.Map.insert unit Unit_Sum
420 , unit_sum_accounts = Data.Map.empty
423 let diff = Data.Map.difference all_accounts unit_sum_accounts
424 Data.Map.insert unit Unit_Sum
426 , unit_sum_accounts = diff
432 -- ** The equilibrium
434 -- | Return the 'Balance' (adjusted by inferred 'quantity's)
435 -- of the given 'Posting's and either:
437 -- * 'Left': the 'Posting's that cannot be inferred.
438 -- * 'Right': the given 'Posting's with inferred 'quantity's inserted.
441 , account ~ Posting_Account posting
442 , unit ~ Posting_Unit posting
443 , quantity ~ Posting_Quantity posting
444 , account ~ Account_Path (Account_Section account)
449 ) => Map account [posting]
450 -> ( Balance account unit quantity
451 , Either [(unit, Unit_Sum account quantity)]
452 (Map account [posting])
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})
461 case Data.Map.size unit_sum_accounts of
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
469 _ -> (bal, Left [(unit, unit_sum)] : lr))
472 let (l, r) = Lib.Foldable.accumLeftsAndFoldrRights
473 (\(acct, unit, qty) ->
475 (\_new_ps -> insert_amount (unit, qty))
476 acct (assert False []))
479 [] -> (bal_adjusted, Right r)
480 _ -> (bal_adjusted, Left l)
484 , Ord (Posting_Unit posting)
485 ) => ( Posting_Unit posting
486 , Posting_Quantity posting )
487 -> [posting] -> [posting]
488 insert_amount p@(unit, qty) ps =
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
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
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)) =
510 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
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)) =
519 (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
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)
536 ) => Monoid (Account_Sum_Expanded unit quantity) where
537 mempty = Account_Sum_Expanded mempty mempty
539 (Account_Sum_Expanded e0 i0)
540 (Account_Sum_Expanded e1 i1) =
545 -- | Return the given 'Balance_by_Account' with:
547 -- * all missing 'Account.ascending' 'Account's inserted,
549 -- * and every mapped 'quantity' added with any 'quantity'
550 -- of the 'Account's for which it is 'Account.ascending'.
553 , Ord account_section
555 ) => Balance_by_Account account_section unit quantity
556 -> Expanded account_section unit quantity
558 TreeMap.map_by_depth_first
559 (\descendants value ->
560 let exclusive = Strict.fromMaybe mempty value in
565 ( flip $ mappend . inclusive
566 . Strict.fromMaybe (assert False undefined)
567 . TreeMap.node_value )
569 TreeMap.nodes descendants
572 -- | Return a 'Balance_by_Unit'
573 -- derived from the given 'Expanded' balance.
575 -- NOTE: also correct if the 'Expanded' has been filtered.
576 by_unit_of_expanded ::
578 , account ~ Account_Path (Account_Section account)
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 =
587 go p (TreeMap.TreeMap nodes) bal =
588 Data.Map.foldrWithKey
589 (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
591 Strict.Nothing -> go (k:p) node_descendants acc
593 let account = TreeMap.reverse $ TreeMap.path k p in
594 cons_by_unit (account, inclusive a) acc)