{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
module Hcompta.Calc.Balance where
import Data.Data
import qualified Data.Foldable
+import Data.Foldable (Foldable(..))
import qualified Data.List
import qualified Data.Map.Strict as Data.Map
import Data.Map.Strict (Map)
-import Data.Foldable
-import Data.Typeable ()
import Data.Maybe (fromMaybe)
-import qualified GHC.Num
+import Data.Typeable ()
-import qualified Hcompta.Model as Model ()
-import qualified Hcompta.Model.Account as Account
import qualified Hcompta.Lib.Foldable as Lib.Foldable
import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
+import Hcompta.Lib.TreeMap (TreeMap)
+import qualified Hcompta.Model.Account as Account
import Hcompta.Model.Account (Account)
-import qualified Hcompta.Model.Amount as Amount
-import Hcompta.Model.Amount (Amount, Unit)
-import qualified Hcompta.Model.Transaction as Transaction
-import Hcompta.Model.Transaction (Transaction, Posting)
-import qualified Hcompta.Model.Transaction.Posting as Posting
-import qualified Hcompta.Model.Journal as Journal
-import Hcompta.Model.Journal (Journal)
+
+-- * The 'Posting' class
+
+-- | A 'posting' used to produce a 'Balance'
+-- must be an instance of this class.
+class
+ ( Ord (Posting_Unit p)
+ , Num (Posting_Amount p)
+ ) =>
+ Posting p where
+ type Posting_Amount p
+ type Posting_Unit p
+ posting_account :: p -> Account
+ posting_amounts :: p -> Map (Posting_Unit p) (Posting_Amount p)
+ posting_make :: Account -> Map (Posting_Unit p) (Posting_Amount p) -> p
-- * The 'Balance' type
--- | Sum by 'Account' and sum by 'Unit' of some 'Posting's.
-data Balance
+-- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
+data Balance amount unit
= Balance
- { by_account :: By_Account
- , by_unit :: By_Unit
- } deriving (Data, Eq, Read, Show, Typeable)
+ { balance_by_account :: Balance_by_Account amount unit
+ , balance_by_unit :: Balance_by_Unit amount unit
+ } deriving (Data, Eq, Show, Typeable)
+
+type Balance_by_Account amount unit
+ = TreeMap Account.Name
+ (Account_Sum amount unit)
-type By_Account
- = Lib.TreeMap.TreeMap Account.Name Account_Sum
--- | A sum of 'Amount's,
+-- | A sum of 'amount's,
-- concerning a single 'Account'.
-type Account_Sum
- = Amount.By_Unit
+type Account_Sum amount unit
+ = Data.Map.Map unit amount
-type By_Unit
- = Map Amount.Unit Unit_Sum
--- | A sum of 'Amount's with their 'Account's involved,
--- concerning a single 'Unit'.
-data Unit_Sum
+type Balance_by_Unit amount unit
+ = Map unit (Unit_Sum amount)
+
+-- | A sum of 'amount's with their 'Account's involved,
+-- concerning a single 'unit'.
+data Unit_Sum amount
= Unit_Sum
- { amount :: Amount -- ^ The sum of 'Amount's for a single 'Unit'.
- , accounts :: Map Account () -- ^ The 'Account's involved to build 'amount'.
- } deriving (Data, Eq, Read, Show, Typeable)
+ { unit_sum_amount :: amount -- ^ The sum of 'amount's for a single 'unit'.
+ , unit_sum_accounts :: Map Account () -- ^ The 'Account's involved to build 'unit_sum_amount'.
+ } deriving (Data, Eq, Show, Typeable)
-- ** Constructors
-nil :: Balance
-nil =
+balance :: (Num amount, Ord unit) => Balance amount unit
+balance =
Balance
- { by_account = Lib.TreeMap.empty
- , by_unit = Data.Map.empty
+ { balance_by_account = Lib.TreeMap.empty
+ , balance_by_unit = Data.Map.empty
}
-nil_By_Account :: By_Account
-nil_By_Account =
- Lib.TreeMap.empty
-
-nil_By_Unit :: By_Unit
-nil_By_Unit =
- Data.Map.empty
-
-nil_Account_Sum :: Account_Sum
-nil_Account_Sum =
- Data.Map.empty
-
-nil_Unit_Sum :: Unit_Sum
-nil_Unit_Sum =
- Unit_Sum
- { accounts = Data.Map.empty
- , amount = Amount.nil
- }
-
--- | Return a tuple associating the given 'Unit_Sum' with its 'Unit'.
-assoc_unit_sum :: Unit_Sum -> (Unit, Unit_Sum)
-assoc_unit_sum s = (Amount.unit $ amount s, s)
-
--- | Return a 'Map' associating the given 'Unit_Sum' with their respective 'Unit'.
-by_Unit_from_List :: [Unit_Sum] -> By_Unit
-by_Unit_from_List balances =
- Data.Map.fromListWith
- (\x y -> Unit_Sum
- { amount=(GHC.Num.+) (amount x) (amount y)
- , accounts=Data.Map.union (accounts x) (accounts y)
- }) $
- Data.List.map assoc_unit_sum balances
-
--- ** Incremental constructors
-
-- | Return the given 'Balance'
-- updated by the given 'Posting'.
-posting :: Posting -> Balance -> Balance
-posting post balance =
- balance
- { by_account =
+posting ::
+ ( Posting posting
+ , unit ~ Posting_Unit posting
+ , amount ~ Posting_Amount posting
+ ) => posting -> Balance amount unit -> Balance amount unit
+posting post bal =
+ bal
+ { balance_by_account =
Lib.TreeMap.insert
- (Data.Map.unionWith (GHC.Num.+))
- (Posting.account post)
- (Posting.amounts post)
- (by_account balance)
- , by_unit =
+ (Data.Map.unionWith (flip (+)))
+ (posting_account post)
+ (posting_amounts post)
+ (balance_by_account bal)
+ , balance_by_unit =
Data.Map.unionWith
- (\x y -> Unit_Sum
- { amount = (GHC.Num.+) (amount x) (amount y)
- , accounts = Data.Map.union (accounts x) (accounts y)
+ (\new old -> Unit_Sum
+ { unit_sum_amount = (+)
+ (unit_sum_amount old)
+ (unit_sum_amount new)
+ , unit_sum_accounts = Data.Map.unionWith
+ (const::()->()->())
+ (unit_sum_accounts old)
+ (unit_sum_accounts new)
})
- (by_unit balance) $
+ (balance_by_unit bal) $
Data.Map.map
(\amount -> Unit_Sum
- { amount
- , accounts = Data.Map.singleton (Posting.account post) ()
+ { unit_sum_amount = amount
+ , unit_sum_accounts = Data.Map.singleton (posting_account post) ()
})
- (Posting.amounts post)
+ (posting_amounts post)
}
-- | Return the given 'Balance'
-- updated by the given 'Posting's.
-postings :: (Foldable to, Foldable ti) => to (ti Posting) -> Balance -> Balance
-postings = flip $ Data.Foldable.foldr (flip (Data.Foldable.foldr posting))
-
--- | Return the given 'Balance'
--- updated by the 'Transaction.postings'
--- of the given 'Transaction'.
-transaction :: Transaction -> Balance -> Balance
-transaction = postings . Transaction.postings
-
--- | Return the given 'Balance'
--- updated by the 'Transaction.postings'
--- and 'Transaction.virtual_postings'
--- and 'Transaction.balanced_virtual_postings'
--- of the given 'Transaction'.
-transaction_with_virtual :: Transaction -> Balance -> Balance
-transaction_with_virtual tr =
- postings (Transaction.balanced_virtual_postings tr) .
- postings (Transaction.virtual_postings tr) .
- postings (Transaction.postings tr)
-
--- | Return the given 'Balance'
--- updated by the 'Transaction.balanced_virtual_postings' of the given 'Transaction'.
-transaction_balanced_virtual :: Transaction -> Balance -> Balance
-transaction_balanced_virtual =
- postings . Transaction.balanced_virtual_postings
-
--- | Return the given 'Balance'
--- updated by the 'Journal.transactions'
--- of the given 'Journal',
--- through 'transaction'.
-journal :: Journal -> Balance -> Balance
-journal jour balance =
- Data.Map.foldl
- (Data.List.foldl (flip transaction))
- balance
- (Journal.transactions jour)
-
--- | Return the given 'Balance'
--- updated by the 'Journal.transactions'
--- of the given 'Journal',
--- through 'transaction'.
-journal_with_virtual :: Journal -> Balance -> Balance
-journal_with_virtual jour balance =
- Data.Map.foldl
- (Data.List.foldl (flip transaction_with_virtual))
- balance
- (Journal.transactions jour)
+postings ::
+ ( Posting posting
+ , unit ~ Posting_Unit posting
+ , amount ~ Posting_Amount posting
+ , Foldable foldable )
+ => foldable posting
+ -> Balance amount unit
+ -> Balance amount unit
+postings = flip (Data.Foldable.foldr posting)
-- | Return the first given 'Balance'
-- updated by the second given 'Balance'.
-union :: Balance -> Balance -> Balance
+union
+ :: (Num amount, Ord unit)
+ => Balance amount unit
+ -> Balance amount unit
+ -> Balance amount unit
union b0 b1 =
b0
- { by_account =
+ { balance_by_account =
Lib.TreeMap.union
- (Data.Map.unionWith (GHC.Num.+))
- (by_account b0)
- (by_account b1)
- , by_unit =
+ (Data.Map.unionWith (flip (+)))
+ (balance_by_account b0)
+ (balance_by_account b1)
+ , balance_by_unit =
Data.Map.unionWith
- (\x y -> Unit_Sum
- { amount = (GHC.Num.+) (amount x) (amount y)
- , accounts = Data.Map.union (accounts x) (accounts y)
+ (\new old -> Unit_Sum
+ { unit_sum_amount = (+)
+ (unit_sum_amount old)
+ (unit_sum_amount new)
+ , unit_sum_accounts = Data.Map.unionWith
+ (const::()->()->())
+ (unit_sum_accounts old)
+ (unit_sum_accounts new)
})
- (by_unit b0)
- (by_unit b1)
+ (balance_by_unit b0)
+ (balance_by_unit b1)
}
-- * The 'Deviation' type
--- | The 'By_Unit' whose 'Unit_Sum's’ 'amount'
+-- | The 'Balance_by_Unit' whose 'unit_sum_amount'
-- is not zero and possible 'Account' to 'infer_equilibrium'.
-newtype Deviation
- = Deviation By_Unit
- deriving (Data, Eq, Read, Show, Typeable)
+newtype Deviation amount unit
+ = Deviation (Balance_by_Unit amount unit)
+ deriving (Data, Eq, Show, Typeable)
--- | Return the 'by_unit' of the given 'Balance' with:
+-- | Return the 'balance_by_unit' of the given 'Balance' with:
--
--- * 'Unit's whose 'Unit_Sum' 'amount' verifying 'Amount.is_zero' removed,
+-- * 'unit's whose 'unit_sum_amount' verifying 'amount_is_zero' removed,
--
--- * and remaining 'Unit's having their 'Unit_Sum' 'accounts'
--- complemented with the 'by_account' of the given 'Balance'
--- (i.e. now mapping to accounts __not__ involved to build the 'Unit_Sum').
-deviation :: Balance -> Deviation
-deviation balance = do
- let all_accounts = Lib.TreeMap.flatten (const ()) (by_account balance)
+-- * and remaining 'unit's having their '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 'Unit_Sum').
+deviation
+ :: (Amount amount, Ord unit)
+ => Balance amount unit
+ -> Deviation amount unit
+deviation bal = do
+ let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
let max_accounts = Data.Map.size all_accounts
Deviation $
Data.Map.foldlWithKey
- (\m unit Unit_Sum{amount, accounts} ->
- if Amount.is_zero amount
+ (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
+ if amount_is_zero unit_sum_amount
then m
else
- case Data.Map.size accounts of
+ case Data.Map.size unit_sum_accounts of
n | n == max_accounts ->
- Data.Map.insert unit Unit_Sum{amount, accounts=Data.Map.empty} m
+ Data.Map.insert unit Unit_Sum
+ { unit_sum_amount
+ , unit_sum_accounts = Data.Map.empty
+ } m
_ -> do
- let diff = Data.Map.difference all_accounts accounts
- Data.Map.insert unit Unit_Sum{amount, accounts=diff} m
+ let diff = Data.Map.difference all_accounts unit_sum_accounts
+ Data.Map.insert unit Unit_Sum
+ { unit_sum_amount
+ , unit_sum_accounts = diff
+ } m
)
Data.Map.empty
- (by_unit balance)
+ (balance_by_unit bal)
+
+-- ** The 'Amount' class
+
+-- | An 'amount' used to produce a 'Deviation'
+-- must be an instance of this class.
+class
+ Num a =>
+ Amount a where
+ amount_is_zero :: a -> Bool
+
+-- ** The equilibrium
-- | Return the 'Balance' of the given 'Posting's and either:
--
-- * 'Left': the 'Posting's that cannot be inferred.
--- * 'Right': the given 'Posting's with inferred 'Amount's inserted.
-infer_equilibrium
- :: Posting.By_Account
- -> (Balance, Either [Unit_Sum] Posting.By_Account)
+-- * 'Right': the given 'Posting's with inferred 'amount's inserted.
+infer_equilibrium ::
+ ( Posting posting
+ , Amount amount
+ , Ord unit
+ , amount ~ Posting_Amount posting
+ , unit ~ Posting_Unit posting )
+ => Map Account [posting]
+ -> ( Balance amount unit
+ , Either [Unit_Sum amount] (Map Account [posting])
+ )
infer_equilibrium ps = do
- let bal = postings ps nil
+ let bal = flip (Data.Foldable.foldr postings) ps balance
let Deviation dev = deviation bal
(\(l, r) -> (bal, case l of { [] -> Right r; _ -> Left l })) $ do
Lib.Foldable.accumLeftsAndFoldrRights
(\p -> Data.Map.insertWith
- (\pn -> (++) pn . Data.List.filter (not . Data.Map.null . Posting.amounts))
- (Posting.account p) [p])
+ (\pn -> (++) pn . Data.List.filter (not . Data.Map.null . posting_amounts))
+ (posting_account p) [p])
ps $ do
- Data.Foldable.foldr
- (\unit_sum@(Unit_Sum{ amount=amt, accounts }) acc ->
- case Data.Map.size accounts of
- 1 -> (Right $ (Posting.nil $ fst $ Data.Map.elemAt 0 accounts)
- { Posting.amounts = Amount.from_List [negate amt] }):acc
+ Data.Map.foldrWithKey
+ (\unit unit_sum@(Unit_Sum{ unit_sum_amount=amt, unit_sum_accounts }) acc ->
+ case Data.Map.size unit_sum_accounts of
+ 1 -> (Right $ (posting_make $ fst $ Data.Map.elemAt 0 unit_sum_accounts) (Data.Map.singleton unit (negate amt))):acc
_ -> Left [unit_sum]:acc)
[]
dev
--- ** Tests
-
--- | Return 'True' if and only if the given 'Deviation' maps no 'Unit'.
-is_at_equilibrium :: Deviation -> Bool
+-- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
+is_at_equilibrium :: Deviation amount unit -> Bool
is_at_equilibrium (Deviation dev) = Data.Map.null dev
-- | Return 'True' if and only if the given 'Deviation'
--- maps only to 'Unit_Sum's whose 'accounts'
+-- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
-- maps exactly one 'Account'.
-is_equilibrium_inferrable :: Deviation -> Bool
+is_equilibrium_inferrable :: Deviation amount unit -> Bool
is_equilibrium_inferrable (Deviation dev) =
Data.Foldable.all
- (\Unit_Sum{accounts} -> Data.Map.size accounts == 1)
+ (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
dev
-- | Return 'True' if and only if the given 'Deviation'
--- maps to at least one 'Unit_Sum's whose 'accounts'
+-- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
-- maps more than one 'Account'.
-is_equilibrium_non_inferrable :: Deviation -> Bool
+is_equilibrium_non_inferrable :: Deviation amount unit -> Bool
is_equilibrium_non_inferrable (Deviation dev) =
Data.Foldable.any
- (\Unit_Sum{accounts} -> Data.Map.size accounts > 1)
+ (\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
dev
-- * The 'Expanded' type
--- | Descending propagation of 'Amount's accross 'Account's.
-type Expanded = Lib.TreeMap.TreeMap Account.Name Account_Sum_Expanded
-data Account_Sum_Expanded
+-- | Descending propagation of 'amount's accross 'Account's.
+type Expanded amount unit
+ = TreeMap Account.Name
+ (Account_Sum_Expanded amount unit)
+data Account_Sum_Expanded amount unit
= Account_Sum_Expanded
- { inclusive :: Amount.By_Unit
- , exclusive :: Amount.By_Unit
+ { inclusive :: Map unit amount
+ , exclusive :: Map unit amount
}
- deriving (Data, Eq, Read, Show, Typeable)
+ deriving (Data, Eq, Show, Typeable)
--- | Return the given 'By_Account' with:
+-- | Return the given 'Balance_by_Account' with:
--
-- * all missing 'Account.ascending' 'Account's inserted,
--
--- * and every mapped Amount.'Amount.By_Unit'
--- added with any Amount.'Amount.By_Unit'
+-- * and every mapped 'amount'
+-- added with any 'amount'
-- of the 'Account's’ for which it is 'Account.ascending'.
-expanded :: By_Account -> Expanded
+expanded ::
+ ( Num amount, Ord unit )
+ => Balance_by_Account amount unit
+ -> Expanded amount unit
expanded =
Lib.TreeMap.map_by_depth_first
(\descendants value ->
{ exclusive = exc
, inclusive =
Data.Map.foldr
- ( Data.Map.unionWith (GHC.Num.+)
+ ( Data.Map.unionWith (flip (+))
. ( inclusive
. fromMaybe (error "Oops, should not happen in: Hcompta.Calc.Balance.expanded")
. Lib.TreeMap.node_value) )
sourcephile / git / comptalang.git / blobdiff