From a65ef7cd199fd8a95bdb7faa9f71cf28b332a4bb Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sun, 3 Jan 2021 22:33:01 +1100 Subject: [PATCH 1/6] lib: Consume list immediately in commodityStylesFromAmounts. This reduced the maximum heap size per thread from ~850K to ~430K in a real-world register test. --- hledger-lib/Hledger/Data/Journal.hs | 43 ++++++++++++++--------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 13a2b73aa..3a18f33a0 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -92,6 +92,7 @@ module Hledger.Data.Journal ( ) where +import Control.Applicative ((<|>)) import Control.Monad.Except (ExceptT(..), runExceptT, throwError) import "extra" Control.Monad.Extra (whenM) import Control.Monad.Reader as R @@ -102,9 +103,9 @@ import Data.Default (Default(..)) import Data.Function ((&)) import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.ST.Cuckoo as H -import Data.List (find, sortOn) -import Data.List.Extra (groupSort, nubSort) -import qualified Data.Map as M +import Data.List (find, foldl', sortOn) +import Data.List.Extra (nubSort) +import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) @@ -1109,42 +1110,40 @@ journalInferCommodityStyles j = -- and this function never reports an error. -- commodityStylesFromAmounts :: [Amount] -> Either String (M.Map CommoditySymbol AmountStyle) -commodityStylesFromAmounts amts = - Right $ M.fromList commstyles - where - commamts = groupSort [(acommodity as, as) | as <- amts] - commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts] +commodityStylesFromAmounts = + Right . foldr (\a -> M.insertWith canonicalStyle (acommodity a) (astyle a)) mempty + +-- | Given a list of amount styles (assumed to be from parsed amounts +-- in a single commodity), in parse order, choose a canonical style. +canonicalStyleFrom :: [AmountStyle] -> AmountStyle +-- canonicalStyleFrom [] = amountstyle +canonicalStyleFrom ss = foldl' canonicalStyle amountstyle ss -- TODO: should probably detect and report inconsistencies here. -- Though, we don't have the info for a good error message, so maybe elsewhere. --- | Given a list of amount styles (assumed to be from parsed amounts --- in a single commodity), in parse order, choose a canonical style. +-- | Given a pair of AmountStyles, choose a canonical style. -- This is: --- the general style of the first amount, +-- the general style of the first amount, -- with the first digit group style seen, -- with the maximum precision of all. --- -canonicalStyleFrom :: [AmountStyle] -> AmountStyle -canonicalStyleFrom [] = amountstyle -canonicalStyleFrom ss@(s:_) = - s{asprecision=prec, asdecimalpoint=Just decmark, asdigitgroups=mgrps} +canonicalStyle :: AmountStyle -> AmountStyle -> AmountStyle +canonicalStyle a b = a{asprecision=prec, asdecimalpoint=decmark, asdigitgroups=mgrps} where -- precision is maximum of all precisions - prec = maximumStrict $ map asprecision ss + prec = max (asprecision a) (asprecision b) -- identify the digit group mark (& group sizes) - mgrps = headMay $ mapMaybe asdigitgroups ss + mgrps = asdigitgroups a <|> asdigitgroups b -- if a digit group mark was identified above, we can rely on that; -- make sure the decimal mark is different. If not, default to period. - defdecmark = - case mgrps of + defdecmark = case mgrps of Just (DigitGroups '.' _) -> ',' _ -> '.' -- identify the decimal mark: the first one used, or the above default, -- but never the same character as the digit group mark. -- urgh.. refactor.. decmark = case mgrps of - Just _ -> defdecmark - _ -> headDef defdecmark $ mapMaybe asdecimalpoint ss + Just _ -> Just defdecmark + Nothing -> asdecimalpoint a <|> asdecimalpoint b <|> Just defdecmark -- -- | Apply this journal's historical price records to unpriced amounts where possible. -- journalApplyPriceDirectives :: Journal -> Journal From 2ada289e284df7ac40bd3b8e783e5ce6c587fd86 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Wed, 6 Jan 2021 20:46:31 +1100 Subject: [PATCH 2/6] lib: Include sign in TotalPrice in Amount, rather than relying on the sign of aquantity. Journal entries still require a positive @@ price, but now the sign is set after parsing, rather than when converting in amountToCost. The reason for this change is that, if we're going to perform arithmetic on Amount with TotalCost, then the presence of aquantity=0 means that amountToCost would render the total cost as 0, because signum 0 == 0. This makes journal entries like the following impossible to balance: 2000-01-01 a 0 @@ 10 A b -10 A --- hledger-lib/Hledger/Data/Amount.hs | 41 +++++++++++++------------ hledger-lib/Hledger/Data/Transaction.hs | 5 +-- hledger-lib/Hledger/Read/Common.hs | 18 +++++++---- 3 files changed, 36 insertions(+), 28 deletions(-) diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index 8027219b1..91cf2748f 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -209,7 +209,7 @@ instance Num Amount where abs a@Amount{aquantity=q} = a{aquantity=abs q} signum a@Amount{aquantity=q} = a{aquantity=signum q} fromInteger i = nullamt{aquantity=fromInteger i} - negate a@Amount{aquantity=q} = a{aquantity= -q} + negate a = transformAmountAndPrice negate a (+) = similarAmountsOp (+) (-) = similarAmountsOp (-) (*) = similarAmountsOp (*) @@ -260,14 +260,14 @@ amountWithCommodity c a = a{acommodity=c, aprice=Nothing} -- - price amounts must be MixedAmounts with exactly one component Amount -- (or there will be a runtime error XXX) -- --- - price amounts should be positive +-- - price amounts should be positive in the Journal -- (though this is currently not enforced) amountCost :: Amount -> Amount amountCost a@Amount{aquantity=q, aprice=mp} = case mp of Nothing -> a Just (UnitPrice p@Amount{aquantity=pq}) -> p{aquantity=pq * q} - Just (TotalPrice p@Amount{aquantity=pq}) -> p{aquantity=pq * signum q} + Just (TotalPrice p@Amount{aquantity=pq}) -> p{aquantity=pq} -- | Replace an amount's TotalPrice, if it has one, with an equivalent UnitPrice. -- Has no effect on amounts without one. @@ -293,21 +293,20 @@ divideAmount n a@Amount{aquantity=q} = a{aquantity=q/n} multiplyAmount :: Quantity -> Amount -> Amount multiplyAmount n a@Amount{aquantity=q} = a{aquantity=q*n} --- | Divide an amount's quantity (and its total price, if it has one) by a constant. --- The total price will be kept positive regardless of the multiplier's sign. -divideAmountAndPrice :: Quantity -> Amount -> Amount -divideAmountAndPrice n a@Amount{aquantity=q,aprice=p} = a{aquantity=q/n, aprice=f <$> p} +-- | Apply a function to an amount's quantity (and its total price, if it has one). +transformAmountAndPrice :: (Quantity -> Quantity) -> Amount -> Amount +transformAmountAndPrice f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p} where - f (TotalPrice a) = TotalPrice $ abs $ n `divideAmount` a - f p = p + f' (TotalPrice a@Amount{aquantity=pq}) = TotalPrice a{aquantity = f pq} + f' p = p + +-- | Divide an amount's quantity (and its total price, if it has one) by a constant. +divideAmountAndPrice :: Quantity -> Amount -> Amount +divideAmountAndPrice n = transformAmountAndPrice (/n) -- | Multiply an amount's quantity (and its total price, if it has one) by a constant. --- The total price will be kept positive regardless of the multiplier's sign. multiplyAmountAndPrice :: Quantity -> Amount -> Amount -multiplyAmountAndPrice n a@Amount{aquantity=q,aprice=p} = a{aquantity=q*n, aprice=f <$> p} - where - f (TotalPrice a) = TotalPrice $ abs $ n `multiplyAmount` a - f p = p +multiplyAmountAndPrice n = transformAmountAndPrice (*n) -- | Is this amount negative ? The price is ignored. isNegativeAmount :: Amount -> Bool @@ -372,10 +371,12 @@ setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalpoint=mc} } withDecimalPoint :: Amount -> Maybe Char -> Amount withDecimalPoint = flip setAmountDecimalPoint -showAmountPrice :: Maybe AmountPrice -> WideBuilder -showAmountPrice Nothing = mempty -showAmountPrice (Just (UnitPrice pa)) = WideBuilder (TB.fromString " @ ") 3 <> showAmountB noColour pa -showAmountPrice (Just (TotalPrice pa)) = WideBuilder (TB.fromString " @@ ") 4 <> showAmountB noColour pa +showAmountPrice :: Amount -> WideBuilder +showAmountPrice amt = case aprice amt of + Nothing -> mempty + Just (UnitPrice pa) -> WideBuilder (TB.fromString " @ ") 3 <> showAmountB noColour pa + Just (TotalPrice pa) -> WideBuilder (TB.fromString " @@ ") 4 <> showAmountB noColour (sign pa) + where sign = if aquantity amt < 0 then negate else id showAmountPriceDebug :: Maybe AmountPrice -> String showAmountPriceDebug Nothing = "" @@ -428,7 +429,7 @@ showAmountB opts a@Amount{astyle=style} = | otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a) space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty c' = WideBuilder (TB.fromText c) (textWidth c) - price = if displayPrice opts then showAmountPrice (aprice a) else mempty + price = if displayPrice opts then showAmountPrice a else mempty color = if displayColour opts && isNegativeAmount a then colorB Dull Red else id -- | Colour version. For a negative amount, adds ANSI codes to change the colour, @@ -874,7 +875,7 @@ tests_Amount = tests "Amount" [ amountCost (eur 1) @?= eur 1 amountCost (eur 2){aprice=Just $ UnitPrice $ usd 2} @?= usd 4 amountCost (eur 1){aprice=Just $ TotalPrice $ usd 2} @?= usd 2 - amountCost (eur (-1)){aprice=Just $ TotalPrice $ usd 2} @?= usd (-2) + amountCost (eur (-1)){aprice=Just $ TotalPrice $ usd (-2)} @?= usd (-2) ,test "amountLooksZero" $ do assertBool "" $ amountLooksZero amount diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 222f4e6c7..147d86841 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -553,8 +553,9 @@ priceInferrerFor t pt = inferprice = p{pamount=Mixed [a{aprice=Just conversionprice}], poriginal=Just $ originalPosting p} where fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe + totalpricesign = if aquantity a < 0 then negate else id conversionprice - | fromcount==1 = TotalPrice $ abs toamount `withPrecision` NaturalPrecision + | fromcount==1 = TotalPrice $ totalpricesign (abs toamount) `withPrecision` NaturalPrecision | otherwise = UnitPrice $ abs unitprice `withPrecision` unitprecision where fromcount = length $ filter ((==fromcommodity).acommodity) pamounts @@ -923,7 +924,7 @@ tests_Transaction = "" [] [ posting {paccount = "a", pamount = Mixed [usd 1 @@ eur 1]} - , posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur 1]} + , posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur (-1)]} ]) ] , tests "isTransactionBalanced" [ diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index cfe34a701..3d6731493 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -757,7 +757,7 @@ amountp = label "amount" $ do spaces = lift $ skipNonNewlineSpaces amount <- amountwithoutpricep <* spaces (mprice, _elotprice, _elotdate) <- runPermutation $ - (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp <* spaces) + (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amount <* spaces) <*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces) <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces) pure $ amount { aprice = mprice } @@ -767,7 +767,7 @@ amountpnolotpricesp = label "amount" $ do let spaces = lift $ skipNonNewlineSpaces amount <- amountwithoutpricep spaces - mprice <- optional $ priceamountp <* spaces + mprice <- optional $ priceamountp amount <* spaces pure $ amount { aprice = mprice } amountwithoutpricep :: JournalParser m Amount @@ -877,18 +877,24 @@ quotedcommoditysymbolp = simplecommoditysymbolp :: TextParser m CommoditySymbol simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar) -priceamountp :: JournalParser m AmountPrice -priceamountp = label "transaction price" $ do +priceamountp :: Amount -> JournalParser m AmountPrice +priceamountp baseAmt = label "transaction price" $ do -- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs parenthesised <- option False $ char '(' >> pure True char '@' - priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice + totalPrice <- char '@' *> pure True <|> pure False when parenthesised $ void $ char ')' lift skipNonNewlineSpaces priceAmount <- amountwithoutpricep -- "unpriced amount (specifying a price)" - pure $ priceConstructor priceAmount + let amtsign' = signum $ aquantity baseAmt + amtsign = if amtsign' == 0 then 1 else amtsign' + + pure $ if totalPrice + then TotalPrice priceAmount{aquantity=amtsign * aquantity priceAmount} + else UnitPrice priceAmount + balanceassertionp :: JournalParser m BalanceAssertion balanceassertionp = do From 81b778a3891ecc9159452082a3c2d719f58c136f Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 16 Jan 2021 21:38:16 +1100 Subject: [PATCH 3/6] lib: Make fields of Amount, AmountPrice, AmountStyle, and DigitGroupStyle strict. --- hledger-lib/Hledger/Data/Types.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 0710c4d67..1afac7ebc 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -178,16 +178,16 @@ instance ToMarkup Quantity -- | An amount's per-unit or total cost/selling price in another -- commodity, as recorded in the journal entry eg with @ or @@. -- Docs call this "transaction price". The amount is always positive. -data AmountPrice = UnitPrice Amount | TotalPrice Amount +data AmountPrice = UnitPrice !Amount | TotalPrice !Amount deriving (Eq,Ord,Generic,Show) -- | Display style for an amount. data AmountStyle = AmountStyle { - ascommodityside :: Side, -- ^ does the symbol appear on the left or the right ? - ascommodityspaced :: Bool, -- ^ space between symbol and quantity ? - asprecision :: !AmountPrecision, -- ^ number of digits displayed after the decimal point - asdecimalpoint :: Maybe Char, -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default" - asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any + ascommodityside :: !Side, -- ^ does the symbol appear on the left or the right ? + ascommodityspaced :: !Bool, -- ^ space between symbol and quantity ? + asprecision :: !AmountPrecision, -- ^ number of digits displayed after the decimal point + asdecimalpoint :: !(Maybe Char), -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default" + asdigitgroups :: !(Maybe DigitGroupStyle) -- ^ style for displaying digit groups, if any } deriving (Eq,Ord,Read,Generic) instance Show AmountStyle where @@ -211,7 +211,7 @@ data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read -- point), and the size of each group, starting with the one nearest -- the decimal point. The last group size is assumed to repeat. Eg, -- comma between thousands is DigitGroups ',' [3]. -data DigitGroupStyle = DigitGroups Char [Word8] +data DigitGroupStyle = DigitGroups !Char ![Word8] deriving (Eq,Ord,Read,Show,Generic) type CommoditySymbol = Text @@ -222,12 +222,12 @@ data Commodity = Commodity { } deriving (Show,Eq,Generic) --,Ord) data Amount = Amount { - acommodity :: CommoditySymbol, -- commodity symbol, or special value "AUTO" - aquantity :: Quantity, -- numeric quantity, or zero in case of "AUTO" - aismultiplier :: Bool, -- ^ kludge: a flag marking this amount and posting as a multiplier - -- in a TMPostingRule. In a regular Posting, should always be false. - astyle :: AmountStyle, - aprice :: Maybe AmountPrice -- ^ the (fixed, transaction-specific) price for this amount, if any + acommodity :: !CommoditySymbol, -- commodity symbol, or special value "AUTO" + aquantity :: !Quantity, -- numeric quantity, or zero in case of "AUTO" + aismultiplier :: !Bool, -- ^ kludge: a flag marking this amount and posting as a multiplier + -- in a TMPostingRule. In a regular Posting, should always be false. + astyle :: !AmountStyle, + aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any } deriving (Eq,Ord,Generic,Show) newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show) From ecca7f4e0cd108dc9e394d8e5f8a5619e9b73be2 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 16 Jan 2021 21:43:24 +1100 Subject: [PATCH 4/6] lib: Distinguish between an Amount having quantity (or rounded quantity 0), and having both quantity and totalprice 0 (or rounded to 0). --- hledger-lib/Hledger/Data/Amount.hs | 33 +++++++++++++++++++++++-- hledger-lib/Hledger/Data/Posting.hs | 2 +- hledger-lib/Hledger/Data/Transaction.hs | 6 ++--- 3 files changed, 35 insertions(+), 6 deletions(-) diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index 91cf2748f..98c531348 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -63,6 +63,8 @@ module Hledger.Data.Amount ( amountCost, amountIsZero, amountLooksZero, + amountAndPriceIsZero, + amountAndPriceLooksZero, divideAmount, multiplyAmount, divideAmountAndPrice, @@ -114,6 +116,8 @@ module Hledger.Data.Amount ( isNegativeMixedAmount, mixedAmountIsZero, mixedAmountLooksZero, + mixedAmountAndPriceIsZero, + mixedAmountAndPriceLooksZero, mixedAmountTotalPriceToUnitPrice, -- ** rendering styleMixedAmount, @@ -324,10 +328,27 @@ amountRoundedQuantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p}} = c amountLooksZero :: Amount -> Bool amountLooksZero = (0==) . amountRoundedQuantity +-- | Does mixed amount and its price appear to be zero when rendered with its +-- display precision ? +amountAndPriceLooksZero :: Amount -> Bool +amountAndPriceLooksZero amt = amountLooksZero amt && priceLooksZero + where + priceLooksZero = case aprice amt of + Just (TotalPrice p) -> amountLooksZero p + _ -> True + -- | Is this amount exactly zero, ignoring its display precision ? amountIsZero :: Amount -> Bool amountIsZero Amount{aquantity=q} = q == 0 +-- | Are this amount and its price exactly zero, ignoring its display precision ? +amountAndPriceIsZero :: Amount -> Bool +amountAndPriceIsZero amt@Amount{aquantity=q} = q == 0 && priceIsZero + where + priceIsZero = case aprice amt of + Just (TotalPrice p) -> amountIsZero p + _ -> True + -- | Set an amount's display precision, flipped. withPrecision :: Amount -> AmountPrecision -> Amount withPrecision = flip amountSetPrecision @@ -496,8 +517,7 @@ applyDigitGroupStyle (Just (DigitGroups c (g:gs))) l s = addseps (g:|gs) (toInte -- | Canonicalise an amount's display style using the provided commodity style map. canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'} - where - s' = findWithDefault s c styles + where s' = M.findWithDefault s c styles ------------------------------------------------------------------------------- -- MixedAmount @@ -658,10 +678,19 @@ isNegativeMixedAmount m = mixedAmountLooksZero :: MixedAmount -> Bool mixedAmountLooksZero = all amountLooksZero . amounts . normaliseMixedAmountSquashPricesForDisplay +-- | Does this mixed amount and its price appear to be zero when rendered with its +-- display precision ? +mixedAmountAndPriceLooksZero :: MixedAmount -> Bool +mixedAmountAndPriceLooksZero = all amountAndPriceLooksZero . amounts . normaliseMixedAmountSquashPricesForDisplay + -- | Is this mixed amount exactly zero, ignoring display precisions ? mixedAmountIsZero :: MixedAmount -> Bool mixedAmountIsZero = all amountIsZero . amounts . normaliseMixedAmountSquashPricesForDisplay +-- | Is this mixed amount exactly zero, ignoring display precisions ? +mixedAmountAndPriceIsZero :: MixedAmount -> Bool +mixedAmountAndPriceIsZero = all amountAndPriceIsZero . amounts . normaliseMixedAmountSquashPricesForDisplay + -- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we -- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there. -- -- For now, use this when cross-commodity zero equality is important. diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 7e2679ce8..26e6bfaf3 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -257,7 +257,7 @@ isPostingInDateSpan' PrimaryDate s = spanContainsDate s . postingDate isPostingInDateSpan' SecondaryDate s = spanContainsDate s . postingDate2 isEmptyPosting :: Posting -> Bool -isEmptyPosting = mixedAmountLooksZero . pamount +isEmptyPosting = mixedAmountAndPriceLooksZero . pamount -- AccountName stuff that depends on PostingType diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 147d86841..336cbea8d 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -367,8 +367,8 @@ transactionCheckBalanced mstyles t = errs -- check for mixed signs, detecting nonzeros at display precision canonicalise = maybe id canonicaliseMixedAmount mstyles - signsOk ps = - case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of + signsOk ps = + case filter (not.mixedAmountAndPriceLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of nonzeros | length nonzeros >= 2 -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 _ -> True @@ -378,7 +378,7 @@ transactionCheckBalanced mstyles t = errs (rsum, bvsum) = (sumPostings rps, sumPostings bvps) (rsumcost, bvsumcost) = (mixedAmountCost rsum, mixedAmountCost bvsum) (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost) - (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) + (rsumok, bvsumok) = (mixedAmountAndPriceLooksZero rsumdisplay, mixedAmountAndPriceLooksZero bvsumdisplay) -- generate error messages, showing amounts with their original precision errs = filter (not.null) [rmsg, bvmsg] From 9d527a99266028e82fbdb5979f60e6ebb8c07f44 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 16 Jan 2021 21:46:39 +1100 Subject: [PATCH 5/6] lib: normaliseHelper now uses a strict Map for combining amounts internally, closing a big space leak. This also now combines Amounts with TotalPrices in the same commodity when normalising; amounts with TotalPrices were previously never combined. --- hledger-lib/Hledger/Data/Amount.hs | 59 ++++++++++++++---------------- 1 file changed, 27 insertions(+), 32 deletions(-) diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index 98c531348..3b896f644 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -40,6 +40,7 @@ exchange rates. -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -144,12 +145,10 @@ module Hledger.Data.Amount ( import Control.Monad (foldM) import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo) import Data.Default (Default(..)) -import Data.Function (on) -import Data.List (groupBy, intercalate, intersperse, mapAccumL, partition, - sortBy) +import Data.Foldable (toList) +import Data.List (intercalate, intersperse, mapAccumL, partition) import Data.List.NonEmpty (NonEmpty(..), nonEmpty) -import qualified Data.Map as M -import Data.Map (findWithDefault) +import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup ((<>)) @@ -246,8 +245,8 @@ amt @@ priceamt = amt{aprice=Just $ TotalPrice priceamt} -- Prices are ignored and discarded. -- Remember: the caller is responsible for ensuring both amounts have the same commodity. similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount -similarAmountsOp op Amount{acommodity=_, aquantity=q1, astyle=AmountStyle{asprecision=p1}} - Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} = +similarAmountsOp op !Amount{acommodity=_, aquantity=q1, astyle=AmountStyle{asprecision=p1}} + !Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} = -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug) amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}} -- c1==c2 || q1==0 || q2==0 = @@ -559,24 +558,18 @@ normaliseMixedAmount = normaliseHelper False normaliseHelper :: Bool -> MixedAmount -> MixedAmount normaliseHelper squashprices (Mixed as) - | missingamt `elem` as = missingmixedamt -- missingamt should always be alone, but detect it even if not - | null nonzeros = Mixed [newzero] - | otherwise = Mixed nonzeros + | missingkey `M.member` amtMap = missingmixedamt -- missingamt should always be alone, but detect it even if not + | M.null nonzeros= Mixed [newzero] + | otherwise = Mixed $ toList nonzeros where - newzero = lastDef nullamt $ filter (not . T.null . acommodity) zeros - (zeros, nonzeros) = partition amountIsZero $ - map sumSimilarAmountsUsingFirstPrice $ - groupBy groupfn $ - sortBy sortfn - as - sortfn | squashprices = compare `on` acommodity - | otherwise = compare `on` \a -> (acommodity a, aprice a) - groupfn | squashprices = (==) `on` acommodity - | otherwise = \a1 a2 -> acommodity a1 == acommodity a2 && combinableprices a1 a2 - - combinableprices Amount{aprice=Nothing} Amount{aprice=Nothing} = True - combinableprices Amount{aprice=Just (UnitPrice p1)} Amount{aprice=Just (UnitPrice p2)} = p1 == p2 - combinableprices _ _ = False + newzero = maybe nullamt snd . M.lookupMin $ M.filter (not . T.null . acommodity) zeros + (zeros, nonzeros) = M.partition amountAndPriceIsZero amtMap + amtMap = foldr (\a -> M.insertWith sumSimilarAmountsUsingFirstPrice (key a) a) mempty as + key Amount{acommodity=c,aprice=p} = (c, if squashprices then Nothing else priceKey <$> p) + where + priceKey (UnitPrice x) = (acommodity x, Just $ aquantity x) + priceKey (TotalPrice x) = (acommodity x, Nothing) + missingkey = key missingamt -- | Like normaliseMixedAmount, but combine each commodity's amounts -- into just one by throwing away all prices except the first. This is @@ -600,9 +593,13 @@ unifyMixedAmount = foldM combine 0 . amounts -- | Sum same-commodity amounts in a lossy way, applying the first -- price to the result and discarding any other prices. Only used as a -- rendering helper. -sumSimilarAmountsUsingFirstPrice :: [Amount] -> Amount -sumSimilarAmountsUsingFirstPrice [] = nullamt -sumSimilarAmountsUsingFirstPrice as = (sumStrict as){aprice=aprice $ head as} +sumSimilarAmountsUsingFirstPrice :: Amount -> Amount -> Amount +sumSimilarAmountsUsingFirstPrice a b = (a + b){aprice=p} + where + p = case (aprice a, aprice b) of + (Just (TotalPrice ap), Just (TotalPrice bp)) + -> Just . TotalPrice $ ap{aquantity = aquantity ap + aquantity bp } + _ -> aprice a -- -- | Sum same-commodity amounts. If there were different prices, set -- -- the price to a special marker indicating "various". Only used as a @@ -945,9 +942,7 @@ tests_Amount = tests "Amount" [ [usd 1 @@ eur 1 ,usd (-2) @@ eur 1 ]) - @?= Mixed [usd 1 @@ eur 1 - ,usd (-2) @@ eur 1 - ] + @?= Mixed [usd (-1) @@ eur 2 ] ,test "showMixedAmount" $ do showMixedAmount (Mixed [usd 1]) @?= "$1.00" @@ -970,8 +965,8 @@ tests_Amount = tests "Amount" [ normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= Mixed [usd 2 `at` eur 1] ,test "amounts with different unit prices are not combined" $ normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2] - ,test "amounts with total prices are not combined" $ - normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1] + ,test "amounts with total prices are combined" $ + normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= Mixed [usd 2 @@ eur 2] ] ,test "normaliseMixedAmountSquashPricesForDisplay" $ do From f0655d1c7f2269c3b9fdceb79c6b79ef7cd6cf41 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 20 Feb 2021 10:06:51 +1100 Subject: [PATCH 6/6] lib: (amount|mixedAmount)(Looks|Is)Zero functions now check whether both the quantity and the cost are zero. This is usually what you want, but if you do only want to check whether the quantity is zero, you can run mixedAmountStripPrices (or similar) before this. (multiply|divide)(Mixed)?Amount now also multiply or divide the TotalPrice if it is present, and the old (multiply|divide)(Mixed)?AmountAndPrice functions are removed. --- hledger-lib/Hledger/Data/Amount.hs | 100 +++++------------- hledger-lib/Hledger/Data/Posting.hs | 2 +- hledger-lib/Hledger/Data/Transaction.hs | 4 +- .../Hledger/Data/TransactionModifier.hs | 2 +- 4 files changed, 33 insertions(+), 75 deletions(-) diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index 3b896f644..b62f2c6c5 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -64,12 +64,8 @@ module Hledger.Data.Amount ( amountCost, amountIsZero, amountLooksZero, - amountAndPriceIsZero, - amountAndPriceLooksZero, divideAmount, multiplyAmount, - divideAmountAndPrice, - multiplyAmountAndPrice, amountTotalPriceToUnitPrice, -- ** rendering AmountDisplayOpts(..), @@ -110,15 +106,11 @@ module Hledger.Data.Amount ( mixedAmountCost, divideMixedAmount, multiplyMixedAmount, - divideMixedAmountAndPrice, - multiplyMixedAmountAndPrice, averageMixedAmounts, isNegativeAmount, isNegativeMixedAmount, mixedAmountIsZero, mixedAmountLooksZero, - mixedAmountAndPriceIsZero, - mixedAmountAndPriceLooksZero, mixedAmountTotalPriceToUnitPrice, -- ** rendering styleMixedAmount, @@ -212,7 +204,7 @@ instance Num Amount where abs a@Amount{aquantity=q} = a{aquantity=abs q} signum a@Amount{aquantity=q} = a{aquantity=signum q} fromInteger i = nullamt{aquantity=fromInteger i} - negate a = transformAmountAndPrice negate a + negate a = transformAmount negate a (+) = similarAmountsOp (+) (-) = similarAmountsOp (-) (*) = similarAmountsOp (*) @@ -288,28 +280,20 @@ amountTotalPriceToUnitPrice Precision p -> Precision $ if p == maxBound then maxBound else p + 1 amountTotalPriceToUnitPrice a = a --- | Divide an amount's quantity by a constant. -divideAmount :: Quantity -> Amount -> Amount -divideAmount n a@Amount{aquantity=q} = a{aquantity=q/n} - --- | Multiply an amount's quantity by a constant. -multiplyAmount :: Quantity -> Amount -> Amount -multiplyAmount n a@Amount{aquantity=q} = a{aquantity=q*n} - -- | Apply a function to an amount's quantity (and its total price, if it has one). -transformAmountAndPrice :: (Quantity -> Quantity) -> Amount -> Amount -transformAmountAndPrice f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p} +transformAmount :: (Quantity -> Quantity) -> Amount -> Amount +transformAmount f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p} where f' (TotalPrice a@Amount{aquantity=pq}) = TotalPrice a{aquantity = f pq} f' p = p -- | Divide an amount's quantity (and its total price, if it has one) by a constant. -divideAmountAndPrice :: Quantity -> Amount -> Amount -divideAmountAndPrice n = transformAmountAndPrice (/n) +divideAmount :: Quantity -> Amount -> Amount +divideAmount n = transformAmount (/n) -- | Multiply an amount's quantity (and its total price, if it has one) by a constant. -multiplyAmountAndPrice :: Quantity -> Amount -> Amount -multiplyAmountAndPrice n = transformAmountAndPrice (*n) +multiplyAmount :: Quantity -> Amount -> Amount +multiplyAmount n = transformAmount (*n) -- | Is this amount negative ? The price is ignored. isNegativeAmount :: Amount -> Bool @@ -322,31 +306,20 @@ amountRoundedQuantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p}} = c NaturalPrecision -> q Precision p' -> roundTo p' q --- | Does mixed amount appear to be zero when rendered with its +-- | Apply a test to both an Amount and its total price, if it has one. +testAmountAndTotalPrice :: (Amount -> Bool) -> Amount -> Bool +testAmountAndTotalPrice f amt = case aprice amt of + Just (TotalPrice price) -> f amt && f price + _ -> f amt + +-- | Do this Amount and (and its total price, if it has one) appear to be zero when rendered with its -- display precision ? amountLooksZero :: Amount -> Bool -amountLooksZero = (0==) . amountRoundedQuantity +amountLooksZero = testAmountAndTotalPrice ((0==) . amountRoundedQuantity) --- | Does mixed amount and its price appear to be zero when rendered with its --- display precision ? -amountAndPriceLooksZero :: Amount -> Bool -amountAndPriceLooksZero amt = amountLooksZero amt && priceLooksZero - where - priceLooksZero = case aprice amt of - Just (TotalPrice p) -> amountLooksZero p - _ -> True - --- | Is this amount exactly zero, ignoring its display precision ? +-- | Is this Amount (and its total price, if it has one) exactly zero, ignoring its display precision ? amountIsZero :: Amount -> Bool -amountIsZero Amount{aquantity=q} = q == 0 - --- | Are this amount and its price exactly zero, ignoring its display precision ? -amountAndPriceIsZero :: Amount -> Bool -amountAndPriceIsZero amt@Amount{aquantity=q} = q == 0 && priceIsZero - where - priceIsZero = case aprice amt of - Just (TotalPrice p) -> amountIsZero p - _ -> True +amountIsZero = testAmountAndTotalPrice ((0==) . aquantity) -- | Set an amount's display precision, flipped. withPrecision :: Amount -> AmountPrecision -> Amount @@ -563,7 +536,7 @@ normaliseHelper squashprices (Mixed as) | otherwise = Mixed $ toList nonzeros where newzero = maybe nullamt snd . M.lookupMin $ M.filter (not . T.null . acommodity) zeros - (zeros, nonzeros) = M.partition amountAndPriceIsZero amtMap + (zeros, nonzeros) = M.partition amountIsZero amtMap amtMap = foldr (\a -> M.insertWith sumSimilarAmountsUsingFirstPrice (key a) a) mempty as key Amount{acommodity=c,aprice=p} = (c, if squashprices then Nothing else priceKey <$> p) where @@ -636,24 +609,14 @@ mapMixedAmount f (Mixed as) = Mixed $ map f as mixedAmountCost :: MixedAmount -> MixedAmount mixedAmountCost = mapMixedAmount amountCost --- | Divide a mixed amount's quantities by a constant. +-- | Divide a mixed amount's quantities (and total prices, if any) by a constant. divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount divideMixedAmount n = mapMixedAmount (divideAmount n) --- | Multiply a mixed amount's quantities by a constant. +-- | Multiply a mixed amount's quantities (and total prices, if any) by a constant. multiplyMixedAmount :: Quantity -> MixedAmount -> MixedAmount multiplyMixedAmount n = mapMixedAmount (multiplyAmount n) --- | Divide a mixed amount's quantities (and total prices, if any) by a constant. --- The total prices will be kept positive regardless of the multiplier's sign. -divideMixedAmountAndPrice :: Quantity -> MixedAmount -> MixedAmount -divideMixedAmountAndPrice n = mapMixedAmount (divideAmountAndPrice n) - --- | Multiply a mixed amount's quantities (and total prices, if any) by a constant. --- The total prices will be kept positive regardless of the multiplier's sign. -multiplyMixedAmountAndPrice :: Quantity -> MixedAmount -> MixedAmount -multiplyMixedAmountAndPrice n = mapMixedAmount (multiplyAmountAndPrice n) - -- | Calculate the average of some mixed amounts. averageMixedAmounts :: [MixedAmount] -> MixedAmount averageMixedAmounts [] = 0 @@ -670,24 +633,18 @@ isNegativeMixedAmount m = as | not (any isNegativeAmount as) -> Just False _ -> Nothing -- multiple amounts with different signs --- | Does this mixed amount appear to be zero when rendered with its --- display precision ? +-- | Does this mixed amount appear to be zero when rendered with its display precision? +-- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero), +-- and zero quantity for each unit price? mixedAmountLooksZero :: MixedAmount -> Bool mixedAmountLooksZero = all amountLooksZero . amounts . normaliseMixedAmountSquashPricesForDisplay --- | Does this mixed amount and its price appear to be zero when rendered with its --- display precision ? -mixedAmountAndPriceLooksZero :: MixedAmount -> Bool -mixedAmountAndPriceLooksZero = all amountAndPriceLooksZero . amounts . normaliseMixedAmountSquashPricesForDisplay - --- | Is this mixed amount exactly zero, ignoring display precisions ? +-- | Is this mixed amount exactly to be zero, ignoring its display precision? +-- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero), +-- and zero quantity for each unit price? mixedAmountIsZero :: MixedAmount -> Bool mixedAmountIsZero = all amountIsZero . amounts . normaliseMixedAmountSquashPricesForDisplay --- | Is this mixed amount exactly zero, ignoring display precisions ? -mixedAmountAndPriceIsZero :: MixedAmount -> Bool -mixedAmountAndPriceIsZero = all amountAndPriceIsZero . amounts . normaliseMixedAmountSquashPricesForDisplay - -- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we -- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there. -- -- For now, use this when cross-commodity zero equality is important. @@ -767,10 +724,11 @@ showMixedAmountDebug m | m == missingmixedamt = "(missing)" -- maximum width will be elided. showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder showMixedAmountB opts ma - | displayOneLine opts = showMixedAmountOneLineB opts ma + | displayOneLine opts = showMixedAmountOneLineB opts ma' | otherwise = WideBuilder (wbBuilder . mconcat $ intersperse sep lines) width where - lines = showMixedAmountLinesB opts ma + ma' = if displayPrice opts then ma else mixedAmountStripPrices ma + lines = showMixedAmountLinesB opts ma' width = headDef 0 $ map wbWidth lines sep = WideBuilder (TB.singleton '\n') 0 diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 26e6bfaf3..7e2679ce8 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/hledger-lib/Hledger/Data/Posting.hs @@ -257,7 +257,7 @@ isPostingInDateSpan' PrimaryDate s = spanContainsDate s . postingDate isPostingInDateSpan' SecondaryDate s = spanContainsDate s . postingDate2 isEmptyPosting :: Posting -> Bool -isEmptyPosting = mixedAmountAndPriceLooksZero . pamount +isEmptyPosting = mixedAmountLooksZero . pamount -- AccountName stuff that depends on PostingType diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index 336cbea8d..cf380a170 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -368,7 +368,7 @@ transactionCheckBalanced mstyles t = errs -- check for mixed signs, detecting nonzeros at display precision canonicalise = maybe id canonicaliseMixedAmount mstyles signsOk ps = - case filter (not.mixedAmountAndPriceLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of + case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of nonzeros | length nonzeros >= 2 -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 _ -> True @@ -378,7 +378,7 @@ transactionCheckBalanced mstyles t = errs (rsum, bvsum) = (sumPostings rps, sumPostings bvps) (rsumcost, bvsumcost) = (mixedAmountCost rsum, mixedAmountCost bvsum) (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost) - (rsumok, bvsumok) = (mixedAmountAndPriceLooksZero rsumdisplay, mixedAmountAndPriceLooksZero bvsumdisplay) + (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) -- generate error messages, showing amounts with their original precision errs = filter (not.null) [rmsg, bvmsg] diff --git a/hledger-lib/Hledger/Data/TransactionModifier.hs b/hledger-lib/Hledger/Data/TransactionModifier.hs index f11dbf5ce..3a09b03a3 100644 --- a/hledger-lib/Hledger/Data/TransactionModifier.hs +++ b/hledger-lib/Hledger/Data/TransactionModifier.hs @@ -120,7 +120,7 @@ tmPostingRuleToFunction querytxt pr = -- Approach 1: convert to a unit price and increase the display precision slightly -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount -- Approach 2: multiply the total price (keeping it positive) as well as the quantity - Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmountAndPrice` matchedamount + Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` matchedamount in case acommodity pramount of "" -> Mixed as