slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib: more transaction balancing/assertions/assignments cleanup

Browse Source
This commit is contained in:
Simon Michael 2019-02-18 12:11:07 -08:00
parent 8789a442a8
commit ba850f3871
5 changed files with 273 additions and 264 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

388
hledger-lib/Hledger/Data/Journal.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
@ -78,18 +79,22 @@ where
import Control.Applicative (Const(..)) import Control.Applicative (Const(..))
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Extra
import Control.Monad.Reader as R import Control.Monad.Reader as R
import Control.Monad.ST import Control.Monad.ST
import Data.Array.ST import Data.Array.ST
import Data.Function ((&))
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
import qualified Data.HashTable.ST.Cuckoo as H import qualified Data.HashTable.ST.Cuckoo as H
import Data.List import Data.List
import Data.List.Extra (groupSort) import Data.List.Extra (groupSort)
import qualified Data.Map as M
import Data.Maybe import Data.Maybe
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Monoid import Data.Monoid
#endif #endif
import qualified Data.Semigroup as Sem import qualified Data.Semigroup as Sem
import qualified Data.Set as S
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Safe (headMay, headDef) import Safe (headMay, headDef)
@ -97,8 +102,6 @@ import Data.Time.Calendar
import Data.Tree import Data.Tree
import System.Time (ClockTime(TOD)) import System.Time (ClockTime(TOD))
import Text.Printf import Text.Printf
import qualified Data.Map as M
import qualified Data.Set as S
import Hledger.Utils import Hledger.Utils
import Hledger.Data.Types import Hledger.Data.Types
@ -567,6 +570,55 @@ journalModifyTransactions j = j{ jtxns = modifyTransactions (jtxnmodifiers j) (j
journalCheckBalanceAssertions :: Journal -> Maybe String journalCheckBalanceAssertions :: Journal -> Maybe String
journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTransactions True 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 -- | Infer any missing amounts (to satisfy balance assignments and
-- to balance transactions) and check that all transactions balance -- to balance transactions) and check that all transactions balance
-- and (optional) all balance assertions pass. Or return an error message -- 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, -- This does multiple things because amount inferring, balance assignments,
-- balance assertions and posting dates are interdependent. -- 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 -- ******* journalBalanceTransactions
-- ******** runST -- ******** runST
-- ********* runExceptT -- ********* runExceptT
-- ********** balanceTransaction (Transaction.hs)
-- *********** balanceTransactionHelper
-- ********** runReaderT -- ********** runReaderT
-- *********** balanceNoAssignmentTransactionB -- *********** balanceTransactionAndCheckAssertionsB
-- ************ balanceTransactionB [[Transaction.hs]] -- ************ addAmountAndCheckAssertionB
-- ************* balanceTransactionHelper -- ************ addOrAssignAmountAndCheckAssertionB
-- ************** inferBalancingAmount -- ************ balanceTransactionHelper (Transaction.hs)
-- *********** balanceAssignmentTransactionAndOrCheckAssertionsB -- ****** uiCheckBalanceAssertions d ui@UIState{aopts=UIOpts{cliopts_=copts}, ajournal=j} (ErrorScreen.hs)
-- ************ addAmountAndCheckBalanceAssertionB
-- ************* addToBalanceB
-- ************ inferFromAssignmentB
-- ************ balanceTransactionB [[Transaction.hs]]
-- ************* balanceTransactionHelper
-- ************ addToBalanceB
-- ****** uiCheckBalanceAssertions d ui@UIState{aopts=UIOpts{cliopts_=copts}, ajournal=j} [[ErrorScreen.hs]]
-- ******* journalCheckBalanceAssertions -- ******* journalCheckBalanceAssertions
-- ******** journalBalanceTransactions -- ******** journalBalanceTransactions
-- ****** transactionWizard, postingsBalanced [[Add.hs]], tests [[Transaction.hs]] -- ****** transactionWizard, postingsBalanced (Add.hs), tests (Transaction.hs)
-- ******* balanceTransaction -- ******* balanceTransaction (Transaction.hs) XXX hledger add won't allow balance assignments + missing amount ?
-- @ -- @
journalBalanceTransactions :: Bool -> Journal -> Either String Journal journalBalanceTransactions :: Bool -> Journal -> Either String Journal
journalBalanceTransactions assrt j' = journalBalanceTransactions assrt j' =
let let
-- ensure transactions are numbered, so we can store them by number -- ensure transactions are numbered, so we can store them by number
j@Journal{jtxns=ts} = journalNumberTransactions j' 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 -- balance assignments will not be allowed on these
txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j txnmodifieraccts = S.fromList $ map paccount $ concatMap tmpostingrules $ jtxnmodifiers j
in in
runST $ do runST $ do
bals <- H.newSized (length $ journalAccountNamesUsed j) -- We'll update a mutable array of transactions as we balance them,
txns <- newListArray (1, genericLength ts) ts -- not strictly necessary but avoids a sort at the end I think.
runExceptT $ do balancedtxns <- newListArray (1, genericLength ts) ts
flip runReaderT (BalancingState styles txnmodifieraccts assrt bals txns) $ do
-- Fill in missing posting amounts, check transactions are balanced, -- Infer missing posting amounts, check transactions are balanced,
-- and check balance assertions. This is done in two passes: -- and check balance assertions. This is done in two passes:
-- 1. Balance the transactions which don't have balance assignments, runExceptT $ do
-- and collect their postings, plus the still-unbalanced transactions, in date order.
sortedpsandts <- sortOn (either postingDate tdate) . concat <$> -- 1. Balance the transactions which don't have balance assignments.
mapM' balanceNoAssignmentTransactionB (jtxns j) let (noassignmenttxns, withassignmenttxns) = partition (null . assignmentPostings) ts
-- 2. Step through these, keeping running account balances, noassignmenttxns' <- forM noassignmenttxns $ \t ->
-- performing balance assignments in and balancing the remaining transactions, either throwError (\t -> lift (writeArray balancedtxns (tindex t) t) >> return t) $
-- and checking balance assertions. This last could be a separate pass balanceTransaction styles t
-- but perhaps it's more efficient to do all at once.
void $ mapM' balanceAssignmentTransactionAndOrCheckAssertionsB sortedpsandts -- 2. Step through the postings of those transactions, and the remaining transactions, in date order,
ts' <- lift $ getElems txns 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'} return j{jtxns=ts'}
-- | If this transaction has no balance assignments, balance and store it -- | This function is called statefully on each of a date-ordered sequence of
-- and return its postings. If it can't be balanced, an error will be thrown. -- 1. fully explicit postings from already-balanced transactions and
-- -- 2. not-yet-balanced transactions containing balance assignments.
-- It it has balance assignments, return it unchanged. If any posting has both -- It executes balance assignments and finishes balancing the transactions,
-- a balance assignment and a custom date, an error will be thrown. -- and checks balance assertions on each posting as it goes.
-- -- An error will be thrown if a transaction can't be balanced
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,
-- or if an illegal balance assignment is found (cf checkIllegalBalanceAssignment). -- or if an illegal balance assignment is found (cf checkIllegalBalanceAssignment).
-- -- Transaction prices are removed, which helps eg balance-assertions.test: 15. Mix different commodities and assignments.
balanceAssignmentTransactionAndOrCheckAssertionsB :: Either Posting Transaction -> Balancing s () -- This stores the balanced transactions in case 2 but not in case 1.
balanceAssignmentTransactionAndOrCheckAssertionsB (Left p) = do balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s ()
checkIllegalBalanceAssignmentB p
void $ addAmountAndCheckBalanceAssertionB return p balanceTransactionAndCheckAssertionsB (Left p@Posting{}) =
balanceAssignmentTransactionAndOrCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do -- 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 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 styles <- R.reader bsStyles
storeTransactionB =<< case balanceTransactionHelper styles t{tpostings=ps'} of
balanceTransactionB (fmap void . addToBalanceB) (Just styles) t{tpostings=ps'} 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 -- | If this posting has an explicit amount, add it to the account's running balance.
-- the account does not allow balance assignments (because it is referenced -- If it has a missing amount and a balance assignment, infer the amount from, and
-- by a transaction modifier). -- reset the running balance to, the assigned balance.
checkIllegalBalanceAssignmentB :: Posting -> Balancing s () -- If it has a missing amount and no balance assignment, leave it for later.
checkIllegalBalanceAssignmentB p = do -- Then test the balance assertion if any.
unassignable <- R.asks bsUnassignable addOrAssignAmountAndCheckAssertionB :: Posting -> Balancing s Posting
when (isAssignment p && paccount p `S.member` unassignable) $ addOrAssignAmountAndCheckAssertionB p@Posting{paccount=acc, pamount=amt, pbalanceassertion=mba}
throwError $ | hasAmount p = do
unlines $ newbal <- addAmountB acc amt
[ "cannot assign amount to account " whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal
, ""
, " " ++ 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
return p 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 -- | Check a posting's balance assertion against the given actual balance, and
-- return an error if the assertion is not satisfied. -- return an error if the assertion is not satisfied.
@ -766,22 +784,21 @@ checkBalanceAssertionB _ _ = return ()
-- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance. -- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance.
checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s () checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s ()
checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do
-- sum the running balances of this account and any subaccounts seen so far let isinclusive = maybe False bainclusive $ pbalanceassertion p
bals <- R.asks bsBalances actualbal' <-
actualibal <- liftB $ const $ H.foldM if isinclusive
(\bal (acc, amt) -> return $ then
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc -- sum the running balances of this account and any of its subaccounts seen so far
then bal + amt withB $ \BalancingState{bsBalances} ->
else bal) H.foldM
(\ibal (acc, amt) -> return $ ibal +
if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then amt else 0)
0 0
bals bsBalances
else return actualbal
let let
isinclusive = maybe False bainclusive $ pbalanceassertion p
actualbal'
| isinclusive = actualibal
| otherwise = actualbal
assertedcomm = acommodity assertedamt assertedcomm = acommodity assertedamt
actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm actualbal' actualbalincomm = headDef 0 $ amounts $ filterMixedAmountByCommodity assertedcomm $ actualbal'
pass = pass =
aquantity aquantity
-- traceWith (("asserted:"++).showAmountDebug) -- traceWith (("asserted:"++).showAmountDebug)
@ -823,6 +840,47 @@ checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt
when (not pass) $ throwError errmsg 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 -- | Choose and apply a consistent display format to the posting
-- amounts in each commodity. Each commodity's format is specified by -- amounts in each commodity. Each commodity's format is specified by
-- a commodity format directive, or otherwise inferred from posting -- 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 "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]
] ]

6
hledger-lib/Hledger/Data/Posting.hs
View File

@ -25,7 +25,7 @@ module Hledger.Data.Posting (
isVirtual, isVirtual,
isBalancedVirtual, isBalancedVirtual,
isEmptyPosting, isEmptyPosting,
isAssignment, hasBalanceAssignment,
hasAmount, hasAmount,
postingAllTags, postingAllTags,
transactionAllTags, transactionAllTags,
@ -144,8 +144,8 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting
hasAmount :: Posting -> Bool hasAmount :: Posting -> Bool
hasAmount = (/= missingmixedamt) . pamount hasAmount = (/= missingmixedamt) . pamount
isAssignment :: Posting -> Bool hasBalanceAssignment :: Posting -> Bool
isAssignment p = not (hasAmount p) && isJust (pbalanceassertion p) hasBalanceAssignment p = not (hasAmount p) && isJust (pbalanceassertion p)
-- | Sorted unique account names referenced by these postings. -- | Sorted unique account names referenced by these postings.
accountNamesFromPostings :: [Posting] -> [AccountName] accountNamesFromPostings :: [Posting] -> [AccountName]

98
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -28,12 +28,7 @@ module Hledger.Data.Transaction (
transactionsPostings, transactionsPostings,
isTransactionBalanced, isTransactionBalanced,
balanceTransaction, balanceTransaction,
Balancing, balanceTransactionHelper,
BalancingState(..),
addToBalanceB,
storeTransactionB,
liftB,
balanceTransactionB,
-- nonzerobalanceerror, -- nonzerobalanceerror,
-- * date operations -- * date operations
transactionDate2, transactionDate2,
@ -49,18 +44,12 @@ module Hledger.Data.Transaction (
sourceFilePath, sourceFilePath,
sourceFirstLine, sourceFirstLine,
showGenericSourcePos, showGenericSourcePos,
annotateErrorWithTransaction,
-- * tests -- * tests
tests_Transaction tests_Transaction
) )
where where
import Data.List 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.Maybe
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -308,7 +297,7 @@ realPostings :: Transaction -> [Posting]
realPostings = filter isReal . tpostings realPostings = filter isReal . tpostings
assignmentPostings :: Transaction -> [Posting] assignmentPostings :: Transaction -> [Posting]
assignmentPostings = filter isAssignment . tpostings assignmentPostings = filter hasBalanceAssignment . tpostings
virtualPostings :: Transaction -> [Posting] virtualPostings :: Transaction -> [Posting]
virtualPostings = filter isVirtual . tpostings virtualPostings = filter isVirtual . tpostings
@ -341,69 +330,28 @@ isTransactionBalanced styles t =
bvsum' = canonicalise $ costOfMixedAmount bvsum bvsum' = canonicalise $ costOfMixedAmount bvsum
canonicalise = maybe id canonicaliseMixedAmount styles canonicalise = maybe id canonicaliseMixedAmount styles
-- | Monad used for statefully "balancing" a sequence of transactions. -- | Balance this transaction, ensuring that its postings
type Balancing s = ReaderT (BalancingState s) (ExceptT String (ST s)) -- (and its balanced virtual postings) sum to 0,
-- | 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,
-- by inferring a missing amount or conversion price(s) if needed. -- by inferring a missing amount or conversion price(s) if needed.
-- Or if balancing is not possible, because of unbalanced amounts or -- Or if balancing is not possible, because the amounts don't sum to 0 or
-- more than one missing amount, returns an error message. -- because there's more than one missing amount, return an error message.
-- Note this function may be unable to balance some transactions --
-- that journalBalanceTransactions/balanceTransactionB can balance -- Transactions with balance assignments can have more than one
-- (eg ones with balance assignments). -- missing amount; to balance those you should use the more powerful
-- Whether postings "sum to 0" depends on commodity display precisions, -- journalBalanceTransactions.
-- so those can optionally be provided. --
-- 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 :: balanceTransaction ::
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
-> Transaction -> Transaction
-> Either String Transaction -> Either String Transaction
balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles balanceTransaction mstyles = fmap fst . balanceTransactionHelper mstyles
-- | Like balanceTransaction, but when inferring amounts it will also -- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB;
-- use the given state update function to update running account balances. -- use one of those instead. It also returns a list of accounts
-- Used when balancing a sequence of transactions (see journalBalanceTransactions). -- and amounts that were inferred.
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'
balanceTransactionHelper :: balanceTransactionHelper ::
Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles Maybe (Map.Map CommoditySymbol AmountStyle) -- ^ commodity display styles
-> Transaction -> Transaction
@ -413,7 +361,7 @@ balanceTransactionHelper mstyles t = do
inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t inferBalancingAmount (fromMaybe Map.empty mstyles) $ inferBalancingPrices t
if isTransactionBalanced mstyles t' if isTransactionBalanced mstyles t'
then Right (txnTieKnot t', inferredamtsandaccts) then Right (txnTieKnot t', inferredamtsandaccts)
else Left $ annotateErrorWithTxn t' $ nonzerobalanceerror t' else Left $ annotateErrorWithTransaction t' $ nonzerobalanceerror t'
where where
nonzerobalanceerror :: Transaction -> String nonzerobalanceerror :: Transaction -> String
@ -428,8 +376,8 @@ balanceTransactionHelper mstyles t = do
++ showMixedAmount (costOfMixedAmount bvsum) ++ showMixedAmount (costOfMixedAmount bvsum)
sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String
annotateErrorWithTxn :: Transaction -> String -> String annotateErrorWithTransaction :: Transaction -> String -> String
annotateErrorWithTxn t s = intercalate "\n" [showGenericSourcePos $ tsourcepos t, s, showTransactionUnelided t] annotateErrorWithTransaction t s = intercalate "\n" [showGenericSourcePos $ tsourcepos t, s, showTransactionUnelided t]
-- | Infer up to one missing amount for this transactions's real postings, and -- | 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 -- likewise for its balanced virtual postings, if needed; or return an error
@ -445,9 +393,9 @@ inferBalancingAmount ::
-> Either String (Transaction, [(AccountName, MixedAmount)]) -> Either String (Transaction, [(AccountName, MixedAmount)])
inferBalancingAmount styles t@Transaction{tpostings=ps} inferBalancingAmount styles t@Transaction{tpostings=ps}
| length amountlessrealps > 1 | 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 | 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 | otherwise
= let psandinferredamts = map inferamount ps = let psandinferredamts = map inferamount ps
inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts] inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts]

2
tests/journal/auto-postings.test
View File

@ -162,7 +162,7 @@ $ hledger -f- print --auto -x
# 9. # 9.
$ hledger print -f- --auto $ hledger print -f- --auto
>2 /cannot assign amount to account/ >2 /cannot be used with accounts which are/
>=1 >=1

45
tests/journal/balance-assertions.test
View File

@ -231,27 +231,10 @@ hledger -f - stats
a $1 =$1 a $1 =$1
b =$-1 ; date:2012/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 >>>=1
# 13. Having both assignments and posting dates is not supported. # 13. Posting Date
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
hledger -f - stats hledger -f - stats
<<< <<<
@ -276,7 +259,7 @@ hledger -f - stats
>>>2 >>>2
>>>=0 >>>=0
# 15. Mix different commodities # 14. Mix different commodities
hledger -f - stats hledger -f - stats
<<< <<<
2016/1/1 2016/1/1
@ -290,7 +273,7 @@ hledger -f - stats
>>>2 >>>2
>>>=0 >>>=0
# 16. Mix different commodities and assignments # 15. Mix different commodities and assignments
hledger -f - stats hledger -f - stats
<<< <<<
2016/1/1 2016/1/1
@ -311,7 +294,7 @@ hledger -f - stats
>>>2 >>>2
>>>=0 >>>=0
# 17. Total assertions (==) parse correctly # 16. Total assertions (==) parse correctly
hledger -f - stats hledger -f - stats
<<< <<<
2016/1/1 2016/1/1
@ -324,7 +307,7 @@ hledger -f - stats
>>>2 >>>2
>>>=0 >>>=0
# 18. Total assertions consider entire multicommodity amount # 17. Total assertions consider entire multicommodity amount
hledger -f - stats hledger -f - stats
<<< <<<
2016/1/1 2016/1/1
@ -340,7 +323,7 @@ hledger -f - stats
>>>2 /balance assertion.*line 10, column 15/ >>>2 /balance assertion.*line 10, column 15/
>>>=1 >>>=1
# 19. Mix different commodities and total assignments # 18. Mix different commodities and total assignments
hledger -f - stats hledger -f - stats
<<< <<<
2016/1/1 2016/1/1
@ -359,7 +342,7 @@ hledger -f - stats
>>>2 >>>2
>>>=0 >>>=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 hledger -f- print
<<< <<<
2019/01/01 2019/01/01
@ -370,7 +353,7 @@ hledger -f- print
>>>=0 >>>=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. # But not shown as part of the balance assertion in the resulting posting.
hledger -f- print --explicit hledger -f- print --explicit
<<< <<<
@ -382,7 +365,7 @@ hledger -f- print --explicit
>>>=0 >>>=0
# 22. close generates balance assertions without prices # 21. close generates balance assertions without prices
hledger -f- close -e 2019/1/2 hledger -f- close -e 2019/1/2
<<< <<<
2019/01/01 2019/01/01
@ -398,7 +381,7 @@ hledger -f- close -e 2019/1/2
>>>=0 >>>=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 hledger -f- print
<<< <<<
commodity $1000.00 commodity $1000.00
@ -413,7 +396,7 @@ commodity $1000.00
>>>2 >>>2
>>>=0 >>>=0
# 24. This fails # 23. This fails
hledger -f- print hledger -f- print
<<< <<<
commodity $1000.00 commodity $1000.00
@ -427,7 +410,7 @@ commodity $1000.00
>>>2 /difference: 0\.004/ >>>2 /difference: 0\.004/
>>>=1 >>>=1
# 25. This fails # 24. This fails
hledger -f- print hledger -f- print
<<< <<<
commodity $1000.00 commodity $1000.00
@ -441,7 +424,7 @@ commodity $1000.00
>>>2 /difference: 0\.0001/ >>>2 /difference: 0\.0001/
>>>=1 >>>=1
# 26. Inclusive assertions include balances from subaccounts. # 25. Inclusive assertions include balances from subaccounts.
hledger -f- print hledger -f- print
<<< <<<
2019/1/1 2019/1/1