diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -8,10 +8,37 @@ Breaking changes Misc. changes -nn + --> Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. + +# 1.31 2023-09-03 + +Breaking changes + +- There is a new consolidated API for styling amounts, and a + convenient HasAmounts typeclass. AmountStyle's fields have been + renamed/reordered more mnemonically, and setting the precision is + now optional. (This simplifies the amount-stylingn code, but + complicates the semantics a little. When reading, an unset precision + generally behaves like NaturalPrecision.) + +- (Possible breaking change): + showMixedAmountLinesB, showAmountB, showAmountPrice now preserve + commodityful zeroes when rendering. This is intended to affect print output, + but it seems possible it might also affect balance and register reports, + though our tests show no change in those. + +- Renamed: journalAddInferredEquityPostings -> journalInferEquityFromCosts + +Misc. changes + +- Reports now do a final amount styling pass before rendering. + +- groupByDateSpan code cleanup (Jay Neubrand) + +- Allow aeson 2.2, megaparsec 9.5 # 1.30 2023-06-01 diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -73,8 +73,13 @@ oneLine, csvDisplay, amountstyle, + canonicaliseAmount, styleAmount, - styleAmountExceptPrecision, + amountSetStyles, + amountSetStylesExceptPrecision, + amountSetMainStyle, + amountSetCostStyle, + amountStyleUnsetPrecision, amountUnstyled, showAmountB, showAmount, @@ -91,7 +96,6 @@ setAmountDecimalPoint, withDecimalPoint, amountStripPrices, - canonicaliseAmount, -- * MixedAmount nullmixedamt, missingmixedamt, @@ -102,6 +106,7 @@ maAddAmounts, amounts, amountsRaw, + amountsPreservingZeros, maCommodities, filterMixedAmount, filterMixedAmountByCommodity, @@ -124,7 +129,10 @@ maIsNonZero, mixedAmountLooksZero, -- ** rendering + canonicaliseMixedAmount, styleMixedAmount, + mixedAmountSetStyles, + mixedAmountSetStylesExceptPrecision, mixedAmountUnstyled, showMixedAmount, showMixedAmountOneLine, @@ -139,7 +147,6 @@ wbUnpack, mixedAmountSetPrecision, mixedAmountSetFullPrecision, - canonicaliseMixedAmount, -- * misc. tests_Amount ) where @@ -170,6 +177,7 @@ import Hledger.Utils (colorB, numDigitsInt) import Hledger.Utils.Text (textQuoteIfNeeded) import Text.WideString (WideBuilder(..), wbFromText, wbToText, wbUnpack) +import Data.Functor ((<&>)) -- A 'Commodity' is a symbol representing a currency or some other kind of @@ -195,6 +203,7 @@ -- | Options for the display of Amount and MixedAmount. +-- (See also Types.AmountStyle) data AmountDisplayOpts = AmountDisplayOpts { displayPrice :: Bool -- ^ Whether to display the Price of an Amount. , displayZeroCommodity :: Bool -- ^ If the Amount rounds to 0, whether to display its commodity string. @@ -208,10 +217,10 @@ , displayOrder :: Maybe [CommoditySymbol] } deriving (Show) --- | Display Amount and MixedAmount with no colour. +-- | By default, display Amount and MixedAmount using @noColour@ amount display options. instance Default AmountDisplayOpts where def = noColour --- | Display Amount and MixedAmount with no colour. +-- | Display amounts without colour, and with various other defaults. noColour :: AmountDisplayOpts noColour = AmountDisplayOpts { displayPrice = True , displayColour = False @@ -239,11 +248,13 @@ -- Amount styles -- | Default amount style -amountstyle = AmountStyle L False (Precision 0) (Just '.') Nothing +amountstyle = AmountStyle L False Nothing (Just '.') (Just $ Precision 0) ------------------------------------------------------------------------------- -- Amount +instance HasAmounts Amount where styleAmounts = amountSetStyles + instance Num Amount where abs a@Amount{aquantity=q} = a{aquantity=abs q} signum a@Amount{aquantity=q} = a{aquantity=signum q} @@ -253,11 +264,14 @@ (-) = similarAmountsOp (-) (*) = similarAmountsOp (*) --- | The empty simple amount. +-- | The empty simple amount - a zero with no commodity symbol or cost +-- and the default amount display style. nullamt :: Amount nullamt = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle} --- | A temporary value for parsed transactions which had no amount specified. +-- | A special amount used as a marker, meaning +-- "no explicit amount provided here, infer it when needed". +-- It is nullamt with commodity symbol "AUTO". missingamt :: Amount missingamt = nullamt{acommodity="AUTO"} @@ -265,11 +279,11 @@ -- usd/eur/gbp round their argument to a whole number of pennies/cents. -- XXX these are a bit clashy num n = nullamt{acommodity="", aquantity=n} -hrs n = nullamt{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=Precision 2, ascommodityside=R}} -usd n = nullamt{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}} -eur n = nullamt{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}} -gbp n = nullamt{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}} -per n = nullamt{acommodity="%", aquantity=n, astyle=amountstyle{asprecision=Precision 1, ascommodityside=R, ascommodityspaced=True}} +hrs n = nullamt{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=Just $ Precision 2, ascommodityside=R}} +usd n = nullamt{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Just $ Precision 2}} +eur n = nullamt{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Just $ Precision 2}} +gbp n = nullamt{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Just $ Precision 2}} +per n = nullamt{acommodity="%", aquantity=n, astyle=amountstyle{asprecision=Just $ Precision 1, ascommodityside=R, ascommodityspaced=True}} amt `at` priceamt = amt{aprice=Just $ UnitPrice priceamt} amt @@ priceamt = amt{aprice=Just $ TotalPrice priceamt} @@ -327,12 +341,13 @@ isNegativeAmount :: Amount -> Bool isNegativeAmount Amount{aquantity=q} = q < 0 --- | Round an Amount's Quantity to its specified display precision. If that is --- NaturalPrecision, this does nothing. +-- | Round an Amount's Quantity (internally) to match its display precision. +-- If that is unset or NaturalPrecision, this does nothing. amountRoundedQuantity :: Amount -> Quantity -amountRoundedQuantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p}} = case p of - NaturalPrecision -> q - Precision p' -> roundTo p' q +amountRoundedQuantity Amount{aquantity=q, astyle=AmountStyle{asprecision=mp}} = case mp of + Nothing -> q + Just NaturalPrecision -> q + Just (Precision p) -> roundTo p q -- | Apply a test to both an Amount and its total price, if it has one. testAmountAndTotalPrice :: (Amount -> Bool) -> Amount -> Bool @@ -340,14 +355,17 @@ 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 ? +-- | Do this Amount and (and its total price, if it has one) appear to be zero +-- when rendered with its display precision ? +-- The display precision should usually have a specific value here; +-- if unset, it will be treated like NaturalPrecision. amountLooksZero :: Amount -> Bool amountLooksZero = testAmountAndTotalPrice looksZero where looksZero Amount{aquantity=Decimal e q, astyle=AmountStyle{asprecision=p}} = case p of - Precision d -> if e > d then abs q <= 5*10^(e-d-1) else q == 0 - NaturalPrecision -> q == 0 + Just (Precision d) -> if e > d then abs q <= 5*10^(e-d-1) else q == 0 + Just NaturalPrecision -> q == 0 + Nothing -> q == 0 -- | Is this Amount (and its total price, if it has one) exactly zero, ignoring its display precision ? amountIsZero :: Amount -> Bool @@ -359,16 +377,16 @@ -- | Set an amount's display precision. amountSetPrecision :: AmountPrecision -> Amount -> Amount -amountSetPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=p}} +amountSetPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=Just p}} -- | Increase an amount's display precision, if needed, to enough decimal places --- to show it exactly (showing all significant decimal digits, excluding trailing --- zeros). +-- to show it exactly (showing all significant decimal digits, without trailing zeros). +-- If the amount's display precision is unset, it is will be treated as precision 0. amountSetFullPrecision :: Amount -> Amount amountSetFullPrecision a = amountSetPrecision p a where p = max displayprecision naturalprecision - displayprecision = asprecision $ astyle a + displayprecision = fromMaybe (Precision 0) $ asprecision $ astyle a naturalprecision = Precision . decimalPlaces . normalizeDecimal $ aquantity a -- | Set an amount's internal precision, ie rounds the Decimal representing @@ -379,7 +397,7 @@ -- Intended mainly for internal use, eg when comparing amounts in tests. setAmountInternalPrecision :: Word8 -> Amount -> Amount setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{ - astyle=s{asprecision=Precision p} + astyle=s{asprecision=Just $ Precision p} ,aquantity=roundTo p q } @@ -390,7 +408,7 @@ -- | Set (or clear) an amount's display decimal point. setAmountDecimalPoint :: Maybe Char -> Amount -> Amount -setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalpoint=mc} } +setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalmark=mc} } -- | Set (or clear) an amount's display decimal point, flipped. withDecimalPoint :: Amount -> Maybe Char -> Amount @@ -403,8 +421,8 @@ 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) + Just (UnitPrice pa) -> WideBuilder (TB.fromString " @ ") 3 <> showAmountB noColour{displayZeroCommodity=True} pa + Just (TotalPrice pa) -> WideBuilder (TB.fromString " @@ ") 4 <> showAmountB noColour{displayZeroCommodity=True} (sign pa) where sign = if aquantity amt < 0 then negate else id showAmountPriceDebug :: Maybe AmountPrice -> String @@ -412,33 +430,76 @@ showAmountPriceDebug (Just (UnitPrice pa)) = " @ " ++ showAmountDebug pa showAmountPriceDebug (Just (TotalPrice pa)) = " @@ " ++ showAmountDebug pa +-- Amount styling +-- v1 + +-- like journalCanonicaliseAmounts +-- | Canonicalise an amount's display style using the provided commodity style map. +-- Its cost amount, if any, is not affected. +canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +canonicaliseAmount = amountSetMainStyle +{-# DEPRECATED canonicaliseAmount "please use amountSetMainStyle (or amountSetStyles) instead" #-} + +-- v2 + -- | Given a map of standard commodity display styles, apply the -- appropriate one to this amount. If there's no standard style for -- this amount's commodity, return the amount unchanged. --- Also apply the style to the price (except for precision) +-- Also do the same for the cost amount if any, but leave its precision unchanged. styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -styleAmount styles a = styledAmount{aprice = stylePrice styles (aprice styledAmount)} - where - styledAmount = case M.lookup (acommodity a) styles of - Just s -> a{astyle=s} - Nothing -> a +styleAmount = amountSetStyles +{-# DEPRECATED styleAmount "please use amountSetStyles instead" #-} -stylePrice :: M.Map CommoditySymbol AmountStyle -> Maybe AmountPrice -> Maybe AmountPrice -stylePrice styles (Just (UnitPrice a)) = Just (UnitPrice $ styleAmountExceptPrecision styles a) -stylePrice styles (Just (TotalPrice a)) = Just (TotalPrice $ styleAmountExceptPrecision styles a) -stylePrice _ _ = Nothing +-- v3 --- | Like styleAmount, but keep the number of decimal places unchanged. -styleAmountExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -styleAmountExceptPrecision styles a@Amount{astyle=AmountStyle{asprecision=origp}} = - case M.lookup (acommodity a) styles of +-- | Given some commodity display styles, find and apply the appropriate +-- display style to this amount, and do the same for its cost amount if any +-- (and then stop; we assume costs don't have costs). +-- The main amount's display precision is set or not, according to its style; +-- the cost amount's display precision is left unchanged, regardless of its style. +-- If no style is found for an amount, it is left unchanged. +amountSetStyles :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +amountSetStyles styles = amountSetMainStyle styles <&> amountSetCostStyle styles + +-- | Like amountSetStyles, but leave the display precision unchanged +-- in both main and cost amounts. +amountSetStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +amountSetStylesExceptPrecision styles a@Amount{astyle=AmountStyle{asprecision=origp}} = + case M.lookup (acommodity a) styles' of Just s -> a{astyle=s{asprecision=origp}} Nothing -> a + where styles' = M.map amountStyleUnsetPrecision styles +amountStyleUnsetPrecision :: AmountStyle -> AmountStyle +amountStyleUnsetPrecision as = as{asprecision=Nothing} + +-- | Find and apply the appropriate display style, if any, to this amount. +-- The display precision is set or not, according to the style. +amountSetMainStyle :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +amountSetMainStyle styles a@Amount{acommodity=comm, astyle=AmountStyle{asprecision=morigp}} = + case M.lookup comm styles of + Nothing -> a + Just s@AmountStyle{asprecision=mp} -> a{astyle=s'} + where + s' = case mp of + Nothing -> s{asprecision=morigp} + _ -> s + +-- | Find and apply the appropriate display style, if any, to this amount's cost, if any. +-- The display precision is left unchanged, regardless of the style. +amountSetCostStyle :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +amountSetCostStyle styles a@Amount{aprice=mcost} = + case mcost of + Nothing -> a + Just (UnitPrice a2) -> a{aprice=Just $ UnitPrice $ amountSetStylesExceptPrecision styles a2} + Just (TotalPrice a2) -> a{aprice=Just $ TotalPrice $ amountSetStylesExceptPrecision styles a2} + + -- | Reset this amount's display style to the default. amountUnstyled :: Amount -> Amount amountUnstyled a = a{astyle=amountstyle} + -- | Get the string representation of an amount, based on its -- commodity's display settings. String representations equivalent to -- zero are converted to just \"0\". The special "missing" amount is @@ -449,24 +510,35 @@ showAmount = wbUnpack . showAmountB noColour -- | General function to generate a WideBuilder for an Amount, according the --- supplied AmountDisplayOpts. The special "missing" amount is displayed as --- the empty string. This is the main function to use for showing +-- supplied AmountDisplayOpts. This is the main function to use for showing -- Amounts, constructing a builder; it can then be converted to a Text with -- wbToText, or to a String with wbUnpack. +-- Some special cases: +-- +-- * The special "missing" amount is displayed as the empty string. +-- +-- * If an amount is showing digit group separators but no decimal places, +-- we force showing a decimal mark (with nothing after it) to make +-- it easier to parse correctly. +-- showAmountB :: AmountDisplayOpts -> Amount -> WideBuilder showAmountB _ Amount{acommodity="AUTO"} = mempty showAmountB opts a@Amount{astyle=style} = color $ case ascommodityside style of - L -> showC (wbFromText c) space <> quantity' <> price - R -> quantity' <> showC space (wbFromText c) <> price + L -> showC (wbFromText comm) space <> quantity' <> price + R -> quantity' <> showC space (wbFromText comm) <> price where - quantity = showamountquantity $ if displayThousandsSep opts then a else a{astyle=(astyle a){asdigitgroups=Nothing}} - (quantity',c) | amountLooksZero a && not (displayZeroCommodity opts) = (WideBuilder (TB.singleton '0') 1,"") - | otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a) - space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty + color = if displayColour opts && isNegativeAmount a then colorB Dull Red else id + quantity = showamountquantity $ + if displayThousandsSep opts then a else a{astyle=(astyle a){asdigitgroups=Nothing}} + (quantity', comm) + | amountLooksZero a && not (displayZeroCommodity opts) = (WideBuilder (TB.singleton '0') 1, "") + | otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a) + space = if not (T.null comm) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty + -- concatenate these texts, + -- or return the empty text if there's a commodity display order. XXX why ? showC l r = if isJust (displayOrder opts) then mempty else l <> r 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, -- currently to hard-coded red. @@ -496,27 +568,33 @@ ++ ", aprice=" ++ showAmountPriceDebug aprice ++ ", astyle=" ++ show astyle ++ "}" -- | Get a Text Builder for the string representation of the number part of of an amount, --- using the display settings from its commodity. Also returns the width of the --- number. +-- using the display settings from its commodity. Also returns the width of the number. +-- A special case: if it is showing digit group separators but no decimal places, +-- show a decimal mark (with nothing after it) to make it easier to parse correctly. showamountquantity :: Amount -> WideBuilder -showamountquantity amt@Amount{astyle=AmountStyle{asdecimalpoint=mdec, asdigitgroups=mgrps}} = +showamountquantity amt@Amount{astyle=AmountStyle{asdecimalmark=mdec, asdigitgroups=mgrps}} = signB <> intB <> fracB where - Decimal e n = amountRoundedQuantity amt - - strN = T.pack . show $ abs n - len = T.length strN - intLen = max 1 $ len - fromIntegral e + Decimal decplaces mantissa = amountRoundedQuantity amt + numtxt = T.pack . show $ abs mantissa + numlen = T.length numtxt + intLen = max 1 $ numlen - fromIntegral decplaces dec = fromMaybe '.' mdec - padded = T.replicate (fromIntegral e + 1 - len) "0" <> strN - (intPart, fracPart) = T.splitAt intLen padded + numtxtwithzero = T.replicate (fromIntegral decplaces + 1 - numlen) "0" <> numtxt + (intPart, fracPart) = T.splitAt intLen numtxtwithzero + intB = applyDigitGroupStyle mgrps intLen $ if decplaces == 0 then numtxt else intPart + signB = if mantissa < 0 then WideBuilder (TB.singleton '-') 1 else mempty + fracB = if decplaces > 0 || isshowingdigitgroupseparator + then WideBuilder (TB.singleton dec <> TB.fromText fracPart) (1 + fromIntegral decplaces) + else mempty - intB = applyDigitGroupStyle mgrps intLen $ if e == 0 then strN else intPart - signB = if n < 0 then WideBuilder (TB.singleton '-') 1 else mempty - fracB = if e > 0 then WideBuilder (TB.singleton dec <> TB.fromText fracPart) (fromIntegral e + 1) else mempty + isshowingdigitgroupseparator = case mgrps of + Just (DigitGroups _ (rightmostgrplen:_)) -> intLen > fromIntegral rightmostgrplen + _ -> False --- | Split a string representation into chunks according to DigitGroupStyle, --- returning a Text builder and the number of separators used. +-- | Given an integer as text, and its length, apply the given DigitGroupStyle, +-- inserting digit group separators between digit groups where appropriate. +-- Returns a Text builder and the number of digit group separators used. applyDigitGroupStyle :: Maybe DigitGroupStyle -> Int -> T.Text -> WideBuilder applyDigitGroupStyle Nothing l s = WideBuilder (TB.fromText s) l applyDigitGroupStyle (Just (DigitGroups _ [])) l s = WideBuilder (TB.fromText s) l @@ -530,15 +608,11 @@ gs2 = fromMaybe (g1:|[]) $ nonEmpty gs1 l2 = l1 - toInteger g1 --- like journalCanonicaliseAmounts --- | 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' = M.findWithDefault s c styles - ------------------------------------------------------------------------------- -- MixedAmount +instance HasAmounts MixedAmount where styleAmounts = mixedAmountSetStyles + instance Semigroup MixedAmount where (<>) = maPlus sconcat = maSum @@ -567,11 +641,15 @@ nullmixedamt :: MixedAmount nullmixedamt = Mixed mempty --- | A temporary value for parsed transactions which had no amount specified. +-- | A special mixed amount used as a marker, meaning +-- "no explicit amount provided here, infer it when needed". missingmixedamt :: MixedAmount missingmixedamt = mixedAmount missingamt --- | Whether a MixedAmount has a missing amount +-- | Does this MixedAmount include the "missing amount" marker ? +-- Note: currently does not test for equality with missingmixedamt, +-- instead it looks for missingamt among the Amounts. +-- missingamt should always be alone, but detect it even if not. isMissingMixedAmount :: MixedAmount -> Bool isMissingMixedAmount (Mixed ma) = amountKey missingamt `M.member` ma @@ -663,7 +741,8 @@ maIsNonZero :: MixedAmount -> Bool maIsNonZero = not . mixedAmountIsZero --- | Get a mixed amount's component amounts. +-- | Get a mixed amount's component amounts, with some cleanups. +-- The following descriptions are old and possibly wrong: -- -- * amounts in the same commodity are combined unless they have different prices or total prices -- @@ -677,13 +756,37 @@ -- amounts :: MixedAmount -> [Amount] amounts (Mixed ma) - | isMissingMixedAmount (Mixed ma) = [missingamt] -- missingamt should always be alone, but detect it even if not + | isMissingMixedAmount (Mixed ma) = [missingamt] | M.null nonzeros = [newzero] | otherwise = toList nonzeros where newzero = fromMaybe nullamt $ find (not . T.null . acommodity) zeros (zeros, nonzeros) = M.partition amountIsZero ma +-- | Get a mixed amount's component amounts, with some cleanups. +-- This is a new version of @amounts@, with updated descriptions +-- and optimised for @print@ to show commodityful zeros. +-- +-- * If it contains the "missing amount" marker, only that is returned +-- (discarding any additional amounts). +-- +-- * Or if it contains any non-zero amounts, only those are returned +-- (discarding any zeroes). +-- +-- * Or if it contains any zero amounts (possibly more than one, +-- possibly in different commodities), all of those are returned. +-- +-- * Otherwise the null amount is returned. +-- +amountsPreservingZeros :: MixedAmount -> [Amount] +amountsPreservingZeros (Mixed ma) + | isMissingMixedAmount (Mixed ma) = [missingamt] + | not $ M.null nonzeros = toList nonzeros + | not $ M.null zeros = toList zeros + | otherwise = [nullamt] + where + (zeros, nonzeros) = M.partition amountIsZero ma + -- | Get a mixed amount's component amounts without normalising zero and missing -- amounts. This is used for JSON serialisation, so the order is important. In -- particular, we want the Amounts given in the order of the MixedAmountKeys, @@ -768,15 +871,36 @@ -- where a' = mixedAmountStripPrices a -- b' = mixedAmountStripPrices b --- | Given a map of standard commodity display styles, apply the --- appropriate one to each individual amount. +-- Mixed amount styling +-- v1 + +-- | Canonicalise a mixed amount's display styles using the provided commodity style map. +-- Cost amounts, if any, are not affected. +canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount +canonicaliseMixedAmount styles = mapMixedAmountUnsafe (canonicaliseAmount styles) +{-# DEPRECATED canonicaliseMixedAmount "please use mixedAmountSetMainStyle (or mixedAmountSetStyles) instead" #-} + +-- v2 + +-- | Given a map of standard commodity display styles, find and apply +-- the appropriate style to each individual amount. styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount -styleMixedAmount styles = mapMixedAmountUnsafe (styleAmount styles) +styleMixedAmount = mixedAmountSetStyles +{-# DEPRECATED styleMixedAmount "please use mixedAmountSetStyles instead" #-} +-- v3 + +mixedAmountSetStyles :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount +mixedAmountSetStyles styles = mapMixedAmountUnsafe (amountSetStyles styles) + +mixedAmountSetStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount +mixedAmountSetStylesExceptPrecision styles = mapMixedAmountUnsafe (amountSetStylesExceptPrecision styles) + -- | Reset each individual amount's display style to the default. mixedAmountUnstyled :: MixedAmount -> MixedAmount mixedAmountUnstyled = mapMixedAmountUnsafe amountUnstyled + -- | Get the string representation of a mixed amount, after -- normalising it to one amount per commodity. Assumes amounts have -- no or similar prices, otherwise this can show misleading prices. @@ -848,10 +972,9 @@ width = headDef 0 $ map wbWidth ls sep = WideBuilder (TB.singleton '\n') 0 --- | Helper for showMixedAmountB to show a list of Amounts on multiple lines. This returns --- the list of WideBuilders: one for each Amount, and padded/elided to the appropriate --- width. This does not honour displayOneLine: all amounts will be displayed as if --- displayOneLine were False. +-- | Helper for showMixedAmountB (and postingAsLines, ...) to show a list of Amounts on multiple lines. +-- This returns the list of WideBuilders: one for each Amount, and padded/elided to the appropriate width. +-- This does not honour displayOneLine; all amounts will be displayed as if displayOneLine were False. showMixedAmountLinesB :: AmountDisplayOpts -> MixedAmount -> [WideBuilder] showMixedAmountLinesB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWidth=mmin} ma = map (adBuilder . pad) elided @@ -905,11 +1028,19 @@ -- Add the elision strings (if any) to each amount withElided = zipWith (\n2 amt -> (amt, elisionDisplay Nothing (wbWidth sep) n2 amt)) [n-1,n-2..0] +-- Get a mixed amount's component amounts with a bit of cleanup, +-- optionally preserving multiple zeros in different commodities, +-- optionally sorting them according to a commodity display order. orderedAmounts :: AmountDisplayOpts -> MixedAmount -> [Amount] -orderedAmounts dopts = maybe id (mapM pad) (displayOrder dopts) . amounts +orderedAmounts AmountDisplayOpts{displayZeroCommodity=preservezeros, displayOrder=mcommodityorder} = + if preservezeros then amountsPreservingZeros else amounts + <&> maybe id (mapM findfirst) mcommodityorder -- maybe sort them (somehow..) where - pad c = fromMaybe (amountWithCommodity c nullamt) . find ((c==) . acommodity) - + -- Find the first amount with the given commodity, otherwise a null amount in that commodity. + findfirst :: CommoditySymbol -> [Amount] -> Amount + findfirst c = fromMaybe nullamtc . find ((c==) . acommodity) + where + nullamtc = amountWithCommodity c nullamt data AmountDisplay = AmountDisplay { adBuilder :: !WideBuilder -- ^ String representation of the Amount @@ -962,11 +1093,7 @@ foldl' (\m a -> maAddAmount m a{aprice=Nothing}) (Mixed noPrices) withPrices where (noPrices, withPrices) = M.partition (isNothing . aprice) ma --- | Canonicalise a mixed amount's display styles using the provided commodity style map. -canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount -canonicaliseMixedAmount styles = mapMixedAmountUnsafe (canonicaliseAmount styles) - ------------------------------------------------------------------------------- -- tests @@ -993,8 +1120,8 @@ (usd (-1.23) + usd (-1.23)) @?= usd (-2.46) sum [usd 1.23,usd (-1.23),usd (-1.23),-(usd (-1.23))] @?= usd 0 -- highest precision is preserved - asprecision (astyle $ sum [usd 1 `withPrecision` Precision 1, usd 1 `withPrecision` Precision 3]) @?= Precision 3 - asprecision (astyle $ sum [usd 1 `withPrecision` Precision 3, usd 1 `withPrecision` Precision 1]) @?= Precision 3 + asprecision (astyle $ sum [usd 1 `withPrecision` Precision 1, usd 1 `withPrecision` Precision 3]) @?= Just (Precision 3) + asprecision (astyle $ sum [usd 1 `withPrecision` Precision 3, usd 1 `withPrecision` Precision 1]) @?= Just (Precision 3) -- adding different commodities assumes conversion rate 1 assertBool "" $ amountLooksZero (usd 1.23 - eur 1.23) diff --git a/Hledger/Data/Balancing.hs b/Hledger/Data/Balancing.hs --- a/Hledger/Data/Balancing.hs +++ b/Hledger/Data/Balancing.hs @@ -101,12 +101,12 @@ VirtualPosting -> (l, r) -- check for mixed signs, detecting nonzeros at display precision - canonicalise = maybe id canonicaliseMixedAmount commodity_styles_ + setstyles = maybe id mixedAmountSetStyles commodity_styles_ postingBalancingAmount p | "_price-matched" `elem` map fst (ptags p) = mixedAmountStripPrices $ pamount p | otherwise = mixedAmountCost $ pamount p signsOk ps = - case filter (not.mixedAmountLooksZero) $ map (canonicalise.postingBalancingAmount) ps of + case filter (not.mixedAmountLooksZero) $ map (setstyles.postingBalancingAmount) ps of nonzeros | length nonzeros >= 2 -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 _ -> True @@ -114,7 +114,7 @@ -- check for zero sum, at display precision (rsumcost, bvsumcost) = (foldMap postingBalancingAmount rps, foldMap postingBalancingAmount bvps) - (rsumdisplay, bvsumdisplay) = (canonicalise rsumcost, canonicalise bvsumcost) + (rsumdisplay, bvsumdisplay) = (setstyles rsumcost, setstyles bvsumcost) (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) -- generate error messages, showing amounts with their original precision @@ -250,7 +250,7 @@ -- Inferred amounts are converted to cost. -- Also ensure the new amount has the standard style for its commodity -- (since the main amount styling pass happened before this balancing pass); - a' = styleMixedAmount styles . mixedAmountCost $ maNegate a + a' = mixedAmountSetStyles styles . mixedAmountCost $ maNegate a -- | Infer costs for this transaction's posting amounts, if needed to make -- the postings balance, and if permitted. This is done once for the real @@ -337,8 +337,8 @@ unitprice = aquantity fromamount `divideAmount` toamount unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of - (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b - _ -> NaturalPrecision + (Just (Precision a), Just (Precision b)) -> Precision . max 2 $ saturatedAdd a b + _ -> NaturalPrecision saturatedAdd a b = if maxBound - a < b then maxBound else a + b @@ -454,6 +454,9 @@ -- display precisions used in balanced checking styles = Just $ journalCommodityStyles j bopts = bopts'{commodity_styles_=styles} + -- XXX ^ The commodity directive styles and default style and inferred styles + -- are merged into the command line styles in commodity_styles_ - why ? + -- Mainly for the precisions, used during amount and cost inference and balanced checking ? -- balance assignments are not allowed on accounts affected by auto postings autopostingaccts = S.fromList . map (paccount . tmprPosting) . concatMap tmpostingrules $ jtxnmodifiers j in @@ -628,7 +631,7 @@ "but the calculated balance is: %s", -- (at display precision: %s)", "a difference of: %s", "", - "Consider viewing this account's calculated balances to troubleshoot. Eg:", + "To troubleshoot, you can view this account's running balance. Eg:", "", "hledger reg '%s'%s -I # -f FILE" ]) @@ -1005,26 +1008,26 @@ -- testCase "1091a" $ do commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} - ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} + nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Just $ Precision 3)} + ,nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 2)} ] @?= -- The commodity style should have period as decimal mark -- and comma as digit group mark. Right (M.fromList [ - ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) + ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 3)) ]) -- same journal, entries in reverse order ,testCase "1091b" $ do commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 2) (Just '.') (Just (DigitGroups ',' [3]))} - ,nullamt{aquantity=1000, astyle=AmountStyle L False (Precision 3) (Just ',') Nothing} + nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 2)} + ,nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Just $ Precision 3)} ] @?= -- The commodity style should have period as decimal mark -- and comma as digit group mark. Right (M.fromList [ - ("", AmountStyle L False (Precision 3) (Just '.') (Just (DigitGroups ',' [3]))) + ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 3)) ]) ] diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -317,7 +317,7 @@ groupByCols (c:cs) ps = (c, map snd matches) : groupByCols cs later where (matches, later) = span ((spanEnd c >) . Just . fst) ps - beforeStart = maybe (const True) (>) $ spanStart =<< headMay colspans + beforeStart = maybe (const False) (>) $ spanStart =<< headMay colspans -- | Calculate the intersection of a number of datespans. spansIntersect [] = nulldatespan diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -26,7 +26,7 @@ commodityStylesFromAmounts, journalCommodityStyles, journalToCost, - journalAddInferredEquityPostings, + journalInferEquityFromCosts, journalInferCostsFromEquity, journalMarkRedundantCosts, journalReverse, @@ -793,16 +793,17 @@ Left err -> Left err -- | Choose and apply a consistent display style to the posting --- amounts in each commodity (see journalCommodityStyles). +-- amounts in each commodity (see journalCommodityStyles), +-- keeping all display precisions unchanged. -- Can return an error message eg if inconsistent number formats are found. journalApplyCommodityStyles :: Journal -> Either String Journal journalApplyCommodityStyles = fmap fixjournal . journalInferCommodityStyles where fixjournal j@Journal{jpricedirectives=pds} = - journalMapPostings (postingApplyCommodityStyles styles) j{jpricedirectives=map fixpricedirective pds} + journalMapPostings (postingApplyCommodityStylesExceptPrecision styles) j{jpricedirectives=map fixpricedirective pds} where styles = journalCommodityStyles j - fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmountExceptPrecision styles a} + fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=amountSetStylesExceptPrecision styles a} -- | Get the canonical amount styles for this journal, whether (in order of precedence): -- set globally in InputOpts, @@ -858,7 +859,7 @@ -- with the first digit group style seen, -- with the maximum precision of all. canonicalStyle :: AmountStyle -> AmountStyle -> AmountStyle -canonicalStyle a b = a{asprecision=prec, asdecimalpoint=decmark, asdigitgroups=mgrps} +canonicalStyle a b = a{asprecision=prec, asdecimalmark=decmark, asdigitgroups=mgrps} where -- precision is maximum of all precisions prec = max (asprecision a) (asprecision b) @@ -874,7 +875,7 @@ -- urgh.. refactor.. decmark = case mgrps of Just _ -> Just defdecmark - Nothing -> asdecimalpoint a <|> asdecimalpoint b <|> Just defdecmark + Nothing -> asdecimalmark a <|> asdecimalmark b <|> Just defdecmark -- -- | Apply this journal's historical price records to unpriced amounts where possible. -- journalApplyPriceDirectives :: Journal -> Journal @@ -908,21 +909,19 @@ journalPostings j } --- | Convert all this journal's amounts to cost using the transaction prices, if any. --- The journal's commodity styles are applied to the resulting amounts. +-- | Convert all this journal's amounts to cost using their attached prices, if any. journalToCost :: ConversionOp -> Journal -> Journal -journalToCost cost j@Journal{jtxns=ts} = j{jtxns=map (transactionToCost styles cost) ts} - where - styles = journalCommodityStyles j +journalToCost cost j@Journal{jtxns=ts} = j{jtxns=map (transactionToCost cost) ts} --- | Add inferred equity postings to a 'Journal' using transaction prices. -journalAddInferredEquityPostings :: Bool -> Journal -> Journal -journalAddInferredEquityPostings verbosetags j = journalMapTransactions (transactionAddInferredEquityPostings verbosetags equityAcct) j +-- | Add equity postings inferred from costs, where needed and possible. +-- See hledger manual > Cost reporting. +journalInferEquityFromCosts :: Bool -> Journal -> Journal +journalInferEquityFromCosts verbosetags j = journalMapTransactions (transactionAddInferredEquityPostings verbosetags equityAcct) j where equityAcct = journalConversionAccount j -- | Add costs inferred from equity conversion postings, where needed and possible. --- See hledger manual > Inferring cost from equity postings. +-- See hledger manual > Cost reporting. journalInferCostsFromEquity :: Journal -> Either String Journal journalInferCostsFromEquity j = do ts <- mapM (transactionInferCostsFromEquity False $ jaccounttypes j) $ jtxns j @@ -1083,16 +1082,24 @@ -- | Replace this posting's account name with the value -- of the given field or tag, if any, otherwise the empty string. postingPivot :: Text -> Posting -> Posting -postingPivot fieldortagname p = p{paccount = pivotedacct, poriginal = Just $ originalPosting p} - where - pivotedacct - | Just t <- ptransaction p, fieldortagname == "code" = tcode t - | Just t <- ptransaction p, fieldortagname == "description" = tdescription t - | Just t <- ptransaction p, fieldortagname == "payee" = transactionPayee t - | Just t <- ptransaction p, fieldortagname == "note" = transactionNote t - | Just t <- ptransaction p, fieldortagname == "status" = T.pack . show . tstatus $ t - | Just (_, value) <- postingFindTag fieldortagname p = value - | otherwise = "" +postingPivot fieldortagname p = + p{paccount = pivotAccount fieldortagname p, poriginal = Just $ originalPosting p} + +pivotAccount :: Text -> Posting -> Text +pivotAccount fieldortagname p = + T.intercalate ":" [pivotComponent x p | x <- T.splitOn ":" fieldortagname] + +pivotComponent :: Text -> Posting -> Text +pivotComponent fieldortagname p + | fieldortagname == "acct" = paccount p + | Just t <- ptransaction p, fieldortagname == "code" = tcode t + | Just t <- ptransaction p, fieldortagname == "desc" = tdescription t + | Just t <- ptransaction p, fieldortagname == "description" = tdescription t -- backward compatible with 1.30 and older + | Just t <- ptransaction p, fieldortagname == "payee" = transactionPayee t + | Just t <- ptransaction p, fieldortagname == "note" = transactionNote t + | Just t <- ptransaction p, fieldortagname == "status" = T.pack . show . tstatus $ t + | Just (_, value) <- postingFindTag fieldortagname p = value + | otherwise = "" postingFindTag :: TagName -> Posting -> Maybe (TagName, TagValue) postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p diff --git a/Hledger/Data/JournalChecks.hs b/Hledger/Data/JournalChecks.hs --- a/Hledger/Data/JournalChecks.hs +++ b/Hledger/Data/JournalChecks.hs @@ -6,7 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} module Hledger.Data.JournalChecks ( journalCheckAccounts, @@ -25,19 +24,21 @@ import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Text as T -import Safe (atMay, lastMay) +import Safe (atMay, lastMay, headMay) import Text.Printf (printf) import Hledger.Data.Errors import Hledger.Data.Journal import Hledger.Data.JournalChecks.Ordereddates import Hledger.Data.JournalChecks.Uniqueleafnames -import Hledger.Data.Posting (isVirtual, postingDate, postingStatus, transactionAllTags) +import Hledger.Data.Posting (isVirtual, postingDate, transactionAllTags) import Hledger.Data.Types -import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt) +import Hledger.Data.Amount (amountIsZero, amountsRaw, missingamt, amounts) import Hledger.Data.Transaction (transactionPayee, showTransactionLineFirstPart, partitionAndCheckConversionPostings) import Data.Time (Day, diffDays) import Hledger.Utils +import Data.Ord +import Hledger.Data.Dates (showDate) -- | Check that all the journal's postings are to accounts with -- account directives, returning an error message otherwise. @@ -209,97 +210,64 @@ ---------- --- | Information useful for checking the age and lag of an account's latest balance assertion. -data BalanceAssertionInfo = BAI { - baiAccount :: AccountName -- ^ the account - , baiLatestAssertionPosting :: Posting -- ^ the account's latest posting with a balance assertion - , baiLatestAssertionDate :: Day -- ^ the posting date - , baiLatestAssertionStatus :: Status -- ^ the posting status - , baiLatestPostingDate :: Day -- ^ the date of this account's latest posting with or without a balance assertion -} - --- | Given a list of postings to the same account, --- if any of them contain a balance assertion, --- calculate the last asserted and posted dates. -balanceAssertionInfo :: [Posting] -> Maybe BalanceAssertionInfo -balanceAssertionInfo ps = - case (mlatestp, mlatestassertp) of - (Just latestp, Just latestassertp) -> Just $ - BAI{baiAccount = paccount latestassertp - ,baiLatestAssertionDate = postingDate latestassertp - ,baiLatestAssertionPosting = latestassertp - ,baiLatestAssertionStatus = postingStatus latestassertp - ,baiLatestPostingDate = postingDate latestp - } - _ -> Nothing - where - ps' = sortOn postingDate ps - mlatestp = lastMay ps' - mlatestassertp = lastMay [p | p@Posting{pbalanceassertion=Just _} <- ps'] - -- | The number of days allowed between an account's latest balance assertion --- and latest posting. +-- and latest posting (7). maxlag = 7 --- | The number of days between this balance assertion and the latest posting in its account. -baiLag BAI{..} = diffDays baiLatestPostingDate baiLatestAssertionDate - --- -- | The earliest balance assertion date which would satisfy the recentassertions check. --- baiLagOkDate :: BalanceAssertionInfo -> Day --- baiLagOkDate BAI{..} = addDays (-7) baiLatestPostingDate - --- | Check that this latest assertion is close enough to the account's latest posting. -checkRecentAssertion :: BalanceAssertionInfo -> Either (BalanceAssertionInfo, String) () -checkRecentAssertion bai@BAI{..} - | lag > maxlag = - Left (bai, printf (chomp $ unlines [ - "the last balance assertion (%s) was %d days before" - ,"the latest posting (%s)." - ]) - (show baiLatestAssertionDate) lag (show baiLatestPostingDate) - ) - | otherwise = Right () - where - lag = baiLag bai - --- | Check that all the journal's accounts with balance assertions have --- an assertion no more than 7 days before their latest posting. +-- | Check that accounts with balance assertions have no posting more +-- than maxlag days after their latest balance assertion. -- Today's date is provided for error messages. journalCheckRecentAssertions :: Day -> Journal -> Either String () journalCheckRecentAssertions today j = - let - acctps = groupOn paccount $ sortOn paccount $ journalPostings j - acctassertioninfos = mapMaybe balanceAssertionInfo acctps - in - case mapM_ checkRecentAssertion acctassertioninfos of - Right () -> Right () - Left (BAI{..}, msg) -> Left errmsg - where - errmsg = chomp $ printf - (unlines [ - "%s:", - "%s\n", - "The recentassertions check is enabled, so accounts with balance assertions must", - "have a balance assertion no more than %d days before their latest posting date.", - "In account %s,", - "%s", - "", - "%s" - ]) - (maybe "(no position)" -- shouldn't happen - (sourcePosPretty . baposition) $ pbalanceassertion baiLatestAssertionPosting) - (textChomp excerpt) - maxlag - baiAccount - msg - recommendation - where - (_,_,_,excerpt) = makeBalanceAssertionErrorExcerpt baiLatestAssertionPosting - recommendation = unlines [ - "Consider adding a more recent balance assertion for this account. Eg:", - "", - printf "%s *\n %s $0 = $0 ; <- adjust" (show today) baiAccount - ] + let acctps = groupOn paccount $ sortOn paccount $ journalPostings j + in case mapMaybe (findRecentAssertionError today) acctps of + [] -> Right () + firsterr:_ -> Left firsterr + +-- | Do the recentassertions check for one account: given a list of postings to the account, +-- if any of them contain a balance assertion, identify the latest balance assertion, +-- and if any postings are >maxlag days later than the assertion, +-- return an error message identifying the first of them. +-- Postings on the same date will be handled in parse order (hopefully). +findRecentAssertionError :: Day -> [Posting] -> Maybe String +findRecentAssertionError today ps = do + let rps = sortOn (Data.Ord.Down . postingDate) ps + let (afterlatestassertrps, untillatestassertrps) = span (isNothing.pbalanceassertion) rps + latestassertdate <- postingDate <$> headMay untillatestassertrps + let withinlimit date = diffDays date latestassertdate <= maxlag + firsterrorp <- lastMay $ dropWhileEnd (withinlimit.postingDate) afterlatestassertrps + let lag = diffDays (postingDate firsterrorp) latestassertdate + let acct = paccount firsterrorp + let (f,l,_mcols,ex) = makePostingAccountErrorExcerpt firsterrorp + let comm = + case map acommodity $ amounts $ pamount firsterrorp of + [] -> "" + (t:_) | T.length t == 1 -> t + (t:_) -> t <> " " + Just $ chomp $ printf + (unlines [ + "%s:%d:", + "%s\n", + "The recentassertions check is enabled, so accounts with balance assertions must", + "have a balance assertion within %d days of their latest posting.", + "In account \"%s\", this posting is %d days later", + "than the last balance assertion, which was on %s.", + "", + "Consider adding a more recent balance assertion for this account. Eg:", + "", + "%s\n %s %s0 = %s0 ; (adjust asserted amount)" + ]) + f + l + (textChomp ex) + maxlag + acct + lag + (showDate latestassertdate) + (show today) + acct + comm + comm -- -- | Print the last balance assertion date & status of all accounts with balance assertions. -- printAccountLastAssertions :: Day -> [BalanceAssertionInfo] -> IO () diff --git a/Hledger/Data/Json.hs b/Hledger/Data/Json.hs --- a/Hledger/Data/Json.hs +++ b/Hledger/Data/Json.hs @@ -2,6 +2,7 @@ JSON instances. Should they be in Types.hs ? -} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -67,7 +68,13 @@ toJSON = object . decimalKV toEncoding = pairs . mconcat . decimalKV -decimalKV :: (KeyValue kv, Integral a, ToJSON a) => DecimalRaw a -> [kv] +decimalKV :: ( +#if MIN_VERSION_aeson(2,2,0) + KeyValue e kv, +#else + KeyValue kv, +#endif + Integral a, ToJSON a) => DecimalRaw a -> [kv] decimalKV d = let d' = if decimalPlaces d <= 10 then d else roundTo 10 d in [ "decimalPlaces" .= decimalPlaces d' , "decimalMantissa" .= decimalMantissa d' @@ -102,7 +109,13 @@ toJSON = object . postingKV toEncoding = pairs . mconcat . postingKV -postingKV :: KeyValue kv => Posting -> [kv] +postingKV :: +#if MIN_VERSION_aeson(2,2,0) + KeyValue e kv +#else + KeyValue kv +#endif + => Posting -> [kv] postingKV Posting{..} = [ "pdate" .= pdate , "pdate2" .= pdate2 @@ -144,7 +157,13 @@ toJSON = object . accountKV toEncoding = pairs . mconcat . accountKV -accountKV :: KeyValue kv => Account -> [kv] +accountKV :: +#if MIN_VERSION_aeson(2,2,0) + KeyValue e kv +#else + KeyValue kv +#endif + => Account -> [kv] accountKV a = [ "aname" .= aname a , "aebalance" .= aebalance a diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -39,6 +39,7 @@ postingStripPrices, postingApplyAliases, postingApplyCommodityStyles, + postingApplyCommodityStylesExceptPrecision, postingAddTags, -- * date operations postingDate, @@ -97,7 +98,15 @@ import Hledger.Data.Valuation +instance HasAmounts BalanceAssertion where + styleAmounts styles ba@BalanceAssertion{baamount} = ba{baamount=styleAmounts styles baamount} +instance HasAmounts Posting where + styleAmounts styles p@Posting{pamount, pbalanceassertion} = + p{ pamount=styleAmounts styles pamount + ,pbalanceassertion=styleAmounts styles pbalanceassertion + } + nullposting, posting :: Posting nullposting = Posting {pdate=Nothing @@ -220,6 +229,9 @@ -- Or if onelineamounts is true, such amounts are shown on one line, comma-separated -- (and the output will not be valid journal syntax). -- +-- If an amount is zero, any commodity symbol attached to it is shown +-- (and the corresponding commodity display style is used). +-- -- By default, 4 spaces (2 if there's a status flag) are shown between -- account name and start of amount area, which is typically 12 chars wide -- and contains a right-aligned amount (so 10-12 visible spaces between @@ -262,7 +274,7 @@ -- amtwidth at all. shownAmounts | elideamount = [mempty] - | otherwise = showMixedAmountLinesB noColour{displayOneLine=onelineamounts} $ pamount p + | otherwise = showMixedAmountLinesB noColour{displayZeroCommodity=True, displayOneLine=onelineamounts} $ pamount p thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts -- when there is a balance assertion, show it only on the last posting line @@ -407,14 +419,23 @@ err = "problem while applying account aliases:\n" ++ pshow aliases ++ "\n to account name: "++T.unpack paccount++"\n "++e --- | Choose and apply a consistent display style to the posting --- amounts in each commodity (see journalCommodityStyles). +-- | Find and apply the appropriate display style to the posting amounts +-- in each commodity (see journalCommodityStyles). +-- Main amount precisions may be set or not according to the styles, but cost precisions are not set. postingApplyCommodityStyles :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting -postingApplyCommodityStyles styles p = p{pamount=styleMixedAmount styles $ pamount p - ,pbalanceassertion=fixbalanceassertion <$> pbalanceassertion p} +postingApplyCommodityStyles styles p = p{pamount=mixedAmountSetStyles styles $ pamount p + ,pbalanceassertion=balanceassertionsetstyles <$> pbalanceassertion p} where - fixbalanceassertion ba = ba{baamount=styleAmountExceptPrecision styles $ baamount ba} + balanceassertionsetstyles ba = ba{baamount=amountSetStyles styles $ baamount ba} +-- | Like postingApplyCommodityStyles, but neither +-- main amount precisions or cost precisions are set. +postingApplyCommodityStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting +postingApplyCommodityStylesExceptPrecision styles p = p{pamount=mixedAmountSetStylesExceptPrecision styles $ pamount p + ,pbalanceassertion=balanceassertionsetstyles <$> pbalanceassertion p} + where + balanceassertionsetstyles ba = ba{baamount=amountSetStylesExceptPrecision styles $ baamount ba} + -- | Add tags to a posting, discarding any for which the posting already has a value. postingAddTags :: Posting -> [Tag] -> Posting postingAddTags p@Posting{ptags} tags = p{ptags=ptags `union` tags} @@ -426,14 +447,13 @@ postingApplyValuation priceoracle styles periodlast today v p = postingTransformAmount (mixedAmountApplyValuation priceoracle styles periodlast today (postingDate p) v) p --- | Maybe convert this 'Posting's amount to cost, and apply apply appropriate --- amount styles. -postingToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Posting -> Maybe Posting -postingToCost _ NoConversionOp p = Just p -postingToCost styles ToCost p +-- | Maybe convert this 'Posting's amount to cost. +postingToCost :: ConversionOp -> Posting -> Maybe Posting +postingToCost NoConversionOp p = Just p +postingToCost ToCost p -- If this is a conversion posting with a matched transaction price posting, ignore it | "_conversion-matched" `elem` map fst (ptags p) && noCost = Nothing - | otherwise = Just $ postingTransformAmount (styleMixedAmount styles . mixedAmountCost) p + | otherwise = Just $ postingTransformAmount mixedAmountCost p where noCost = (not . any (isJust . aprice) . amountsRaw) $ pamount p diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -53,8 +53,8 @@ ) where import Control.Monad.Trans.State (StateT(..), evalStateT) -import Data.Bifunctor (first) -import Data.Foldable (foldrM) +import Data.Bifunctor (first, second) +import Data.Foldable (foldlM) import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Semigroup (Endo(..)) import Data.Text (Text) @@ -70,8 +70,13 @@ import Hledger.Data.Posting import Hledger.Data.Amount import Hledger.Data.Valuation +import Data.Decimal (normalizeDecimal, decimalPlaces) +import Data.Functor ((<&>)) +instance HasAmounts Transaction where + styleAmounts styles t = t{tpostings=styleAmounts styles $ tpostings t} + nulltransaction :: Transaction nulltransaction = Transaction { tindex=0, @@ -216,10 +221,9 @@ transactionApplyValuation priceoracle styles periodlast today v = transactionTransformPostings (postingApplyValuation priceoracle styles periodlast today v) --- | Maybe convert this 'Transaction's amounts to cost and apply the --- appropriate amount styles. -transactionToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Transaction -> Transaction -transactionToCost styles cost t = t{tpostings = mapMaybe (postingToCost styles cost) $ tpostings t} +-- | Maybe convert this 'Transaction's amounts to cost. +transactionToCost :: ConversionOp -> Transaction -> Transaction +transactionToCost cost t = t{tpostings = mapMaybe (postingToCost cost) $ tpostings t} -- | Add inferred equity postings to a 'Transaction' using transaction prices. transactionAddInferredEquityPostings :: Bool -> AccountName -> Transaction -> Transaction @@ -228,8 +232,12 @@ type IdxPosting = (Int, Posting) --- WARNING: twisty code ahead +-- XXX Warning: The following code - for analysing equity conversion postings, +-- inferring missing costs and ignoring redundant costs - +-- is twisty and hard to follow. +label s = ((s <> ": ")++) + -- | Add costs inferred from equity postings in this transaction. -- For every adjacent pair of conversion postings, it will first search the postings -- with costs to see if any match. If so, it will tag these as matched. @@ -240,71 +248,117 @@ -- the costful and conversion postings, but don't add costs. transactionInferCostsFromEquity :: Bool -> M.Map AccountName AccountType -> Transaction -> Either String Transaction transactionInferCostsFromEquity dryrun acctTypes t = first (annotateErrorWithTransaction t . T.unpack) $ do - (conversionPairs, stateps) <- partitionAndCheckConversionPostings False acctTypes npostings - f <- transformIndexedPostingsF (addCostsToPostings dryrun) conversionPairs stateps - return t{tpostings = map (snd . f) npostings} + -- number the postings + let npostings = zip [0..] $ tpostings t + + -- Identify all pairs of conversion postings and all other postings (with and without costs) in the transaction. + (conversionPairs, otherps) <- partitionAndCheckConversionPostings False acctTypes npostings + + -- Generate a pure function that can be applied to each of this transaction's postings, + -- possibly modifying it, to produce the following end result: + -- 1. each pair of conversion postings, and the corresponding postings which balance them, are tagged for easy identification + -- 2. each pair of balancing postings which did't have an explicit cost, have had a cost calculated and added to one of them + -- 3. if any ambiguous situation was detected, an informative error is raised + processposting <- transformIndexedPostingsF (addCostsToPostings dryrun) conversionPairs otherps + + -- And if there was no error, use it to modify the transaction's postings. + return t{tpostings = map (snd . processposting) npostings} + where - -- Include indices for postings - npostings = zip [0..] $ tpostings t - transformIndexedPostingsF f = evalStateT . fmap (appEndo . foldMap Endo) . traverse f - -- Given a pair of indexed conversion postings, and a state consisting of lists of - -- costful and costless non-conversion postings, create a function which adds a conversion cost - -- to the posting which matches the conversion postings if necessary, - -- and tags the conversion and matched postings. Then update the state by removing the - -- matched postings. If there are no matching postings or too much ambiguity, - -- return an error string annotated with the conversion postings. - -- If the first argument is true, do a dry run instead: identify and tag - -- the costful and conversion postings, but don't add costs. - addCostsToPostings :: Bool -> (IdxPosting, IdxPosting) - -> StateT ([IdxPosting], [IdxPosting]) (Either Text) (IdxPosting -> IdxPosting) + -- Generate the tricksy processposting function, + -- which when applied to each posting in turn, rather magically has the effect of + -- applying addCostsToPostings to each pair of conversion postings in the transaction, + -- matching them with the other postings, tagging them and perhaps adding cost information to the other postings. + -- General type: + -- transformIndexedPostingsF :: (Monad m, Foldable t, Traversable t) => + -- (a -> StateT s m (a1 -> a1)) -> + -- t a -> + -- s -> + -- m (a1 -> a1) + -- Concrete type: + transformIndexedPostingsF :: + ((IdxPosting, IdxPosting) -> StateT ([IdxPosting],[IdxPosting]) (Either Text) (IdxPosting -> IdxPosting)) -> -- state update function (addCostsToPostings with the bool applied) + [(IdxPosting, IdxPosting)] -> -- initial state: the pairs of adjacent conversion postings in the transaction + ([IdxPosting],[IdxPosting]) -> -- initial state: the other postings in the transaction, separated into costful and costless + (Either Text (IdxPosting -> IdxPosting)) -- returns an error message or a posting transform function + transformIndexedPostingsF updatefn = evalStateT . fmap (appEndo . foldMap Endo) . traverse (updatefn) + + -- A tricksy state update helper for processposting/transformIndexedPostingsF. + -- Approximately: given a pair of conversion postings to match, + -- and lists of the remaining unmatched costful and costless other postings, + -- 1. find (and consume) two other postings which match the two conversion postings + -- 2. add identifying tags to the four postings + -- 3. add an explicit cost, if missing, to one of the matched other postings + -- 4. or if there is a problem, raise an informative error or do nothing as appropriate. + -- Or, if the first argument is true: + -- do a dry run instead: find and consume, add tags, but don't add costs + -- (and if there are no costful postings at all, do nothing). + addCostsToPostings :: Bool -> (IdxPosting, IdxPosting) -> StateT ([IdxPosting], [IdxPosting]) (Either Text) (IdxPosting -> IdxPosting) addCostsToPostings dryrun' ((n1, cp1), (n2, cp2)) = StateT $ \(costps, otherps) -> do - -- Get the two conversion posting amounts, if possible - ca1 <- conversionPostingAmountNoCost cp1 - ca2 <- conversionPostingAmountNoCost cp2 - let -- The function to add costs and tag postings in the indexed list of postings - transformPostingF np costp (n,p) = - (n, if | n == np -> costp `postingAddTags` [("_price-matched","")] - | n == n1 || n == n2 -> p `postingAddTags` [("_conversion-matched","")] - | otherwise -> p) - -- All costful postings which match the conversion posting pair - matchingCostPs = mapMaybe (mapM $ costfulPostingIfMatchesBothAmounts ca1 ca2) costps - -- All other postings which match at least one of the conversion posting pair. - -- Add a corresponding cost to these postings, unless in dry run mode. - matchingOtherPs - | dryrun' = [(n,(p, a)) | (n,p) <- otherps, let Just a = postingSingleAmount p] - | otherwise = mapMaybe (mapM $ addCostIfMatchesOneAmount ca1 ca2) otherps + -- Get the two conversion posting amounts, if possible + ca1 <- conversionPostingAmountNoCost cp1 + ca2 <- conversionPostingAmountNoCost cp2 + let + -- All costful postings which match the conversion posting pair + matchingCostPs = + dbg7With (label "matched costful postings".show.length) $ + mapMaybe (mapM $ costfulPostingIfMatchesBothAmounts ca1 ca2) costps - -- Annotate any errors with the conversion posting pair - first (annotateWithPostings [cp1, cp2]) $ - if -- If a single costful posting matches the conversion postings, - -- delete it from the list of costful postings in the state, delete the - -- first matching costless posting from the list of costless postings - -- in the state, and return the transformation function with the new state. - | [(np, (costp, _))] <- matchingCostPs - , Just newcostps <- deleteIdx np costps - -> Right (transformPostingF np costp, (if dryrun' then costps else newcostps, otherps)) - -- If no costful postings match the conversion postings, but some - -- of the costless postings match, check that the first such posting has a - -- different amount from all the others, and if so add a cost to it, - -- then delete it from the list of costless postings in the state, - -- and return the transformation function with the new state. - | [] <- matchingCostPs - , (np, (costp, amt)):nps <- matchingOtherPs - , not $ any (amountMatches amt . snd . snd) nps - , Just newotherps <- deleteIdx np otherps - -> Right (transformPostingF np costp, (costps, if dryrun' then otherps else newotherps)) - -- Otherwise it's too ambiguous to make a guess, so return an error. - | otherwise -> Left "There is not a unique posting which matches the conversion posting pair:" + -- All other single-commodity postings whose amount matches at least one of the conversion postings, + -- with an explicit cost added. Or in dry run mode, all other single-commodity postings. + matchingOtherPs = + dbg7With (label "matched costless postings".show.length) $ + if dryrun' + then [(n,(p, a)) | (n,p) <- otherps, let Just a = postingSingleAmount p] + else mapMaybe (mapM $ addCostIfMatchesOneAmount ca1 ca2) otherps + -- A function that adds a cost and/or tag to a numbered posting if appropriate. + postingAddCostAndOrTag np costp (n,p) = + (n, if | n == np -> costp `postingAddTags` [("_price-matched","")] + | n == n1 || n == n2 -> p `postingAddTags` [("_conversion-matched","")] + | otherwise -> p) + + -- Annotate any errors with the conversion posting pair + first (annotateWithPostings [cp1, cp2]) $ + if + -- If a single costful posting matches the conversion postings, + -- delete it from the list of costful postings in the state, delete the + -- first matching costless posting from the list of costless postings + -- in the state, and return the transformation function with the new state. + | [(np, costp)] <- matchingCostPs + , Just newcostps <- deleteIdx np costps + -> Right (postingAddCostAndOrTag np costp, (if dryrun' then costps else newcostps, otherps)) + + -- If no costful postings match the conversion postings, but some + -- of the costless postings match, check that the first such posting has a + -- different amount from all the others, and if so add a cost to it, + -- then delete it from the list of costless postings in the state, + -- and return the transformation function with the new state. + | [] <- matchingCostPs + , (np, (costp, amt)):nps <- matchingOtherPs + , not $ any (amountsMatch amt . snd . snd) nps + , Just newotherps <- deleteIdx np otherps + -> Right (postingAddCostAndOrTag np costp, (costps, if dryrun' then otherps else newotherps)) + + -- Otherwise, do nothing, leaving the transaction unchanged. + -- We don't want to be over-zealous reporting problems here + -- since this is always called at least in dry run mode by + -- journalFinalise > journalMarkRedundantCosts. (#2045) + | otherwise -> Right (id, (costps, otherps)) + -- If a posting with cost matches both the conversion amounts, return it along -- with the matching amount which must be present in another non-conversion posting. - costfulPostingIfMatchesBothAmounts :: Amount -> Amount -> Posting -> Maybe (Posting, Amount) - costfulPostingIfMatchesBothAmounts a1 a2 p = do - a@Amount{aprice=Just _} <- postingSingleAmount p - if | amountMatches (-a1) a && amountMatches a2 (amountCost a) -> Just (p, -a2) - | amountMatches (-a2) a && amountMatches a1 (amountCost a) -> Just (p, -a1) + costfulPostingIfMatchesBothAmounts :: Amount -> Amount -> Posting -> Maybe Posting + costfulPostingIfMatchesBothAmounts a1 a2 costfulp = do + a@Amount{aprice=Just _} <- postingSingleAmount costfulp + if + | dbgamtmatch 1 a1 a (amountsMatch (-a1) a) && dbgcostmatch 2 a2 a (amountsMatch a2 (amountCost a)) -> Just costfulp + | dbgamtmatch 2 a2 a (amountsMatch (-a2) a) && dbgcostmatch 1 a1 a (amountsMatch a1 (amountCost a)) -> Just costfulp | otherwise -> Nothing + where + dbgamtmatch n a b = dbg7 ("conversion posting " <>show n<>" "<>showAmount a<>" balances amount "<>showAmountWithoutPrice b <>" of costful posting "<>showAmount b<>" at precision "<>dbgShowAmountPrecision a<>" ?") + dbgcostmatch n a b = dbg7 ("and\nconversion posting "<>show n<>" "<>showAmount a<>" matches cost " <>showAmount (amountCost b)<>" of costful posting "<>showAmount b<>" at precision "<>dbgShowAmountPrecision a<>" ?") -- Add a cost to a posting if it matches (negative) one of the -- supplied conversion amounts, adding the other amount as the cost. @@ -312,9 +366,10 @@ addCostIfMatchesOneAmount a1 a2 p = do a <- postingSingleAmount p let newp cost = p{pamount = mixedAmount a{aprice = Just $ TotalPrice cost}} - if | amountMatches (-a1) a -> Just (newp a2, a2) - | amountMatches (-a2) a -> Just (newp a1, a1) - | otherwise -> Nothing + if + | amountsMatch (-a1) a -> Just (newp a2, a2) + | amountsMatch (-a2) a -> Just (newp a1, a1) + | otherwise -> Nothing -- Get the single-commodity costless amount from a conversion posting, or raise an error. conversionPostingAmountNoCost p = case postingSingleAmount p of @@ -322,7 +377,12 @@ Just Amount{aprice=Just _} -> Left $ annotateWithPostings [p] "Conversion postings must not have a cost:" Nothing -> Left $ annotateWithPostings [p] "Conversion postings must have a single-commodity amount:" - amountMatches a b = acommodity a == acommodity b && aquantity a == aquantity b + -- Do these amounts look the same when compared at the first's display precision ? + -- (Or if that's unset, compare as-is) + amountsMatch a b = + case asprecision $ astyle a of + Just p -> amountLooksZero $ amountSetPrecision p $ a - b + Nothing -> amountLooksZero $ a - b -- Delete a posting from the indexed list of postings based on either its -- index or its posting amount. @@ -338,19 +398,30 @@ deleteUniqueMatch _ [] = Nothing annotateWithPostings xs str = T.unlines $ str : postingsAsLines False xs +dbgShowAmountPrecision a = + case asprecision $ astyle a of + Just (Precision n) -> show n + Just NaturalPrecision -> show $ decimalPlaces $ normalizeDecimal $ aquantity a + Nothing -> "unset" + -- Using the provided account types map, sort the given indexed postings -- into three lists of posting numbers (stored in two pairs), like so: --- (conversion postings, (costful postings, other postings)). +-- (conversion postings, (costful other postings, costless other postings)). -- A true first argument activates its secondary function: check that all -- conversion postings occur in adjacent pairs, otherwise return an error. partitionAndCheckConversionPostings :: Bool -> M.Map AccountName AccountType -> [IdxPosting] -> Either Text ( [(IdxPosting, IdxPosting)], ([IdxPosting], [IdxPosting]) ) -partitionAndCheckConversionPostings check acctTypes = fmap fst . foldrM select (([], ([], [])), Nothing) +partitionAndCheckConversionPostings check acctTypes = + -- Left fold processes postings in parse order, so that eg inferred costs + -- will be added to the first (top-most) posting, not the last one. + foldlM select (([], ([], [])), Nothing) + -- The costless other postings are somehow reversed still; "second (second reverse" fixes that. + <&> fmap (second (second reverse) . fst) where - select np@(_, p) ((cs, others@(ps, os)), Nothing) + select ((cs, others@(ps, os)), Nothing) np@(_, p) | isConversion p = Right ((cs, others), Just np) | hasCost p = Right ((cs, (np:ps, os)), Nothing) | otherwise = Right ((cs, (ps, np:os)), Nothing) - select np@(_, p) ((cs, others@(ps,os)), Just lst) + select ((cs, others@(ps,os)), Just lst) np@(_, p) | isConversion p = Right (((lst, np):cs, others), Nothing) | check = Left "Conversion postings must occur in adjacent pairs" | otherwise = Right ((cs, (ps, np:os)), Nothing) diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -249,31 +249,34 @@ data AmountPrice = UnitPrice !Amount | TotalPrice !Amount deriving (Eq,Ord,Generic,Show) --- | Display style for an amount. +-- | The display style for an amount. +-- (See also Amount.AmountDisplayOpts). 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, -- ^ show the symbol on the left or the right ? + ascommodityspaced :: !Bool, -- ^ show a space between symbol and quantity ? + asdigitgroups :: !(Maybe DigitGroupStyle), -- ^ show the integer part with these digit group marks, or not + asdecimalmark :: !(Maybe Char), -- ^ show this character (should be . or ,) as decimal mark, or use the default (.) + asprecision :: !(Maybe AmountPrecision) -- ^ show this number of digits after the decimal point, or show as-is (leave precision unchanged) + -- XXX Making asprecision a maybe simplifies code for styling with or without precision, + -- but complicates the semantics (Nothing is useful only when setting style). } deriving (Eq,Ord,Read,Generic) instance Show AmountStyle where - show AmountStyle{..} = concat - [ "AmountStylePP \"" + show AmountStyle{..} = unwords + [ "AmountStylePP" , show ascommodityside , show ascommodityspaced - , show asprecision - , show asdecimalpoint , show asdigitgroups - , "..\"" + , show asdecimalmark + , show asprecision ] -- | The "display precision" for a hledger amount, by which we mean -- the number of decimal digits to display to the right of the decimal mark. --- This can be from 0 to 255 digits (the maximum supported by the Decimal library), --- or NaturalPrecision meaning "show all significant decimal digits". -data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Generic) +data AmountPrecision = + Precision !Word8 -- ^ show this many decimal digits (0..255) + | NaturalPrecision -- ^ show all significant decimal digits stored internally + deriving (Eq,Ord,Read,Show,Generic) -- | A style for displaying digit groups in the integer part of a -- floating point number. It consists of the character used to @@ -297,6 +300,24 @@ astyle :: !AmountStyle, aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any } deriving (Eq,Ord,Generic,Show) + +-- | Types with this class have one or more amounts, +-- which can have display styles applied to them. +class HasAmounts a where + styleAmounts :: M.Map CommoditySymbol AmountStyle -> a -> a + +instance HasAmounts a => + HasAmounts [a] + where styleAmounts styles = map (styleAmounts styles) + +instance (HasAmounts a, HasAmounts b) => + HasAmounts (a,b) + where styleAmounts styles (aa,bb) = (styleAmounts styles aa, styleAmounts styles bb) + +instance HasAmounts a => + HasAmounts (Maybe a) + where styleAmounts styles = fmap (styleAmounts styles) + newtype MixedAmount = Mixed (M.Map MixedAmountKey Amount) deriving (Generic,Show) diff --git a/Hledger/Data/Valuation.hs b/Hledger/Data/Valuation.hs --- a/Hledger/Data/Valuation.hs +++ b/Hledger/Data/Valuation.hs @@ -110,8 +110,8 @@ where style' = (astyle a) { asprecision = precision' } precision' = case asprecision (astyle a) of - NaturalPrecision -> NaturalPrecision - Precision p -> Precision $ (numDigitsInt $ truncate n) + p + Just (Precision p) -> Just $ Precision $ (numDigitsInt $ truncate n) + p + mp -> mp ------------------------------------------------------------------------------ -- Converting things to value @@ -129,7 +129,7 @@ -- | Convert an Amount to its cost if requested, and style it appropriately. amountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Amount -> Amount -amountToCost styles ToCost = styleAmount styles . amountCost +amountToCost styles ToCost = amountSetStyles styles . amountCost amountToCost _ NoConversionOp = id -- | Apply a specified valuation to this amount, using the provided @@ -192,7 +192,7 @@ -- setNaturalPrecisionUpTo 8 $ -- XXX force higher precision in case amount appears to be zero ? -- Make default display style use precision 2 instead of 0 ? -- Leave as is for now; mentioned in manual. - styleAmount styles + amountSetStyles styles nullamt{acommodity=comm, aquantity=rate * aquantity a} -- | Calculate the gain of each component amount, that is the difference diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -193,7 +193,7 @@ rawOptsToInputOpts :: Day -> RawOpts -> InputOpts rawOptsToInputOpts day rawopts = - let noinferbalancingcosts = boolopt "strict" rawopts || stringopt "args" rawopts == "balancednoautoconversion" + let noinferbalancingcosts = boolopt "strict" rawopts || stringopt "args" rawopts == "balanced" -- Do we really need to do all this work just to get the requested end date? This is duplicating -- much of reportOptsToSpec. @@ -334,7 +334,7 @@ >>= journalMarkRedundantCosts -- Mark redundant costs, to help journalBalanceTransactions ignore them >>= journalBalanceTransactions balancingopts_ -- Balance all transactions and maybe check balance assertions. >>= (if infer_costs_ then journalInferCostsFromEquity else pure) -- Maybe infer costs from equity postings where possible - <&> (if infer_equity_ then journalAddInferredEquityPostings verbose_tags_ else id) -- Maybe infer equity postings from costs where possible + <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id) -- Maybe infer equity postings from costs where possible <&> journalInferMarketPricesFromTransactions -- infer market prices from commodity-exchanging transactions <&> traceOrLogAt 6 ("journalFinalise: " <> takeFileName f) -- debug logging <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> " acct decls : ") @@ -386,7 +386,7 @@ getDecimalMarkStyle :: JournalParser m (Maybe AmountStyle) getDecimalMarkStyle = do Journal{jparsedecimalmark} <- get - let mdecmarkStyle = (\c -> Just $ amountstyle{asdecimalpoint=Just c}) =<< jparsedecimalmark + let mdecmarkStyle = (\c -> Just $ amountstyle{asdecimalmark=Just c}) =<< jparsedecimalmark return mdecmarkStyle setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m () @@ -802,7 +802,7 @@ offAfterNum <- getOffset let numRegion = (offBeforeNum, offAfterNum) (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent - let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} + let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=Just prec, asdecimalmark=mdec, asdigitgroups=mgrps} return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, aprice=Nothing} -- An amount with commodity symbol on the right or no commodity symbol. @@ -824,7 +824,7 @@ -- XXX amounts of this commodity in periodic transaction rules and auto posting rules ? #1461 let msuggestedStyle = mdecmarkStyle <|> mcommodityStyle (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent - let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} + let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=Just prec, asdecimalmark=mdec, asdigitgroups=mgrps} return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing} -- no symbol amount Nothing -> do @@ -840,8 +840,8 @@ -- (unless it's a multiplier in an automated posting) defcs <- getDefaultCommodityAndStyle let (c,s) = case (mult, defcs) of - (False, Just (defc,defs)) -> (defc, defs{asprecision=max (asprecision defs) prec}) - _ -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}) + (False, Just (defc,defs)) -> (defc, defs{asprecision=max (asprecision defs) (Just prec)}) + _ -> ("", amountstyle{asprecision=Just prec, asdecimalmark=mdec, asdigitgroups=mgrps}) return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing} -- For reducing code duplication. Doesn't parse anything. Has the type @@ -1066,9 +1066,9 @@ where isValidDecimalBy :: Char -> AmountStyle -> Bool isValidDecimalBy c = \case - AmountStyle{asdecimalpoint = Just d} -> d == c + AmountStyle{asdecimalmark = Just d} -> d == c AmountStyle{asdigitgroups = Just (DigitGroups g _)} -> g /= c - AmountStyle{asprecision = Precision 0} -> False + AmountStyle{asprecision = Just (Precision 0)} -> False _ -> True -- | Parse and interpret the structure of a number without external hints. @@ -1568,28 +1568,28 @@ ,testCase "ends with decimal mark" $ assertParseEq amountp "$1." (usd 1 `withPrecision` Precision 0) ,testCase "unit price" $ assertParseEq amountp "$10 @ €0.5" -- not precise enough: - -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.' + -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalmark=Just '.' nullamt{ acommodity="$" ,aquantity=10 -- need to test internal precision with roundTo ? I think not - ,astyle=amountstyle{asprecision=Precision 0, asdecimalpoint=Nothing} + ,astyle=amountstyle{asprecision=Just $ Precision 0, asdecimalmark=Nothing} ,aprice=Just $ UnitPrice $ nullamt{ acommodity="€" ,aquantity=0.5 - ,astyle=amountstyle{asprecision=Precision 1, asdecimalpoint=Just '.'} + ,astyle=amountstyle{asprecision=Just $ Precision 1, asdecimalmark=Just '.'} } } ,testCase "total price" $ assertParseEq amountp "$10 @@ €5" nullamt{ acommodity="$" ,aquantity=10 - ,astyle=amountstyle{asprecision=Precision 0, asdecimalpoint=Nothing} + ,astyle=amountstyle{asprecision=Just $ Precision 0, asdecimalmark=Nothing} ,aprice=Just $ TotalPrice $ nullamt{ acommodity="€" ,aquantity=5 - ,astyle=amountstyle{asprecision=Precision 0, asdecimalpoint=Nothing} + ,astyle=amountstyle{asprecision=Just $ Precision 0, asdecimalmark=Nothing} } } ,testCase "unit price, parenthesised" $ assertParse amountp "$10 (@) €0.5" diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -490,7 +490,7 @@ lift skipNonNewlineSpaces _ <- lift followingcommentp let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle} - if isNothing $ asdecimalpoint astyle + if isNothing $ asdecimalmark astyle then customFailure $ parseErrorAt off pleaseincludedecimalpoint else modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j}) @@ -533,7 +533,7 @@ _ <- lift followingcommentp if acommodity==expectedsym then - if isNothing $ asdecimalpoint astyle + if isNothing $ asdecimalmark astyle then customFailure $ parseErrorAt off pleaseincludedecimalpoint else return $ dbg6 "style from format subdirective" astyle else customFailure $ parseErrorAt off $ @@ -648,7 +648,7 @@ off <- getOffset Amount{acommodity,astyle} <- amountp lift restofline - if isNothing $ asdecimalpoint astyle + if isNothing $ asdecimalmark astyle then customFailure $ parseErrorAt off pleaseincludedecimalpoint else setDefaultCommodityAndStyle (acommodity, astyle) diff --git a/Hledger/Read/TimedotReader.hs b/Hledger/Read/TimedotReader.hs --- a/Hledger/Read/TimedotReader.hs +++ b/Hledger/Read/TimedotReader.hs @@ -192,8 +192,8 @@ mcs <- getDefaultCommodityAndStyle let (c,s) = case mcs of - Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) (Precision 2)}) - _ -> ("", amountstyle{asprecision=Precision 2}) + Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) (Just $ Precision 2)}) + _ -> ("", amountstyle{asprecision=Just $ Precision 2}) -- lift $ traceparse' "timedotentryp end" return $ nullposting{paccount=a ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hours, astyle=s} diff --git a/Hledger/Reports/AccountTransactionsReport.hs b/Hledger/Reports/AccountTransactionsReport.hs --- a/Hledger/Reports/AccountTransactionsReport.hs +++ b/Hledger/Reports/AccountTransactionsReport.hs @@ -85,6 +85,10 @@ ,MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction ) +instance HasAmounts AccountTransactionsReportItem where + styleAmounts styles (torig,tacct,b,c,a1,a2) = + (styleAmounts styles torig,styleAmounts styles tacct,b,c,styleAmounts styles a1,styleAmounts styles a2) + triOrigTransaction (torig,_,_,_,_,_) = torig triDate (_,tacct,_,_,_,_) = tdate tacct triAmount (_,_,_,_,a,_) = a @@ -125,7 +129,7 @@ -- maybe convert these transactions to cost or value . journalApplyValuationFromOpts rspec . traceOrLogAtWith 5 (("ts2:\n"++).pshowTransactions.jtxns) - -- apply any cur:SYM filters in reportq + -- apply any cur: or amt: filters in reportq . (if queryIsNull amtq then id else filterJournalAmounts amtq) -- only consider transactions which match thisacctq (possibly excluding postings -- which are not real or have the wrong status) diff --git a/Hledger/Reports/BalanceReport.hs b/Hledger/Reports/BalanceReport.hs --- a/Hledger/Reports/BalanceReport.hs +++ b/Hledger/Reports/BalanceReport.hs @@ -49,6 +49,9 @@ type BalanceReport = ([BalanceReportItem], MixedAmount) type BalanceReportItem = (AccountName, AccountName, Int, MixedAmount) +instance HasAmounts BalanceReportItem where + styleAmounts styles (a,b,c,d) = (a,b,c,styleAmounts styles d) + -- | When true (the default), this makes balance --flat reports and their implementation clearer. -- Single/multi-col balance reports currently aren't all correct if this is false. flatShowsExclusiveBalance = True diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -617,7 +617,8 @@ tests_MultiBalanceReport = testGroup "MultiBalanceReport" [ let - amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = Precision 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}} + amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, + astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing, asdecimalmark = Just '.', asprecision = Just $ Precision 2}} (rspec,journal) `gives` r = do let rspec' = rspec{_rsQuery=And [queryFromFlags $ _rsReportOpts rspec, _rsQuery rspec]} (eitems, etotal) = r diff --git a/Hledger/Reports/PostingsReport.hs b/Hledger/Reports/PostingsReport.hs --- a/Hledger/Reports/PostingsReport.hs +++ b/Hledger/Reports/PostingsReport.hs @@ -52,6 +52,9 @@ -- the running total/average. ) +instance HasAmounts PostingsReportItem where + styleAmounts styles (a,b,c,d,e) = (a,b,c,styleAmounts styles d,styleAmounts styles e) + -- | A summary posting summarises the activity in one account within a report -- interval. It is by a regular Posting with no description, the interval's -- start date stored as the posting date, and the interval's Period attached diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -623,7 +623,7 @@ gain mc spn = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn) costing = case fromMaybe NoConversionOp $ conversionop_ ropts of NoConversionOp -> id - ToCost -> styleMixedAmount styles . mixedAmountCost + ToCost -> mixedAmountSetStyles styles . mixedAmountCost styles = journalCommodityStyles j err = error "mixedAmountApplyValuationAfterSumFromOptsWith: expected all spans to have an end date" diff --git a/Hledger/Reports/ReportTypes.hs b/Hledger/Reports/ReportTypes.hs --- a/Hledger/Reports/ReportTypes.hs +++ b/Hledger/Reports/ReportTypes.hs @@ -4,6 +4,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} module Hledger.Reports.ReportTypes ( PeriodicReport(..) @@ -91,6 +93,10 @@ instance Bifunctor PeriodicReport where bimap f g pr = pr{prRows = map (bimap f g) $ prRows pr, prTotals = g <$> prTotals pr} +instance HasAmounts b => HasAmounts (PeriodicReport a b) where + styleAmounts styles r@PeriodicReport{prRows,prTotals} = + r{prRows=styleAmounts styles prRows, prTotals=styleAmounts styles prTotals} + data PeriodicReportRow a b = PeriodicReportRow { prrName :: a -- An account name. @@ -106,6 +112,13 @@ instance Semigroup b => Semigroup (PeriodicReportRow a b) where (<>) = prrAdd +instance HasAmounts b => HasAmounts (PeriodicReportRow a b) where + styleAmounts styles r = + r{prrAmounts=styleAmounts styles $ prrAmounts r + ,prrTotal =styleAmounts styles $ prrTotal r + ,prrAverage=styleAmounts styles $ prrAverage r + } + -- | Add two 'PeriodicReportRows', preserving the name of the first. prrAdd :: Semigroup b => PeriodicReportRow a b -> PeriodicReportRow a b -> PeriodicReportRow a b prrAdd (PeriodicReportRow n1 amts1 t1 a1) (PeriodicReportRow _ amts2 t2 a2) = @@ -161,6 +174,16 @@ , cbrSubreports :: [(Text, PeriodicReport a b, Bool)] , cbrTotals :: PeriodicReportRow () b } deriving (Show, Functor, Generic, ToJSON) + +instance HasAmounts b => HasAmounts (CompoundPeriodicReport a b) where + styleAmounts styles cpr@CompoundPeriodicReport{cbrSubreports, cbrTotals} = + cpr{ + cbrSubreports = styleAmounts styles cbrSubreports + , cbrTotals = styleAmounts styles cbrTotals + } + +instance HasAmounts b => HasAmounts (Text, PeriodicReport a b, Bool) where + styleAmounts styles (a,b,c) = (a,styleAmounts styles b,c) -- | Description of one subreport within a compound balance report. -- Part of a "CompoundBalanceCommandSpec", but also used in hledger-lib. diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hledger-lib -version: 1.30 +version: 1.31 synopsis: A reusable library providing the core functionality of hledger description: A reusable library containing hledger's core functionality. This is used by most hledger* packages so that they support the same @@ -27,7 +27,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC==8.10.7, GHC==9.0.2, GHC==9.2.7, GHC==9.4.4 + GHC==8.10.7, GHC==9.0.2, GHC==9.2.8, GHC==9.4.5, GHC==9.6.2 extra-source-files: CHANGES.md README.md @@ -102,7 +102,7 @@ build-depends: Decimal >=0.5.1 , Glob >=0.9 - , aeson >=1 + , aeson >=1 && <2.3 , aeson-pretty , ansi-terminal >=0.9 , array @@ -124,7 +124,7 @@ , file-embed >=0.0.10 , filepath , hashtables >=1.2.3.1 - , megaparsec >=7.0.0 && <9.4 + , megaparsec >=7.0.0 && <9.6 , microlens >=0.4 , microlens-th >=0.4 , mtl >=2.2.1 @@ -160,7 +160,7 @@ build-depends: Decimal >=0.5.1 , Glob >=0.7 - , aeson >=1 + , aeson >=1 && <2.3 , aeson-pretty , ansi-terminal >=0.9 , array @@ -183,7 +183,7 @@ , file-embed >=0.0.10 , filepath , hashtables >=1.2.3.1 - , megaparsec >=7.0.0 && <9.4 + , megaparsec >=7.0.0 && <9.6 , microlens >=0.4 , microlens-th >=0.4 , mtl >=2.2.1 @@ -221,7 +221,7 @@ build-depends: Decimal >=0.5.1 , Glob >=0.9 - , aeson >=1 + , aeson >=1 && <2.3 , aeson-pretty , ansi-terminal >=0.9 , array @@ -244,7 +244,7 @@ , filepath , hashtables >=1.2.3.1 , hledger-lib - , megaparsec >=7.0.0 && <9.4 + , megaparsec >=7.0.0 && <9.6 , microlens >=0.4 , microlens-th >=0.4 , mtl >=2.2.1