diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index 91415797c40..1987c6f080a 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-| A simple 'Amount' is some quantity of money, shares, or anything else. It has a (possibly null) 'CommoditySymbol' and a numeric quantity: @@ -106,6 +107,7 @@ module Hledger.Data.Amount ( mixedAmountStripPrices, -- ** arithmetic mixedAmountCost, + mixedAmountCostPreservingPrecision, divideMixedAmount, multiplyMixedAmount, divideMixedAmountAndPrice, @@ -319,6 +321,13 @@ amountCost a@Amount{aquantity=q, aprice=mp} = Just (UnitPrice p@Amount{aquantity=pq}) -> p{aquantity=pq * q} Just (TotalPrice p@Amount{aquantity=pq}) -> p{aquantity=pq * signum q} +-- | Like amountCost, but then re-apply the display precision of the +-- original commodity. +amountCostPreservingPrecision :: Amount -> Amount +amountCostPreservingPrecision a@Amount{astyle=AmountStyle{asprecision}} = + a'{astyle=astyle'{asprecision=asprecision}} + where a'@Amount{astyle=astyle'} = amountCost a + -- | Replace an amount's TotalPrice, if it has one, with an equivalent UnitPrice. -- Has no effect on amounts without one. -- Also increases the unit price's display precision to show one extra decimal place, @@ -668,6 +677,11 @@ mapMixedAmount f (Mixed as) = Mixed $ map f as mixedAmountCost :: MixedAmount -> MixedAmount mixedAmountCost = mapMixedAmount amountCost +-- | Like mixedAmountCost, but then re-apply the display precision of the +-- original commodity. +mixedAmountCostPreservingPrecision :: MixedAmount -> MixedAmount +mixedAmountCostPreservingPrecision = mapMixedAmount amountCostPreservingPrecision + -- | Divide a mixed amount's quantities by a constant. divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount divideMixedAmount n = mapMixedAmount (divideAmount n) diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index fb3d14f250b..f13b998b4cf 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-| A 'Transaction' represents a movement of some commodity(ies) between two @@ -83,6 +84,7 @@ import Hledger.Data.Valuation import Text.Tabular import Text.Tabular.AsciiWide import Control.Applicative ((<|>)) +import Text.Printf (printf) sourceFilePath :: GenericSourcePos -> FilePath sourceFilePath = \case @@ -378,10 +380,41 @@ transactionCheckBalanced mglobalstyles t = errs -- of decimal places specified by its display style, from either the -- provided global display styles, or local styles inferred from just -- this transaction. + + -- Which local styles (& thence, precisions) exactly should we + -- infer from this transaction ? Since amounts are going to be + -- converted to cost, we may end up with the commodity of + -- transaction prices, so we'll need to pick a style for those too. + -- + -- Option 1: also infer styles from the price amounts, which normally isn't done. + -- canonicalise = maybe id canonicaliseMixedAmount (mglobalstyles <|> mtxnstyles) + -- where + -- mtxnstyles = dbg0 "transactionCheckBalanced mtxnstyles" $ + -- either (const Nothing) Just $ -- shouldn't get any error here, but if so just.. carry on, comparing uncanonicalised amounts XXX + -- commodityStylesFromAmounts $ concatMap postingAllAmounts $ rps ++ bvps + -- where + -- -- | Get all the individual Amounts from a posting's MixedAmount, + -- -- and all their price Amounts as well. + -- postingAllAmounts :: Posting -> [Amount] + -- postingAllAmounts p = catMaybes $ concat [[Just a, priceamount a] | a <- amounts $ pamount p] + -- where + -- priceamount Amount{aprice} = + -- case aprice of + -- Just (UnitPrice a) -> Just a + -- Just (TotalPrice a) -> Just a + -- Nothing -> Nothing + -- + -- Option 2, for amounts converted to cost, where the new commodity appears only in prices, + -- use the precision of their original commodity (by using mixedAmountCostPreservingPrecision). + (tocost,costlabel) = case mglobalstyles of + Just _ -> (mixedAmountCost,"") -- --balancing=styled + Nothing -> (mixedAmountCostPreservingPrecision,"withorigprecision") -- --balancing=exact canonicalise = maybe id canonicaliseMixedAmount (mglobalstyles <|> mtxnstyles) where - mtxnstyles = either (const Nothing) Just $ -- shouldn't get any error here, but if so just.. carry on, comparing uncanonicalised amounts XXX - commodityStylesFromAmounts $ concatMap (amounts.pamount) $ rps ++ bvps + mtxnstyles = dbg9 "transactionCheckBalanced mtxnstyles" $ + either (const Nothing) Just $ -- shouldn't get an error here, but if so just don't canonicalise + commodityStylesFromAmounts $ concatMap (amounts.pamount) $ rps ++ bvps + -- check for mixed signs, detecting nonzeros at display precision signsOk ps = @@ -392,22 +425,28 @@ transactionCheckBalanced mglobalstyles t = errs (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) + (rsum, bvsum) = (dbg9 "transactionCheckBalanced rsum" $ sumPostings rps, sumPostings bvps) + (rsumcost, bvsumcost) = (dbg9 ("transactionCheckBalanced rsumcost"++costlabel) $ tocost rsum, tocost bvsum) + (rsumstyled, bvsumstyled) = (dbg9 "transactionCheckBalanced rsumstyled" $ canonicalise rsumcost, canonicalise bvsumcost) + (rsumok, bvsumok) = (mixedAmountLooksZero rsumstyled, mixedAmountLooksZero bvsumstyled) - -- generate error messages, showing amounts with their original precision + -- generate error messages errs = filter (not.null) [rmsg, bvmsg] where rmsg | not rsignsok = "real postings all have the same sign" - | not rsumok = "real postings' sum should be 0 but is: " ++ showMixedAmount (mixedAmountSetFullPrecision rsumcost) + | not rsumok = printf "real postings' sum should be %s but is %s (rounded from %s)" rsumexpected rsumactual rsumfull | otherwise = "" bvmsg | not bvsignsok = "balanced virtual postings all have the same sign" - | not bvsumok = "balanced virtual postings' sum should be 0 but is: " ++ showMixedAmount (mixedAmountSetFullPrecision bvsumcost) + | not bvsumok = printf "balanced virtual postings' sum should be %s but is %s (rounded from %s)" bvsumexpected bvsumactual bvsumfull | otherwise = "" + rsumexpected = showMixedAmountWithZeroCommodity $ mapMixedAmount (\a -> a{aquantity=0}) rsumstyled + rsumactual = showMixedAmount rsumstyled + rsumfull = showMixedAmount (mixedAmountSetFullPrecision rsumcost) + bvsumexpected = showMixedAmountWithZeroCommodity $ mapMixedAmount (\a -> a{aquantity=0}) rsumstyled + bvsumactual = showMixedAmount bvsumstyled + bvsumfull = showMixedAmount (mixedAmountSetFullPrecision bvsumcost) -- | Legacy form of transactionCheckBalanced. isTransactionBalanced :: Maybe (M.Map CommoditySymbol AmountStyle) -> Transaction -> Bool diff --git a/hledger/test/journal/transaction-balancing.test b/hledger/test/journal/transaction-balancing.test index fa167db774b..1b1f2ba3fbe 100644 --- a/hledger/test/journal/transaction-balancing.test +++ b/hledger/test/journal/transaction-balancing.test @@ -1,19 +1,43 @@ -# test some specific transaction balanced checking issues +# Test cases for balanced-transaction checking, cf #1479 -# Old journal entries dependent on commodity directives for balancing (#1479) < commodity $0.00 2021-01-01 move a lot elsewhere, adjusting cost basis due to fees - assets:investments1 AAAA -11.0 @ $0.093735 - expenses:fees AAAA 0.6 - equity:basis adjustment AAAA -0.6 - assets:investments2 AAAA 10.4 @ $0.099143 + assets:investments1 A -11.0 @ B 0.093735 + expenses:fees A 0.6 + equity:basis adjustment A -0.6 + assets:investments2 A 10.4 @ B 0.099143 -# 1. fail with default "exact" balanced checking +# 1, 2. succeeds with old "styled" and new "exact" balanced checking +$ hledger -f- check --balancing=styled $ hledger -f- check ->2 /real postings' sum should be 0 but is: \$0.0000022/ ->=1 -# 2. succeed with "styled" balanced checking +< +commodity $0.00 + +2021-01-01 + a A -11.0 @ B 0.093735 + b A 10.4 @ B 0.099143 + +# 3, 4. succeeds with old and new balanced checking $ hledger -f- check --balancing=styled +$ hledger -f- check + +< +commodity B0.00 + +2021-01-01 + a A -9514.405544 @ B 0.104314 + b A 9513.805544 @ B 0.1043206 + +# 5, 6. succeeds and fails with old and new balanced checking +$ hledger -f- check --balancing=styled +$ hledger -f- check +>2 // +>= 1 + +# < +# 2021-01-01 +# a 1C @ $1.0049 +# b $-1.000