mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 02:37:12 +03:00
Balance Assignments and accounts resetting (#438)
* Changed behavior of `readJournalFiles` to be identical to `readJournalFile` for singleton lists
* Balance Assertions have to be simple Amounts
* Add 'isAssignment' and 'assignmentPostings' to Hledger.Data.Posting and Transaction
* Implemented 'balanceTransactionUpdate', a more general version of 'balanceTransaction' that takes an update function
* Fixed test cases.
* Implemented balance assignment ("resetting a balance")
* Add assertions to show function
* updated the comments
* numbering is not needed in journalCheckBalanceAssertions
* remove prices before balance checks
* rename functions
This commit is contained in:
Johannes Gerer
Simon Michael
parent
74502f7e50
commit
45401e538e
@ -82,7 +82,10 @@ module Hledger.Data.Amount (
|
||||
costOfMixedAmount,
|
||||
divideMixedAmount,
|
||||
averageMixedAmounts,
|
||||
isNegativeAmount,
|
||||
isNegativeMixedAmount,
|
||||
isZeroAmount,
|
||||
isReallyZeroAmount,
|
||||
isZeroMixedAmount,
|
||||
isReallyZeroMixedAmount,
|
||||
isReallyZeroMixedAmountCost,
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-}
|
||||
{-|
|
||||
|
||||
@ -61,7 +62,13 @@ module Hledger.Data.Journal (
|
||||
tests_Hledger_Data_Journal,
|
||||
)
|
||||
where
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import qualified Control.Monad.Reader as R
|
||||
import Control.Monad.ST
|
||||
import Data.Array.ST
|
||||
import qualified Data.HashTable.ST.Cuckoo as HT
|
||||
import Data.List
|
||||
-- import Data.Map (findWithDefault)
|
||||
import Data.Maybe
|
||||
@ -463,8 +470,8 @@ journalApplyAliases aliases j@Journal{jtxns=ts} =
|
||||
-- check balance assertions.
|
||||
journalFinalise :: ClockTime -> FilePath -> Text -> Bool -> ParsedJournal -> Either String Journal
|
||||
journalFinalise t path txt assrt j@Journal{jfiles=fs} = do
|
||||
(journalNumberAndTieTransactions <$>
|
||||
(journalBalanceTransactions $
|
||||
(journalTieTransactions <$>
|
||||
(journalBalanceTransactions assrt $
|
||||
journalApplyCommodityStyles $
|
||||
j{ jfiles = (path,txt) : reverse fs
|
||||
, jlastreadtime = t
|
||||
@ -473,7 +480,6 @@ journalFinalise t path txt assrt j@Journal{jfiles=fs} = do
|
||||
, jperiodictxns = reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction
|
||||
, jmarketprices = reverse $ jmarketprices j -- NOTE: see addMarketPrice
|
||||
}))
|
||||
>>= if assrt then journalCheckBalanceAssertions else return
|
||||
|
||||
journalNumberAndTieTransactions = journalTieTransactions . journalNumberTransactions
|
||||
|
||||
@ -494,94 +500,208 @@ journalUntieTransactions t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{
|
||||
-- | Check any balance assertions in the journal and return an error
|
||||
-- message if any of them fail.
|
||||
journalCheckBalanceAssertions :: Journal -> Either String Journal
|
||||
journalCheckBalanceAssertions j = do
|
||||
let postingsByAccount = groupBy (\p1 p2 -> paccount p1 == paccount p2) $
|
||||
sortBy (comparing paccount) $
|
||||
journalPostings j
|
||||
forM_ postingsByAccount checkBalanceAssertionsForAccount
|
||||
Right j
|
||||
journalCheckBalanceAssertions j =
|
||||
runST $ journalBalanceTransactionsST True j
|
||||
(return ()) (\_ _ -> return ()) (const $ return j) -- noops
|
||||
|
||||
-- Check any balance assertions in this sequence of postings to a single account.
|
||||
checkBalanceAssertionsForAccount :: [Posting] -> Either String ()
|
||||
checkBalanceAssertionsForAccount ps
|
||||
| null errs = Right ()
|
||||
| otherwise = Left $ head errs
|
||||
where
|
||||
errs = fst $
|
||||
foldl' checkBalanceAssertion ([],nullmixedamt) $
|
||||
splitAssertions $
|
||||
sortBy (comparing postingDate) ps
|
||||
|
||||
-- Given a starting balance, accumulated errors, and a non-null sequence of
|
||||
-- postings to a single account with a balance assertion in the last:
|
||||
-- check that the final balance matches the balance assertion.
|
||||
-- If it does, return the new balance, otherwise add an error to the
|
||||
-- error list. Intended to be called from a fold.
|
||||
checkBalanceAssertion :: ([String],MixedAmount) -> [Posting] -> ([String],MixedAmount)
|
||||
checkBalanceAssertion (errs,startbal) ps
|
||||
| null ps = (errs,startbal)
|
||||
| isNothing $ pbalanceassertion p = (errs,startbal)
|
||||
| iswrong = (errs++[err], finalfullbal)
|
||||
| otherwise = (errs,finalfullbal)
|
||||
where
|
||||
p = last ps
|
||||
Just assertedbal = pbalanceassertion p
|
||||
assertedcomm = maybe "" acommodity $ headMay $ amounts assertedbal
|
||||
finalfullbal = sum $ [startbal] ++ map pamount (dbg2 "ps" ps)
|
||||
finalsinglebal = filterMixedAmount (\a -> acommodity a == assertedcomm) finalfullbal
|
||||
actualbal = finalsinglebal -- just check the single-commodity balance, like Ledger; maybe add ==FULLBAL later
|
||||
iswrong = dbg2 debugmsg $
|
||||
not (isReallyZeroMixedAmount (actualbal - assertedbal))
|
||||
-- bal' /= assertedbal -- MixedAmount's Eq instance currently gets confused by different precisions
|
||||
where
|
||||
debugmsg = "assertions: on " ++ show (postingDate p) ++ " balance of " ++ show assertedcomm
|
||||
++ " in " ++ T.unpack (paccount p) ++ " should be " ++ show assertedbal
|
||||
diff = assertedbal - actualbal
|
||||
diffplus | isNegativeMixedAmount diff == Just False = "+"
|
||||
| otherwise = ""
|
||||
err = printf (unlines [
|
||||
"balance assertion error%s",
|
||||
"after posting:",
|
||||
"%s",
|
||||
"balance assertion details:",
|
||||
"date: %s",
|
||||
"account: %s",
|
||||
"commodity: %s",
|
||||
"calculated: %s",
|
||||
"asserted: %s (difference: %s)"
|
||||
])
|
||||
(case ptransaction p of
|
||||
Nothing -> ":" -- shouldn't happen
|
||||
Just t -> printf " in \"%s\" (line %d, column %d):\nin transaction:\n%s" f l c (chomp $ show t) :: String
|
||||
where GenericSourcePos f l c = tsourcepos t)
|
||||
(showPostingLine p)
|
||||
(showDate $ postingDate p)
|
||||
(T.unpack $ paccount p) -- XXX pack
|
||||
assertedcomm
|
||||
(showMixedAmount finalsinglebal)
|
||||
(showMixedAmount assertedbal)
|
||||
(diffplus ++ showMixedAmount diff)
|
||||
-- | Check a posting's balance assertion and return an error if it
|
||||
-- fails.
|
||||
checkBalanceAssertion :: Posting -> MixedAmount -> Either String ()
|
||||
checkBalanceAssertion p@Posting{ pbalanceassertion = Just ass} amt
|
||||
| isReallyZeroAmount diff = Right ()
|
||||
| True = Left err
|
||||
where assertedcomm = acommodity ass
|
||||
actualbal = fromMaybe nullamt $ find ((== assertedcomm) . acommodity) (amounts amt)
|
||||
diff = ass - actualbal
|
||||
diffplus | isNegativeAmount diff == False = "+"
|
||||
| otherwise = ""
|
||||
err = printf (unlines
|
||||
[ "balance assertion error%s",
|
||||
"after posting:",
|
||||
"%s",
|
||||
"balance assertion details:",
|
||||
"date: %s",
|
||||
"account: %s",
|
||||
"commodity: %s",
|
||||
"calculated: %s",
|
||||
"asserted: %s (difference: %s)"
|
||||
])
|
||||
(case ptransaction p of
|
||||
Nothing -> ":" -- shouldn't happen
|
||||
Just t -> printf " in \"%s\" (line %d, column %d):\nin transaction:\n%s"
|
||||
f l c (chomp $ show t) :: String
|
||||
where GenericSourcePos f l c = tsourcepos t)
|
||||
(showPostingLine p)
|
||||
(showDate $ postingDate p)
|
||||
(T.unpack $ paccount p) -- XXX pack
|
||||
assertedcomm
|
||||
(showAmount actualbal)
|
||||
(showAmount ass)
|
||||
(diffplus ++ showAmount diff)
|
||||
checkBalanceAssertion _ _ = Right ()
|
||||
|
||||
-- Given a sequence of postings to a single account, split it into
|
||||
-- sub-sequences consisting of ordinary postings followed by a single
|
||||
-- balance-asserting posting. Postings not followed by a balance
|
||||
-- assertion are discarded.
|
||||
splitAssertions :: [Posting] -> [[Posting]]
|
||||
splitAssertions ps
|
||||
| null rest = []
|
||||
| otherwise = (ps'++[head rest]):splitAssertions (tail rest)
|
||||
where
|
||||
(ps',rest) = break (isJust . pbalanceassertion) ps
|
||||
-- | Environment for 'CurrentBalancesModifier'
|
||||
data Env s = Env { eBalances :: HT.HashTable s AccountName MixedAmount
|
||||
, eStoreTx :: Transaction -> ST s ()
|
||||
, eAssrt :: Bool
|
||||
, eStyles :: Maybe (M.Map CommoditySymbol AmountStyle) }
|
||||
|
||||
-- | Monad transformer stack with a reference to a mutable hashtable
|
||||
-- of current account balances and a mutable array of finished
|
||||
-- transactions in original parsing order.
|
||||
type CurrentBalancesModifier s = R.ReaderT (Env s) (ExceptT String (ST s))
|
||||
|
||||
-- | Fill in any missing amounts and check that all journal transactions
|
||||
-- balance, or return an error message. This is done after parsing all
|
||||
-- amounts and applying canonical commodity styles, since balancing
|
||||
-- depends on display precision. Reports only the first error encountered.
|
||||
journalBalanceTransactions :: Journal -> Either String Journal
|
||||
journalBalanceTransactions j@Journal{jtxns=ts, jinferredcommodities=ss} =
|
||||
case sequence $ map balance ts of Right ts' -> Right j{jtxns=ts'}
|
||||
Left e -> Left e
|
||||
where balance = balanceTransaction (Just ss)
|
||||
journalBalanceTransactions :: Bool -> Journal -> Either String Journal
|
||||
journalBalanceTransactions assrt j =
|
||||
runST $ journalBalanceTransactionsST assrt (journalNumberTransactions j)
|
||||
(newArray_ (1, genericLength $ jtxns j)
|
||||
:: forall s. ST s (STArray s Integer Transaction))
|
||||
(\arr tx -> writeArray arr (tindex tx) tx)
|
||||
$ fmap (\txns -> j{ jtxns = txns}) . getElems
|
||||
|
||||
|
||||
-- | Generalization used in the definition of
|
||||
-- 'journalBalanceTransactionsST and 'journalCheckBalanceAssertions'
|
||||
journalBalanceTransactionsST ::
|
||||
Bool
|
||||
-> Journal
|
||||
-> ST s txns
|
||||
-- ^ creates transaction store
|
||||
-> (txns -> Transaction -> ST s ())
|
||||
-- ^ "store" operation
|
||||
-> (txns -> ST s a)
|
||||
-- ^ calculate result from transactions
|
||||
-> ST s (Either String a)
|
||||
journalBalanceTransactionsST assrt j createStore storeIn extract =
|
||||
runExceptT $ do
|
||||
bals <- lift $ HT.newSized size
|
||||
txStore <- lift $ createStore
|
||||
flip R.runReaderT (Env bals (storeIn txStore) assrt $
|
||||
Just $ jinferredcommodities j) $ do
|
||||
dated <- fmap snd . sortBy (comparing fst) . concat
|
||||
<$> mapM discriminateByDate (jtxns j)
|
||||
mapM checkInferAndRegisterAmounts dated
|
||||
lift $ extract txStore
|
||||
where size = genericLength $ journalPostings j
|
||||
|
||||
-- | This converts a transaction into a list of objects whose dates
|
||||
-- have to be considered when checking balance assertions and handled
|
||||
-- by 'checkInferAndRegisterAmounts'.
|
||||
--
|
||||
-- Transaction without balance assignments can be balanced and stored
|
||||
-- immediately and their (possibly) dated postings are returned.
|
||||
--
|
||||
-- Transaction with balance assignments are only supported if no
|
||||
-- posting has a 'pdate' value. Supported transactions will be
|
||||
-- returned unchanged and balanced and stored later in 'checkInferAndRegisterAmounts'.
|
||||
discriminateByDate :: Transaction
|
||||
-> CurrentBalancesModifier s [(Day, Either Posting Transaction)]
|
||||
discriminateByDate tx
|
||||
| null (assignmentPostings tx) = do
|
||||
styles <- R.reader $ eStyles
|
||||
balanced <- lift $ ExceptT $ return
|
||||
$ balanceTransaction styles tx
|
||||
storeTransaction balanced
|
||||
return $ fmap (postingDate &&& (Left . removePrices))
|
||||
$ tpostings $ balanced
|
||||
| True = do
|
||||
when (any (isJust . pdate) $ tpostings tx) $
|
||||
throwError $ unlines $
|
||||
["Not supported: Transactions with balance assignments "
|
||||
,"AND dated postings without amount:\n"
|
||||
, showTransaction tx]
|
||||
return [(tdate tx, Right
|
||||
$ tx { tpostings = removePrices <$> tpostings tx })]
|
||||
|
||||
-- | This function takes different objects describing changes to
|
||||
-- account balances on a single day. It can handle either a single
|
||||
-- posting (from an already balanced transaction without assigments)
|
||||
-- or a whole transaction with assignments (which is required to no
|
||||
-- posting with pdate set.).
|
||||
--
|
||||
-- For a single posting, there is not much to do. Only add its amount
|
||||
-- to its account and check the assertion, if there is one. This
|
||||
-- functionality is provided by 'addAmountAndCheckBalance'.
|
||||
--
|
||||
-- For a whole transaction, it loops over all postings, and performs
|
||||
-- 'addAmountAndCheckBalance', if there is an amount. If there is no
|
||||
-- amount, the amount is inferred by the assertion or left empty if
|
||||
-- there is no assertion. Then, the transaction is balanced, the
|
||||
-- inferred amount added to the balance (all in
|
||||
-- 'balanceTransactionUpdate') and the resulting transaction with no
|
||||
-- missing amounts is stored in the array, for later retrieval.
|
||||
--
|
||||
-- Again in short:
|
||||
--
|
||||
-- 'Left Posting': Check the balance assertion and update the
|
||||
-- account balance. If the amount is empty do nothing. this can be
|
||||
-- the case e.g. for virtual postings
|
||||
--
|
||||
-- 'Right Transaction': Loop over all postings, infer their amounts
|
||||
-- and then balance and store the transaction.
|
||||
checkInferAndRegisterAmounts :: Either Posting Transaction
|
||||
-> CurrentBalancesModifier s ()
|
||||
checkInferAndRegisterAmounts (Left p) =
|
||||
void $ addAmountAndCheckBalance return p
|
||||
checkInferAndRegisterAmounts (Right oldTx) = do
|
||||
let ps = tpostings oldTx
|
||||
styles <- R.reader $ eStyles
|
||||
newPostings <- forM ps $ addAmountAndCheckBalance inferFromAssignment
|
||||
storeTransaction =<< balanceTransactionUpdate
|
||||
(fmap void . addToBalance) styles oldTx { tpostings = newPostings }
|
||||
where
|
||||
inferFromAssignment :: Posting -> CurrentBalancesModifier s Posting
|
||||
inferFromAssignment p = maybe (return p)
|
||||
(fmap (\a -> p { pamount = a }) . setBalance (paccount p))
|
||||
$ pbalanceassertion p
|
||||
|
||||
-- | Adds a posting's amonut to the posting's account balance and
|
||||
-- checks a possible balance assertion. If there is no amount, it runs
|
||||
-- the supplied fallback action.
|
||||
addAmountAndCheckBalance :: (Posting -> CurrentBalancesModifier s Posting)
|
||||
-- ^ action to execute, if posting has no amount
|
||||
-> Posting
|
||||
-> CurrentBalancesModifier s Posting
|
||||
addAmountAndCheckBalance _ p | hasAmount p = do
|
||||
newAmt <- addToBalance (paccount p) $ pamount p
|
||||
assrt <- R.reader eAssrt
|
||||
lift $ when assrt $ ExceptT $ return
|
||||
$ checkBalanceAssertion p newAmt
|
||||
return p
|
||||
addAmountAndCheckBalance fallback p = fallback p
|
||||
|
||||
-- | Sets an account's balance to a given amount and returns the
|
||||
-- difference of new and old amount
|
||||
setBalance :: AccountName -> Amount -> CurrentBalancesModifier s MixedAmount
|
||||
setBalance acc amt = liftModifier $ \Env{ eBalances = bals } -> do
|
||||
old <- HT.lookup bals acc
|
||||
let new = Mixed $ (amt :) $ maybe []
|
||||
(filter ((/= acommodity amt) . acommodity) . amounts) old
|
||||
HT.insert bals acc new
|
||||
return $ maybe new (new -) old
|
||||
|
||||
-- | Adds an amount to an account's balance and returns the resulting
|
||||
-- balance
|
||||
addToBalance :: AccountName -> MixedAmount -> CurrentBalancesModifier s MixedAmount
|
||||
addToBalance acc amt = liftModifier $ \Env{ eBalances = bals } -> do
|
||||
new <- maybe amt (+ amt) <$> HT.lookup bals acc
|
||||
HT.insert bals acc new
|
||||
return new
|
||||
|
||||
-- | Stores a transaction in the transaction array in original parsing
|
||||
-- order.
|
||||
storeTransaction :: Transaction -> CurrentBalancesModifier s ()
|
||||
storeTransaction tx = liftModifier $ ($tx) . eStoreTx
|
||||
|
||||
-- | Helper function
|
||||
liftModifier :: (Env s -> ST s a) -> CurrentBalancesModifier s a
|
||||
liftModifier f = R.ask >>= lift . lift . f
|
||||
|
||||
|
||||
-- | Choose and apply a consistent display format to the posting
|
||||
-- amounts in each commodity. Each commodity's format is specified by
|
||||
@ -792,7 +912,7 @@ abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat
|
||||
-- liabilities:debts $1
|
||||
-- assets:bank:checking
|
||||
--
|
||||
Right samplejournal = journalBalanceTransactions $
|
||||
Right samplejournal = journalBalanceTransactions False $
|
||||
nulljournal
|
||||
{jtxns = [
|
||||
txnTieKnot $ Transaction {
|
||||
|
||||
@ -20,10 +20,12 @@ module Hledger.Data.Posting (
|
||||
isVirtual,
|
||||
isBalancedVirtual,
|
||||
isEmptyPosting,
|
||||
isAssignment,
|
||||
hasAmount,
|
||||
postingAllTags,
|
||||
transactionAllTags,
|
||||
relatedPostings,
|
||||
removePrices,
|
||||
-- * date operations
|
||||
postingDate,
|
||||
postingDate2,
|
||||
@ -117,12 +119,20 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting
|
||||
hasAmount :: Posting -> Bool
|
||||
hasAmount = (/= missingmixedamt) . pamount
|
||||
|
||||
isAssignment :: Posting -> Bool
|
||||
isAssignment p = not (hasAmount p) && isJust (pbalanceassertion p)
|
||||
|
||||
accountNamesFromPostings :: [Posting] -> [AccountName]
|
||||
accountNamesFromPostings = nub . map paccount
|
||||
|
||||
sumPostings :: [Posting] -> MixedAmount
|
||||
sumPostings = sum . map pamount
|
||||
|
||||
-- | Remove all prices of a posting
|
||||
removePrices :: Posting -> Posting
|
||||
removePrices p = p{ pamount = Mixed $ remove <$> amounts (pamount p) }
|
||||
where remove a = a { aprice = NoPrice }
|
||||
|
||||
-- | Get a posting's (primary) date - it's own primary date if specified,
|
||||
-- otherwise the parent transaction's primary date, or the null date if
|
||||
-- there is no parent transaction.
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-|
|
||||
|
||||
A 'Transaction' represents a movement of some commodity(ies) between two
|
||||
@ -19,6 +20,7 @@ module Hledger.Data.Transaction (
|
||||
showAccountName,
|
||||
hasRealPostings,
|
||||
realPostings,
|
||||
assignmentPostings,
|
||||
virtualPostings,
|
||||
balancedVirtualPostings,
|
||||
transactionsPostings,
|
||||
@ -29,6 +31,7 @@ module Hledger.Data.Transaction (
|
||||
-- * arithmetic
|
||||
transactionPostingBalances,
|
||||
balanceTransaction,
|
||||
balanceTransactionUpdate,
|
||||
-- * rendering
|
||||
showTransaction,
|
||||
showTransactionUnelided,
|
||||
@ -39,6 +42,8 @@ module Hledger.Data.Transaction (
|
||||
)
|
||||
where
|
||||
import Data.List
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Identity
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@ -185,8 +190,8 @@ postingAsLines elideamount onelineamounts ps p =
|
||||
postinglines
|
||||
++ newlinecomments
|
||||
where
|
||||
postinglines = map rstrip $ lines $ concatTopPadded [account, " ", amount, samelinecomment]
|
||||
|
||||
postinglines = map rstrip $ lines $ concatTopPadded [account, " ", amount, assertion, samelinecomment]
|
||||
assertion = maybe "" ((" = " ++) . showAmount) $ pbalanceassertion p
|
||||
account =
|
||||
indent $
|
||||
showstatus p ++ fitString (Just acctwidth) Nothing False True (showAccountName Nothing (ptype p) (paccount p))
|
||||
@ -260,6 +265,9 @@ hasRealPostings = not . null . realPostings
|
||||
realPostings :: Transaction -> [Posting]
|
||||
realPostings = filter isReal . tpostings
|
||||
|
||||
assignmentPostings :: Transaction -> [Posting]
|
||||
assignmentPostings = filter isAssignment . tpostings
|
||||
|
||||
virtualPostings :: Transaction -> [Posting]
|
||||
virtualPostings = filter isVirtual . tpostings
|
||||
|
||||
@ -292,25 +300,41 @@ isTransactionBalanced styles t =
|
||||
-- amount or conversion price(s), or return an error message.
|
||||
-- Balancing is affected by commodity display precisions, so those can
|
||||
-- (optionally) be provided.
|
||||
balanceTransaction :: Maybe (Map.Map CommoditySymbol AmountStyle) -> Transaction -> Either String Transaction
|
||||
balanceTransaction styles t =
|
||||
case inferBalancingAmount t of
|
||||
Left err -> Left err
|
||||
Right t' -> let t'' = inferBalancingPrices t'
|
||||
in if isTransactionBalanced styles t''
|
||||
then Right $ txnTieKnot t''
|
||||
else Left $ printerr $ nonzerobalanceerror t''
|
||||
where
|
||||
printerr s = intercalate "\n" [s, showTransactionUnelided t]
|
||||
nonzerobalanceerror :: Transaction -> String
|
||||
nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg
|
||||
where
|
||||
(rsum, _, bvsum) = transactionPostingBalances t
|
||||
rmsg | isReallyZeroMixedAmountCost rsum = ""
|
||||
| otherwise = "real postings are off by " ++ showMixedAmount (costOfMixedAmount rsum)
|
||||
bvmsg | isReallyZeroMixedAmountCost bvsum = ""
|
||||
| otherwise = "balanced virtual postings are off by " ++ showMixedAmount (costOfMixedAmount bvsum)
|
||||
sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String
|
||||
--
|
||||
-- this fails for example, if there are several missing amounts
|
||||
-- (possibly with balance assignments)
|
||||
balanceTransaction :: Maybe (Map.Map CommoditySymbol AmountStyle)
|
||||
-> Transaction -> Either String Transaction
|
||||
balanceTransaction stylemap = runIdentity . runExceptT
|
||||
. balanceTransactionUpdate (\_ _ -> return ()) stylemap
|
||||
|
||||
|
||||
-- | More general version of 'balanceTransaction' that takes an update
|
||||
-- function
|
||||
balanceTransactionUpdate :: MonadError String m
|
||||
=> (AccountName -> MixedAmount -> m ())
|
||||
-- ^ update function
|
||||
-> Maybe (Map.Map CommoditySymbol AmountStyle)
|
||||
-> Transaction -> m Transaction
|
||||
balanceTransactionUpdate update styles t =
|
||||
finalize =<< inferBalancingAmount update t
|
||||
where
|
||||
finalize t' = let t'' = inferBalancingPrices t'
|
||||
in if isTransactionBalanced styles t''
|
||||
then return $ txnTieKnot t''
|
||||
else throwError $ printerr $ nonzerobalanceerror t''
|
||||
printerr s = intercalate "\n" [s, showTransactionUnelided t]
|
||||
nonzerobalanceerror :: Transaction -> String
|
||||
nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg
|
||||
where
|
||||
(rsum, _, bvsum) = transactionPostingBalances t
|
||||
rmsg | isReallyZeroMixedAmountCost rsum = ""
|
||||
| otherwise = "real postings are off by "
|
||||
++ showMixedAmount (costOfMixedAmount rsum)
|
||||
bvmsg | isReallyZeroMixedAmountCost bvsum = ""
|
||||
| otherwise = "balanced virtual postings are off by "
|
||||
++ showMixedAmount (costOfMixedAmount bvsum)
|
||||
sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String
|
||||
|
||||
-- | 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
|
||||
@ -319,61 +343,70 @@ balanceTransaction styles t =
|
||||
-- We can infer a missing amount when there are multiple postings and exactly
|
||||
-- one of them is amountless. If the amounts had price(s) the inferred amount
|
||||
-- have the same price(s), and will be converted to the price commodity.
|
||||
--
|
||||
inferBalancingAmount :: Transaction -> Either String Transaction
|
||||
inferBalancingAmount t@Transaction{tpostings=ps}
|
||||
inferBalancingAmount :: MonadError String m
|
||||
=> (AccountName -> MixedAmount -> m ())
|
||||
-- ^ update function
|
||||
-> Transaction -> m Transaction
|
||||
inferBalancingAmount update t@Transaction{tpostings=ps}
|
||||
| length amountlessrealps > 1
|
||||
= Left $ printerr "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)"
|
||||
= throwError $ printerr "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 $ printerr "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)"
|
||||
= throwError $ printerr "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
|
||||
= Right t{tpostings=map inferamount ps}
|
||||
= do postings <- mapM inferamount ps
|
||||
return t{tpostings=postings}
|
||||
where
|
||||
printerr s = intercalate "\n" [s, showTransactionUnelided t]
|
||||
((amountfulrealps, amountlessrealps), realsum) = (partition hasAmount (realPostings t), sum $ map pamount amountfulrealps)
|
||||
((amountfulbvps, amountlessbvps), bvsum) = (partition hasAmount (balancedVirtualPostings t), sum $ map pamount amountfulbvps)
|
||||
inferamount p@Posting{ptype=RegularPosting} | not (hasAmount p) = p{pamount=costOfMixedAmount (-realsum)}
|
||||
inferamount p@Posting{ptype=BalancedVirtualPosting} | not (hasAmount p) = p{pamount=costOfMixedAmount (-bvsum)}
|
||||
inferamount p = p
|
||||
((amountfulrealps, amountlessrealps), realsum) =
|
||||
(partition hasAmount (realPostings t), sum $ map pamount amountfulrealps)
|
||||
((amountfulbvps, amountlessbvps), bvsum) =
|
||||
(partition hasAmount (balancedVirtualPostings t), sum $ map pamount amountfulbvps)
|
||||
inferamount p@Posting{ptype=RegularPosting}
|
||||
| not (hasAmount p) = updateAmount p realsum
|
||||
inferamount p@Posting{ptype=BalancedVirtualPosting}
|
||||
| not (hasAmount p) = updateAmount p bvsum
|
||||
inferamount p = return p
|
||||
updateAmount p amt = update (paccount p) amt' >> return p { pamount=amt' }
|
||||
where amt' = costOfMixedAmount (-amt)
|
||||
|
||||
-- | Infer prices for this transaction's posting amounts, if needed to make
|
||||
-- the postings balance, and if possible. This is done once for the real
|
||||
-- postings and again (separately) for the balanced virtual postings. When
|
||||
-- it's not possible, the transaction is left unchanged.
|
||||
--
|
||||
--
|
||||
-- The simplest example is a transaction with two postings, each in a
|
||||
-- different commodity, with no prices specified. In this case we'll add a
|
||||
-- price to the first posting such that it can be converted to the commodity
|
||||
-- of the second posting (with -B), and such that the postings balance.
|
||||
--
|
||||
--
|
||||
-- In general, we can infer a conversion price when the sum of posting amounts
|
||||
-- contains exactly two different commodities and no explicit prices. Also
|
||||
-- all postings are expected to contain an explicit amount (no missing
|
||||
-- amounts) in a single commodity. Otherwise no price inferring is attempted.
|
||||
--
|
||||
--
|
||||
-- The transaction itself could contain more than two commodities, and/or
|
||||
-- prices, if they cancel out; what matters is that the sum of posting amounts
|
||||
-- contains exactly two commodities and zero prices.
|
||||
--
|
||||
--
|
||||
-- There can also be more than two postings in either of the commodities.
|
||||
--
|
||||
--
|
||||
-- We want to avoid excessive display of digits when the calculated price is
|
||||
-- an irrational number, while hopefully also ensuring the displayed numbers
|
||||
-- make sense if the user does a manual calculation. This is (mostly) achieved
|
||||
-- in two ways:
|
||||
--
|
||||
--
|
||||
-- - when there is only one posting in the "from" commodity, a total price
|
||||
-- (@@) is used, and all available decimal digits are shown
|
||||
--
|
||||
--
|
||||
-- - otherwise, a suitable averaged unit price (@) is applied to the relevant
|
||||
-- postings, with display precision equal to the summed display precisions
|
||||
-- of the two commodities being converted between, or 2, whichever is larger.
|
||||
--
|
||||
--
|
||||
-- (We don't always calculate a good-looking display precision for unit prices
|
||||
-- when the commodity display precisions are low, eg when a journal doesn't
|
||||
-- use any decimal places. The minimum of 2 helps make the prices shown by the
|
||||
-- print command a bit less surprising in this case. Could do better.)
|
||||
--
|
||||
--
|
||||
inferBalancingPrices :: Transaction -> Transaction
|
||||
inferBalancingPrices t@Transaction{tpostings=ps} = t{tpostings=ps'}
|
||||
where
|
||||
|
||||
@ -198,7 +198,7 @@ data Posting = Posting {
|
||||
pcomment :: Text, -- ^ this posting's comment lines, as a single non-indented multi-line string
|
||||
ptype :: PostingType,
|
||||
ptags :: [Tag], -- ^ tag names and values, extracted from the comment
|
||||
pbalanceassertion :: Maybe MixedAmount, -- ^ optional: the expected balance in the account after this posting
|
||||
pbalanceassertion :: Maybe Amount, -- ^ optional: the expected balance in this commodity in the account after this posting
|
||||
ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types).
|
||||
-- Tying this knot gets tedious, Maybe makes it easier/optional.
|
||||
} deriving (Typeable,Data,Generic)
|
||||
|
||||
@ -427,14 +427,14 @@ priceamountp =
|
||||
return $ UnitPrice a))
|
||||
<|> return NoPrice
|
||||
|
||||
partialbalanceassertionp :: Monad m => JournalStateParser m (Maybe MixedAmount)
|
||||
partialbalanceassertionp :: Monad m => JournalStateParser m (Maybe Amount)
|
||||
partialbalanceassertionp =
|
||||
try (do
|
||||
lift (many spacenonewline)
|
||||
char '='
|
||||
lift (many spacenonewline)
|
||||
a <- amountp -- XXX should restrict to a simple amount
|
||||
return $ Just $ Mixed [a])
|
||||
return $ Just $ a)
|
||||
<|> return Nothing
|
||||
|
||||
-- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount)
|
||||
|
||||
@ -387,7 +387,7 @@ tests_balanceReport =
|
||||
]
|
||||
|
||||
Right samplejournal2 =
|
||||
journalBalanceTransactions
|
||||
journalBalanceTransactions False
|
||||
nulljournal{
|
||||
jtxns = [
|
||||
txnTieKnot Transaction{
|
||||
|
||||
@ -71,6 +71,7 @@ library
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
, hashtables >= 1.2
|
||||
, megaparsec >=5.0 && < 5.2
|
||||
, mtl
|
||||
, mtl-compat
|
||||
@ -168,6 +169,7 @@ test-suite doctests
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
, hashtables >= 1.2
|
||||
, megaparsec >=5.0 && < 5.2
|
||||
, mtl
|
||||
, mtl-compat
|
||||
@ -256,6 +258,7 @@ test-suite hunittests
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
, hashtables >= 1.2
|
||||
, megaparsec >=5.0 && < 5.2
|
||||
, mtl
|
||||
, mtl-compat
|
||||
|
||||
@ -52,6 +52,7 @@ dependencies:
|
||||
- deepseq
|
||||
- directory
|
||||
- filepath
|
||||
- hashtables >= 1.2
|
||||
- megaparsec >=5.0 && < 5.2
|
||||
- mtl
|
||||
- mtl-compat
|
||||
|
||||
@ -43,7 +43,7 @@ hledger print -f personal.journal -f business.journal -f alias.journal -f person
|
||||
|
||||
|
||||
# 3. files can be of different formats
|
||||
hledger print -f personal.journal -f a.timeclock -f b.timedot
|
||||
hledger print -f personal.journal -f ../journal/a.timeclock -f ../journal/b.timedot
|
||||
>>>
|
||||
2014/01/02
|
||||
expenses:food $1
|
||||
@ -55,6 +55,7 @@ hledger print -f personal.journal -f a.timeclock -f b.timedot
|
||||
2016/01/01 *
|
||||
(b.bb) 1.00
|
||||
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
u
|
||||
@ -31,6 +31,7 @@ hledger -f - print
|
||||
㐀:㐁:㐂:㐃:㐄 1
|
||||
㐀 -1
|
||||
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 2.
|
||||
@ -42,6 +43,7 @@ hledger -f chinese.journal register --width 80
|
||||
㐀:㐁:㐂:㐃 -1 0
|
||||
2014/01/03 transaction 3 㐀:㐁:㐂:㐃:㐄 1 1
|
||||
㐀 -1 0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 3.
|
||||
@ -53,6 +55,7 @@ hledger -f chinese.journal balance
|
||||
1 㐄
|
||||
--------------------
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 4.
|
||||
@ -69,6 +72,7 @@ Balance changes in 2014:
|
||||
----------------++-------
|
||||
|| 0
|
||||
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 5.
|
||||
|
||||
@ -136,3 +136,175 @@ hledger -f - stats
|
||||
# >>> /Transactions/
|
||||
# >>>2
|
||||
# >>>=0
|
||||
|
||||
# 8. resetting a balance
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2013/1/1
|
||||
a $1.20
|
||||
b
|
||||
|
||||
2013/1/2
|
||||
a =$1.3
|
||||
b
|
||||
|
||||
2013/1/2
|
||||
a $10 =$11.3
|
||||
b =$-11.3
|
||||
|
||||
>>> /Transactions/
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
|
||||
# 9. Multiple assertions for an account in the same transaction.
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2013/1/1
|
||||
a $1 =$1
|
||||
b =-$1
|
||||
|
||||
2013/1/2
|
||||
a $1 =$2
|
||||
b $-1 =$-2
|
||||
|
||||
2013/1/3
|
||||
a $2 = $4
|
||||
b $-1 = $-3
|
||||
b $-1 = $-4
|
||||
|
||||
>>> /Transactions/
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 10. Multiple assertions and assignments for an account in the same transaction.
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2013/1/1
|
||||
a $1 =$1
|
||||
b =-$1
|
||||
|
||||
2013/1/3
|
||||
a $6 = $7
|
||||
b $-1 = $-2
|
||||
b $-1 = $-3
|
||||
b $-7 = $-10
|
||||
b $-1
|
||||
b $-1 = $-12
|
||||
b
|
||||
|
||||
2013/1/4
|
||||
a $0 = $7
|
||||
b $0 = $-7
|
||||
|
||||
>>> /Transactions/
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 11. Assignments and virtual postings
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2013/1/1
|
||||
b
|
||||
[a] 1$
|
||||
(b) = $14
|
||||
[b]
|
||||
a 4$
|
||||
|
||||
|
||||
2013/1/2
|
||||
[a] = $5
|
||||
b = $9
|
||||
|
||||
|
||||
|
||||
|
||||
>>> /Transactions/
|
||||
>>>2
|
||||
>>>=0
|
||||
# 12. Having both assignements and posting dates is not supported.
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2013/1/1
|
||||
a $1 =$1
|
||||
b =$-1 ; date:2012/1/1
|
||||
|
||||
>>>2 /Not supported/
|
||||
>>>=1
|
||||
|
||||
# 13. Having both assignements 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 /Not supported/
|
||||
>>>=1
|
||||
|
||||
# 14. Posting Date
|
||||
hledger -f - stats
|
||||
<<<
|
||||
|
||||
2011/5/5
|
||||
[a] = -10
|
||||
|
||||
2013/1/1
|
||||
a 1 = -12
|
||||
b
|
||||
c = 5
|
||||
|
||||
2014/1/1
|
||||
a ; date:2012/1/1
|
||||
d 3 = 3
|
||||
|
||||
2015/1/1
|
||||
[a] ; date:2011/1/1
|
||||
[d] 10
|
||||
|
||||
|
||||
>>> /Transactions/
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 15. Mix different commodities
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2016/1/1
|
||||
a $1
|
||||
b -1 zorkmids
|
||||
|
||||
2016/1/2
|
||||
a $-1 = $0
|
||||
b
|
||||
>>> /Transactions/
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
# 16. Mix different commodities and assignments
|
||||
hledger -f - stats
|
||||
<<<
|
||||
2016/1/1
|
||||
a $1
|
||||
b -1 zorkmids
|
||||
|
||||
2016/1/4
|
||||
[a] = $1
|
||||
|
||||
|
||||
2016/1/5
|
||||
[a] = -1 zorkmids
|
||||
|
||||
2016/1/2
|
||||
a
|
||||
b = 0 zorkmids
|
||||
>>> /Transactions/
|
||||
>>>2
|
||||
>>>=0
|
||||
@ -51,4 +51,5 @@ hledger -f- balance
|
||||
-10 f
|
||||
--------------------
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
Loading…
Reference in New Issue
Block a user