simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-12-29 13:22:27 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch pr/Xitian9/1445 (Fix some space leaks, #1445)

Browse Source 
- Consume list immediately in commodityStylesFromAmounts.

  This and/or the other strictness fixes below reduce memory and time
  usage, a lot, for journals with many @@ total prices.

- 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 amount arithmetic more consistent, and allows negative
  prices to be represented. It also means that total prices override
  the primary amount: 0A @@ 1B is now 1B, not 0.

- Make fields of Amount, AmountPrice, AmountStyle, and DigitGroupStyle
  strict.

- Distinguish between an Amount having quantity (or rounded quantity 0),
  and having both quantity and totalprice 0 (or rounded to 0).

- 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.

- (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.
This commit is contained in:
Simon Michael 2021-02-23 15:22:51 -08:00
commit 7bfbcde627
6 changed files with 121 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
hledger-lib/Hledger/Data/Amount.hs
View File

@ -40,6 +40,7 @@ exchange rates.
-} -}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -65,8 +66,6 @@ module Hledger.Data.Amount (
amountLooksZero, amountLooksZero,
divideAmount, divideAmount,
multiplyAmount, multiplyAmount,
divideAmountAndPrice,
multiplyAmountAndPrice,
amountTotalPriceToUnitPrice, amountTotalPriceToUnitPrice,
-- ** rendering -- ** rendering
AmountDisplayOpts(..), AmountDisplayOpts(..),
@ -107,8 +106,6 @@ module Hledger.Data.Amount (
mixedAmountCost, mixedAmountCost,
divideMixedAmount, divideMixedAmount,
multiplyMixedAmount, multiplyMixedAmount,
divideMixedAmountAndPrice,
multiplyMixedAmountAndPrice,
averageMixedAmounts, averageMixedAmounts,
isNegativeAmount, isNegativeAmount,
isNegativeMixedAmount, isNegativeMixedAmount,
@ -140,12 +137,10 @@ module Hledger.Data.Amount (
import Control.Monad (foldM) import Control.Monad (foldM)
import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo) import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo)
import Data.Default (Default(..)) import Data.Default (Default(..))
import Data.Function (on) import Data.Foldable (toList)
import Data.List (groupBy, intercalate, intersperse, mapAccumL, partition, import Data.List (intercalate, intersperse, mapAccumL, partition)
sortBy)
import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import qualified Data.Map as M import qualified Data.Map.Strict as M
import Data.Map (findWithDefault)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>)) import Data.Semigroup ((<>))
@ -209,7 +204,7 @@ instance Num Amount where
abs a@Amount{aquantity=q} = a{aquantity=abs q} abs a@Amount{aquantity=q} = a{aquantity=abs q}
signum a@Amount{aquantity=q} = a{aquantity=signum q} signum a@Amount{aquantity=q} = a{aquantity=signum q}
fromInteger i = nullamt{aquantity=fromInteger i} fromInteger i = nullamt{aquantity=fromInteger i}
negate a@Amount{aquantity=q} = a{aquantity= -q} negate a = transformAmount negate a
(+) = similarAmountsOp (+) (+) = similarAmountsOp (+)
(-) = similarAmountsOp (-) (-) = similarAmountsOp (-)
(*) = similarAmountsOp (*) (*) = similarAmountsOp (*)
@ -242,8 +237,8 @@ amt @@ priceamt = amt{aprice=Just $ TotalPrice priceamt}
-- Prices are ignored and discarded. -- Prices are ignored and discarded.
-- Remember: the caller is responsible for ensuring both amounts have the same commodity. -- Remember: the caller is responsible for ensuring both amounts have the same commodity.
similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount
similarAmountsOp op Amount{acommodity=_, aquantity=q1, astyle=AmountStyle{asprecision=p1}} similarAmountsOp op !Amount{acommodity=_, aquantity=q1, astyle=AmountStyle{asprecision=p1}}
Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} = !Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} =
-- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug) -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug)
amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}} amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}}
-- c1==c2 || q1==0 || q2==0 = -- c1==c2 || q1==0 || q2==0 =
@ -260,14 +255,14 @@ amountWithCommodity c a = a{acommodity=c, aprice=Nothing}
-- - price amounts must be MixedAmounts with exactly one component Amount -- - price amounts must be MixedAmounts with exactly one component Amount
-- (or there will be a runtime error XXX) -- (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) -- (though this is currently not enforced)
amountCost :: Amount -> Amount amountCost :: Amount -> Amount
amountCost a@Amount{aquantity=q, aprice=mp} = amountCost a@Amount{aquantity=q, aprice=mp} =
case mp of case mp of
Nothing -> a Nothing -> a
Just (UnitPrice p@Amount{aquantity=pq}) -> p{aquantity=pq * q} 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. -- | Replace an amount's TotalPrice, if it has one, with an equivalent UnitPrice.
-- Has no effect on amounts without one. -- Has no effect on amounts without one.
@ -285,29 +280,20 @@ amountTotalPriceToUnitPrice
Precision p -> Precision $ if p == maxBound then maxBound else p + 1 Precision p -> Precision $ if p == maxBound then maxBound else p + 1
amountTotalPriceToUnitPrice a = a amountTotalPriceToUnitPrice a = a
-- | Divide an amount's quantity by a constant. -- | Apply a function to an amount's quantity (and its total price, if it has one).
divideAmount :: Quantity -> Amount -> Amount transformAmount :: (Quantity -> Quantity) -> Amount -> Amount
divideAmount n a@Amount{aquantity=q} = a{aquantity=q/n} transformAmount f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p}
where
-- | Multiply an amount's quantity by a constant. f' (TotalPrice a@Amount{aquantity=pq}) = TotalPrice a{aquantity = f pq}
multiplyAmount :: Quantity -> Amount -> Amount f' p = p
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. -- | 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. divideAmount :: Quantity -> Amount -> Amount
divideAmountAndPrice :: Quantity -> Amount -> Amount divideAmount n = transformAmount (/n)
divideAmountAndPrice n a@Amount{aquantity=q,aprice=p} = a{aquantity=q/n, aprice=f <$> p}
where
f (TotalPrice a) = TotalPrice $ abs $ n `divideAmount` a
f p = p
-- | Multiply an amount's quantity (and its total price, if it has one) by a constant. -- | 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. multiplyAmount :: Quantity -> Amount -> Amount
multiplyAmountAndPrice :: Quantity -> Amount -> Amount multiplyAmount n = transformAmount (*n)
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
-- | Is this amount negative ? The price is ignored. -- | Is this amount negative ? The price is ignored.
isNegativeAmount :: Amount -> Bool isNegativeAmount :: Amount -> Bool
@ -320,14 +306,20 @@ amountRoundedQuantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p}} = c
NaturalPrecision -> q NaturalPrecision -> q
Precision p' -> roundTo p' 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 ? -- display precision ?
amountLooksZero :: Amount -> Bool amountLooksZero :: Amount -> Bool
amountLooksZero = (0==) . amountRoundedQuantity amountLooksZero = testAmountAndTotalPrice ((0==) . amountRoundedQuantity)
-- | 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 -> Bool
amountIsZero Amount{aquantity=q} = q == 0 amountIsZero = testAmountAndTotalPrice ((0==) . aquantity)
-- | Set an amount's display precision, flipped. -- | Set an amount's display precision, flipped.
withPrecision :: Amount -> AmountPrecision -> Amount withPrecision :: Amount -> AmountPrecision -> Amount
@ -372,10 +364,12 @@ setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalpoint=mc} }
withDecimalPoint :: Amount -> Maybe Char -> Amount withDecimalPoint :: Amount -> Maybe Char -> Amount
withDecimalPoint = flip setAmountDecimalPoint withDecimalPoint = flip setAmountDecimalPoint
showAmountPrice :: Maybe AmountPrice -> WideBuilder showAmountPrice :: Amount -> WideBuilder
showAmountPrice Nothing = mempty showAmountPrice amt = case aprice amt of
showAmountPrice (Just (UnitPrice pa)) = WideBuilder (TB.fromString " @ ") 3 <> showAmountB noColour pa Nothing -> mempty
showAmountPrice (Just (TotalPrice pa)) = WideBuilder (TB.fromString " @@ ") 4 <> showAmountB noColour pa 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 :: Maybe AmountPrice -> String
showAmountPriceDebug Nothing = "" showAmountPriceDebug Nothing = ""
@ -428,7 +422,7 @@ showAmountB opts a@Amount{astyle=style} =
| otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a) | otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a)
space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty
c' = WideBuilder (TB.fromText c) (textWidth c) 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 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, -- | Colour version. For a negative amount, adds ANSI codes to change the colour,
@ -495,8 +489,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. -- | Canonicalise an amount's display style using the provided commodity style map.
canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount
canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'} canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'}
where where s' = M.findWithDefault s c styles
s' = findWithDefault s c styles
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- MixedAmount -- MixedAmount
@ -538,24 +531,18 @@ normaliseMixedAmount = normaliseHelper False
normaliseHelper :: Bool -> MixedAmount -> MixedAmount normaliseHelper :: Bool -> MixedAmount -> MixedAmount
normaliseHelper squashprices (Mixed as) normaliseHelper squashprices (Mixed as)
| missingamt `elem` as = missingmixedamt -- missingamt should always be alone, but detect it even if not | missingkey `M.member` amtMap = missingmixedamt -- missingamt should always be alone, but detect it even if not
| null nonzeros = Mixed [newzero] | M.null nonzeros= Mixed [newzero]
| otherwise = Mixed nonzeros | otherwise = Mixed $ toList nonzeros
where where
newzero = lastDef nullamt $ filter (not . T.null . acommodity) zeros newzero = maybe nullamt snd . M.lookupMin $ M.filter (not . T.null . acommodity) zeros
(zeros, nonzeros) = partition amountIsZero $ (zeros, nonzeros) = M.partition amountIsZero amtMap
map sumSimilarAmountsUsingFirstPrice $ amtMap = foldr (\a -> M.insertWith sumSimilarAmountsUsingFirstPrice (key a) a) mempty as
groupBy groupfn $ key Amount{acommodity=c,aprice=p} = (c, if squashprices then Nothing else priceKey <$> p)
sortBy sortfn where
as priceKey (UnitPrice x) = (acommodity x, Just $ aquantity x)
sortfn | squashprices = compare `on` acommodity priceKey (TotalPrice x) = (acommodity x, Nothing)
| otherwise = compare `on` \a -> (acommodity a, aprice a) missingkey = key missingamt
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
-- | Like normaliseMixedAmount, but combine each commodity's amounts -- | Like normaliseMixedAmount, but combine each commodity's amounts
-- into just one by throwing away all prices except the first. This is -- into just one by throwing away all prices except the first. This is
@ -579,9 +566,13 @@ unifyMixedAmount = foldM combine 0 . amounts
-- | Sum same-commodity amounts in a lossy way, applying the first -- | Sum same-commodity amounts in a lossy way, applying the first
-- price to the result and discarding any other prices. Only used as a -- price to the result and discarding any other prices. Only used as a
-- rendering helper. -- rendering helper.
sumSimilarAmountsUsingFirstPrice :: [Amount] -> Amount sumSimilarAmountsUsingFirstPrice :: Amount -> Amount -> Amount
sumSimilarAmountsUsingFirstPrice [] = nullamt sumSimilarAmountsUsingFirstPrice a b = (a + b){aprice=p}
sumSimilarAmountsUsingFirstPrice as = (sumStrict as){aprice=aprice $ head as} 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 -- -- | Sum same-commodity amounts. If there were different prices, set
-- -- the price to a special marker indicating "various". Only used as a -- -- the price to a special marker indicating "various". Only used as a
@ -618,24 +609,14 @@ mapMixedAmount f (Mixed as) = Mixed $ map f as
mixedAmountCost :: MixedAmount -> MixedAmount mixedAmountCost :: MixedAmount -> MixedAmount
mixedAmountCost = mapMixedAmount amountCost 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 :: Quantity -> MixedAmount -> MixedAmount
divideMixedAmount n = mapMixedAmount (divideAmount n) 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 :: Quantity -> MixedAmount -> MixedAmount
multiplyMixedAmount n = mapMixedAmount (multiplyAmount n) 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. -- | Calculate the average of some mixed amounts.
averageMixedAmounts :: [MixedAmount] -> MixedAmount averageMixedAmounts :: [MixedAmount] -> MixedAmount
averageMixedAmounts [] = 0 averageMixedAmounts [] = 0
@ -652,12 +633,15 @@ isNegativeMixedAmount m =
as | not (any isNegativeAmount as) -> Just False as | not (any isNegativeAmount as) -> Just False
_ -> Nothing -- multiple amounts with different signs _ -> Nothing -- multiple amounts with different signs
-- | Does this mixed amount appear to be zero when rendered with its -- | Does this mixed amount appear to be zero when rendered with its display precision?
-- 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 :: MixedAmount -> Bool
mixedAmountLooksZero = all amountLooksZero . amounts . normaliseMixedAmountSquashPricesForDisplay mixedAmountLooksZero = all amountLooksZero . 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 :: MixedAmount -> Bool
mixedAmountIsZero = all amountIsZero . amounts . normaliseMixedAmountSquashPricesForDisplay mixedAmountIsZero = all amountIsZero . amounts . normaliseMixedAmountSquashPricesForDisplay
@ -740,10 +724,11 @@ showMixedAmountDebug m | m == missingmixedamt = "(missing)"
-- maximum width will be elided. -- maximum width will be elided.
showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder
showMixedAmountB opts ma showMixedAmountB opts ma
| displayOneLine opts = showMixedAmountOneLineB opts ma | displayOneLine opts = showMixedAmountOneLineB opts ma'
| otherwise = WideBuilder (wbBuilder . mconcat $ intersperse sep lines) width | otherwise = WideBuilder (wbBuilder . mconcat $ intersperse sep lines) width
where where
lines = showMixedAmountLinesB opts ma ma' = if displayPrice opts then ma else mixedAmountStripPrices ma
lines = showMixedAmountLinesB opts ma'
width = headDef 0 $ map wbWidth lines width = headDef 0 $ map wbWidth lines
sep = WideBuilder (TB.singleton '\n') 0 sep = WideBuilder (TB.singleton '\n') 0
@ -874,7 +859,7 @@ tests_Amount = tests "Amount" [
amountCost (eur 1) @?= eur 1 amountCost (eur 1) @?= eur 1
amountCost (eur 2){aprice=Just $ UnitPrice $ usd 2} @?= usd 4 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) amountCost (eur (-1)){aprice=Just $ TotalPrice $ usd (-2)} @?= usd (-2)
,test "amountLooksZero" $ do ,test "amountLooksZero" $ do
assertBool "" $ amountLooksZero amount assertBool "" $ amountLooksZero amount
@ -915,9 +900,7 @@ tests_Amount = tests "Amount" [
[usd 1 @@ eur 1 [usd 1 @@ eur 1
,usd (-2) @@ eur 1 ,usd (-2) @@ eur 1
]) ])
@?= Mixed [usd 1 @@ eur 1 @?= Mixed [usd (-1) @@ eur 2 ]
,usd (-2) @@ eur 1
]
,test "showMixedAmount" $ do ,test "showMixedAmount" $ do
showMixedAmount (Mixed [usd 1]) @?= "$1.00" showMixedAmount (Mixed [usd 1]) @?= "$1.00"
@ -940,8 +923,8 @@ tests_Amount = tests "Amount" [
normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= Mixed [usd 2 `at` eur 1] 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" $ ,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] 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" $ ,test "amounts with total prices are combined" $
normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1] normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= Mixed [usd 2 @@ eur 2]
] ]
,test "normaliseMixedAmountSquashPricesForDisplay" $ do ,test "normaliseMixedAmountSquashPricesForDisplay" $ do

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

@ -92,6 +92,7 @@ module Hledger.Data.Journal (
) )
where where
import Control.Applicative ((<|>))
import Control.Monad.Except (ExceptT(..), runExceptT, throwError) import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
import "extra" Control.Monad.Extra (whenM) import "extra" Control.Monad.Extra (whenM)
import Control.Monad.Reader as R import Control.Monad.Reader as R
@ -102,9 +103,9 @@ import Data.Default (Default(..))
import Data.Function ((&)) import Data.Function ((&))
import qualified Data.HashTable.Class as H (toList) import qualified Data.HashTable.Class as H (toList)
import qualified Data.HashTable.ST.Cuckoo as H import qualified Data.HashTable.ST.Cuckoo as H
import Data.List (find, sortOn) import Data.List (find, foldl', sortOn)
import Data.List.Extra (groupSort, nubSort) import Data.List.Extra (nubSort)
import qualified Data.Map as M import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe) import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe)
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..)) import Data.Semigroup (Semigroup(..))
@ -1109,42 +1110,40 @@ journalInferCommodityStyles j =
-- and this function never reports an error. -- and this function never reports an error.
-- --
commodityStylesFromAmounts :: [Amount] -> Either String (M.Map CommoditySymbol AmountStyle) commodityStylesFromAmounts :: [Amount] -> Either String (M.Map CommoditySymbol AmountStyle)
commodityStylesFromAmounts amts = commodityStylesFromAmounts =
Right $ M.fromList commstyles Right . foldr (\a -> M.insertWith canonicalStyle (acommodity a) (astyle a)) mempty
where
commamts = groupSort [(acommodity as, as) | as <- amts] -- | Given a list of amount styles (assumed to be from parsed amounts
commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts] -- 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. -- TODO: should probably detect and report inconsistencies here.
-- Though, we don't have the info for a good error message, so maybe elsewhere. -- 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 -- | Given a pair of AmountStyles, choose a canonical style.
-- in a single commodity), in parse order, choose a canonical style.
-- This is: -- 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 first digit group style seen,
-- with the maximum precision of all. -- with the maximum precision of all.
-- canonicalStyle :: AmountStyle -> AmountStyle -> AmountStyle
canonicalStyleFrom :: [AmountStyle] -> AmountStyle canonicalStyle a b = a{asprecision=prec, asdecimalpoint=decmark, asdigitgroups=mgrps}
canonicalStyleFrom [] = amountstyle
canonicalStyleFrom ss@(s:_) =
s{asprecision=prec, asdecimalpoint=Just decmark, asdigitgroups=mgrps}
where where
-- precision is maximum of all precisions -- precision is maximum of all precisions
prec = maximumStrict $ map asprecision ss prec = max (asprecision a) (asprecision b)
-- identify the digit group mark (& group sizes) -- 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; -- 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. -- make sure the decimal mark is different. If not, default to period.
defdecmark = defdecmark = case mgrps of
case mgrps of
Just (DigitGroups '.' _) -> ',' Just (DigitGroups '.' _) -> ','
_ -> '.' _ -> '.'
-- identify the decimal mark: the first one used, or the above default, -- identify the decimal mark: the first one used, or the above default,
-- but never the same character as the digit group mark. -- but never the same character as the digit group mark.
-- urgh.. refactor.. -- urgh.. refactor..
decmark = case mgrps of decmark = case mgrps of
Just _ -> defdecmark Just _ -> Just defdecmark
_ -> headDef defdecmark $ mapMaybe asdecimalpoint ss Nothing -> asdecimalpoint a <|> asdecimalpoint b <|> Just defdecmark
-- -- | Apply this journal's historical price records to unpriced amounts where possible. -- -- | Apply this journal's historical price records to unpriced amounts where possible.
-- journalApplyPriceDirectives :: Journal -> Journal -- journalApplyPriceDirectives :: Journal -> Journal

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

@ -367,7 +367,7 @@ transactionCheckBalanced mstyles t = errs
-- check for mixed signs, detecting nonzeros at display precision -- check for mixed signs, detecting nonzeros at display precision
canonicalise = maybe id canonicaliseMixedAmount mstyles canonicalise = maybe id canonicaliseMixedAmount mstyles
signsOk ps = signsOk ps =
case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of
nonzeros | length nonzeros >= 2 nonzeros | length nonzeros >= 2
-> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1
@ -553,8 +553,9 @@ priceInferrerFor t pt = inferprice
= p{pamount=Mixed [a{aprice=Just conversionprice}], poriginal=Just $ originalPosting p} = p{pamount=Mixed [a{aprice=Just conversionprice}], poriginal=Just $ originalPosting p}
where where
fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe
totalpricesign = if aquantity a < 0 then negate else id
conversionprice conversionprice
| fromcount==1 = TotalPrice $ abs toamount `withPrecision` NaturalPrecision | fromcount==1 = TotalPrice $ totalpricesign (abs toamount) `withPrecision` NaturalPrecision
| otherwise = UnitPrice $ abs unitprice `withPrecision` unitprecision | otherwise = UnitPrice $ abs unitprice `withPrecision` unitprecision
where where
fromcount = length $ filter ((==fromcommodity).acommodity) pamounts 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 1 @@ eur 1]}
, posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur 1]} , posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur (-1)]}
]) ])
] ]
, tests "isTransactionBalanced" [ , tests "isTransactionBalanced" [

2
hledger-lib/Hledger/Data/TransactionModifier.hs
View File

@ -120,7 +120,7 @@ tmPostingRuleToFunction querytxt pr =
-- Approach 1: convert to a unit price and increase the display precision slightly -- Approach 1: convert to a unit price and increase the display precision slightly
-- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount
-- Approach 2: multiply the total price (keeping it positive) as well as the quantity -- 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 in
case acommodity pramount of case acommodity pramount of
"" -> Mixed as "" -> Mixed as

26
hledger-lib/Hledger/Data/Types.hs
View File

@ -178,16 +178,16 @@ instance ToMarkup Quantity
-- | An amount's per-unit or total cost/selling price in another -- | An amount's per-unit or total cost/selling price in another
-- commodity, as recorded in the journal entry eg with @ or @@. -- commodity, as recorded in the journal entry eg with @ or @@.
-- Docs call this "transaction price". The amount is always positive. -- 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) deriving (Eq,Ord,Generic,Show)
-- | Display style for an amount. -- | Display style for an amount.
data AmountStyle = AmountStyle { data AmountStyle = AmountStyle {
ascommodityside :: Side, -- ^ does the symbol appear on the left or the right ? ascommodityside :: !Side, -- ^ does the symbol appear on the left or the right ?
ascommodityspaced :: Bool, -- ^ space between symbol and quantity ? ascommodityspaced :: !Bool, -- ^ space between symbol and quantity ?
asprecision :: !AmountPrecision, -- ^ number of digits displayed after the decimal point 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" 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 asdigitgroups :: !(Maybe DigitGroupStyle) -- ^ style for displaying digit groups, if any
} deriving (Eq,Ord,Read,Generic) } deriving (Eq,Ord,Read,Generic)
instance Show AmountStyle where 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 -- point), and the size of each group, starting with the one nearest
-- the decimal point. The last group size is assumed to repeat. Eg, -- the decimal point. The last group size is assumed to repeat. Eg,
-- comma between thousands is DigitGroups ',' [3]. -- comma between thousands is DigitGroups ',' [3].
data DigitGroupStyle = DigitGroups Char [Word8] data DigitGroupStyle = DigitGroups !Char ![Word8]
deriving (Eq,Ord,Read,Show,Generic) deriving (Eq,Ord,Read,Show,Generic)
type CommoditySymbol = Text type CommoditySymbol = Text
@ -222,12 +222,12 @@ data Commodity = Commodity {
} deriving (Show,Eq,Generic) --,Ord) } deriving (Show,Eq,Generic) --,Ord)
data Amount = Amount { data Amount = Amount {
acommodity :: CommoditySymbol, -- commodity symbol, or special value "AUTO" acommodity :: !CommoditySymbol, -- commodity symbol, or special value "AUTO"
aquantity :: Quantity, -- numeric quantity, or zero in case of "AUTO" aquantity :: !Quantity, -- numeric quantity, or zero in case of "AUTO"
aismultiplier :: Bool, -- ^ kludge: a flag marking this amount and posting as a multiplier aismultiplier :: !Bool, -- ^ kludge: a flag marking this amount and posting as a multiplier
-- in a TMPostingRule. In a regular Posting, should always be false. -- in a TMPostingRule. In a regular Posting, should always be false.
astyle :: AmountStyle, astyle :: !AmountStyle,
aprice :: Maybe AmountPrice -- ^ the (fixed, transaction-specific) price for this amount, if any aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any
} deriving (Eq,Ord,Generic,Show) } deriving (Eq,Ord,Generic,Show)
newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show) newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show)

18
hledger-lib/Hledger/Read/Common.hs
View File

@ -757,7 +757,7 @@ amountp = label "amount" $ do
spaces = lift $ skipNonNewlineSpaces spaces = lift $ skipNonNewlineSpaces
amount <- amountwithoutpricep <* spaces amount <- amountwithoutpricep <* spaces
(mprice, _elotprice, _elotdate) <- runPermutation $ (mprice, _elotprice, _elotdate) <- runPermutation $
(,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp <* spaces) (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amount <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces) <*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces)
<*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces) <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces)
pure $ amount { aprice = mprice } pure $ amount { aprice = mprice }
@ -767,7 +767,7 @@ amountpnolotpricesp = label "amount" $ do
let spaces = lift $ skipNonNewlineSpaces let spaces = lift $ skipNonNewlineSpaces
amount <- amountwithoutpricep amount <- amountwithoutpricep
spaces spaces
mprice <- optional $ priceamountp <* spaces mprice <- optional $ priceamountp amount <* spaces
pure $ amount { aprice = mprice } pure $ amount { aprice = mprice }
amountwithoutpricep :: JournalParser m Amount amountwithoutpricep :: JournalParser m Amount
@ -877,18 +877,24 @@ quotedcommoditysymbolp =
simplecommoditysymbolp :: TextParser m CommoditySymbol simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar) simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)
priceamountp :: JournalParser m AmountPrice priceamountp :: Amount -> JournalParser m AmountPrice
priceamountp = label "transaction price" $ do priceamountp baseAmt = label "transaction price" $ do
-- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs -- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs
parenthesised <- option False $ char '(' >> pure True parenthesised <- option False $ char '(' >> pure True
char '@' char '@'
priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice totalPrice <- char '@' *> pure True <|> pure False
when parenthesised $ void $ char ')' when parenthesised $ void $ char ')'
lift skipNonNewlineSpaces lift skipNonNewlineSpaces
priceAmount <- amountwithoutpricep -- <?> "unpriced amount (specifying a price)" 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 :: JournalParser m BalanceAssertion
balanceassertionp = do balanceassertionp = do