mirror of
https://github.com/simonmichael/hledger.git
synced 2024-12-28 21:02:04 +03:00
Merge branch pr/Xitian9/1445 (Fix some space leaks, #1445)
- 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
commit
7bfbcde627
@ -40,6 +40,7 @@ exchange rates.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@ -65,8 +66,6 @@ module Hledger.Data.Amount (
|
||||
amountLooksZero,
|
||||
divideAmount,
|
||||
multiplyAmount,
|
||||
divideAmountAndPrice,
|
||||
multiplyAmountAndPrice,
|
||||
amountTotalPriceToUnitPrice,
|
||||
-- ** rendering
|
||||
AmountDisplayOpts(..),
|
||||
@ -107,8 +106,6 @@ module Hledger.Data.Amount (
|
||||
mixedAmountCost,
|
||||
divideMixedAmount,
|
||||
multiplyMixedAmount,
|
||||
divideMixedAmountAndPrice,
|
||||
multiplyMixedAmountAndPrice,
|
||||
averageMixedAmounts,
|
||||
isNegativeAmount,
|
||||
isNegativeMixedAmount,
|
||||
@ -140,12 +137,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 ((<>))
|
||||
@ -209,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@Amount{aquantity=q} = a{aquantity= -q}
|
||||
negate a = transformAmount negate a
|
||||
(+) = similarAmountsOp (+)
|
||||
(-) = similarAmountsOp (-)
|
||||
(*) = similarAmountsOp (*)
|
||||
@ -242,8 +237,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 =
|
||||
@ -260,14 +255,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.
|
||||
@ -285,29 +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).
|
||||
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.
|
||||
-- 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}
|
||||
where
|
||||
f (TotalPrice a) = TotalPrice $ abs $ n `divideAmount` a
|
||||
f p = p
|
||||
divideAmount :: Quantity -> Amount -> Amount
|
||||
divideAmount n = transformAmount (/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
|
||||
multiplyAmount :: Quantity -> Amount -> Amount
|
||||
multiplyAmount n = transformAmount (*n)
|
||||
|
||||
-- | Is this amount negative ? The price is ignored.
|
||||
isNegativeAmount :: Amount -> Bool
|
||||
@ -320,14 +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)
|
||||
|
||||
-- | 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
|
||||
amountIsZero = testAmountAndTotalPrice ((0==) . aquantity)
|
||||
|
||||
-- | Set an amount's display precision, flipped.
|
||||
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 = 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 +422,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,
|
||||
@ -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.
|
||||
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
|
||||
@ -538,24 +531,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 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
|
||||
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
|
||||
@ -579,9 +566,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
|
||||
@ -618,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
|
||||
@ -652,12 +633,15 @@ 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
|
||||
|
||||
-- | 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
|
||||
|
||||
@ -740,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
|
||||
|
||||
@ -874,7 +859,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
|
||||
@ -915,9 +900,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"
|
||||
@ -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]
|
||||
,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -367,7 +367,7 @@ transactionCheckBalanced mstyles t = errs
|
||||
|
||||
-- check for mixed signs, detecting nonzeros at display precision
|
||||
canonicalise = maybe id canonicaliseMixedAmount mstyles
|
||||
signsOk ps =
|
||||
signsOk ps =
|
||||
case filter (not.mixedAmountLooksZero) $ map (canonicalise.mixedAmountCost.pamount) ps of
|
||||
nonzeros | length nonzeros >= 2
|
||||
-> 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}
|
||||
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" [
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user