diff --git a/hledger-lib/Hledger/Data.hs b/hledger-lib/Hledger/Data.hs index 732d3f100..32d3cdd55 100644 --- a/hledger-lib/Hledger/Data.hs +++ b/hledger-lib/Hledger/Data.hs @@ -12,6 +12,7 @@ module Hledger.Data ( module Hledger.Data.Account, module Hledger.Data.AccountName, module Hledger.Data.Amount, + module Hledger.Data.Balancing, module Hledger.Data.Dates, module Hledger.Data.Journal, module Hledger.Data.Json, @@ -34,6 +35,7 @@ import Test.Tasty (testGroup) import Hledger.Data.Account import Hledger.Data.AccountName import Hledger.Data.Amount +import Hledger.Data.Balancing import Hledger.Data.Dates import Hledger.Data.Journal import Hledger.Data.Json @@ -53,6 +55,7 @@ tests_Data = testGroup "Data" [ tests_AccountName ,tests_Amount ,tests_Dates + ,tests_Balancing ,tests_Journal ,tests_Ledger ,tests_Posting diff --git a/hledger-lib/Hledger/Data/Balancing.hs b/hledger-lib/Hledger/Data/Balancing.hs new file mode 100644 index 000000000..ee0cc85e1 --- /dev/null +++ b/hledger-lib/Hledger/Data/Balancing.hs @@ -0,0 +1,986 @@ +{-| +Functions for ensuring transactions and journals are balanced. +-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Hledger.Data.Balancing +( -- * BalancingOpts + BalancingOpts(..) +, HasBalancingOpts(..) +, defbalancingopts + -- * transaction balancing +, isTransactionBalanced +, balanceTransaction +, balanceTransactionHelper +, annotateErrorWithTransaction + -- * journal balancing +, journalBalanceTransactions +, journalCheckBalanceAssertions + -- * tests +, tests_Balancing +) +where + +import Control.Monad.Except (ExceptT(..), runExceptT, throwError) +import "extra" Control.Monad.Extra (whenM) +import Control.Monad.Reader as R +import Control.Monad.ST (ST, runST) +import Data.Array.ST (STArray, getElems, newListArray, writeArray) +import Data.Foldable (asum) +import Data.Function ((&)) +import qualified Data.HashTable.Class as H (toList) +import qualified Data.HashTable.ST.Cuckoo as H +import Data.List (intercalate, partition, sortOn) +import Data.List.Extra (nubSort) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Time.Calendar (fromGregorian) +import qualified Data.Map as M +import Safe (headDef) +import Text.Printf (printf) + +import Hledger.Utils +import Hledger.Data.Types +import Hledger.Data.AccountName (isAccountNamePrefixOf) +import Hledger.Data.Amount +import Hledger.Data.Dates (showDate) +import Hledger.Data.Journal +import Hledger.Data.Posting +import Hledger.Data.Transaction + + +data BalancingOpts = BalancingOpts + { ignore_assertions_ :: Bool -- ^ Ignore balance assertions + , infer_transaction_prices_ :: Bool -- ^ Infer prices in unbalanced multicommodity amounts + , commodity_styles_ :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles + } deriving (Show) + +defbalancingopts :: BalancingOpts +defbalancingopts = BalancingOpts + { ignore_assertions_ = False + , infer_transaction_prices_ = True + , commodity_styles_ = Nothing + } + +-- | Check that this transaction would appear balanced to a human when displayed. +-- On success, returns the empty list, otherwise one or more error messages. +-- +-- In more detail: +-- For the real postings, and separately for the balanced virtual postings: +-- +-- 1. Convert amounts to cost where possible +-- +-- 2. When there are two or more non-zero amounts +-- (appearing non-zero when displayed, using the given display styles if provided), +-- are they a mix of positives and negatives ? +-- This is checked separately to give a clearer error message. +-- (Best effort; could be confused by postings with multicommodity amounts.) +-- +-- 3. Does the amounts' sum appear non-zero when displayed ? +-- (using the given display styles if provided) +-- +transactionCheckBalanced :: BalancingOpts -> Transaction -> [String] +transactionCheckBalanced BalancingOpts{commodity_styles_} t = errs + where + (rps, bvps) = foldr partitionPosting ([], []) $ tpostings t + where + partitionPosting p ~(l, r) = case ptype p of + RegularPosting -> (p:l, r) + BalancedVirtualPosting -> (l, p:r) + VirtualPosting -> (l, r) + + -- check for mixed signs, detecting nonzeros at display precision + canonicalise = maybe id canonicaliseMixedAmount commodity_styles_ + signsOk ps = + case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of + nonzeros | length nonzeros >= 2 + -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 + _ -> True + (rsignsok, bvsignsok) = (signsOk rps, signsOk bvps) + + -- check for zero sum, at display precision + (rsum, bvsum) = (sumPostings rps, sumPostings bvps) + (rsumcost, bvsumcost) = (mixedAmountCost rsum, mixedAmountCost bvsum) + (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost) + (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) + + -- generate error messages, showing amounts with their original precision + errs = filter (not.null) [rmsg, bvmsg] + where + rmsg + | rsumok = "" + | not rsignsok = "real postings all have the same sign" + | otherwise = "real postings' sum should be 0 but is: " ++ showMixedAmount rsumcost + bvmsg + | bvsumok = "" + | not bvsignsok = "balanced virtual postings all have the same sign" + | otherwise = "balanced virtual postings' sum should be 0 but is: " ++ showMixedAmount bvsumcost + +-- | Legacy form of transactionCheckBalanced. +isTransactionBalanced :: BalancingOpts -> Transaction -> Bool +isTransactionBalanced bopts = null . transactionCheckBalanced bopts + +-- | 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 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 :: + BalancingOpts + -> Transaction + -> Either String Transaction +balanceTransaction bopts = fmap fst . balanceTransactionHelper bopts + +-- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB; +-- use one of those instead. It also returns a list of accounts +-- and amounts that were inferred. +balanceTransactionHelper :: + BalancingOpts + -> Transaction + -> Either String (Transaction, [(AccountName, MixedAmount)]) +balanceTransactionHelper bopts t = do + (t', inferredamtsandaccts) <- inferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) $ + if infer_transaction_prices_ bopts then inferBalancingPrices t else t + case transactionCheckBalanced bopts t' of + [] -> Right (txnTieKnot t', inferredamtsandaccts) + errs -> Left $ transactionBalanceError t' errs + +-- | Generate a transaction balancing error message, given the transaction +-- and one or more suberror messages. +transactionBalanceError :: Transaction -> [String] -> String +transactionBalanceError t errs = + annotateErrorWithTransaction t $ + intercalate "\n" $ "could not balance this transaction:" : errs + +annotateErrorWithTransaction :: Transaction -> String -> String +annotateErrorWithTransaction t s = + unlines [ showGenericSourcePos $ tsourcepos t, s + , T.unpack . T.stripEnd $ showTransaction 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 +-- message if we can't. Returns the updated transaction and any inferred posting amounts, +-- with the corresponding accounts, in order). +-- +-- 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 :: + M.Map CommoditySymbol AmountStyle -- ^ commodity display styles + -> Transaction + -> Either String (Transaction, [(AccountName, MixedAmount)]) +inferBalancingAmount styles t@Transaction{tpostings=ps} + | length amountlessrealps > 1 + = Left $ transactionBalanceError t + ["can't have more than one real posting with no amount" + ,"(remember to put two or more spaces between account and amount)"] + | length amountlessbvps > 1 + = Left $ transactionBalanceError t + ["can't have more than one balanced virtual posting with no amount" + ,"(remember to put two or more spaces between account and amount)"] + | otherwise + = let psandinferredamts = map inferamount ps + inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts] + in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts) + where + (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t) + realsum = sumPostings amountfulrealps + (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t) + bvsum = sumPostings amountfulbvps + + inferamount :: Posting -> (Posting, Maybe MixedAmount) + inferamount p = + let + minferredamt = case ptype p of + RegularPosting | not (hasAmount p) -> Just realsum + BalancedVirtualPosting | not (hasAmount p) -> Just bvsum + _ -> Nothing + in + case minferredamt of + Nothing -> (p, Nothing) + Just a -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a') + where + -- Inferred amounts are converted to cost. + -- Also ensure the new amount has the standard style for its commodity + -- (since the main amount styling pass happened before this balancing pass); + a' = styleMixedAmount styles . mixedAmountCost $ maNegate a + +-- | 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 + ps' = map (priceInferrerFor t BalancedVirtualPosting . priceInferrerFor t RegularPosting) ps + +-- | Generate a posting update function which assigns a suitable balancing +-- price to the posting, if and as appropriate for the given transaction and +-- posting type (real or balanced virtual). If we cannot or should not infer +-- prices, just act as the identity on postings. +priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting) +priceInferrerFor t pt = maybe id inferprice inferFromAndTo + where + postings = filter ((==pt).ptype) $ tpostings t + pcommodities = map acommodity $ concatMap (amounts . pamount) postings + sumamounts = amounts $ sumPostings postings -- amounts normalises to one amount per commodity & price + + -- We can infer prices if there are no prices given, exactly two commodities in the normalised + -- sum of postings in this transaction, and these two have opposite signs. The amount we are + -- converting from is the first commodity to appear in the ordered list of postings, and the + -- commodity we are converting to is the other. If we cannot infer prices, return Nothing. + inferFromAndTo = case sumamounts of + [a,b] | noprices, oppositesigns -> asum $ map orderIfMatches pcommodities + where + noprices = all (isNothing . aprice) sumamounts + oppositesigns = signum (aquantity a) /= signum (aquantity b) + orderIfMatches x | x == acommodity a = Just (a,b) + | x == acommodity b = Just (b,a) + | otherwise = Nothing + _ -> Nothing + + -- For each posting, if the posting type matches, there is only a single amount in the posting, + -- and the commodity of the amount matches the amount we're converting from, + -- then set its price based on the ratio between fromamount and toamount. + inferprice (fromamount, toamount) posting + | [a] <- amounts (pamount posting), ptype posting == pt, acommodity a == acommodity fromamount + = posting{ pamount = mixedAmount a{aprice=Just conversionprice} + , poriginal = Just $ originalPosting posting } + | otherwise = posting + where + -- If only one Amount in the posting list matches fromamount we can use TotalPrice. + -- Otherwise divide the conversion equally among the Amounts by using a unit price. + conversionprice = case filter (== acommodity fromamount) pcommodities of + [_] -> TotalPrice $ negate toamount + _ -> UnitPrice $ negate unitprice `withPrecision` unitprecision + + unitprice = aquantity fromamount `divideAmount` toamount + unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of + (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b + _ -> NaturalPrecision + saturatedAdd a b = if maxBound - a < b then maxBound else a + b + + +-- | Check any balance assertions in the journal and return an error message +-- if any of them fail (or if the transaction balancing they require fails). +journalCheckBalanceAssertions :: Journal -> Maybe String +journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTransactions defbalancingopts + +-- "Transaction balancing", including: inferring missing amounts, +-- applying balance assignments, checking transaction balancedness, +-- checking balance assertions, respecting posting dates. These things +-- are all interdependent. +-- WARN tricky algorithm and code ahead. +-- +-- Code overview as of 20190219, this could/should be simplified/documented more: +-- parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), journalAddBudgetGoalTransactions (BudgetReport.hs), tests (BalanceReport.hs) +-- journalBalanceTransactions +-- runST +-- runExceptT +-- balanceTransaction (Transaction.hs) +-- balanceTransactionHelper +-- runReaderT +-- 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 (Transaction.hs) XXX hledger add won't allow balance assignments + missing amount ? + +-- | 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 -- ^ a mutable array of the transactions being balanced + -- (for efficiency ? journalBalanceTransactions says: not strictly necessary but avoids a sort at the end I think) + } + +-- | Access the current balancing state, and possibly modify the mutable bits, +-- lifting through the Except and Reader layers into the Balancing monad. +withRunningBalance :: (BalancingState s -> ST s a) -> Balancing s a +withRunningBalance f = ask >>= lift . lift . f + +-- | Get this account's current exclusive running balance. +getRunningBalanceB :: AccountName -> Balancing s MixedAmount +getRunningBalanceB acc = withRunningBalance $ \BalancingState{bsBalances} -> do + fromMaybe nullmixedamt <$> H.lookup bsBalances acc + +-- | Add this amount to this account's exclusive running balance. +-- Returns the new running balance. +addToRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount +addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do + old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc + let new = maPlus old amt + H.insert bsBalances acc new + return new + +-- | Set this account's exclusive running balance to this amount. +-- Returns the change in exclusive running balance. +setRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount +setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do + old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc + H.insert bsBalances acc amt + return $ maMinus amt old + +-- | Set this account's exclusive running balance to whatever amount +-- makes its *inclusive* running balance (the sum of exclusive running +-- balances of this account and any subaccounts) be the given amount. +-- Returns the change in exclusive running balance. +setInclusiveRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount +setInclusiveRunningBalanceB acc newibal = withRunningBalance $ \BalancingState{bsBalances} -> do + oldebal <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc + allebals <- H.toList bsBalances + let subsibal = -- sum of any subaccounts' running balances + maSum . map snd $ filter ((acc `isAccountNamePrefixOf`).fst) allebals + let newebal = maMinus newibal subsibal + H.insert bsBalances acc newebal + return $ maMinus newebal oldebal + +-- | Update (overwrite) this transaction in the balancing state. +updateTransactionB :: Transaction -> Balancing s () +updateTransactionB t = withRunningBalance $ \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 +-- (just the first error encountered). +-- +-- Assumes journalInferCommodityStyles has been called, since those +-- affect transaction balancing. +-- +-- This does multiple things at once because amount inferring, balance +-- assignments, balance assertions and posting dates are interdependent. +journalBalanceTransactions :: BalancingOpts -> Journal -> Either String Journal +journalBalanceTransactions bopts' j' = + let + -- ensure transactions are numbered, so we can store them by number + j@Journal{jtxns=ts} = journalNumberTransactions j' + -- display precisions used in balanced checking + styles = Just $ journalCommodityStyles j + bopts = bopts'{commodity_styles_=styles} + -- balance assignments will not be allowed on these + txnmodifieraccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j + in + runST $ do + -- 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, toInteger $ length ts) ts + + -- Infer missing posting amounts, check transactions are balanced, + -- and check balance assertions. This is done in two passes: + runExceptT $ do + + -- 1. Step through the transactions, balancing the ones which don't have balance assignments + -- and leaving the others for later. The balanced ones are split into their postings. + -- The postings and not-yet-balanced transactions remain in the same relative order. + psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case + t | null $ assignmentPostings t -> case balanceTransaction bopts t of + Left e -> throwError e + Right t' -> do + lift $ writeArray balancedtxns (tindex t') t' + return $ map Left $ tpostings t' + t -> return [Right t] + + -- 2. Sort these items by date, preserving the order of same-day items, + -- and step through them while keeping running account balances, + runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j) + flip runReaderT (BalancingState styles txnmodifieraccts (not $ ignore_assertions_ bopts) runningbals balancedtxns) $ do + -- performing balance assignments in, and balancing, the remaining transactions, + -- and checking balance assertions as each posting is processed. + void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts + + ts' <- lift $ getElems balancedtxns + return j{jtxns=ts'} + +-- | 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). +-- 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 $ postingStripPrices p +balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do + -- make sure we can handle the balance assignments + mapM_ checkIllegalBalanceAssignmentB ps + -- 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' <- mapM (addOrAssignAmountAndCheckAssertionB . postingStripPrices) ps + -- infer any remaining missing amounts, and make sure the transaction is now fully balanced + styles <- R.reader bsStyles + case balanceTransactionHelper defbalancingopts{commodity_styles_=styles} t{tpostings=ps'} of + Left err -> throwError err + Right (t', inferredacctsandamts) -> do + -- for each amount just inferred, update the running balance + mapM_ (uncurry addToRunningBalanceB) inferredacctsandamts + -- and save the balanced transaction. + updateTransactionB t' + +-- | 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} + -- an explicit posting amount + | hasAmount p = do + newbal <- addToRunningBalanceB acc amt + whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal + return p + + -- no explicit posting amount, but there is a balance assignment + | Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do + newbal <- if batotal + -- a total balance assignment (==, all commodities) + then return $ mixedAmount baamount + -- a partial balance assignment (=, one commodity) + else do + oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getRunningBalanceB acc + return $ maAddAmount oldbalothercommodities baamount + diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal + let p' = p{pamount=diff, poriginal=Just $ originalPosting p} + whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal + return p' + + -- no explicit posting amount, no balance assignment + | otherwise = 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 <- addToRunningBalanceB (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. +-- If the assertion is partial, unasserted commodities in the actual balance +-- are ignored; if it is total, they will cause the assertion to fail. +checkBalanceAssertionB :: Posting -> MixedAmount -> Balancing s () +checkBalanceAssertionB p@Posting{pbalanceassertion=Just (BalanceAssertion{baamount,batotal})} actualbal = + forM_ (baamount : otheramts) $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal + where + assertedcomm = acommodity baamount + otheramts | batotal = map (\a -> a{aquantity=0}) . amountsRaw + $ filterMixedAmount ((/=assertedcomm).acommodity) actualbal + | otherwise = [] +checkBalanceAssertionB _ _ = return () + +-- | Does this (single commodity) expected balance match the amount of that +-- commodity in the given (multicommodity) actual balance ? If not, returns a +-- balance assertion failure message based on the provided posting. To match, +-- the amounts must be exactly equal (display precision is ignored here). +-- If the assertion is inclusive, the expected amount is compared with the account's +-- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance. +checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s () +checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do + 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 + withRunningBalance $ \BalancingState{bsBalances} -> + H.foldM + (\ibal (acc, amt) -> return $ + if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then maPlus ibal amt else ibal) + nullmixedamt + bsBalances + else return actualbal + let + assertedcomm = acommodity assertedamt + actualbalincomm = headDef nullamt . amountsRaw . filterMixedAmountByCommodity assertedcomm $ actualbal' + pass = + aquantity + -- traceWith (("asserted:"++).showAmountDebug) + assertedamt == + aquantity + -- traceWith (("actual:"++).showAmountDebug) + actualbalincomm + + errmsg = printf (unlines + [ "balance assertion: %s", + "\nassertion details:", + "date: %s", + "account: %s%s", + "commodity: %s", + -- "display precision: %d", + "calculated: %s", -- (at display precision: %s)", + "asserted: %s", -- (at display precision: %s)", + "difference: %s" + ]) + (case ptransaction p of + Nothing -> "?" -- shouldn't happen + Just t -> printf "%s\ntransaction:\n%s" + (showGenericSourcePos pos) + (textChomp $ showTransaction t) + :: String + where + pos = baposition $ fromJust $ pbalanceassertion p + ) + (showDate $ postingDate p) + (T.unpack $ paccount p) -- XXX pack + (if isinclusive then " (and subs)" else "" :: String) + assertedcomm + -- (asprecision $ astyle actualbalincommodity) -- should be the standard display precision I think + (show $ aquantity actualbalincomm) + -- (showAmount actualbalincommodity) + (show $ aquantity assertedamt) + -- (showAmount assertedamt) + (show $ aquantity assertedamt - aquantity actualbalincomm) + + unless 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 . T.unpack $ T.unlines + ["postings which are balance assignments may not have a custom date." + ,"Please write the posting amount explicitly, or remove the posting date:" + ,"" + ,maybe (T.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 . T.unpack $ T.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: " <> paccount p + ,"" + ,"transaction:" + ,"" + ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p + ] + +-- lenses + +makeHledgerClassyLenses ''BalancingOpts + +-- tests + +tests_Balancing :: TestTree +tests_Balancing = + testGroup "Balancing" [ + + testCase "inferBalancingAmount" $ do + (fst <$> inferBalancingAmount M.empty nulltransaction) @?= Right nulltransaction + (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?= + Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]} + (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?= + Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]} + + , testGroup "balanceTransaction" [ + testCase "detect unbalanced entry, sign error" $ + assertLeft + (balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "test" + "" + [] + [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = mixedAmount (usd 1)}])) + ,testCase "detect unbalanced entry, multiple missing amounts" $ + assertLeft $ + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "test" + "" + [] + [ posting {paccount = "a", pamount = missingmixedamt} + , posting {paccount = "b", pamount = missingmixedamt} + ]) + ,testCase "one missing amount is inferred" $ + (pamount . last . tpostings <$> + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "" + "" + [] + [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?= + Right (mixedAmount $ usd (-1)) + ,testCase "conversion price is inferred" $ + (pamount . head . tpostings <$> + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2007 01 28) + Nothing + Unmarked + "" + "" + "" + [] + [ posting {paccount = "a", pamount = mixedAmount (usd 1.35)} + , posting {paccount = "b", pamount = mixedAmount (eur (-1))} + ])) @?= + Right (mixedAmount $ usd 1.35 @@ eur 1) + ,testCase "balanceTransaction balances based on cost if there are unit prices" $ + assertRight $ + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2011 01 01) + Nothing + Unmarked + "" + "" + "" + [] + [ posting {paccount = "a", pamount = mixedAmount $ usd 1 `at` eur 2} + , posting {paccount = "a", pamount = mixedAmount $ usd (-2) `at` eur 1} + ]) + ,testCase "balanceTransaction balances based on cost if there are total prices" $ + assertRight $ + balanceTransaction defbalancingopts + (Transaction + 0 + "" + nullsourcepos + (fromGregorian 2011 01 01) + Nothing + Unmarked + "" + "" + "" + [] + [ posting {paccount = "a", pamount = mixedAmount $ usd 1 @@ eur 1} + , posting {paccount = "a", pamount = mixedAmount $ usd (-2) @@ eur (-1)} + ]) + ] + , testGroup "isTransactionBalanced" [ + testCase "detect balanced" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + ] + ,testCase "detect unbalanced" $ + assertBool "" $ + not $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.01))} + ] + ,testCase "detect unbalanced, one posting" $ + assertBool "" $ + not $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [posting {paccount = "b", pamount = mixedAmount (usd 1.00)}] + ,testCase "one zero posting is considered balanced for now" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [posting {paccount = "b", pamount = mixedAmount (usd 0)}] + ,testCase "virtual postings don't need to balance" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = VirtualPosting} + ] + ,testCase "balanced virtual postings need to balance among themselves" $ + assertBool "" $ + not $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} + ] + ,testCase "balanced virtual postings need to balance among themselves (2)" $ + assertBool "" $ + isTransactionBalanced defbalancingopts $ + Transaction + 0 + "" + nullsourcepos + (fromGregorian 2009 01 01) + Nothing + Unmarked + "" + "a" + "" + [] + [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} + , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} + , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} + , posting {paccount = "3", pamount = mixedAmount (usd (-100)), ptype = BalancedVirtualPosting} + ] + ] + + ,testGroup "journalBalanceTransactions" [ + + testCase "missing-amounts" $ do + let ej = journalBalanceTransactions defbalancingopts $ samplejournalMaybeExplicit False + assertRight ej + journalPostings <$> ej @?= Right (journalPostings samplejournal) + + ,testCase "balance-assignment" $ do + let ej = journalBalanceTransactions defbalancingopts $ + --2019/01/01 + -- (a) = 1 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] + ]} + assertRight ej + let Right j = ej + (jtxns j & head & tpostings & head & pamount & amountsRaw) @?= [num 1] + + ,testCase "same-day-1" $ do + assertRight $ journalBalanceTransactions defbalancingopts $ + --2019/01/01 + -- (a) = 1 + --2019/01/01 + -- (a) 1 = 2 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] + ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 2)) ] + ]} + + ,testCase "same-day-2" $ do + assertRight $ journalBalanceTransactions defbalancingopts $ + --2019/01/01 + -- (a) 2 = 2 + --2019/01/01 + -- b 1 + -- a + --2019/01/01 + -- a 0 = 1 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 2) (balassert (num 2)) ] + ,transaction (fromGregorian 2019 01 01) [ + post' "b" (num 1) Nothing + ,post' "a" missingamt Nothing + ] + ,transaction (fromGregorian 2019 01 01) [ post' "a" (num 0) (balassert (num 1)) ] + ]} + + ,testCase "out-of-order" $ do + assertRight $ journalBalanceTransactions defbalancingopts $ + --2019/1/2 + -- (a) 1 = 2 + --2019/1/1 + -- (a) 1 = 1 + nulljournal{ jtxns = [ + transaction (fromGregorian 2019 01 02) [ vpost' "a" (num 1) (balassert (num 2)) ] + ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 1)) ] + ]} + + ] + + ,testGroup "commodityStylesFromAmounts" $ [ + + -- Journal similar to the one on #1091: + -- 2019/09/24 + -- (a) 1,000.00 + -- + -- 2019/09/26 + -- (a) 1000,000 + -- + testCase "1091a" $ do + commodityStylesFromAmounts [ + nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} + ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} + ] + @?= + -- The commodity style should have period as decimal mark + -- and comma as digit group mark. + Right (M.fromList [ + ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) + ]) + -- same journal, entries in reverse order + ,testCase "1091b" $ do + commodityStylesFromAmounts [ + nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} + ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} + ] + @?= + -- The commodity style should have period as decimal mark + -- and comma as digit group mark. + Right (M.fromList [ + ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) + ]) + + ] + + ] diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index a532e774c..cc4aa4ae1 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,7 +19,6 @@ module Hledger.Data.Journal ( addTransactionModifier, addPeriodicTransaction, addTransaction, - journalBalanceTransactions, journalInferMarketPricesFromTransactions, journalApplyCommodityStyles, commodityStylesFromAmounts, @@ -86,34 +83,28 @@ module Hledger.Data.Journal ( -- * Misc canonicalStyleFrom, nulljournal, - journalCheckBalanceAssertions, + journalNumberTransactions, journalNumberAndTieTransactions, journalUntieTransactions, journalModifyTransactions, journalApplyAliases, -- * Tests samplejournal, - tests_Journal, + samplejournalMaybeExplicit, + tests_Journal ) where import Control.Applicative ((<|>)) -import Control.Monad.Except (ExceptT(..), runExceptT, throwError) -import "extra" Control.Monad.Extra (whenM) -import Control.Monad.Reader as R -import Control.Monad.ST (ST, runST) +import Control.Monad.Except (ExceptT(..)) import Control.Monad.State.Strict (StateT) -import Data.Array.ST (STArray, getElems, newListArray, writeArray) import Data.Char (toUpper, isDigit) import Data.Default (Default(..)) import Data.Foldable (toList) -import Data.Function ((&)) -import qualified Data.HashTable.Class as H (toList) -import qualified Data.HashTable.ST.Cuckoo as H -import Data.List ((\\), find, foldl', sortBy, sortOn) +import Data.List ((\\), find, foldl', sortBy) import Data.List.Extra (nubSort) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe, maybeToList) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -129,7 +120,6 @@ import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount -import Hledger.Data.Dates import Hledger.Data.Transaction import Hledger.Data.TransactionModifier import Hledger.Data.Posting @@ -734,339 +724,6 @@ journalModifyTransactions d j = Right ts -> Right j{jtxns=ts} Left err -> Left err --- | Check any balance assertions in the journal and return an error message --- if any of them fail (or if the transaction balancing they require fails). -journalCheckBalanceAssertions :: Journal -> Maybe String -journalCheckBalanceAssertions = either Just (const Nothing) . journalBalanceTransactions defbalancingopts - --- "Transaction balancing", including: inferring missing amounts, --- applying balance assignments, checking transaction balancedness, --- checking balance assertions, respecting posting dates. These things --- are all interdependent. --- WARN tricky algorithm and code ahead. --- --- Code overview as of 20190219, this could/should be simplified/documented more: --- parseAndFinaliseJournal['] (Cli/Utils.hs), journalAddForecast (Common.hs), journalAddBudgetGoalTransactions (BudgetReport.hs), tests (BalanceReport.hs) --- journalBalanceTransactions --- runST --- runExceptT --- balanceTransaction (Transaction.hs) --- balanceTransactionHelper --- runReaderT --- 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 (Transaction.hs) XXX hledger add won't allow balance assignments + missing amount ? - --- | 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 -- ^ a mutable array of the transactions being balanced - -- (for efficiency ? journalBalanceTransactions says: not strictly necessary but avoids a sort at the end I think) - } - --- | Access the current balancing state, and possibly modify the mutable bits, --- lifting through the Except and Reader layers into the Balancing monad. -withRunningBalance :: (BalancingState s -> ST s a) -> Balancing s a -withRunningBalance f = ask >>= lift . lift . f - --- | Get this account's current exclusive running balance. -getRunningBalanceB :: AccountName -> Balancing s MixedAmount -getRunningBalanceB acc = withRunningBalance $ \BalancingState{bsBalances} -> do - fromMaybe nullmixedamt <$> H.lookup bsBalances acc - --- | Add this amount to this account's exclusive running balance. --- Returns the new running balance. -addToRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount -addToRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do - old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc - let new = maPlus old amt - H.insert bsBalances acc new - return new - --- | Set this account's exclusive running balance to this amount. --- Returns the change in exclusive running balance. -setRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount -setRunningBalanceB acc amt = withRunningBalance $ \BalancingState{bsBalances} -> do - old <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc - H.insert bsBalances acc amt - return $ maMinus amt old - --- | Set this account's exclusive running balance to whatever amount --- makes its *inclusive* running balance (the sum of exclusive running --- balances of this account and any subaccounts) be the given amount. --- Returns the change in exclusive running balance. -setInclusiveRunningBalanceB :: AccountName -> MixedAmount -> Balancing s MixedAmount -setInclusiveRunningBalanceB acc newibal = withRunningBalance $ \BalancingState{bsBalances} -> do - oldebal <- fromMaybe nullmixedamt <$> H.lookup bsBalances acc - allebals <- H.toList bsBalances - let subsibal = -- sum of any subaccounts' running balances - maSum . map snd $ filter ((acc `isAccountNamePrefixOf`).fst) allebals - let newebal = maMinus newibal subsibal - H.insert bsBalances acc newebal - return $ maMinus newebal oldebal - --- | Update (overwrite) this transaction in the balancing state. -updateTransactionB :: Transaction -> Balancing s () -updateTransactionB t = withRunningBalance $ \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 --- (just the first error encountered). --- --- Assumes journalInferCommodityStyles has been called, since those --- affect transaction balancing. --- --- This does multiple things at once because amount inferring, balance --- assignments, balance assertions and posting dates are interdependent. -journalBalanceTransactions :: BalancingOpts -> Journal -> Either String Journal -journalBalanceTransactions bopts' j' = - let - -- ensure transactions are numbered, so we can store them by number - j@Journal{jtxns=ts} = journalNumberTransactions j' - -- display precisions used in balanced checking - styles = Just $ journalCommodityStyles j - bopts = bopts'{commodity_styles_=styles} - -- balance assignments will not be allowed on these - txnmodifieraccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j - in - runST $ do - -- 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, toInteger $ length ts) ts - - -- Infer missing posting amounts, check transactions are balanced, - -- and check balance assertions. This is done in two passes: - runExceptT $ do - - -- 1. Step through the transactions, balancing the ones which don't have balance assignments - -- and leaving the others for later. The balanced ones are split into their postings. - -- The postings and not-yet-balanced transactions remain in the same relative order. - psandts :: [Either Posting Transaction] <- fmap concat $ forM ts $ \case - t | null $ assignmentPostings t -> case balanceTransaction bopts t of - Left e -> throwError e - Right t' -> do - lift $ writeArray balancedtxns (tindex t') t' - return $ map Left $ tpostings t' - t -> return [Right t] - - -- 2. Sort these items by date, preserving the order of same-day items, - -- and step through them while keeping running account balances, - runningbals <- lift $ H.newSized (length $ journalAccountNamesUsed j) - flip runReaderT (BalancingState styles txnmodifieraccts (not $ ignore_assertions_ bopts) runningbals balancedtxns) $ do - -- performing balance assignments in, and balancing, the remaining transactions, - -- and checking balance assertions as each posting is processed. - void $ mapM' balanceTransactionAndCheckAssertionsB $ sortOn (either postingDate tdate) psandts - - ts' <- lift $ getElems balancedtxns - return j{jtxns=ts'} - --- | 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). --- 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 $ postingStripPrices p -balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do - -- make sure we can handle the balance assignments - mapM_ checkIllegalBalanceAssignmentB ps - -- 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' <- mapM (addOrAssignAmountAndCheckAssertionB . postingStripPrices) ps - -- infer any remaining missing amounts, and make sure the transaction is now fully balanced - styles <- R.reader bsStyles - case balanceTransactionHelper defbalancingopts{commodity_styles_=styles} t{tpostings=ps'} of - Left err -> throwError err - Right (t', inferredacctsandamts) -> do - -- for each amount just inferred, update the running balance - mapM_ (uncurry addToRunningBalanceB) inferredacctsandamts - -- and save the balanced transaction. - updateTransactionB t' - --- | 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} - -- an explicit posting amount - | hasAmount p = do - newbal <- addToRunningBalanceB acc amt - whenM (R.reader bsAssrt) $ checkBalanceAssertionB p newbal - return p - - -- no explicit posting amount, but there is a balance assignment - | Just BalanceAssertion{baamount,batotal,bainclusive} <- mba = do - newbal <- if batotal - -- a total balance assignment (==, all commodities) - then return $ mixedAmount baamount - -- a partial balance assignment (=, one commodity) - else do - oldbalothercommodities <- filterMixedAmount ((acommodity baamount /=) . acommodity) <$> getRunningBalanceB acc - return $ maAddAmount oldbalothercommodities baamount - diff <- (if bainclusive then setInclusiveRunningBalanceB else setRunningBalanceB) acc newbal - let p' = p{pamount=diff, poriginal=Just $ originalPosting p} - whenM (R.reader bsAssrt) $ checkBalanceAssertionB p' newbal - return p' - - -- no explicit posting amount, no balance assignment - | otherwise = 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 <- addToRunningBalanceB (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. --- If the assertion is partial, unasserted commodities in the actual balance --- are ignored; if it is total, they will cause the assertion to fail. -checkBalanceAssertionB :: Posting -> MixedAmount -> Balancing s () -checkBalanceAssertionB p@Posting{pbalanceassertion=Just (BalanceAssertion{baamount,batotal})} actualbal = - forM_ (baamount : otheramts) $ \amt -> checkBalanceAssertionOneCommodityB p amt actualbal - where - assertedcomm = acommodity baamount - otheramts | batotal = map (\a -> a{aquantity=0}) . amountsRaw - $ filterMixedAmount ((/=assertedcomm).acommodity) actualbal - | otherwise = [] -checkBalanceAssertionB _ _ = return () - --- | Does this (single commodity) expected balance match the amount of that --- commodity in the given (multicommodity) actual balance ? If not, returns a --- balance assertion failure message based on the provided posting. To match, --- the amounts must be exactly equal (display precision is ignored here). --- If the assertion is inclusive, the expected amount is compared with the account's --- subaccount-inclusive balance; otherwise, with the subaccount-exclusive balance. -checkBalanceAssertionOneCommodityB :: Posting -> Amount -> MixedAmount -> Balancing s () -checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt actualbal = do - 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 - withRunningBalance $ \BalancingState{bsBalances} -> - H.foldM - (\ibal (acc, amt) -> return $ - if assertedacct==acc || assertedacct `isAccountNamePrefixOf` acc then maPlus ibal amt else ibal) - nullmixedamt - bsBalances - else return actualbal - let - assertedcomm = acommodity assertedamt - actualbalincomm = headDef nullamt . amountsRaw . filterMixedAmountByCommodity assertedcomm $ actualbal' - pass = - aquantity - -- traceWith (("asserted:"++).showAmountDebug) - assertedamt == - aquantity - -- traceWith (("actual:"++).showAmountDebug) - actualbalincomm - - errmsg = printf (unlines - [ "balance assertion: %s", - "\nassertion details:", - "date: %s", - "account: %s%s", - "commodity: %s", - -- "display precision: %d", - "calculated: %s", -- (at display precision: %s)", - "asserted: %s", -- (at display precision: %s)", - "difference: %s" - ]) - (case ptransaction p of - Nothing -> "?" -- shouldn't happen - Just t -> printf "%s\ntransaction:\n%s" - (showGenericSourcePos pos) - (textChomp $ showTransaction t) - :: String - where - pos = baposition $ fromJust $ pbalanceassertion p - ) - (showDate $ postingDate p) - (T.unpack $ paccount p) -- XXX pack - (if isinclusive then " (and subs)" else "" :: String) - assertedcomm - -- (asprecision $ astyle actualbalincommodity) -- should be the standard display precision I think - (show $ aquantity actualbalincomm) - -- (showAmount actualbalincommodity) - (show $ aquantity assertedamt) - -- (showAmount assertedamt) - (show $ aquantity assertedamt - aquantity actualbalincomm) - - unless 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 . T.unpack $ T.unlines - ["postings which are balance assignments may not have a custom date." - ,"Please write the posting amount explicitly, or remove the posting date:" - ,"" - ,maybe (T.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 . T.unpack $ T.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: " <> paccount p - ,"" - ,"transaction:" - ,"" - ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p - ] - -- -- | Choose and apply a consistent display style to the posting @@ -1394,8 +1051,9 @@ journalApplyAliases aliases j = -- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps -- tests - --- A sample journal for testing, similar to examples/sample.journal: +-- +-- A sample journal for testing, similar to examples/sample.journal. +-- Provide an option to either use explicit amounts or missing amounts, for testing purposes. -- -- 2008/01/01 income -- assets:bank:checking $1 @@ -1421,9 +1079,11 @@ journalApplyAliases aliases j = -- 2008/12/31 * pay off -- liabilities:debts $1 -- assets:bank:checking --- -Right samplejournal = journalBalanceTransactions defbalancingopts $ - nulljournal + +samplejournal = samplejournalMaybeExplicit True + +samplejournalMaybeExplicit :: Bool -> Journal +samplejournalMaybeExplicit explicit = nulljournal {jtxns = [ txnTieKnot $ Transaction { tindex=0, @@ -1437,7 +1097,7 @@ Right samplejournal = journalBalanceTransactions defbalancingopts $ ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 - ,"income:salary" `post` missingamt + ,"income:salary" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } @@ -1454,7 +1114,7 @@ Right samplejournal = journalBalanceTransactions defbalancingopts $ ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 - ,"income:gifts" `post` missingamt + ,"income:gifts" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } @@ -1471,7 +1131,7 @@ Right samplejournal = journalBalanceTransactions defbalancingopts $ ttags=[], tpostings= ["assets:bank:saving" `post` usd 1 - ,"assets:bank:checking" `post` usd (-1) + ,"assets:bank:checking" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } @@ -1488,7 +1148,7 @@ Right samplejournal = journalBalanceTransactions defbalancingopts $ ttags=[], tpostings=["expenses:food" `post` usd 1 ,"expenses:supplies" `post` usd 1 - ,"assets:cash" `post` missingamt + ,"assets:cash" `post` if explicit then usd (-2) else missingamt ], tprecedingcomment="" } @@ -1520,7 +1180,7 @@ Right samplejournal = journalBalanceTransactions defbalancingopts $ tcomment="", ttags=[], tpostings=["liabilities:debts" `post` usd 1 - ,"assets:bank:checking" `post` usd (-1) + ,"assets:bank:checking" `post` if explicit then usd (-1) else missingamt ], tprecedingcomment="" } @@ -1547,109 +1207,17 @@ tests_Journal = testGroup "Journal" [ journalAccountNamesMatching :: Query -> Journal -> [AccountName] journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames namesfrom qfunc = journalAccountNamesMatching (qfunc j) j - in [ - testCase "assets" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] + in [testCase "assets" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] (namesfrom journalAssetAccountQuery) - ,testCase "cash" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] - (namesfrom journalCashAccountQuery) - ,testCase "liabilities" $ assertEqual "" ["liabilities","liabilities:debts"] - (namesfrom journalLiabilityAccountQuery) - ,testCase "equity" $ assertEqual "" [] - (namesfrom journalEquityAccountQuery) - ,testCase "income" $ assertEqual "" ["income","income:gifts","income:salary"] - (namesfrom journalRevenueAccountQuery) - ,testCase "expenses" $ assertEqual "" ["expenses","expenses:food","expenses:supplies"] - (namesfrom journalExpenseAccountQuery) - ] - - ,testGroup "journalBalanceTransactions" [ - - testCase "balance-assignment" $ do - let ej = journalBalanceTransactions defbalancingopts $ - --2019/01/01 - -- (a) = 1 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] - ]} - assertRight ej - let Right j = ej - (jtxns j & head & tpostings & head & pamount & amountsRaw) @?= [num 1] - - ,testCase "same-day-1" $ do - assertRight $ journalBalanceTransactions defbalancingopts $ - --2019/01/01 - -- (a) = 1 - --2019/01/01 - -- (a) 1 = 2 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] - ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 2)) ] - ]} - - ,testCase "same-day-2" $ do - assertRight $ journalBalanceTransactions defbalancingopts $ - --2019/01/01 - -- (a) 2 = 2 - --2019/01/01 - -- b 1 - -- a - --2019/01/01 - -- a 0 = 1 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 2) (balassert (num 2)) ] - ,transaction (fromGregorian 2019 01 01) [ - post' "b" (num 1) Nothing - ,post' "a" missingamt Nothing - ] - ,transaction (fromGregorian 2019 01 01) [ post' "a" (num 0) (balassert (num 1)) ] - ]} - - ,testCase "out-of-order" $ do - assertRight $ journalBalanceTransactions defbalancingopts $ - --2019/1/2 - -- (a) 1 = 2 - --2019/1/1 - -- (a) 1 = 1 - nulljournal{ jtxns = [ - transaction (fromGregorian 2019 01 02) [ vpost' "a" (num 1) (balassert (num 2)) ] - ,transaction (fromGregorian 2019 01 01) [ vpost' "a" (num 1) (balassert (num 1)) ] - ]} - - ] - - ,testGroup "commodityStylesFromAmounts" $ [ - - -- Journal similar to the one on #1091: - -- 2019/09/24 - -- (a) 1,000.00 - -- - -- 2019/09/26 - -- (a) 1000,000 - -- - testCase "1091a" $ do - commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} - ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} - ] - @?= - -- The commodity style should have period as decimal mark - -- and comma as digit group mark. - Right (M.fromList [ - ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) - ]) - -- same journal, entries in reverse order - ,testCase "1091b" $ do - commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} - ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} - ] - @?= - -- The commodity style should have period as decimal mark - -- and comma as digit group mark. - Right (M.fromList [ - ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) - ]) - - ] - + ,testCase "cash" $ assertEqual "" ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] + (namesfrom journalCashAccountQuery) + ,testCase "liabilities" $ assertEqual "" ["liabilities","liabilities:debts"] + (namesfrom journalLiabilityAccountQuery) + ,testCase "equity" $ assertEqual "" [] + (namesfrom journalEquityAccountQuery) + ,testCase "income" $ assertEqual "" ["income","income:gifts","income:salary"] + (namesfrom journalRevenueAccountQuery) + ,testCase "expenses" $ assertEqual "" ["expenses","expenses:food","expenses:supplies"] + (namesfrom journalExpenseAccountQuery) + ] ] diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 1c8ac0e88..ae5e4defa 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -7,69 +7,54 @@ tags. -} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Hledger.Data.Transaction ( - -- * Transaction - nulltransaction, - transaction, - txnTieKnot, - txnUntieKnot, - transactionCheckBalanced, +module Hledger.Data.Transaction +( -- * Transaction + nulltransaction +, transaction +, txnTieKnot +, txnUntieKnot -- * operations - showAccountName, - hasRealPostings, - realPostings, - assignmentPostings, - virtualPostings, - balancedVirtualPostings, - transactionsPostings, - BalancingOpts(..), - HasBalancingOpts(..), - defbalancingopts, - isTransactionBalanced, - balanceTransaction, - balanceTransactionHelper, - transactionTransformPostings, - transactionApplyValuation, - transactionToCost, - transactionApplyAliases, - transactionMapPostings, - transactionMapPostingAmounts, - -- nonzerobalanceerror, +, showAccountName +, hasRealPostings +, realPostings +, assignmentPostings +, virtualPostings +, balancedVirtualPostings +, transactionsPostings +, transactionTransformPostings +, transactionApplyValuation +, transactionToCost +, transactionApplyAliases +, transactionMapPostings +, transactionMapPostingAmounts + -- nonzerobalanceerror -- * date operations - transactionDate2, +, transactionDate2 -- * transaction description parts - transactionPayee, - transactionNote, - -- payeeAndNoteFromDescription, +, transactionPayee +, transactionNote + -- payeeAndNoteFromDescription -- * rendering - showTransaction, - showTransactionOneLineAmounts, - -- showPostingLine, - showPostingLines, +, showTransaction +, showTransactionOneLineAmounts + -- showPostingLine +, showPostingLines -- * GenericSourcePos - sourceFilePath, - sourceFirstLine, - showGenericSourcePos, - annotateErrorWithTransaction, - transactionFile, +, sourceFilePath +, sourceFirstLine +, showGenericSourcePos +, transactionFile -- * tests - tests_Transaction -) -where +, tests_Transaction +) where import Data.Default (Default(..)) -import Data.Foldable (asum) -import Data.List (intercalate, partition) -import Data.List.Extra (nubSort) -import Data.Maybe (fromMaybe, isNothing, mapMaybe) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -356,260 +341,6 @@ balancedVirtualPostings = filter isBalancedVirtual . tpostings transactionsPostings :: [Transaction] -> [Posting] transactionsPostings = concatMap tpostings -data BalancingOpts = BalancingOpts - { ignore_assertions_ :: Bool -- ^ Ignore balance assertions - , infer_transaction_prices_ :: Bool -- ^ Infer prices in unbalanced multicommodity amounts - , commodity_styles_ :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ commodity display styles - } deriving (Show) - -defbalancingopts :: BalancingOpts -defbalancingopts = BalancingOpts - { ignore_assertions_ = False - , infer_transaction_prices_ = True - , commodity_styles_ = Nothing - } - --- | Check that this transaction would appear balanced to a human when displayed. --- On success, returns the empty list, otherwise one or more error messages. --- --- In more detail: --- For the real postings, and separately for the balanced virtual postings: --- --- 1. Convert amounts to cost where possible --- --- 2. When there are two or more non-zero amounts --- (appearing non-zero when displayed, using the given display styles if provided), --- are they a mix of positives and negatives ? --- This is checked separately to give a clearer error message. --- (Best effort; could be confused by postings with multicommodity amounts.) --- --- 3. Does the amounts' sum appear non-zero when displayed ? --- (using the given display styles if provided) --- -transactionCheckBalanced :: BalancingOpts -> Transaction -> [String] -transactionCheckBalanced BalancingOpts{commodity_styles_} t = errs - where - (rps, bvps) = foldr partitionPosting ([], []) $ tpostings t - where - partitionPosting p ~(l, r) = case ptype p of - RegularPosting -> (p:l, r) - BalancedVirtualPosting -> (l, p:r) - VirtualPosting -> (l, r) - - -- check for mixed signs, detecting nonzeros at display precision - canonicalise = maybe id canonicaliseMixedAmount commodity_styles_ - signsOk ps = - case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of - nonzeros | length nonzeros >= 2 - -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 - _ -> True - (rsignsok, bvsignsok) = (signsOk rps, signsOk bvps) - - -- check for zero sum, at display precision - (rsum, bvsum) = (sumPostings rps, sumPostings bvps) - (rsumcost, bvsumcost) = (mixedAmountCost rsum, mixedAmountCost bvsum) - (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost) - (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) - - -- generate error messages, showing amounts with their original precision - errs = filter (not.null) [rmsg, bvmsg] - where - rmsg - | rsumok = "" - | not rsignsok = "real postings all have the same sign" - | otherwise = "real postings' sum should be 0 but is: " ++ showMixedAmount rsumcost - bvmsg - | bvsumok = "" - | not bvsignsok = "balanced virtual postings all have the same sign" - | otherwise = "balanced virtual postings' sum should be 0 but is: " ++ showMixedAmount bvsumcost - --- | Legacy form of transactionCheckBalanced. -isTransactionBalanced :: BalancingOpts -> Transaction -> Bool -isTransactionBalanced bopts = null . transactionCheckBalanced bopts - --- | 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 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 :: - BalancingOpts - -> Transaction - -> Either String Transaction -balanceTransaction bopts = fmap fst . balanceTransactionHelper bopts - --- | Helper used by balanceTransaction and balanceTransactionWithBalanceAssignmentAndCheckAssertionsB; --- use one of those instead. It also returns a list of accounts --- and amounts that were inferred. -balanceTransactionHelper :: - BalancingOpts - -> Transaction - -> Either String (Transaction, [(AccountName, MixedAmount)]) -balanceTransactionHelper bopts t = do - (t', inferredamtsandaccts) <- inferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) $ - if infer_transaction_prices_ bopts then inferBalancingPrices t else t - case transactionCheckBalanced bopts t' of - [] -> Right (txnTieKnot t', inferredamtsandaccts) - errs -> Left $ transactionBalanceError t' errs - --- | Generate a transaction balancing error message, given the transaction --- and one or more suberror messages. -transactionBalanceError :: Transaction -> [String] -> String -transactionBalanceError t errs = - annotateErrorWithTransaction t $ - intercalate "\n" $ "could not balance this transaction:" : errs - -annotateErrorWithTransaction :: Transaction -> String -> String -annotateErrorWithTransaction t s = - unlines [ showGenericSourcePos $ tsourcepos t, s - , T.unpack . T.stripEnd $ showTransaction 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 --- message if we can't. Returns the updated transaction and any inferred posting amounts, --- with the corresponding accounts, in order). --- --- 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 :: - M.Map CommoditySymbol AmountStyle -- ^ commodity display styles - -> Transaction - -> Either String (Transaction, [(AccountName, MixedAmount)]) -inferBalancingAmount styles t@Transaction{tpostings=ps} - | length amountlessrealps > 1 - = Left $ transactionBalanceError t - ["can't have more than one real posting with no amount" - ,"(remember to put two or more spaces between account and amount)"] - | length amountlessbvps > 1 - = Left $ transactionBalanceError t - ["can't have more than one balanced virtual posting with no amount" - ,"(remember to put two or more spaces between account and amount)"] - | otherwise - = let psandinferredamts = map inferamount ps - inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts] - in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts) - where - (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t) - realsum = sumPostings amountfulrealps - (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t) - bvsum = sumPostings amountfulbvps - - inferamount :: Posting -> (Posting, Maybe MixedAmount) - inferamount p = - let - minferredamt = case ptype p of - RegularPosting | not (hasAmount p) -> Just realsum - BalancedVirtualPosting | not (hasAmount p) -> Just bvsum - _ -> Nothing - in - case minferredamt of - Nothing -> (p, Nothing) - Just a -> (p{pamount=a', poriginal=Just $ originalPosting p}, Just a') - where - -- Inferred amounts are converted to cost. - -- Also ensure the new amount has the standard style for its commodity - -- (since the main amount styling pass happened before this balancing pass); - a' = styleMixedAmount styles . mixedAmountCost $ maNegate a - --- | 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 - ps' = map (priceInferrerFor t BalancedVirtualPosting . priceInferrerFor t RegularPosting) ps - --- | Generate a posting update function which assigns a suitable balancing --- price to the posting, if and as appropriate for the given transaction and --- posting type (real or balanced virtual). If we cannot or should not infer --- prices, just act as the identity on postings. -priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting) -priceInferrerFor t pt = maybe id inferprice inferFromAndTo - where - postings = filter ((==pt).ptype) $ tpostings t - pcommodities = map acommodity $ concatMap (amounts . pamount) postings - sumamounts = amounts $ sumPostings postings -- amounts normalises to one amount per commodity & price - - -- We can infer prices if there are no prices given, exactly two commodities in the normalised - -- sum of postings in this transaction, and these two have opposite signs. The amount we are - -- converting from is the first commodity to appear in the ordered list of postings, and the - -- commodity we are converting to is the other. If we cannot infer prices, return Nothing. - inferFromAndTo = case sumamounts of - [a,b] | noprices, oppositesigns -> asum $ map orderIfMatches pcommodities - where - noprices = all (isNothing . aprice) sumamounts - oppositesigns = signum (aquantity a) /= signum (aquantity b) - orderIfMatches x | x == acommodity a = Just (a,b) - | x == acommodity b = Just (b,a) - | otherwise = Nothing - _ -> Nothing - - -- For each posting, if the posting type matches, there is only a single amount in the posting, - -- and the commodity of the amount matches the amount we're converting from, - -- then set its price based on the ratio between fromamount and toamount. - inferprice (fromamount, toamount) posting - | [a] <- amounts (pamount posting), ptype posting == pt, acommodity a == acommodity fromamount - = posting{ pamount = mixedAmount a{aprice=Just conversionprice} - , poriginal = Just $ originalPosting posting } - | otherwise = posting - where - -- If only one Amount in the posting list matches fromamount we can use TotalPrice. - -- Otherwise divide the conversion equally among the Amounts by using a unit price. - conversionprice = case filter (== acommodity fromamount) pcommodities of - [_] -> TotalPrice $ negate toamount - _ -> UnitPrice $ negate unitprice `withPrecision` unitprecision - - unitprice = aquantity fromamount `divideAmount` toamount - unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of - (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b - _ -> NaturalPrecision - saturatedAdd a b = if maxBound - a < b then maxBound else a + b - -- Get a transaction's secondary date, defaulting to the primary date. transactionDate2 :: Transaction -> Day transactionDate2 t = fromMaybe (tdate t) $ tdate2 t @@ -667,10 +398,6 @@ transactionFile Transaction{tsourcepos} = GenericSourcePos f _ _ -> f JournalSourcePos f _ -> f --- lenses - -makeHledgerClassyLenses ''BalancingOpts - -- tests tests_Transaction :: TestTree @@ -743,13 +470,6 @@ tests_Transaction = ] - , testCase "inferBalancingAmount" $ do - (fst <$> inferBalancingAmount M.empty nulltransaction) @?= Right nulltransaction - (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?= - Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]} - (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?= - Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]} - , testGroup "showTransaction" [ testCase "null transaction" $ showTransaction nulltransaction @?= "0000-01-01\n\n" , testCase "non-null transaction" $ showTransaction @@ -862,230 +582,4 @@ tests_Transaction = ])) @?= (T.unlines ["2010-01-01 x", " a 1 @ $2", " b", ""]) ] - , testGroup "balanceTransaction" [ - testCase "detect unbalanced entry, sign error" $ - assertLeft - (balanceTransaction defbalancingopts - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "test" - "" - [] - [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = mixedAmount (usd 1)}])) - ,testCase "detect unbalanced entry, multiple missing amounts" $ - assertLeft $ - balanceTransaction defbalancingopts - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "test" - "" - [] - [ posting {paccount = "a", pamount = missingmixedamt} - , posting {paccount = "b", pamount = missingmixedamt} - ]) - ,testCase "one missing amount is inferred" $ - (pamount . last . tpostings <$> - balanceTransaction defbalancingopts - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "" - "" - [] - [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?= - Right (mixedAmount $ usd (-1)) - ,testCase "conversion price is inferred" $ - (pamount . head . tpostings <$> - balanceTransaction defbalancingopts - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2007 01 28) - Nothing - Unmarked - "" - "" - "" - [] - [ posting {paccount = "a", pamount = mixedAmount (usd 1.35)} - , posting {paccount = "b", pamount = mixedAmount (eur (-1))} - ])) @?= - Right (mixedAmount $ usd 1.35 @@ eur 1) - ,testCase "balanceTransaction balances based on cost if there are unit prices" $ - assertRight $ - balanceTransaction defbalancingopts - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2011 01 01) - Nothing - Unmarked - "" - "" - "" - [] - [ posting {paccount = "a", pamount = mixedAmount $ usd 1 `at` eur 2} - , posting {paccount = "a", pamount = mixedAmount $ usd (-2) `at` eur 1} - ]) - ,testCase "balanceTransaction balances based on cost if there are total prices" $ - assertRight $ - balanceTransaction defbalancingopts - (Transaction - 0 - "" - nullsourcepos - (fromGregorian 2011 01 01) - Nothing - Unmarked - "" - "" - "" - [] - [ posting {paccount = "a", pamount = mixedAmount $ usd 1 @@ eur 1} - , posting {paccount = "a", pamount = mixedAmount $ usd (-2) @@ eur (-1)} - ]) - ] - , testGroup "isTransactionBalanced" [ - testCase "detect balanced" $ - assertBool "" $ - isTransactionBalanced defbalancingopts $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - ] - ,testCase "detect unbalanced" $ - assertBool "" $ - not $ - isTransactionBalanced defbalancingopts $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.01))} - ] - ,testCase "detect unbalanced, one posting" $ - assertBool "" $ - not $ - isTransactionBalanced defbalancingopts $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [posting {paccount = "b", pamount = mixedAmount (usd 1.00)}] - ,testCase "one zero posting is considered balanced for now" $ - assertBool "" $ - isTransactionBalanced defbalancingopts $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [posting {paccount = "b", pamount = mixedAmount (usd 0)}] - ,testCase "virtual postings don't need to balance" $ - assertBool "" $ - isTransactionBalanced defbalancingopts $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = VirtualPosting} - ] - ,testCase "balanced virtual postings need to balance among themselves" $ - assertBool "" $ - not $ - isTransactionBalanced defbalancingopts $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} - ] - ,testCase "balanced virtual postings need to balance among themselves (2)" $ - assertBool "" $ - isTransactionBalanced defbalancingopts $ - Transaction - 0 - "" - nullsourcepos - (fromGregorian 2009 01 01) - Nothing - Unmarked - "" - "a" - "" - [] - [ posting {paccount = "b", pamount = mixedAmount (usd 1.00)} - , posting {paccount = "c", pamount = mixedAmount (usd (-1.00))} - , posting {paccount = "d", pamount = mixedAmount (usd 100), ptype = BalancedVirtualPosting} - , posting {paccount = "3", pamount = mixedAmount (usd (-100)), ptype = BalancedVirtualPosting} - ] - ] ] diff --git a/hledger-lib/Hledger/Read/InputOptions.hs b/hledger-lib/Hledger/Read/InputOptions.hs index ae6028d7a..2b0d27482 100644 --- a/hledger-lib/Hledger/Read/InputOptions.hs +++ b/hledger-lib/Hledger/Read/InputOptions.hs @@ -18,9 +18,9 @@ import Control.Applicative ((<|>)) import Data.Time (Day, addDays) import Hledger.Data.Types -import Hledger.Data.Transaction (BalancingOpts(..), HasBalancingOpts(..), defbalancingopts) import Hledger.Data.Journal (journalEndDate) import Hledger.Data.Dates (nulldate, nulldatespan) +import Hledger.Data.Balancing (BalancingOpts(..), HasBalancingOpts(..), defbalancingopts) import Hledger.Utils (dbg2, makeHledgerClassyLenses) data InputOpts = InputOpts { diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index 650c47e92..2e10a322b 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -45,6 +45,7 @@ library Hledger.Data.Account Hledger.Data.AccountName Hledger.Data.Amount + Hledger.Data.Balancing Hledger.Data.Dates Hledger.Read.InputOptions Hledger.Data.Journal diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 91bf92d8e..b883db019 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -96,6 +96,7 @@ library: - Hledger.Data.Account - Hledger.Data.AccountName - Hledger.Data.Amount + - Hledger.Data.Balancing - Hledger.Data.Dates - Hledger.Read.InputOptions - Hledger.Data.Journal