lib: more transaction balancing/assertions/assignments cleanup
This commit is contained in:
Simon Michael
parent
8789a442a8
commit
ba850f3871
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
@ -78,18 +79,22 @@ where
|
||||
import Control.Applicative (Const(..))
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.Reader as R
|
||||
import Control.Monad.ST
|
||||
import Data.Array.ST
|
||||
import Data.Function ((&))
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import qualified Data.HashTable.ST.Cuckoo as H
|
||||
import Data.List
|
||||
import Data.List.Extra (groupSort)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Monoid
|
||||
#endif
|
||||
import qualified Data.Semigroup as Sem
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Safe (headMay, headDef)
|
||||
@ -97,8 +102,6 @@ import Data.Time.Calendar
|
||||
import Data.Tree
|
||||
import System.Time (ClockTime(TOD))
|
||||
import Text.Printf
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Hledger.Utils
|
||||
import Hledger.Data.Types
|
||||
@ -567,6 +570,55 @@ journalModifyTransactions j = j{ jtxns = modifyTransactions (jtxnmodifiers j) (j
|
||||
journalCheckBalanceAssertions :: Journal -> Maybe String
|
||||
journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTransactions True
|
||||
|
||||
-- "Transaction balancing" - inferring missing amounts and checking transaction balancedness and balance assertions
|
||||
|
||||
-- | Monad used for statefully balancing/amount-inferring/assertion-checking
|
||||
-- a sequence of transactions.
|
||||
-- Perhaps can be simplified, or would a different ordering of layers make sense ?
|
||||
-- If you see a way, let us know.
|
||||
type Balancing s = ReaderT (BalancingState s) (ExceptT String (ST s))
|
||||
|
||||
-- | The state used while balancing a sequence of transactions.
|
||||
data BalancingState s = BalancingState {
|
||||
-- read only
|
||||
bsStyles :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
|
||||
,bsUnassignable :: S.Set AccountName -- ^ accounts in which balance assignments may not be used
|
||||
,bsAssrt :: Bool -- ^ whether to check balance assertions
|
||||
-- mutable
|
||||
,bsBalances :: H.HashTable s AccountName MixedAmount -- ^ running account balances, initially empty
|
||||
,bsTransactions :: STArray s Integer Transaction -- ^ the transactions being balanced
|
||||
}
|
||||
|
||||
-- | Access the current balancing state, and possibly modify the mutable bits,
|
||||
-- lifting through the Except and Reader layers into the Balancing monad.
|
||||
withB :: (BalancingState s -> ST s a) -> Balancing s a
|
||||
withB f = ask >>= lift . lift . f
|
||||
|
||||
-- | Get an account's running balance so far.
|
||||
getAmountB :: AccountName -> Balancing s MixedAmount
|
||||
getAmountB acc = withB $ \BalancingState{bsBalances} -> do
|
||||
fromMaybe 0 <$> H.lookup bsBalances acc
|
||||
|
||||
-- | Add an amount to an account's running balance, and return the new running balance.
|
||||
addAmountB :: AccountName -> MixedAmount -> Balancing s MixedAmount
|
||||
addAmountB acc amt = withB $ \BalancingState{bsBalances} -> do
|
||||
old <- fromMaybe 0 <$> H.lookup bsBalances acc
|
||||
let new = old + amt
|
||||
H.insert bsBalances acc new
|
||||
return new
|
||||
|
||||
-- | Set an account's running balance to this amount, and return the difference from the old.
|
||||
setAmountB :: AccountName -> MixedAmount -> Balancing s MixedAmount
|
||||
setAmountB acc amt = withB $ \BalancingState{bsBalances} -> do
|
||||
old <- fromMaybe 0 <$> H.lookup bsBalances acc
|
||||
H.insert bsBalances acc amt
|
||||
return $ amt - old
|
||||
|
||||
-- | Update (overwrite) this transaction with a new one.
|
||||
storeTransactionB :: Transaction -> Balancing s ()
|
||||
storeTransactionB t = withB $ \BalancingState{bsTransactions} ->
|
||||
void $ writeArray bsTransactions (tindex t) t
|
||||
|
||||
-- | Infer any missing amounts (to satisfy balance assignments and
|
||||
-- to balance transactions) and check that all transactions balance
|
||||
-- and (optional) all balance assertions pass. Or return an error message
|
||||
@ -577,171 +629,137 @@ journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTran
|
||||
-- This does multiple things because amount inferring, balance assignments,
|
||||
-- balance assertions and posting dates are interdependent.
|
||||
--
|
||||
-- Overview, 20190216:
|
||||
-- This can be simplified further. Overview as of 20190219:
|
||||
-- @
|
||||
-- ****** parseAndFinaliseJournal['] [[Cli/Utils.hs]], journalAddForecast [[Common.hs]], budgetJournal [[BudgetReport.hs]], tests [[BalanceReport.hs]]
|
||||
-- ****** parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), budgetJournal (BudgetReport.hs), tests (BalanceReport.hs)
|
||||
-- ******* journalBalanceTransactions
|
||||
-- ******** runST
|
||||
-- ********* runExceptT
|
||||
-- ********** balanceTransaction (Transaction.hs)
|
||||
-- *********** balanceTransactionHelper
|
||||
-- ********** runReaderT
|
||||
-- *********** balanceNoAssignmentTransactionB
|
||||
-- ************ balanceTransactionB [[Transaction.hs]]
|
||||
-- ************* balanceTransactionHelper
|
||||
-- ************** inferBalancingAmount
|
||||
-- *********** balanceAssignmentTransactionAndOrCheckAssertionsB
|
||||
-- ************ addAmountAndCheckBalanceAssertionB
|
||||
-- ************* addToBalanceB
|
||||
-- ************ inferFromAssignmentB
|
||||
-- ************ balanceTransactionB [[Transaction.hs]]
|
||||
-- ************* balanceTransactionHelper
|
||||
-- ************ addToBalanceB
|
||||
-- ****** uiCheckBalanceAssertions d ui@UIState{aopts=UIOpts{cliopts_=copts}, ajournal=j} [[ErrorScreen.hs]]
|
||||
-- *********** balanceTransactionAndCheckAssertionsB
|
||||
-- ************ addAmountAndCheckAssertionB
|
||||
-- ************ addOrAssignAmountAndCheckAssertionB
|
||||
-- ************ balanceTransactionHelper (Transaction.hs)
|
||||
-- ****** uiCheckBalanceAssertions d ui@UIState{aopts=UIOpts{cliopts_=copts}, ajournal=j} (ErrorScreen.hs)
|
||||
-- ******* journalCheckBalanceAssertions
|
||||
-- ******** journalBalanceTransactions
|
||||
-- ****** transactionWizard, postingsBalanced [[Add.hs]], tests [[Transaction.hs]]
|
||||
-- ******* balanceTransaction
|
||||
-- ****** transactionWizard, postingsBalanced (Add.hs), tests (Transaction.hs)
|
||||
-- ******* balanceTransaction (Transaction.hs) XXX hledger add won't allow balance assignments + missing amount ?
|
||||
-- @
|
||||
journalBalanceTransactions :: Bool -> Journal -> Either String Journal
|
||||
journalBalanceTransactions assrt j' =
|
||||
let
|
||||
-- ensure transactions are numbered, so we can store them by number
|
||||
j@Journal{jtxns=ts} = journalNumberTransactions j'
|
||||
styles = journalCommodityStyles j
|
||||
-- display precisions used in balanced checking
|
||||
styles = Just $ journalCommodityStyles j
|
||||
-- balance assignments will not be allowed on these
|
||||
txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j
|
||||
in
|
||||
runST $ do
|
||||
bals <- H.newSized (length $ journalAccountNamesUsed j)
|
||||
txns <- newListArray (1, genericLength ts) ts
|
||||
runExceptT $ do
|
||||
flip runReaderT (BalancingState styles txnmodifieraccts assrt bals txns) $ do
|
||||
-- Fill in missing posting amounts, check transactions are balanced,
|
||||
-- We'll update a mutable array of transactions as we balance them,
|
||||
-- not strictly necessary but avoids a sort at the end I think.
|
||||
balancedtxns <- newListArray (1, genericLength ts) ts
|
||||
|
||||
-- Infer missing posting amounts, check transactions are balanced,
|
||||
-- and check balance assertions. This is done in two passes:
|
||||
-- 1. Balance the transactions which don't have balance assignments,
|
||||
-- and collect their postings, plus the still-unbalanced transactions, in date order.
|
||||
sortedpsandts <- sortOn (either postingDate tdate) . concat <$>
|
||||
mapM' balanceNoAssignmentTransactionB (jtxns j)
|
||||
-- 2. Step through these, keeping running account balances,
|
||||
-- performing balance assignments in and balancing the remaining transactions,
|
||||
-- and checking balance assertions. This last could be a separate pass
|
||||
-- but perhaps it's more efficient to do all at once.
|
||||
void $ mapM' balanceAssignmentTransactionAndOrCheckAssertionsB sortedpsandts
|
||||
ts' <- lift $ getElems txns
|
||||
runExceptT $ do
|
||||
|
||||
-- 1. Balance the transactions which don't have balance assignments.
|
||||
let (noassignmenttxns, withassignmenttxns) = partition (null . assignmentPostings) ts
|
||||
noassignmenttxns' <- forM noassignmenttxns $ \t ->
|
||||
either throwError (\t -> lift (writeArray balancedtxns (tindex t) t) >> return t) $
|
||||
balanceTransaction styles t
|
||||
|
||||
-- 2. Step through the postings of those transactions, and the remaining transactions, in date order,
|
||||
let sortedpsandts :: [Either Posting Transaction] =
|
||||
sortOn (either postingDate tdate) $
|
||||
map Left (concatMap tpostings noassignmenttxns') ++
|
||||
map Right withassignmenttxns
|
||||
-- keeping running account balances,
|
||||
runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j)
|
||||
flip runReaderT (BalancingState styles txnmodifieraccts assrt runningbals balancedtxns) $ do
|
||||
-- performing balance assignments in, and balancing, the remaining transactions,
|
||||
-- and checking balance assertions as each posting is processed.
|
||||
void $ mapM' balanceTransactionAndCheckAssertionsB sortedpsandts
|
||||
|
||||
ts' <- lift $ getElems balancedtxns
|
||||
return j{jtxns=ts'}
|
||||
|
||||
-- | If this transaction has no balance assignments, balance and store it
|
||||
-- and return its postings. If it can't be balanced, an error will be thrown.
|
||||
--
|
||||
-- It it has balance assignments, return it unchanged. If any posting has both
|
||||
-- a balance assignment and a custom date, an error will be thrown.
|
||||
--
|
||||
balanceNoAssignmentTransactionB :: Transaction -> Balancing s [Either Posting Transaction]
|
||||
balanceNoAssignmentTransactionB t
|
||||
| null (assignmentPostings t) = do
|
||||
styles <- R.reader bsStyles
|
||||
t' <- lift $ ExceptT $ return $ balanceTransaction (Just styles) t
|
||||
storeTransactionB t'
|
||||
return [Left $ removePrices p | p <- tpostings t']
|
||||
|
||||
| otherwise = do
|
||||
when (any (isJust . pdate) $ tpostings t) $ -- XXX check more carefully that date and assignment are on same posting ?
|
||||
throwError $
|
||||
unlines $
|
||||
[ "postings may not have both a custom date and a balance assignment."
|
||||
, "Write the posting amount explicitly, or remove the posting date:\n"
|
||||
, showTransaction t
|
||||
]
|
||||
return [Right $ t {tpostings = removePrices <$> tpostings t}]
|
||||
|
||||
-- | This function is called in turn on each item in a date-ordered sequence
|
||||
-- of postings (from already-balanced transactions) or transactions
|
||||
-- (not yet balanced, because containing balance assignments).
|
||||
-- It applies balance assignments and balances the unbalanced transactions,
|
||||
-- and checks any balance assertion(s).
|
||||
--
|
||||
-- For a posting: update the account's running balance, and
|
||||
-- check the balance assertion if any.
|
||||
--
|
||||
-- For a transaction: for each posting,
|
||||
--
|
||||
-- - if it has a missing amount and a balance assignment, infer the amount
|
||||
--
|
||||
-- - update the account's running balance
|
||||
--
|
||||
-- - check the balance assertion if any
|
||||
--
|
||||
-- Then balance the transaction, so that any remaining missing amount is inferred.
|
||||
-- And if that happened, also update *that* account's running balance. XXX and check the assertion ?
|
||||
-- And store the transaction.
|
||||
--
|
||||
-- Will throw an error if a transaction can't be balanced,
|
||||
-- | This function is called statefully on each of a date-ordered sequence of
|
||||
-- 1. fully explicit postings from already-balanced transactions and
|
||||
-- 2. not-yet-balanced transactions containing balance assignments.
|
||||
-- It executes balance assignments and finishes balancing the transactions,
|
||||
-- and checks balance assertions on each posting as it goes.
|
||||
-- An error will be thrown if a transaction can't be balanced
|
||||
-- or if an illegal balance assignment is found (cf checkIllegalBalanceAssignment).
|
||||
--
|
||||
balanceAssignmentTransactionAndOrCheckAssertionsB :: Either Posting Transaction -> Balancing s ()
|
||||
balanceAssignmentTransactionAndOrCheckAssertionsB (Left p) = do
|
||||
checkIllegalBalanceAssignmentB p
|
||||
void $ addAmountAndCheckBalanceAssertionB return p
|
||||
balanceAssignmentTransactionAndOrCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do
|
||||
-- Transaction prices are removed, which helps eg balance-assertions.test: 15. Mix different commodities and assignments.
|
||||
-- This stores the balanced transactions in case 2 but not in case 1.
|
||||
balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s ()
|
||||
|
||||
balanceTransactionAndCheckAssertionsB (Left p@Posting{}) =
|
||||
-- update the account's running balance and check the balance assertion if any
|
||||
void $ addAmountAndCheckAssertionB $ removePrices p
|
||||
|
||||
balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do
|
||||
-- make sure we can handle the balance assignments
|
||||
mapM_ checkIllegalBalanceAssignmentB ps
|
||||
ps' <- forM ps $ addAmountAndCheckBalanceAssertionB inferFromAssignmentB
|
||||
-- for each posting, infer its amount from the balance assignment if applicable,
|
||||
-- update the account's running balance and check the balance assertion if any
|
||||
ps' <- forM ps $ \p -> pure (removePrices p) >>= addOrAssignAmountAndCheckAssertionB
|
||||
-- infer any remaining missing amounts, and make sure the transaction is now fully balanced
|
||||
styles <- R.reader bsStyles
|
||||
storeTransactionB =<<
|
||||
balanceTransactionB (fmap void . addToBalanceB) (Just styles) t{tpostings=ps'}
|
||||
case balanceTransactionHelper styles t{tpostings=ps'} of
|
||||
Left err -> throwError err
|
||||
Right (t', inferredacctsandamts) -> do
|
||||
-- for each amount just inferred, update the running balance
|
||||
mapM_ (uncurry addAmountB) inferredacctsandamts
|
||||
-- and save the balanced transaction.
|
||||
storeTransactionB t'
|
||||
|
||||
-- | Throw an error if this posting is trying to do a balance assignment and
|
||||
-- the account does not allow balance assignments (because it is referenced
|
||||
-- by a transaction modifier).
|
||||
checkIllegalBalanceAssignmentB :: Posting -> Balancing s ()
|
||||
checkIllegalBalanceAssignmentB p = do
|
||||
unassignable <- R.asks bsUnassignable
|
||||
when (isAssignment p && paccount p `S.member` unassignable) $
|
||||
throwError $
|
||||
unlines $
|
||||
[ "cannot assign amount to account "
|
||||
, ""
|
||||
, " " ++ T.unpack (paccount p)
|
||||
, ""
|
||||
, "because it is also included in transaction modifiers."
|
||||
]
|
||||
|
||||
-- | If this posting has a missing amount and a balance assignment, use
|
||||
-- the running account balance to infer the amount required to satisfy
|
||||
-- the assignment.
|
||||
inferFromAssignmentB :: Posting -> Balancing s Posting
|
||||
inferFromAssignmentB p@Posting{paccount=acc} =
|
||||
case pbalanceassertion p of
|
||||
Nothing -> return p
|
||||
Just ba | batotal ba -> do
|
||||
diff <- setAccountRunningBalance acc $ Mixed [baamount ba]
|
||||
return $ setPostingAmount diff p
|
||||
Just ba -> do
|
||||
oldbal <- fromMaybe 0 <$> liftB (\bs -> H.lookup (bsBalances bs) acc)
|
||||
let amt = baamount ba
|
||||
newbal = filterMixedAmount ((/=acommodity amt).acommodity) oldbal + Mixed [amt]
|
||||
diff <- setAccountRunningBalance acc newbal
|
||||
return $ setPostingAmount diff p
|
||||
where
|
||||
setPostingAmount a p = p{pamount=a, porigin=Just $ originalPosting p}
|
||||
-- | Set the account's running balance, and return the difference from the old.
|
||||
setAccountRunningBalance :: AccountName -> MixedAmount -> Balancing s MixedAmount
|
||||
setAccountRunningBalance acc amt = liftB $ \BalancingState{bsBalances=bals} -> do
|
||||
old <- fromMaybe 0 <$> H.lookup bals acc
|
||||
H.insert bals acc amt
|
||||
return $ amt - old
|
||||
|
||||
-- | Adds a posting's amount to the posting's account's running balance, and
|
||||
-- checks the posting's balance assertion if any. Or if the posting has no
|
||||
-- amount, runs the supplied fallback action.
|
||||
addAmountAndCheckBalanceAssertionB ::
|
||||
(Posting -> Balancing s Posting) -- ^ fallback action XXX why ?
|
||||
-> Posting
|
||||
-> Balancing s Posting
|
||||
addAmountAndCheckBalanceAssertionB _ p | hasAmount p = do
|
||||
newAmt <- addToBalanceB (paccount p) (pamount p)
|
||||
assrt <- R.reader bsAssrt
|
||||
when assrt $ checkBalanceAssertionB p newAmt
|
||||
-- | If this posting has an explicit amount, add it to the account's running balance.
|
||||
-- If it has a missing amount and a balance assignment, infer the amount from, and
|
||||
-- reset the running balance to, the assigned balance.
|
||||
-- If it has a missing amount and no balance assignment, leave it for later.
|
||||
-- Then test the balance assertion if any.
|
||||
addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting
|
||||
addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba}
|
||||
| hasAmount p = do
|
||||
newbal <- addAmountB acc amt
|
||||
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
|
||||
return p
|
||||
addAmountAndCheckBalanceAssertionB fallback p = fallback p
|
||||
| Nothing <- mba = return p
|
||||
| Just BalanceAssertion{baamount,batotal} <- mba = do
|
||||
(diff,newbal) <- case batotal of
|
||||
True -> do
|
||||
-- a total balance assignment
|
||||
let newbal = Mixed [baamount]
|
||||
diff <- setAmountB acc newbal
|
||||
return (diff,newbal)
|
||||
False -> do
|
||||
-- a partial balance assignment
|
||||
oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getAmountB acc
|
||||
let assignedbalthiscommodity = Mixed [baamount]
|
||||
newbal = oldbalothercommodities + assignedbalthiscommodity
|
||||
diff <- setAmountB acc newbal
|
||||
return (diff,newbal)
|
||||
let p' = p{pamount=diff, porigin=Just $ originalPosting p}
|
||||
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal
|
||||
return p'
|
||||
|
||||
-- | Add the posting's amount to its account's running balance, and
|
||||
-- optionally check the posting's balance assertion if any.
|
||||
-- The posting is expected to have an explicit amount (otherwise this does nothing).
|
||||
-- Adding and checking balance assertions are tightly paired because we
|
||||
-- need to see the balance as it stands after each individual posting.
|
||||
addAmountAndCheckAssertionB :: Posting -> Balancing s Posting
|
||||
addAmountAndCheckAssertionB p | hasAmount p = do
|
||||
newbal <- addAmountB (paccount p) (pamount p)
|
||||
whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
|
||||
return p
|
||||
addAmountAndCheckAssertionB p = return p
|
||||
|
||||
-- | Check a posting's balance assertion against the given actual balance, and
|
||||
-- return an error if the assertion is not satisfied.
|
||||
@ -766,22 +784,21 @@ checkBalanceAssertionB _ _ = return ()
|
||||
-- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance.
|
||||
checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s ()
|
||||
checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do
|
||||
-- sum the running balances of this account and any subaccounts seen so far
|
||||
bals <- R.asks bsBalances
|
||||
actualibal <- liftB $ const $ H.foldM
|
||||
(\bal (acc, amt) -> return $
|
||||
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc
|
||||
then bal + amt
|
||||
else bal)
|
||||
let isinclusive = maybe False bainclusive $ pbalanceassertion p
|
||||
actualbal' <-
|
||||
if isinclusive
|
||||
then
|
||||
-- sum the running balances of this account and any of its subaccounts seen so far
|
||||
withB $ \BalancingState{bsBalances} ->
|
||||
H.foldM
|
||||
(\ibal (acc, amt) -> return $ ibal +
|
||||
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then amt else 0)
|
||||
0
|
||||
bals
|
||||
bsBalances
|
||||
else return actualbal
|
||||
let
|
||||
isinclusive = maybe False bainclusive $ pbalanceassertion p
|
||||
actualbal'
|
||||
| isinclusive = actualibal
|
||||
| otherwise = actualbal
|
||||
assertedcomm = acommodity assertedamt
|
||||
actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm actualbal'
|
||||
actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm $ actualbal'
|
||||
pass =
|
||||
aquantity
|
||||
-- traceWith (("asserted:"++).showAmountDebug)
|
||||
@ -823,6 +840,47 @@ checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt
|
||||
|
||||
when (not pass) $ throwError errmsg
|
||||
|
||||
-- | Throw an error if this posting is trying to do an illegal balance assignment.
|
||||
checkIllegalBalanceAssignmentB :: Posting -> Balancing s ()
|
||||
checkIllegalBalanceAssignmentB p = do
|
||||
checkBalanceAssignmentPostingDateB p
|
||||
checkBalanceAssignmentUnassignableAccountB p
|
||||
|
||||
-- XXX these should show position. annotateErrorWithTransaction t ?
|
||||
|
||||
-- | Throw an error if this posting is trying to do a balance assignment and
|
||||
-- has a custom posting date (which makes amount inference too hard/impossible).
|
||||
checkBalanceAssignmentPostingDateB :: Posting -> Balancing s ()
|
||||
checkBalanceAssignmentPostingDateB p =
|
||||
when (hasBalanceAssignment p && isJust (pdate p)) $
|
||||
throwError $ unlines $
|
||||
["postings which are balance assignments may not have a custom date."
|
||||
,"Please write the posting amount explicitly, or remove the posting date:"
|
||||
,""
|
||||
,maybe (unlines $ showPostingLines p) showTransaction $ ptransaction p
|
||||
]
|
||||
|
||||
-- | Throw an error if this posting is trying to do a balance assignment and
|
||||
-- the account does not allow balance assignments (eg because it is referenced
|
||||
-- by a transaction modifier, which might generate additional postings to it).
|
||||
checkBalanceAssignmentUnassignableAccountB :: Posting -> Balancing s ()
|
||||
checkBalanceAssignmentUnassignableAccountB p = do
|
||||
unassignable <- R.asks bsUnassignable
|
||||
when (hasBalanceAssignment p && paccount p `S.member` unassignable) $
|
||||
throwError $ unlines $
|
||||
["balance assignments cannot be used with accounts which are"
|
||||
,"posted to by transaction modifier rules (auto postings)."
|
||||
,"Please write the posting amount explicitly, or remove the rule."
|
||||
,""
|
||||
,"account: "++T.unpack (paccount p)
|
||||
,""
|
||||
,"transaction:"
|
||||
,""
|
||||
,maybe (unlines $ showPostingLines p) showTransaction $ ptransaction p
|
||||
]
|
||||
|
||||
--
|
||||
|
||||
-- | Choose and apply a consistent display format to the posting
|
||||
-- amounts in each commodity. Each commodity's format is specified by
|
||||
-- a commodity format directive, or otherwise inferred from posting
|
||||
@ -1190,4 +1248,24 @@ tests_Journal = tests "Journal" [
|
||||
,test "expenses" $ expectEq (namesfrom journalExpenseAccountQuery) ["expenses","expenses:food","expenses:supplies"]
|
||||
]
|
||||
|
||||
,test "journalBalanceTransactions" $ do
|
||||
let ej = journalBalanceTransactions True $
|
||||
nulljournal{ jtxns = [
|
||||
txnTieKnot $ nulltransaction{
|
||||
tdate=parsedate "2019/01/01",
|
||||
tpostings=[
|
||||
nullposting{
|
||||
ptype=VirtualPosting
|
||||
,paccount="a"
|
||||
,pamount=missingmixedamt
|
||||
,pbalanceassertion=Just nullassertion{baamount=num 1}
|
||||
}
|
||||
],
|
||||
tprecedingcomment=""
|
||||
}
|
||||
]
|
||||
}
|
||||
expectRight ej
|
||||
let Right j = ej
|
||||
(jtxns j & head & tpostings & head & pamount) `is` Mixed [num 1]
|
||||
]
|
||||
|
||||
@ -25,7 +25,7 @@ module Hledger.Data.Posting (
|
||||
isVirtual,
|
||||
isBalancedVirtual,
|
||||
isEmptyPosting,
|
||||
isAssignment,
|
||||
hasBalanceAssignment,
|
||||
hasAmount,
|
||||
postingAllTags,
|
||||
transactionAllTags,
|
||||
@ -144,8 +144,8 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting
|
||||
hasAmount :: Posting -> Bool
|
||||
hasAmount = (/= missingmixedamt) . pamount
|
||||
|
||||
isAssignment :: Posting -> Bool
|
||||
isAssignment p = not (hasAmount p) && isJust (pbalanceassertion p)
|
||||
hasBalanceAssignment :: Posting -> Bool
|
||||
hasBalanceAssignment p = not (hasAmount p) && isJust (pbalanceassertion p)
|
||||
|
||||
-- | Sorted unique account names referenced by these postings.
|
||||
accountNamesFromPostings :: [Posting] -> [AccountName]
|
||||
|
||||
@ -28,12 +28,7 @@ module Hledger.Data.Transaction (
|
||||
transactionsPostings,
|
||||
isTransactionBalanced,
|
||||
balanceTransaction,
|
||||
Balancing,
|
||||
BalancingState(..),
|
||||
addToBalanceB,
|
||||
storeTransactionB,
|
||||
liftB,
|
||||
balanceTransactionB,
|
||||
balanceTransactionHelper,
|
||||
-- nonzerobalanceerror,
|
||||
-- * date operations
|
||||
transactionDate2,
|
||||
@ -49,18 +44,12 @@ module Hledger.Data.Transaction (
|
||||
sourceFilePath,
|
||||
sourceFirstLine,
|
||||
showGenericSourcePos,
|
||||
annotateErrorWithTransaction,
|
||||
-- * tests
|
||||
tests_Transaction
|
||||
)
|
||||
where
|
||||
import Data.List
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader (ReaderT, ask)
|
||||
import Control.Monad.ST
|
||||
import Data.Array.ST
|
||||
import qualified Data.HashTable.ST.Cuckoo as HT
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@ -308,7 +297,7 @@ realPostings :: Transaction -> [Posting]
|
||||
realPostings = filter isReal . tpostings
|
||||
|
||||
assignmentPostings :: Transaction -> [Posting]
|
||||
assignmentPostings = filter isAssignment . tpostings
|
||||
assignmentPostings = filter hasBalanceAssignment . tpostings
|
||||
|
||||
virtualPostings :: Transaction -> [Posting]
|
||||
virtualPostings = filter isVirtual . tpostings
|
||||
@ -341,69 +330,28 @@ isTransactionBalanced styles t =
|
||||
bvsum' = canonicalise $ costOfMixedAmount bvsum
|
||||
canonicalise = maybe id canonicaliseMixedAmount styles
|
||||
|
||||
-- | Monad used for statefully "balancing" a sequence of transactions.
|
||||
type Balancing s = ReaderT (BalancingState s) (ExceptT String (ST s))
|
||||
|
||||
-- | The state used while balancing a sequence of transactions.
|
||||
data BalancingState s = BalancingState {
|
||||
-- read only
|
||||
bsStyles :: M.Map CommoditySymbol AmountStyle -- ^ commodity display styles
|
||||
,bsUnassignable :: S.Set AccountName -- ^ accounts in which balance assignments may not be used
|
||||
,bsAssrt :: Bool -- ^ whether to check balance assertions
|
||||
-- mutable
|
||||
,bsBalances :: HT.HashTable s AccountName MixedAmount -- ^ running account balances, initially empty
|
||||
,bsTransactions :: STArray s Integer Transaction -- ^ the transactions being balanced
|
||||
}
|
||||
|
||||
-- | Lift a BalancingState mutator through the Except and Reader
|
||||
-- layers into the Balancing monad.
|
||||
liftB :: (BalancingState s -> ST s a) -> Balancing s a
|
||||
liftB f = ask >>= lift . lift . f
|
||||
|
||||
-- | Add this amount to this account's running balance,
|
||||
-- and return the new running balance.
|
||||
addToBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount
|
||||
addToBalanceB acc amt = liftB $ \BalancingState{bsBalances=bals} -> do
|
||||
b <- maybe amt (+amt) <$> HT.lookup bals acc
|
||||
HT.insert bals acc b
|
||||
return b
|
||||
|
||||
-- | Update (overwrite) this transaction with a new one.
|
||||
storeTransactionB :: Transaction -> Balancing s ()
|
||||
storeTransactionB t = liftB $ \bs ->
|
||||
void $ writeArray (bsTransactions bs) (tindex t) t
|
||||
|
||||
|
||||
-- | Balance this transaction, ensuring that its postings sum to 0,
|
||||
-- | Balance this transaction, ensuring that its postings
|
||||
-- (and its balanced virtual postings) sum to 0,
|
||||
-- by inferring a missing amount or conversion price(s) if needed.
|
||||
-- Or if balancing is not possible, because of unbalanced amounts or
|
||||
-- more than one missing amount, returns an error message.
|
||||
-- Note this function may be unable to balance some transactions
|
||||
-- that journalBalanceTransactions/balanceTransactionB can balance
|
||||
-- (eg ones with balance assignments).
|
||||
-- Whether postings "sum to 0" depends on commodity display precisions,
|
||||
-- so those can optionally be provided.
|
||||
-- Or if balancing is not possible, because the amounts don't sum to 0 or
|
||||
-- because there's more than one missing amount, return an error message.
|
||||
--
|
||||
-- Transactions with balance assignments can have more than one
|
||||
-- missing amount; to balance those you should use the more powerful
|
||||
-- journalBalanceTransactions.
|
||||
--
|
||||
-- The "sum to 0" test is done using commodity display precisions,
|
||||
-- if provided, so that the result agrees with the numbers users can see.
|
||||
--
|
||||
balanceTransaction ::
|
||||
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
|
||||
-> Transaction
|
||||
-> Either String Transaction
|
||||
balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles
|
||||
|
||||
-- | Like balanceTransaction, but when inferring amounts it will also
|
||||
-- use the given state update function to update running account balances.
|
||||
-- Used when balancing a sequence of transactions (see journalBalanceTransactions).
|
||||
balanceTransactionB ::
|
||||
(AccountName -> MixedAmount -> Balancing s ()) -- ^ function to update running balances
|
||||
-> Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
|
||||
-> Transaction
|
||||
-> Balancing s Transaction
|
||||
balanceTransactionB updatebalsfn mstyles t = do
|
||||
case balanceTransactionHelper mstyles t of
|
||||
Left err -> throwError err
|
||||
Right (t', inferredacctsandamts) -> do
|
||||
mapM_ (uncurry updatebalsfn) inferredacctsandamts
|
||||
return t'
|
||||
|
||||
-- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB;
|
||||
-- use one of those instead. It also returns a list of accounts
|
||||
-- and amounts that were inferred.
|
||||
balanceTransactionHelper ::
|
||||
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
|
||||
-> Transaction
|
||||
@ -413,7 +361,7 @@ balanceTransactionHelper mstyles t = do
|
||||
inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t
|
||||
if isTransactionBalanced mstyles t'
|
||||
then Right (txnTieKnot t', inferredamtsandaccts)
|
||||
else Left $ annotateErrorWithTxn t' $ nonzerobalanceerror t'
|
||||
else Left $ annotateErrorWithTransaction t' $ nonzerobalanceerror t'
|
||||
|
||||
where
|
||||
nonzerobalanceerror :: Transaction -> String
|
||||
@ -428,8 +376,8 @@ balanceTransactionHelper mstyles t = do
|
||||
++ showMixedAmount (costOfMixedAmount bvsum)
|
||||
sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String
|
||||
|
||||
annotateErrorWithTxn :: Transaction -> String -> String
|
||||
annotateErrorWithTxn t s = intercalate "\n" [showGenericSourcePos $ tsourcepos t, s, showTransactionUnelided t]
|
||||
annotateErrorWithTransaction :: Transaction -> String -> String
|
||||
annotateErrorWithTransaction t s = intercalate "\n" [showGenericSourcePos $ tsourcepos t, s, showTransactionUnelided t]
|
||||
|
||||
-- | Infer up to one missing amount for this transactions's real postings, and
|
||||
-- likewise for its balanced virtual postings, if needed; or return an error
|
||||
@ -445,9 +393,9 @@ inferBalancingAmount ::
|
||||
-> Either String (Transaction, [(AccountName, MixedAmount)])
|
||||
inferBalancingAmount styles t@Transaction{tpostings=ps}
|
||||
| length amountlessrealps > 1
|
||||
= Left $ annotateErrorWithTxn t "could not balance this transaction - can't have more than one real posting with no amount (remember to put 2 or more spaces before amounts)"
|
||||
= Left $ annotateErrorWithTransaction t "could not balance this transaction - can't have more than one real posting with no amount (remember to put 2 or more spaces before amounts)"
|
||||
| length amountlessbvps > 1
|
||||
= Left $ annotateErrorWithTxn t "could not balance this transaction - can't have more than one balanced virtual posting with no amount (remember to put 2 or more spaces before amounts)"
|
||||
= Left $ annotateErrorWithTransaction t "could not balance this transaction - can't have more than one balanced virtual posting with no amount (remember to put 2 or more spaces before amounts)"
|
||||
| otherwise
|
||||
= let psandinferredamts = map inferamount ps
|
||||
inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts]
|
||||
|
||||
@ -162,7 +162,7 @@ $ hledger -f- print --auto -x
|
||||
|
||||
# 9.
|
||||
$ hledger print -f- --auto
|
||||
>2 /cannot assign amount to account/
|
||||
>2 /cannot be used with accounts which are/
|
||||
>=1
|
||||
|
||||
|
||||
|
||||
@ -231,27 +231,10 @@ hledger -f - stats
|
||||
a $1 =$1
|
||||
b =$-1 ; date:2012/1/1
|
||||
|
||||
>>>2 /postings may not have both a custom date and a balance assignment/
|
||||
>>>2 /balance assignments may not have a custom date/
|
||||
>>>=1
|
||||
|
||||
# 13. Having both assignments and posting dates is not supported.
|
||||
hledger -f - stats
|
||||
<<<
|
||||
|
||||
2013/1/1
|
||||
a 1 = -2
|
||||
b
|
||||
c = 5
|
||||
|
||||
2014/1/1
|
||||
a -3 = -3 ; date:2012/1/1
|
||||
d = 3
|
||||
|
||||
|
||||
>>>2 /postings may not have both a custom date and a balance assignment/
|
||||
>>>=1
|
||||
|
||||
# 14. Posting Date
|
||||
# 13. Posting Date
|
||||
hledger -f - stats
|
||||
<<<
|
||||
|
||||
@ -276,7 +259,7 @@ hledger -f - stats
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 15. Mix different commodities
|
||||
# 14. Mix different commodities
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2016/1/1
|
||||
@ -290,7 +273,7 @@ hledger -f - stats
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 16. Mix different commodities and assignments
|
||||
# 15. Mix different commodities and assignments
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2016/1/1
|
||||
@ -311,7 +294,7 @@ hledger -f - stats
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 17. Total assertions (==) parse correctly
|
||||
# 16. Total assertions (==) parse correctly
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2016/1/1
|
||||
@ -324,7 +307,7 @@ hledger -f - stats
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 18. Total assertions consider entire multicommodity amount
|
||||
# 17. Total assertions consider entire multicommodity amount
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2016/1/1
|
||||
@ -340,7 +323,7 @@ hledger -f - stats
|
||||
>>>2 /balance assertion.*line 10, column 15/
|
||||
>>>=1
|
||||
|
||||
# 19. Mix different commodities and total assignments
|
||||
# 18. Mix different commodities and total assignments
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2016/1/1
|
||||
@ -359,7 +342,7 @@ hledger -f - stats
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 20. Balance assertions may have a price, but it's ignored
|
||||
# 19. Balance assertions may have a price, but it's ignored
|
||||
hledger -f- print
|
||||
<<<
|
||||
2019/01/01
|
||||
@ -370,7 +353,7 @@ hledger -f- print
|
||||
|
||||
>>>=0
|
||||
|
||||
# 21. Balance assignments may have a price, and it's used for the posting amount.
|
||||
# 20. Balance assignments may have a price, and it's used for the posting amount.
|
||||
# But not shown as part of the balance assertion in the resulting posting.
|
||||
hledger -f- print --explicit
|
||||
<<<
|
||||
@ -382,7 +365,7 @@ hledger -f- print --explicit
|
||||
|
||||
>>>=0
|
||||
|
||||
# 22. close generates balance assertions without prices
|
||||
# 21. close generates balance assertions without prices
|
||||
hledger -f- close -e 2019/1/2
|
||||
<<<
|
||||
2019/01/01
|
||||
@ -398,7 +381,7 @@ hledger -f- close -e 2019/1/2
|
||||
|
||||
>>>=0
|
||||
|
||||
# 23. The exact amounts are compared; display precision does not affect assertions.
|
||||
# 22. The exact amounts are compared; display precision does not affect assertions.
|
||||
hledger -f- print
|
||||
<<<
|
||||
commodity $1000.00
|
||||
@ -413,7 +396,7 @@ commodity $1000.00
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 24. This fails
|
||||
# 23. This fails
|
||||
hledger -f- print
|
||||
<<<
|
||||
commodity $1000.00
|
||||
@ -427,7 +410,7 @@ commodity $1000.00
|
||||
>>>2 /difference: 0\.004/
|
||||
>>>=1
|
||||
|
||||
# 25. This fails
|
||||
# 24. This fails
|
||||
hledger -f- print
|
||||
<<<
|
||||
commodity $1000.00
|
||||
@ -441,7 +424,7 @@ commodity $1000.00
|
||||
>>>2 /difference: 0\.0001/
|
||||
>>>=1
|
||||
|
||||
# 26. Inclusive assertions include balances from subaccounts.
|
||||
# 25. Inclusive assertions include balances from subaccounts.
|
||||
hledger -f- print
|
||||
<<<
|
||||
2019/1/1
|
||||
|
||||
Loading…
Reference in New Issue
Block a user