-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
- -- FIXME: to be removed when dropping GHC-7.6 support
-
--- | Balance
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Balance where
--- import Control.Applicative (Const(..))
--- import Control.Arrow (second)
import Control.DeepSeq (NFData(..))
import Control.Exception (assert)
import Data.Bool
import Data.Data
import Data.Either (Either(..))
import Data.Eq (Eq(..))
-import Data.Foldable (Foldable(..))
import qualified Data.Foldable as Foldable
import Data.Function (($), (.), const, flip)
--- import Data.Functor.Identity (Identity(..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
--- import qualified Data.MonoTraversable as MT
import Data.Monoid (Monoid(..))
+import qualified Data.MonoTraversable as MT
import Data.Ord (Ord(..))
+import Data.Semigroup (Semigroup(..))
+import qualified Data.Sequences as Seqs
import qualified Data.Strict.Maybe as Strict
import Data.TreeMap.Strict (TreeMap(..))
import qualified Data.TreeMap.Strict as TreeMap
import Data.Tuple (curry, fst, snd)
import Data.Typeable ()
-import Prelude (undefined)
+import Prelude (seq, undefined)
import Text.Show (Show(..))
-import Hcompta.Account
-import Hcompta.Amount
+import Hcompta.Has
import qualified Hcompta.Lib.Foldable as Foldable
import qualified Hcompta.Lib.Strict as Strict
-import Hcompta.Posting
import Hcompta.Quantity
--- * Class 'Balance_Posting'
-
--- | A 'posting' used to produce a 'Balance'
--- must be an instance of this class.
-class Posting p => Balance_Posting p where
- -- | 'Balance_Posting_Quantity'
- -- enables to build a 'Balance' with some quantity
- -- other than: 'Amount_Quantity' ('Posting_Amount' @p@);
- -- it's useful to 'polarize' it.
- type Balance_Posting_Quantity p
- balance_posting_amounts
- :: p -> Balance_Posting_Amounts p
- balance_posting_amounts_set
- :: Balance_Posting_Amounts p
- -> p -> p
-
--- ** Type 'Balance_Posting_Amounts'
-
--- | 'Balance' operations works on this type of 'Amount's.
-type Balance_Posting_Amounts p
- = Map (Amount_Unit (Posting_Amount p))
- (Balance_Posting_Quantity p)
-
-instance -- (account, Map unit quantity)
- ( Account account
- , Amount (unit, quantity)
- -- , Amount (MT.Element amounts)
- -- , MT.MonoFoldable amounts
- ) => Balance_Posting (account, Map unit quantity) where
- type Balance_Posting_Quantity (account, Map unit quantity) = quantity
- balance_posting_amounts (_, amts) = amts
- balance_posting_amounts_set amts (acct, _) = (acct, amts)
+-- * Type 'Balance_Account'
+-- | 'Balance' operations works on this type of 'Account'.
+type Balance_Account = TreeMap.Path
+instance Get (Balance_Account acct_sect)
+ (Balance_Account acct_sect
+ ,Balance_Amounts unit qty) where get = fst
+
+-- * Type 'Balance_Amounts'
+-- | 'Balance' operations works on this type of 'Amounts'.
+type Balance_Amounts = Map
+instance Get (Balance_Amounts unit qty)
+ (Balance_Account acct_sect
+ ,Balance_Amounts unit qty) where get = snd
+instance Set (Balance_Amounts unit qty)
+ (Balance_Account acct_sect
+ ,Balance_Amounts unit qty) where set x (a, _) = (a, x)
-- * Type 'Balance'
--- | 'Balance_Account' and 'Balance_by_Unit' of some 'Balance_Posting's.
+-- | 'Balance_Account' and 'BalByUnit' of some @post@s.
--
-- NOTE: to reduce memory consumption
-- when applying 'balance_cons' incrementally,
-- the fields are explicitely stricts.
-data Balance account_section unit quantity
+data Balance acct_sect unit qty
= Balance
- { balance_by_account :: !(Balance_by_Account account_section unit quantity)
- , balance_by_unit :: !(Balance_by_Unit account_section unit quantity)
- }
- --deriving (Data, Eq, Show, Typeable)
-deriving instance -- Data
- ( Data account_section
- , Data unit
- , Data quantity
- , Ord unit
- , Ord account_section
- , Typeable unit
- , Typeable quantity
- ) => Data (Balance account_section unit quantity)
-deriving instance -- Eq
- ( Eq account_section
- , Eq unit
- , Eq quantity
- ) => Eq (Balance account_section unit quantity)
-deriving instance -- Show
- ( Show account_section
- , Show unit
- , Show quantity
- ) => Show (Balance account_section unit quantity)
-deriving instance -- Typeable
- Typeable3 Balance
- -- FIXME: use 'Typeable' when dropping GHC-7.6 support
-
-instance -- Monoid
- ( Addable quantity
- , Ord unit
- , Ord account_section
- ) => Monoid (Balance account_section unit quantity) where
- mempty = balance_empty
- mappend = balance_union
-
--- ** Type 'Balance_by_Account'
-type Balance_by_Account account_section unit quantity
- = TreeMap account_section
- (Balance_by_Account_Sum unit quantity)
-
--- *** Type 'Balance_by_Account_Sum'
--- | A sum of 'quantity's, concerning a single 'account'.
-newtype Balance_by_Account_Sum unit quantity
- = Balance_by_Account_Sum (Map unit quantity)
- deriving (Data, Eq, Foldable, Show, Typeable)
-unBalance_by_Account_Sum
- :: Balance_by_Account_Sum unit quantity
- -> Map unit quantity
-unBalance_by_Account_Sum (Balance_by_Account_Sum m) = m
-instance -- Monoid
- ( Addable quantity
- , Ord unit
- ) => Monoid (Balance_by_Account_Sum unit quantity) where
- mempty = Balance_by_Account_Sum mempty
- mappend (Balance_by_Account_Sum x) (Balance_by_Account_Sum y) =
- Balance_by_Account_Sum $ Map.unionWith quantity_add x y
+ { balByAccount :: !(BalByAccount acct_sect unit qty)
+ , balByUnit :: !(BalByUnit acct_sect unit qty)
+ } deriving (Data, Eq, Show, Typeable)
instance -- NFData
- ( NFData unit
- , NFData quantity
- ) => NFData (Balance_by_Account_Sum unit quantity) where
- rnf (Balance_by_Account_Sum m) = rnf m
-instance -- Posting
- ( Account account
- , Amount (unit, quantity)
- ) => Posting (account, Balance_by_Account_Sum unit quantity) where
- type Posting_Account (account, Balance_by_Account_Sum unit quantity) = account
- type Posting_Amount (account, Balance_by_Account_Sum unit quantity) = (unit, quantity)
- type Posting_Amounts (account, Balance_by_Account_Sum unit quantity) = Map unit quantity
- posting_account = fst
- posting_amounts = unBalance_by_Account_Sum . snd
-instance -- Balance_Posting
- ( Account account
- , Amount (unit, quantity)
- ) => Balance_Posting (account, Balance_by_Account_Sum unit quantity) where
- type Balance_Posting_Quantity (account, Balance_by_Account_Sum unit quantity) = quantity
- balance_posting_amounts (_, Balance_by_Account_Sum x) = x
- balance_posting_amounts_set amounts (acct, _) = (acct, Balance_by_Account_Sum amounts)
-
--- ** Type 'Balance_by_Unit'
-newtype Balance_by_Unit account_section unit quantity
- = Balance_by_Unit (Map unit (Balance_by_Unit_Sum account_section quantity))
-deriving instance -- Data
- ( Data account_section
- , Data unit
- , Data quantity
- , Ord unit
- , Ord account_section
- , Typeable unit
- , Typeable quantity
- ) => Data (Balance_by_Unit account_section unit quantity)
-deriving instance -- Eq
- ( Eq account_section
- , Eq unit
- , Eq quantity
- ) => Eq (Balance_by_Unit account_section unit quantity)
+ ( NFData acct_sect
+ , NFData unit
+ , NFData qty
+ , Ord acct_sect
+ ) => NFData (Balance acct_sect unit qty) where
+ rnf (Balance a u) = rnf a `seq` rnf u
+instance -- Semigroup
+ ( Addable qty
+ , Ord unit
+ , Ord acct_sect
+ ) => Semigroup (Balance acct_sect unit qty) where
+ (<>) = balance_union
instance -- Monoid
- ( Addable quantity
+ ( Addable qty
, Ord unit
- , Ord account_section
- ) => Monoid (Balance_by_Unit account_section unit quantity) where
- mempty = Balance_by_Unit mempty
- mappend = balance_by_unit_union
-deriving instance -- Show
- ( Show account_section
- , Show unit
- , Show quantity
- ) => Show (Balance_by_Unit account_section unit quantity)
-deriving instance -- Typeable
- Typeable3 Balance_by_Unit
- -- FIXME: use 'Typeable' when dropping GHC-7.6 support
-
--- *** Type 'Balance_by_Unit_Sum'
-
--- | A sum of 'quantity's with their 'Account's involved,
--- concerning a single 'unit'.
-data Balance_by_Unit_Sum account_section quantity
- = Balance_by_Unit_Sum
- { balance_by_unit_sum_quantity :: !quantity
- -- ^ The sum of 'quantity's for a single 'unit'.
- , balance_by_unit_sum_accounts :: !(Map (Account_Path account_section) ())
- -- ^ The 'account's involved to build 'balance_by_unit_sum_quantity'.
- }
-deriving instance -- Data
- ( Data account_section
- , Data quantity
- , Ord account_section
- ) => Data (Balance_by_Unit_Sum account_section quantity)
-deriving instance -- Eq
- ( Eq account_section
- , Eq quantity
- ) => Eq (Balance_by_Unit_Sum account_section quantity)
-deriving instance -- Show
- ( Show account_section
- , Show quantity
- ) => Show (Balance_by_Unit_Sum account_section quantity)
-deriving instance -- Typeable
- Typeable2 Balance_by_Unit_Sum
- -- FIXME: use 'Typeable' when dropping GHC-7.6 support
-
--- ** Constructors
+ , Ord acct_sect
+ ) => Monoid (Balance acct_sect unit qty) where
+ mempty = balance_empty
+ mappend = (<>)
-balance_empty
- :: ( Addable quantity
- , Ord unit
- , Ord account_section
- )
- => Balance account_section unit quantity
+balance_empty :: Balance acct_sect unit qty
balance_empty =
Balance
- { balance_by_account = mempty
- , balance_by_unit = mempty
+ { balByAccount = TreeMap.empty
+ , balByUnit = BalByUnit Map.empty
}
--- | Return the given 'Balance'
--- updated by the given 'Balance_Posting'.
-balance_cons
- :: ( Balance_Posting posting
- , balance ~ Balance (Account_Section (Posting_Account posting))
- (Amount_Unit (Posting_Amount posting))
- (Balance_Posting_Quantity posting)
- , Addable (Balance_Posting_Quantity posting)
- , Ord (Amount_Unit (Posting_Amount posting))
- )
- => posting -> balance -> balance
-balance_cons post bal =
- bal
- { balance_by_account = balance_by_account_cons post (balance_by_account bal)
- , balance_by_unit = balance_by_unit_cons post (balance_by_unit bal)
- }
-
--- | Return the given 'Balance'
--- updated by the given 'Balance_Posting's.
-balance_postings
- :: ( Balance_Posting posting
- , balance ~ Balance (Account_Section (Posting_Account posting))
- (Amount_Unit (Posting_Amount posting))
- (Balance_Posting_Quantity posting)
- , Foldable foldable
- , Addable (Balance_Posting_Quantity posting)
- , Ord (Amount_Unit (Posting_Amount posting))
- , Posting posting
- )
- => foldable posting -> balance -> balance
-balance_postings = flip (Foldable.foldr balance_cons)
-
-- | Return the first given 'Balance'
-- updated by the second given 'Balance'.
-balance_union
- :: ( Addable quantity
- , Ord unit
- , Ord account_section
- , balance ~ Balance account_section unit quantity
- )
- => balance -> balance -> balance
+balance_union ::
+ (Addable qty, Ord acct_sect, Ord unit)
+ => Balance acct_sect unit qty
+ -> Balance acct_sect unit qty
+ -> Balance acct_sect unit qty
balance_union
(Balance b0a b0u)
(Balance b1a b1u) =
Balance
- { balance_by_account = balance_by_account_union b0a b1a
- , balance_by_unit = balance_by_unit_union b0u b1u
+ { balByAccount = balByAccount_union b0a b1a
+ , balByUnit = balByUnit_union b0u b1u
}
--- | Return the given 'Balance_by_Account'
--- updated by the given 'Balance_Posting'.
-balance_by_account_cons
- :: ( Posting posting
- , Balance_Posting posting
- , account ~ Posting_Account posting
- , quantity ~ Balance_Posting_Quantity posting
- , unit ~ Amount_Unit (Posting_Amount posting)
- , Addable quantity
- , Ord unit
- )
- => posting
- -> Balance_by_Account (Account_Section account) unit quantity
- -> Balance_by_Account (Account_Section account) unit quantity
-balance_by_account_cons post =
- TreeMap.insert mappend
- (account_path $ posting_account post)
- (Balance_by_Account_Sum $ balance_posting_amounts post)
-
--- | Return the given 'Balance_by_Unit'
--- updated by the given 'Balance_Posting'.
-balance_by_unit_cons
- :: ( Balance_Posting posting
- , account_section ~ Account_Section (Posting_Account posting)
- , quantity ~ Balance_Posting_Quantity posting
- , unit ~ Amount_Unit (Posting_Amount posting)
- , Addable quantity
- , Ord unit
- )
- => posting
- -> Balance_by_Unit account_section unit quantity
- -> Balance_by_Unit account_section unit quantity
-balance_by_unit_cons post =
- balance_by_unit_union $
- Balance_by_Unit $
- (`Map.map` balance_posting_amounts post) $
- \quantity -> Balance_by_Unit_Sum
- { balance_by_unit_sum_quantity = quantity
- , balance_by_unit_sum_accounts = Map.singleton (account_path $ posting_account post) ()
- }
-
--- | Return a 'Balance_by_Unit'
--- derived from the given 'Balance_by_Account'.
-balance_by_unit_of_by_account ::
- ( Amount (unit, quantity)
- , Addable quantity
- , Data account_section
- , NFData account_section
- , Ord account_section
- , Ord unit
- , Show account_section
- )
- => Balance_by_Account account_section unit quantity
- -> Balance_by_Unit account_section unit quantity
- -> Balance_by_Unit account_section unit quantity
-balance_by_unit_of_by_account =
- flip $ TreeMap.foldr_with_Path $ curry balance_by_unit_cons
-
--- | Return the first given 'Balance_by_Account'
--- updated by the second given 'Balance_by_Account'.
-balance_by_account_union
- :: ( Addable quantity
- , Ord account_section
- , Ord unit
- )
- => Balance_by_Account account_section unit quantity
- -> Balance_by_Account account_section unit quantity
- -> Balance_by_Account account_section unit quantity
-balance_by_account_union = TreeMap.union mappend
+-- | Return the given 'Balance'
+-- updated by the given @post@.
+balance_cons ::
+ ( Get (Balance_Account acct_sect) post
+ , Get (Balance_Amounts unit qty) post
+ , Addable qty, Ord acct_sect, Ord unit )
+ => post
+ -> Balance acct_sect unit qty
+ -> Balance acct_sect unit qty
+balance_cons post bal =
+ bal
+ { balByAccount = balByAccount_cons post (balByAccount bal)
+ , balByUnit = balByUnit_cons post (balByUnit bal)
+ }
--- | Return the first given 'Balance_by_Unit'
--- updated by the second given 'Balance_by_Unit'.
-balance_by_unit_union
- :: ( Addable quantity
- , Ord unit
- , Ord account_section
- )
- => Balance_by_Unit account_section unit quantity
- -> Balance_by_Unit account_section unit quantity
- -> Balance_by_Unit account_section unit quantity
-balance_by_unit_union
- (Balance_by_Unit a0)
- (Balance_by_Unit a1) =
- Balance_by_Unit $
+-- | Return the given 'Balance'
+-- updated by the given @post@s.
+balance_postings ::
+ ( post ~ MT.Element posts
+ , MT.MonoFoldable posts
+ , Get (Balance_Account acct_sect) post
+ , Get (Balance_Amounts unit qty) post
+ , Addable qty, Ord acct_sect, Ord unit )
+ => posts
+ -> Balance acct_sect unit qty
+ -> Balance acct_sect unit qty
+balance_postings = flip (MT.ofoldr balance_cons)
+
+-- ** Type 'BalByAccount'
+type BalByAccount acct_sect unit qty
+ = TreeMap acct_sect (SumByAccount unit qty)
+
+-- | Return the first given 'BalByAccount'
+-- updated by the second given 'BalByAccount'.
+balByAccount_union ::
+ ( Addable qty
+ , Ord acct_sect
+ , Ord unit )
+ => BalByAccount acct_sect unit qty
+ -> BalByAccount acct_sect unit qty
+ -> BalByAccount acct_sect unit qty
+balByAccount_union = TreeMap.union (<>)
+
+-- | Return the given 'BalByAccount'
+-- updated by the given @post@.
+balByAccount_cons ::
+ ( Get (Balance_Account acct_sect) post
+ , Get (Balance_Amounts unit qty) post
+ , Ord acct_sect
+ , Ord unit
+ , Addable qty
+ ) => post
+ -> BalByAccount acct_sect unit qty
+ -> BalByAccount acct_sect unit qty
+balByAccount_cons post =
+ TreeMap.insert (<>) (get post) (SumByAccount $ get post)
+
+-- *** Type 'SumByAccount'
+-- | A sum of @qty@s, concerning a single 'Balance_Account'.
+newtype SumByAccount unit qty
+ = SumByAccount (Balance_Amounts unit qty)
+ deriving (Data, Eq, NFData, Show, Typeable)
+instance -- Semigroup
+ (Addable qty, Ord unit) =>
+ Semigroup (SumByAccount unit qty) where
+ SumByAccount x <> SumByAccount y =
+ SumByAccount $ Map.unionWith (flip quantity_add) x y
+instance -- Monoid
+ (Addable qty, Ord unit) =>
+ Monoid (SumByAccount unit qty) where
+ mempty = SumByAccount mempty
+ mappend = (<>)
+
+unSumByAccount
+ :: SumByAccount unit qty
+ -> Map unit qty
+unSumByAccount (SumByAccount m) = m
+
+-- ** Type 'BalByUnit'
+newtype BalByUnit acct_sect unit qty
+ = BalByUnit (Map unit (SumByUnit (Balance_Account acct_sect) qty))
+ deriving (Data, Eq, NFData, Show, Typeable)
+instance -- Semigroup
+ (Addable qty, Ord acct_sect, Ord unit) =>
+ Semigroup (BalByUnit acct_sect unit qty) where
+ (<>) = balByUnit_union
+instance -- Monoid
+ (Addable qty, Ord acct_sect, Ord unit) =>
+ Monoid (BalByUnit acct_sect unit qty) where
+ mempty = BalByUnit mempty
+ mappend = (<>)
+
+-- | Return the first given 'BalByUnit'
+-- updated by the second given 'BalByUnit'.
+balByUnit_union
+ :: (Addable qty, Ord acct_sect, Ord unit)
+ => BalByUnit acct_sect unit qty
+ -> BalByUnit acct_sect unit qty
+ -> BalByUnit acct_sect unit qty
+balByUnit_union
+ (BalByUnit a0)
+ (BalByUnit a1) =
+ BalByUnit $
Map.unionWith
- (\new old -> Balance_by_Unit_Sum
- { balance_by_unit_sum_quantity = quantity_add
- (balance_by_unit_sum_quantity old)
- (balance_by_unit_sum_quantity new)
- , balance_by_unit_sum_accounts = Map.unionWith
+ (\new old -> SumByUnit
+ { sumByUnit_quantity = quantity_add
+ (sumByUnit_quantity old)
+ (sumByUnit_quantity new)
+ , sumByUnit_accounts = Map.unionWith
(const::()->()->())
- (balance_by_unit_sum_accounts old)
- (balance_by_unit_sum_accounts new)
+ (sumByUnit_accounts old)
+ (sumByUnit_accounts new)
})
a0 a1
--- * Type 'Balance_Deviation'
-
--- | The 'Balance_by_Unit' whose 'balance_by_unit_sum_quantity'
--- is not zero and possible 'account' to 'balance_infer_equilibrium'.
-newtype Balance_Deviation account_section unit quantity
- = Balance_Deviation (Balance_by_Unit account_section unit quantity)
-deriving instance -- Data
- ( Data account_section
- , Data unit
- , Data quantity
- , Ord unit
- , Ord account_section
- , Typeable unit
- , Typeable quantity
- ) => Data (Balance_Deviation account_section unit quantity)
-deriving instance -- Eq
- ( Eq account_section
- , Eq unit
- , Eq quantity
- ) => Eq (Balance_Deviation account_section unit quantity)
-deriving instance -- Show
- ( Show account_section
- , Show unit
- , Show quantity
- ) => Show (Balance_Deviation account_section unit quantity)
-deriving instance -- Typeable
- Typeable3 Balance_Deviation
- -- FIXME: use 'Typeable' when dropping GHC-7.6 support
+-- | Return the given 'BalByUnit'
+-- updated by the given @post@.
+balByUnit_cons ::
+ ( Get (Balance_Account acct_sect) post
+ , Get (Balance_Amounts unit qty) post
+ , Addable qty
+ , Ord acct_sect
+ , Ord unit
+ ) => post
+ -> BalByUnit acct_sect unit qty
+ -> BalByUnit acct_sect unit qty
+balByUnit_cons post =
+ balByUnit_union $
+ BalByUnit $
+ (`Map.map` get post) $
+ \qty -> SumByUnit
+ { sumByUnit_quantity = qty
+ , sumByUnit_accounts = Map.singleton (get post) ()
+ }
--- | Return the 'balance_by_unit' of the given 'Balance' with:
+-- | Return the given 'BalByUnit'
+-- updated by the given 'BalByAccount'.
+balByUnit_of_BalByAccount
+ :: (Addable qty, Ord acct_sect, Ord unit)
+ => BalByAccount acct_sect unit qty
+ -> BalByUnit acct_sect unit qty
+ -> BalByUnit acct_sect unit qty
+balByUnit_of_BalByAccount =
+ flip $ TreeMap.foldr_with_Path $ curry balByUnit_cons
+
+instance Get ( Balance_Account acct_sect )
+ ( Balance_Account acct_sect
+ , SumByAccount unit qty )
+ where get = fst
+instance Get ( Balance_Amounts unit qty )
+ ( Balance_Account acct_sect
+ , SumByAccount unit qty )
+ where get = unSumByAccount . snd
+
+-- *** Type 'SumByUnit'
+-- | A sum of @qty@s with their 'Account's involved,
+-- concerning a single @unit@.
+data SumByUnit acct qty
+ = SumByUnit
+ { sumByUnit_quantity :: !qty
+ -- ^ The sum of @qty@s for a single @unit@.
+ , sumByUnit_accounts :: !(Map acct ())
+ -- ^ The 'Balance_Account's involved to build 'sumByUnit_quantity'.
+ } deriving (Data, Eq, Ord, Show, Typeable)
+instance -- NFData
+ ( NFData acct
+ , NFData qty
+ ) => NFData (SumByUnit acct qty) where
+ rnf (SumByUnit q a) = rnf q `seq` rnf a
+
+-- * Type 'DeviationByUnit'
+-- | The 'BalByUnit' whose 'sumByUnit_quantity'
+-- is not zero and possible 'Balance_Account' to 'equilibrium'.
+newtype DeviationByUnit acct_sect unit qty
+ = DeviationByUnit (BalByUnit acct_sect unit qty)
+ deriving (Data, Eq, NFData, Show, Typeable)
+
+-- | Return the 'balByUnit' of the given 'Balance' with:
--
--- * 'unit's whose 'balance_by_unit_sum_quantity' is verifying 'quantity_null' removed,
+-- * @unit@s whose 'sumByUnit_quantity' verifying 'quantity_null' are removed,
--
--- * and remaining 'unit's having their 'balance_by_unit_sum_accounts'
--- complemented with the 'balance_by_account' of the given 'Balance'
--- (i.e. now mapping to 'account's __not__ involved to build the 'Balance_by_Unit_Sum').
-balance_deviation
- :: ( Zero quantity
- , Addable quantity
- , Ord account_section
- , Ord unit
- )
- => Balance account_section unit quantity
- -> Balance_Deviation account_section unit quantity
-balance_deviation Balance
- { balance_by_account
- , balance_by_unit=Balance_by_Unit balance_by_unit
+-- * and remaining @unit@s have their 'sumByUnit_accounts'
+-- complemented with the 'balByAccount' of the given 'Balance'
+-- (i.e. now mapping to the 'Balance_Account's __not__ involved to build the 'SumByUnit').
+deviationByUnit
+ :: (Zero qty, Addable qty, Ord acct_sect, Ord unit)
+ => Balance acct_sect unit qty
+ -> DeviationByUnit acct_sect unit qty
+deviationByUnit Balance
+ { balByAccount
+ , balByUnit=BalByUnit balByUnit
} =
- let all_accounts = TreeMap.flatten (const ()) balance_by_account in
+ let all_accounts = TreeMap.flatten (const ()) balByAccount in
let max_accounts = Map.size all_accounts in
- Balance_Deviation $
+ DeviationByUnit $
Map.foldlWithKey
- (\(Balance_by_Unit m) unit Balance_by_Unit_Sum{..} ->
- Balance_by_Unit $
- if quantity_null balance_by_unit_sum_quantity
+ (\(BalByUnit m) unit SumByUnit{..} ->
+ BalByUnit $
+ if quantity_null sumByUnit_quantity
then m
else
- case Map.size balance_by_unit_sum_accounts of
+ case Map.size sumByUnit_accounts of
n | n == max_accounts ->
- Map.insert unit Balance_by_Unit_Sum
- { balance_by_unit_sum_quantity
- , balance_by_unit_sum_accounts = Map.empty
+ Map.insert unit SumByUnit
+ { sumByUnit_quantity
+ , sumByUnit_accounts = Map.empty
} m
_ ->
- let diff = Map.difference all_accounts balance_by_unit_sum_accounts in
- Map.insert unit Balance_by_Unit_Sum
- { balance_by_unit_sum_quantity
- , balance_by_unit_sum_accounts = diff
+ let diff = Map.difference all_accounts sumByUnit_accounts in
+ Map.insert unit SumByUnit
+ { sumByUnit_quantity
+ , sumByUnit_accounts = diff
} m
)
mempty
- balance_by_unit
+ balByUnit
-- ** Balance equilibrium
-
--- | Return the 'Balance' (adjusted by inferred 'quantity's)
--- of the given 'Balance_Posting's and either:
+-- | Return the 'Balance' (adjusted by inferred @qty@s)
+-- of the given @post@s and either:
--
--- * 'Left': the 'Balance_Posting's that cannot be inferred.
--- * 'Right': the given 'Balance_Posting's with inferred 'quantity's inserted.
-balance_infer_equilibrium
- :: ( Balance_Posting posting
- , account ~ Posting_Account posting
- , unit ~ Amount_Unit (Posting_Amount posting)
- , quantity ~ Balance_Posting_Quantity posting
- , account ~ Account_Path (Account_Section account)
- , account_section ~ Account_Section account
- , Addable quantity
- , Eq quantity
- , Negable quantity
- , Zero quantity
- , Ord account_section
- , Ord unit
- )
- => Map account [posting]
- -> ( Balance account_section unit quantity
- , Either [(unit, Balance_by_Unit_Sum account_section quantity)]
- (Map account [posting])
- )
-balance_infer_equilibrium posts =
- let bal_initial = Foldable.foldr balance_postings balance_empty posts in
- let Balance_Deviation (Balance_by_Unit dev) = balance_deviation bal_initial in
+-- * 'Left': the @unit@s which have a non null 'SumByUnit'
+-- and for which no equibrating 'Balance_Account' can be inferred.
+-- * 'Right': the given @post@s with inferred @qty@s inserted.
+equilibrium ::
+ ( post ~ MT.Element posts
+ , Seqs.IsSequence posts
+ , Get (Balance_Account acct_sect) post
+ , Has (Balance_Amounts unit qty) post
+ , Zero qty, Addable qty, Negable qty
+ , Ord acct, Ord acct_sect, Ord unit
+ , Get acct (Balance_Account acct_sect)
+ ) => Map acct posts
+ -> ( Balance acct_sect unit qty
+ , Either [(unit, SumByUnit (Balance_Account acct_sect) qty)]
+ (Map acct posts) )
+equilibrium posts =
+ let bal_initial = MT.ofoldr balance_postings balance_empty posts in
+ let DeviationByUnit (BalByUnit dev) = deviationByUnit bal_initial in
let (bal_adjusted, eithers) =
Map.foldrWithKey
- (\unit unit_sum@Balance_by_Unit_Sum{..} (bal, lr) ->
- case Map.size balance_by_unit_sum_accounts of
+ (\unit unit_sum@SumByUnit{..} (bal, lr) ->
+ case Map.size sumByUnit_accounts of
1 ->
- let acct = fst $ Map.elemAt 0 balance_by_unit_sum_accounts in
- let qty = quantity_neg balance_by_unit_sum_quantity in
+ let acct = fst $ Map.elemAt 0 sumByUnit_accounts in
+ let qty = quantity_neg sumByUnit_quantity in
let amts = Map.singleton unit qty in
- ( balance_cons (acct, Balance_by_Account_Sum amts) bal
+ ( balance_cons (acct, SumByAccount amts) bal
, Right (acct, unit, qty) : lr
)
_ -> (bal, Left [(unit, unit_sum)] : lr))
let (l, r) = Foldable.accumLeftsAndFoldrRights
(\(acct, unit, qty) ->
Map.insertWith
- (\_new_ps -> insert_amount (unit, qty))
- acct (assert False []))
+ (\_new_ps -> Seqs.fromList . insert_amount (unit, qty) . MT.otoList)
+ (get acct) (assert False undefined))
+ -- NOTE: acct is within bal_initial,
+ -- hence posts already has a mapping for acct.
posts eithers in
case l of
[] -> (bal_adjusted, Right r)
_ -> (bal_adjusted, Left l)
where
insert_amount
- :: Balance_Posting posting
- => ( Amount_Unit (Posting_Amount posting)
- , Balance_Posting_Quantity posting
- )
- -> [posting]
- -> [posting]
- insert_amount p@(unit, qty) ps =
- case ps of
+ :: forall post unit qty.
+ ( Ord unit
+ , Has (Balance_Amounts unit qty) post
+ ) => (unit, qty) -> [post] -> [post]
+ insert_amount amt@(unit, qty) l =
+ case l of
[] -> assert False []
- (x:xs) | Map.null (balance_posting_amounts x) ->
- balance_posting_amounts_set (Map.singleton unit qty) x:xs
- | Map.notMember unit (balance_posting_amounts x) ->
- let amts = Map.insertWith
- (assert False undefined)
- unit qty (balance_posting_amounts x) in
- balance_posting_amounts_set amts x:xs
- (x:xs) -> x:insert_amount p xs
-
--- | Return 'True' if and only if the given 'Balance_Deviation' maps no 'unit'.
-is_balance_at_equilibrium
- :: Balance_Deviation account_section unit quantity
- -> Bool
-is_balance_at_equilibrium (Balance_Deviation (Balance_by_Unit dev)) = Map.null dev
-
--- | Return 'True' if and only if the given 'Balance_Deviation'
--- maps only to 'Balance_by_Unit_Sum's whose 'balance_by_unit_sum_accounts'
--- maps exactly one 'account'.
-is_balance_equilibrium_inferrable
- :: Balance_Deviation account_section unit quantity
- -> Bool
-is_balance_equilibrium_inferrable (Balance_Deviation (Balance_by_Unit dev)) =
- Foldable.all
- (\s -> Map.size (balance_by_unit_sum_accounts s) == 1)
- dev
-
--- | Return 'True' if and only if the given 'Balance_Deviation'
--- maps to at least one 'Balance_by_Unit_Sum' whose 'balance_by_unit_sum_accounts'
--- maps more than one 'Account'.
-is_balance_equilibrium_non_inferrable
- :: Balance_Deviation account_section unit quantity
- -> Bool
-is_balance_equilibrium_non_inferrable (Balance_Deviation (Balance_by_Unit dev)) =
- Foldable.any
- (\s -> Map.size (balance_by_unit_sum_accounts s) > 1)
- dev
-
--- * Type 'Balance_Expanded'
-
--- | Descending propagation of 'quantity's accross 'Account's.
-type Balance_Expanded account_section unit quantity
- = TreeMap account_section (Balance_by_Account_Sum_Expanded unit quantity)
-
--- ** Type 'Balance_by_Account_Sum_Expanded'
-
+ -- NOTE: the acct being in bal_initial,
+ -- hence there was at least one post for this acct.
+ p:ps ->
+ let amts :: Balance_Amounts unit qty = get p in
+ if Map.notMember unit amts
+ then set (Map.insert unit qty amts) p:ps
+ else p:insert_amount amt ps
+
+-- | Return 'True' if and only if the given 'DeviationByUnit' maps no @unit@.
+is_equilibrium :: DeviationByUnit acct_sect unit qty -> Bool
+is_equilibrium (DeviationByUnit (BalByUnit dev)) = Map.null dev
+
+-- | Return 'True' if and only if the given 'DeviationByUnit'
+-- maps only to 'SumByUnit's whose 'sumByUnit_accounts'
+-- maps exactly one 'Balance_Account'.
+is_equilibrium_inferrable :: DeviationByUnit acct_sect unit qty -> Bool
+is_equilibrium_inferrable (DeviationByUnit (BalByUnit dev)) =
+ Foldable.all ((== 1) . Map.size . sumByUnit_accounts) dev
+
+-- * Type 'ClusiveBalByAccount'
+
+-- | {Ex,In}clusive 'BalByAccount':
+-- descending propagation of @qty@s accross 'Account's.
+type ClusiveBalByAccount acct_sect unit qty
+ = TreeMap acct_sect (ClusiveSumByAccount unit qty)
+
+-- ** Type 'ClusiveSumByAccount'
-- |
--- * 'Strict.exclusive': contains the original 'Balance_by_Account_Sum'.
+-- * 'Strict.exclusive': contains the original 'SumByAccount'.
-- * 'Strict.inclusive': contains 'quantity_add' folded
-- over 'Strict.exclusive' and 'Strict.inclusive'
-- of 'TreeMap.node_descendants'
-type Balance_by_Account_Sum_Expanded unit quantity
- = Strict.Clusive (Balance_by_Account_Sum unit quantity)
+type ClusiveSumByAccount unit qty
+ = Strict.Clusive (SumByAccount unit qty)
--- | Return the given 'Balance_by_Account' with:
+-- | Return the given 'BalByAccount' with:
--
-- * all missing 'Account.parent' 'Account's inserted;
--- * and every mapped 'quantity' added with any 'quantity'
+-- * and every mapped @qty@ added with any @qty@
-- of the 'Account's for which it is 'Account.parent'.
-balance_expanded ::
- ( Addable quantity
- , Ord account_section
- , Ord unit
- ) => Balance_by_Account account_section unit quantity
- -> Balance_Expanded account_section unit quantity
-balance_expanded =
+clusiveBalByAccount
+ :: (Addable qty, Ord acct_sect, Ord unit)
+ => BalByAccount acct_sect unit qty
+ -> ClusiveBalByAccount acct_sect unit qty
+clusiveBalByAccount =
TreeMap.map_by_depth_first
(\descendants value ->
let exclusive = Strict.fromMaybe mempty value in
{ Strict.exclusive
, Strict.inclusive =
Map.foldl'
- ( flip $ mappend . Strict.inclusive
+ ( flip $ (<>) . Strict.inclusive
. Strict.fromMaybe (assert False undefined)
. TreeMap.node_value )
exclusive $
TreeMap.nodes descendants
})
--- | Return a 'Balance_by_Unit'
--- derived from the given 'Balance_Expanded' balance.
+-- | Return a 'BalByUnit'
+-- derived from the given 'ClusiveBalByAccount' balance.
--
--- NOTE: also correct if the 'Balance_Expanded' has been filtered.
-balance_by_unit_of_expanded
- :: ( Amount (unit, quantity)
- , Addable quantity
- , Data account_section
- , NFData account_section
- , Ord account_section
- , Ord unit
- , Show account_section
- )
- => Balance_Expanded account_section unit quantity
- -> Balance_by_Unit account_section unit quantity
- -> Balance_by_Unit account_section unit quantity
-balance_by_unit_of_expanded =
+-- NOTE: also correct if the 'ClusiveBalByAccount' has been filtered.
+balByUnit_of_ClusiveBalByAccount
+ :: (Addable qty, Ord acct_sect, Ord unit)
+ => ClusiveBalByAccount acct_sect unit qty
+ -> BalByUnit acct_sect unit qty
+ -> BalByUnit acct_sect unit qty
+balByUnit_of_ClusiveBalByAccount =
go []
where
- go p (TreeMap nodes) bal =
- Map.foldrWithKey
- (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
- case node_value of
- Strict.Nothing -> go (k:p) node_descendants acc
- Strict.Just a ->
- let acct = TreeMap.reverse $ TreeMap.path k p in
- balance_by_unit_cons (acct, Strict.inclusive a) acc)
- bal nodes
+ go p (TreeMap nodes) bal =
+ Map.foldrWithKey
+ (\k TreeMap.Node{TreeMap.node_value, TreeMap.node_descendants} acc ->
+ case node_value of
+ Strict.Nothing -> go (k:p) node_descendants acc
+ Strict.Just a ->
+ let acct = TreeMap.reverse $ TreeMap.path k p in
+ balByUnit_cons (acct, Strict.inclusive a) acc)
+ bal nodes
sourcephile / git / comptalang.git / blobdiff