diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,19 +1,63 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. + +# 1.33 2024-04-18 + +Breaking changes + +Fixes + +- Require process 1.6.19.0+ to avoid any vulnerabilities on Windows from + [HSEC-2024-0003](https://haskell.github.io/security-advisories/advisory/HSEC-2024-0003.html). + This has also required disabling this package's doctest test suite for the moment. + +- A potential Glob/filemanip package conflict in Hledger.Utils.IO now prevented, + avoiding build failures. + + +Improvements + +- hledger can now be built with GHC 9.8. +- hledger now requires safe >=0.3.20. +- fix spanUnion with open-ended dates; add spanExtend [#2177] +- move readFileStrictly from hledger to Hledger.Utils.IO +- rename/improve amountSetFullPrecisionUpTo; add mixedAmountSetFullPrecisionUpTo +- rename Amount's aprice -> acost +- rename AmountPrice, UnitPrice, TotalPrice -> AmountCost, UnitCost, TotalCost +- showAmountWithoutPrice -> showAmountWithoutCost +- mixedAmountStripPrices -> mixedAmountStripCosts +- showMixedAmountWithoutPrice -> showMixedAmountWithoutCost +- showMixedAmountOneLineWithoutPrice -> showMixedAmountOneLineWithoutCost +- rename amountStripPrices -> amountStripCost, etc +- rename AmountDisplayOpts -> AmountFormat; add a new flag for symbol display +- rename noColour -> defaultFmt +- rename noCost -> noCostFmt +- rename oneLine -> oneLineFmt +- rename csvDisplay -> machineFmt +- distinguish oneLineFmt and oneLineNoCostFmt; add fullZeroFmt +- matchedPostingsBeforeAndDuring: improve debug output + + # 1.32.3 2024-01-28 diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -52,8 +52,8 @@ aname (if aboring then "y" else "n" :: String) anumpostings - (wbUnpack $ showMixedAmountB noColour aebalance) - (wbUnpack $ showMixedAmountB noColour aibalance) + (wbUnpack $ showMixedAmountB defaultFmt aebalance) + (wbUnpack $ showMixedAmountB defaultFmt aibalance) instance Eq Account where (==) a b = aname a == aname b -- quick equality test for speed @@ -243,7 +243,7 @@ sortSubs = case normalsign of NormallyPositive -> sortOn (\a -> (Down $ amt a, aname a)) NormallyNegative -> sortOn (\a -> (amt a, aname a)) - amt = mixedAmountStripPrices . aibalance + amt = mixedAmountStripCosts . aibalance -- | Add extra info for this account derived from the Journal's -- account directives, if any (comment, tags, declaration order..). @@ -303,6 +303,6 @@ showAccountDebug a = printf "%-25s %4s %4s %s" (aname a) - (wbUnpack . showMixedAmountB noColour $ aebalance a) - (wbUnpack . showMixedAmountB noColour $ aibalance a) + (wbUnpack . showMixedAmountB defaultFmt $ aebalance a) + (wbUnpack . showMixedAmountB defaultFmt $ aibalance a) (if aboring a then "b" else " " :: String) diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -311,7 +311,7 @@ elideparts :: Int -> [Text] -> [Text] -> [Text] elideparts w done ss | realLength (accountNameFromComponents $ done++ss) <= w = done++ss - | length ss > 1 = elideparts w (done++[textTakeWidth 2 $ head ss]) (tail ss) + | length ss > 1 = elideparts w (done++[textTakeWidth 2 $ headErr ss]) (tailErr ss) -- PARTIAL headErr, tailErr will succeed because length > 1 | otherwise = done++ss -- | Keep only the first n components of an account name, where n diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -12,13 +12,13 @@ 0 @ -It may also have an assigned 'Price', representing this amount's per-unit +It may also have an 'AmountCost', representing this amount's per-unit or total cost in a different commodity. If present, this is rendered like so: @ - EUR 2 \@ $1.50 (unit price) - EUR 2 \@\@ $3 (total price) + EUR 2 \@ $1.50 (unit cost) + EUR 2 \@\@ $3 (total cost) @ A 'MixedAmount' is zero or more simple amounts, so can represent multiple @@ -31,12 +31,11 @@ @ A mixed amount is always \"normalised\", it has no more than one amount -in each commodity and price. When calling 'amounts' it will have no zero +in each commodity and cost. When calling 'amounts' it will have no zero amounts, or just a single zero amount and no other amounts. Limited arithmetic with simple and mixed amounts is supported, best used -with similar amounts since it mostly ignores assigned prices and commodity -exchange rates. +with similar amounts since it mostly ignores costss and commodity exchange rates. -} @@ -78,25 +77,27 @@ amountStylesSetRounding, amountUnstyled, -- ** rendering - AmountDisplayOpts(..), - noColour, - noCost, - oneLine, - csvDisplay, - showAmountB, + AmountFormat(..), + defaultFmt, + fullZeroFmt, + noCostFmt, + oneLineFmt, + oneLineNoCostFmt, + machineFmt, showAmount, showAmountWith, - showAmountCostB, + showAmountB, + showAmountsCostB, cshowAmount, showAmountWithZeroCommodity, showAmountDebug, - showAmountWithoutPrice, + showAmountWithoutCost, amountSetPrecision, amountSetPrecisionMin, amountSetPrecisionMax, withPrecision, amountSetFullPrecision, - amountSetFullPrecisionOr, + amountSetFullPrecisionUpTo, amountInternalPrecision, amountDisplayPrecision, defaultMaxPrecision, @@ -122,7 +123,7 @@ filterMixedAmountByCommodity, mapMixedAmount, unifyMixedAmount, - mixedAmountStripPrices, + mixedAmountStripCosts, -- ** arithmetic mixedAmountCost, maNegate, @@ -148,8 +149,8 @@ showMixedAmountWith, showMixedAmountOneLine, showMixedAmountDebug, - showMixedAmountWithoutPrice, - showMixedAmountOneLineWithoutPrice, + showMixedAmountWithoutCost, + showMixedAmountOneLineWithoutCost, showMixedAmountElided, showMixedAmountWithZeroCommodity, showMixedAmountB, @@ -158,6 +159,7 @@ wbUnpack, mixedAmountSetPrecision, mixedAmountSetFullPrecision, + mixedAmountSetFullPrecisionUpTo, mixedAmountSetPrecisionMin, mixedAmountSetPrecisionMax, @@ -217,10 +219,10 @@ | T.any isNonsimpleCommodityChar s = "\"" <> s <> "\"" | otherwise = s - --- | Options for the display of Amount and MixedAmount. --- (ee also Types.AmountStyle. -data AmountDisplayOpts = AmountDisplayOpts +-- | Formatting options available when displaying Amounts and MixedAmounts. +-- Similar to "AmountStyle" but lower level, not attached to amounts or commodities, and can override it in some ways. +-- See also hledger manual > "Amount formatting, parseability", which speaks of human, hledger, and machine output. +data AmountFormat = AmountFormat { displayCommodity :: Bool -- ^ Whether to display commodity symbols. , displayZeroCommodity :: Bool -- ^ Whether to display commodity symbols for zero Amounts. , displayCommodityOrder :: Maybe [CommoditySymbol] @@ -237,17 +239,17 @@ , displayColour :: Bool -- ^ Whether to ansi-colourise negative Amounts. } deriving (Show) --- | By default, display Amount and MixedAmount using @noColour@ amount display options. -instance Default AmountDisplayOpts where def = noColour +-- | By default, display amounts using @defaultFmt@ amount display options. +instance Default AmountFormat where def = defaultFmt -- | Display amounts without colour, and with various other defaults. -noColour :: AmountDisplayOpts -noColour = AmountDisplayOpts { +defaultFmt :: AmountFormat +defaultFmt = AmountFormat { displayCommodity = True , displayZeroCommodity = False , displayCommodityOrder = Nothing , displayDigitGroups = True - , displayForceDecimalMark = False + , displayForceDecimalMark = False , displayOneLine = False , displayMinWidth = Just 0 , displayMaxWidth = Nothing @@ -255,18 +257,26 @@ , displayColour = False } --- | Display Amount and MixedAmount with no prices. -noCost :: AmountDisplayOpts -noCost = def{displayCost=False} +-- | Like defaultFmt but show zero amounts with commodity symbol and styling, like non-zero amounts. +fullZeroFmt :: AmountFormat +fullZeroFmt = defaultFmt{displayZeroCommodity=True} --- | Display Amount and MixedAmount on one line with no prices. -oneLine :: AmountDisplayOpts -oneLine = def{displayOneLine=True, displayCost=False} +-- | Like defaultFmt but don't show costs. +noCostFmt :: AmountFormat +noCostFmt = defaultFmt{displayCost=False} --- | Display Amount and MixedAmount in a form suitable for CSV output. -csvDisplay :: AmountDisplayOpts -csvDisplay = oneLine{displayDigitGroups=False} +-- | Like defaultFmt but display all amounts on one line. +oneLineFmt :: AmountFormat +oneLineFmt = defaultFmt{displayOneLine=True} +-- | Like noCostFmt but display all amounts on one line. +oneLineNoCostFmt :: AmountFormat +oneLineNoCostFmt = noCostFmt{displayOneLine=True} + +-- | A (slightly more) machine-readable amount format; like oneLineNoCostFmt but don't show digit group marks. +machineFmt :: AmountFormat +machineFmt = oneLineNoCostFmt{displayDigitGroups=False} + ------------------------------------------------------------------------------- -- Amount arithmetic @@ -282,7 +292,7 @@ -- | 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} +nullamt = Amount{acommodity="", aquantity=0, acost=Nothing, astyle=amountstyle} -- | A special amount used as a marker, meaning -- "no explicit amount provided here, infer it when needed". @@ -299,15 +309,15 @@ 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}} -amt `at` priceamt = amt{aprice=Just $ UnitPrice priceamt} -amt @@ priceamt = amt{aprice=Just $ TotalPrice priceamt} +amt `at` costamt = amt{acost=Just $ UnitCost costamt} +amt @@ costamt = amt{acost=Just $ TotalCost costamt} -- | Apply a binary arithmetic operator to two amounts, which should -- be in the same commodity if non-zero (warning, this is not checked). -- A zero result keeps the commodity of the second amount. -- The result's display style is that of the second amount, with -- precision set to the highest of either amount. --- Prices are ignored and discarded. +-- Costs 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}} @@ -318,41 +328,42 @@ -- otherwise = error "tried to do simple arithmetic with amounts in different commodities" -- | Convert an amount to the specified commodity, ignoring and discarding --- any assigned prices and assuming an exchange rate of 1. +-- any costs and assuming an exchange rate of 1. amountWithCommodity :: CommoditySymbol -> Amount -> Amount -amountWithCommodity c a = a{acommodity=c, aprice=Nothing} +amountWithCommodity c a = a{acommodity=c, acost=Nothing} --- | Convert a amount to its "cost" or "selling price" in another commodity, --- using its attached transaction price if it has one. Notes: +-- | Convert a amount to its total cost in another commodity, +-- using its attached cost amount if it has one. Notes: -- --- - price amounts must be MixedAmounts with exactly one component Amount +-- - cost amounts must be MixedAmounts with exactly one component Amount -- (or there will be a runtime error XXX) -- --- - price amounts should be positive in the Journal +-- - cost amounts should be positive in the Journal -- (though this is currently not enforced) +-- amountCost :: Amount -> Amount -amountCost a@Amount{aquantity=q, aprice=mp} = +amountCost a@Amount{aquantity=q, acost=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} + Just (UnitCost p@Amount{aquantity=pq}) -> p{aquantity=pq * q} + Just (TotalCost p@Amount{aquantity=pq}) -> p{aquantity=pq} --- | Strip all prices from an Amount +-- | Strip all costs from an Amount amountStripCost :: Amount -> Amount -amountStripCost a = a{aprice=Nothing} +amountStripCost a = a{acost=Nothing} --- | Apply a function to an amount's quantity (and its total price, if it has one). +-- | Apply a function to an amount's quantity (and its total cost, if it has one). transformAmount :: (Quantity -> Quantity) -> Amount -> Amount -transformAmount f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p} +transformAmount f a@Amount{aquantity=q,acost=p} = a{aquantity=f q, acost=f' <$> p} where - f' (TotalPrice a1@Amount{aquantity=pq}) = TotalPrice a1{aquantity = f pq} + f' (TotalCost a1@Amount{aquantity=pq}) = TotalCost a1{aquantity = f pq} f' p' = p' -- | Divide an amount's quantity (and total cost, if any) by some number. divideAmount :: Quantity -> Amount -> Amount divideAmount n = transformAmount (/n) --- | Multiply an amount's quantity (and its total price, if it has one) by a constant. +-- | Multiply an amount's quantity (and its total cost, if it has one) by a constant. multiplyAmount :: Quantity -> Amount -> Amount multiplyAmount n = transformAmount (*n) @@ -361,7 +372,7 @@ invertAmount :: Amount -> Amount invertAmount a@Amount{aquantity=q} = a{aquantity=1/q} --- | Is this amount negative ? The price is ignored. +-- | Is this amount negative ? The cost is ignored. isNegativeAmount :: Amount -> Bool isNegativeAmount Amount{aquantity=q} = q < 0 @@ -372,26 +383,26 @@ NaturalPrecision -> q 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 -testAmountAndTotalPrice f amt = case aprice amt of - Just (TotalPrice price) -> f amt && f price +-- | Apply a test to both an Amount and its total cost, if it has one. +testAmountAndTotalCost :: (Amount -> Bool) -> Amount -> Bool +testAmountAndTotalCost f amt = case acost amt of + Just (TotalCost cost) -> f amt && f cost _ -> f amt --- | Do this Amount and (and its total price, if it has one) appear to be zero +-- | Do this Amount and (and its total cost, 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 +amountLooksZero = testAmountAndTotalCost 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 --- | Is this Amount (and its total price, if it has one) exactly zero, ignoring its display precision ? +-- | Is this Amount (and its total cost, if it has one) exactly zero, ignoring its display precision ? amountIsZero :: Amount -> Bool -amountIsZero = testAmountAndTotalPrice (\Amount{aquantity=Decimal _ q} -> q == 0) +amountIsZero = testAmountAndTotalCost (\Amount{aquantity=Decimal _ q} -> q == 0) -- | Does this amount's internal Decimal representation have the -- maximum number of digits, suggesting that it probably is @@ -443,24 +454,26 @@ -- | We often want to display "infinite decimal" amounts rounded to some readable --- number of digits, while still displaying amounts with a large "non infinite" number --- of decimal digits (eg, 100 or 200 digits) in full. +-- number of digits, while still displaying amounts with a large but "non infinite" +-- number of decimal digits (eg 10 or 100 or 200 digits) in full. -- This helper is like amountSetFullPrecision, but with some refinements: --- 1. If the internal precision is the maximum (255), indicating an infinite decimal, --- the display precision is set to a smaller hard-coded default (8). --- 2. A maximum display precision can be specified, setting a hard upper limit. +-- +-- 1. A maximum display precision can be specified, setting a hard upper limit. +-- +-- 2. If no limit is specified, and the internal precision is the maximum (255), +-- indicating an infinite decimal, display precision is set to a smaller default (8). +-- -- This function always sets an explicit display precision (ie, Precision n). -amountSetFullPrecisionOr :: Maybe Word8 -> Amount -> Amount -amountSetFullPrecisionOr mmaxp a = amountSetPrecision (Precision p2) a +-- +amountSetFullPrecisionUpTo :: Maybe Word8 -> Amount -> Amount +amountSetFullPrecisionUpTo mmaxp a = amountSetPrecision (Precision p) a where - p1 = if -- dbg0 "maxdigits" $ - amountHasMaxDigits a then defaultMaxPrecision else max disp intp - -- & dbg0 "p1" + p = case mmaxp of + Just maxp -> min maxp $ max disp intp + Nothing -> if amountHasMaxDigits a then defaultMaxPrecision else max disp intp where - intp = amountInternalPrecision a disp = amountDisplayPrecision a - p2 = maybe p1 (min p1) mmaxp - -- & dbg0 "p2" + intp = amountInternalPrecision a -- | The fallback display precision used when showing amounts -- representing an infinite decimal. @@ -517,15 +530,15 @@ -- except that costs' precision is never changed (costs are often recorded inexactly, -- so we don't want to imply greater precision than they were recorded with). -- If no style is found for an amount, it is left unchanged. - styleAmounts styles a@Amount{aquantity=qty, acommodity=comm, astyle=oldstyle, aprice=mcost0} = - a{astyle=newstyle, aprice=mcost1} + styleAmounts styles a@Amount{aquantity=qty, acommodity=comm, astyle=oldstyle, acost=mcost0} = + a{astyle=newstyle, acost=mcost1} where newstyle = mknewstyle False qty oldstyle comm mcost1 = case mcost0 of Nothing -> Nothing - Just (UnitPrice ca@Amount{aquantity=cq, astyle=cs, acommodity=ccomm}) -> Just $ UnitPrice ca{astyle=mknewstyle True cq cs ccomm} - Just (TotalPrice ca@Amount{aquantity=cq, astyle=cs, acommodity=ccomm}) -> Just $ TotalPrice ca{astyle=mknewstyle True cq cs ccomm} + Just (UnitCost ca@Amount{aquantity=cq, astyle=cs, acommodity=ccomm}) -> Just $ UnitCost ca{astyle=mknewstyle True cq cs ccomm} + Just (TotalCost ca@Amount{aquantity=cq, astyle=cs, acommodity=ccomm}) -> Just $ TotalCost ca{astyle=mknewstyle True cq cs ccomm} mknewstyle :: Bool -> Quantity -> AmountStyle -> CommoditySymbol -> AmountStyle mknewstyle iscost oldq olds com = @@ -595,12 +608,13 @@ HardRounding -> news{asprecision=if iscost then oldp else newp} AllRounding -> news --- | Set this amount style's rounding strategy when being applied to amounts. +-- | Set this amount style's rounding strategy when it is being applied to amounts. amountStyleSetRounding :: Rounding -> AmountStyle -> AmountStyle amountStyleSetRounding r as = as{asrounding=r} +-- | Set these amount styles' rounding strategy when they are being applied to amounts. amountStylesSetRounding :: Rounding -> M.Map CommoditySymbol AmountStyle -> M.Map CommoditySymbol AmountStyle -amountStylesSetRounding r = M.map (amountStyleSetRounding r) +amountStylesSetRounding r = M.map (amountStyleSetRounding r) -- | Default amount style amountstyle = AmountStyle L False Nothing (Just '.') (Precision 0) NoRounding @@ -619,52 +633,41 @@ -- Amount rendering -showAmountCostB :: Amount -> WideBuilder -showAmountCostB amt = case aprice amt of +-- Show an amount's cost as @ UNITCOST or @@ TOTALCOST (builder version). +showAmountsCostB :: Amount -> WideBuilder +showAmountsCostB amt = case acost amt of Nothing -> mempty - 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) + Just (UnitCost pa) -> WideBuilder (TB.fromString " @ ") 3 <> showAmountB defaultFmt{displayZeroCommodity=True} pa + Just (TotalCost pa) -> WideBuilder (TB.fromString " @@ ") 4 <> showAmountB defaultFmt{displayZeroCommodity=True} (sign pa) where sign = if aquantity amt < 0 then negate else id -showAmountCostDebug :: Maybe AmountPrice -> String +showAmountCostDebug :: Maybe AmountCost -> String showAmountCostDebug Nothing = "" -showAmountCostDebug (Just (UnitPrice pa)) = " @ " ++ showAmountDebug pa -showAmountCostDebug (Just (TotalPrice pa)) = " @@ " ++ showAmountDebug pa +showAmountCostDebug (Just (UnitCost pa)) = " @ " ++ showAmountDebug pa +showAmountCostDebug (Just (TotalCost pa)) = " @@ " ++ showAmountDebug pa --- | 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 --- displayed as the empty string. --- --- > showAmount = wbUnpack . showAmountB noColour +-- | Render an amount using its display style and the default amount format. +-- Zero-equivalent amounts are shown as just \"0\". +-- The special "missing" amount is shown as the empty string. showAmount :: Amount -> String -showAmount = wbUnpack . showAmountB noColour +showAmount = wbUnpack . showAmountB defaultFmt --- | Like showAmount but uses the given amount display options. -showAmountWith :: AmountDisplayOpts -> Amount -> String +-- | Like showAmount but uses the given amount format. +showAmountWith :: AmountFormat -> Amount -> String showAmountWith fmt = wbUnpack . showAmountB fmt --- | General function to generate a WideBuilder for an Amount, according the --- 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 +-- | Render an amount using its display style and the given amount format, as a builder for efficiency. +-- (This can be converted to a Text with wbToText or to a String with wbUnpack). +-- The special "missing" amount is displayed as the empty string. +showAmountB :: AmountFormat -> Amount -> WideBuilder showAmountB _ Amount{acommodity="AUTO"} = mempty showAmountB - AmountDisplayOpts{displayCommodity, displayZeroCommodity, displayDigitGroups + AmountFormat{displayCommodity, displayZeroCommodity, displayDigitGroups ,displayForceDecimalMark, displayCost, displayColour} a@Amount{astyle=style} = color $ case ascommodityside style of - L -> (if displayCommodity then wbFromText comm <> space else mempty) <> quantity' <> price - R -> quantity' <> (if displayCommodity then space <> wbFromText comm else mempty) <> price + L -> (if displayCommodity then wbFromText comm <> space else mempty) <> quantity' <> cost + R -> quantity' <> (if displayCommodity then space <> wbFromText comm else mempty) <> cost where color = if displayColour && isNegativeAmount a then colorB Dull Red else id quantity = showAmountQuantity displayForceDecimalMark $ @@ -673,7 +676,7 @@ | amountLooksZero a && not displayZeroCommodity = (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 - price = if displayCost then showAmountCostB a else mempty + cost = if displayCost then showAmountsCostB a else mempty -- | Colour version. For a negative amount, adds ANSI codes to change the colour, -- currently to hard-coded red. @@ -682,17 +685,17 @@ cshowAmount :: Amount -> String cshowAmount = wbUnpack . showAmountB def{displayColour=True} --- | Get the string representation of an amount, without any \@ price. +-- | Get the string representation of an amount, without any \@ cost. -- --- > showAmountWithoutPrice = wbUnpack . showAmountB noCost -showAmountWithoutPrice :: Amount -> String -showAmountWithoutPrice = wbUnpack . showAmountB noCost +-- > showAmountWithoutCost = wbUnpack . showAmountB noCostFmt +showAmountWithoutCost :: Amount -> String +showAmountWithoutCost = wbUnpack . showAmountB noCostFmt -- | Like showAmount, but show a zero amount's commodity if it has one. -- --- > showAmountWithZeroCommodity = wbUnpack . showAmountB noColour{displayZeryCommodity=True} +-- > showAmountWithZeroCommodity = wbUnpack . showAmountB defaultFmt{displayZeryCommodity=True} showAmountWithZeroCommodity :: Amount -> String -showAmountWithZeroCommodity = wbUnpack . showAmountB noColour{displayZeroCommodity=True} +showAmountWithZeroCommodity = wbUnpack . showAmountB defaultFmt{displayZeroCommodity=True} -- | Get a string representation of an amount for debugging, -- appropriate to the current debug level. 9 shows maximum detail. @@ -700,7 +703,7 @@ showAmountDebug Amount{acommodity="AUTO"} = "(missing)" showAmountDebug Amount{..} = "Amount {acommodity=" ++ show acommodity ++ ", aquantity=" ++ show aquantity - ++ ", aprice=" ++ showAmountCostDebug aprice ++ ", astyle=" ++ show astyle ++ "}" + ++ ", acost=" ++ showAmountCostDebug acost ++ ", 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. @@ -765,10 +768,10 @@ -- | Calculate the key used to store an Amount within a MixedAmount. amountKey :: Amount -> MixedAmountKey -amountKey amt@Amount{acommodity=c} = case aprice amt of - Nothing -> MixedAmountKeyNoPrice c - Just (TotalPrice p) -> MixedAmountKeyTotalPrice c (acommodity p) - Just (UnitPrice p) -> MixedAmountKeyUnitPrice c (acommodity p) (aquantity p) +amountKey amt@Amount{acommodity=c} = case acost amt of + Nothing -> MixedAmountKeyNoCost c + Just (TotalCost p) -> MixedAmountKeyTotalCost c (acommodity p) + Just (UnitCost p) -> MixedAmountKeyUnitCost c (acommodity p) (aquantity p) -- | The empty mixed amount. nullmixedamt :: MixedAmount @@ -797,21 +800,21 @@ -- | Add an Amount to a MixedAmount, normalising the result. -- Amounts with different costs are kept separate. maAddAmount :: MixedAmount -> Amount -> MixedAmount -maAddAmount (Mixed ma) a = Mixed $ M.insertWith sumSimilarAmountsUsingFirstPrice (amountKey a) a ma +maAddAmount (Mixed ma) a = Mixed $ M.insertWith sumSimilarAmountsUsingFirstCost (amountKey a) a ma -- | Add a collection of Amounts to a MixedAmount, normalising the result. -- Amounts with different costs are kept separate. maAddAmounts :: Foldable t => MixedAmount -> t Amount -> MixedAmount maAddAmounts = foldl' maAddAmount --- | Negate mixed amount's quantities (and total prices, if any). +-- | Negate mixed amount's quantities (and total costs, if any). maNegate :: MixedAmount -> MixedAmount maNegate = transformMixedAmount negate -- | Sum two MixedAmount, keeping the cost of the first if any. -- Amounts with different costs are kept separate (since 2021). maPlus :: MixedAmount -> MixedAmount -> MixedAmount -maPlus (Mixed as) (Mixed bs) = Mixed $ M.unionWith sumSimilarAmountsUsingFirstPrice as bs +maPlus (Mixed as) (Mixed bs) = Mixed $ M.unionWith sumSimilarAmountsUsingFirstCost as bs -- | Subtract a MixedAmount from another. -- Amounts with different costs are kept separate. @@ -823,15 +826,15 @@ maSum :: Foldable t => t MixedAmount -> MixedAmount maSum = foldl' maPlus nullmixedamt --- | Divide a mixed amount's quantities (and total prices, if any) by a constant. +-- | Divide a mixed amount's quantities (and total costs, if any) by a constant. divideMixedAmount :: Quantity -> MixedAmount -> MixedAmount divideMixedAmount n = transformMixedAmount (/n) --- | Multiply a mixed amount's quantities (and total prices, if any) by a constant. +-- | Multiply a mixed amount's quantities (and total costs, if any) by a constant. multiplyMixedAmount :: Quantity -> MixedAmount -> MixedAmount multiplyMixedAmount n = transformMixedAmount (*n) --- | Apply a function to a mixed amount's quantities (and its total prices, if it has any). +-- | Apply a function to a mixed amount's quantities (and its total costs, if it has any). transformMixedAmount :: (Quantity -> Quantity) -> MixedAmount -> MixedAmount transformMixedAmount f = mapMixedAmountUnsafe (transformAmount f) @@ -843,7 +846,7 @@ -- Ie when normalised, are all individual commodity amounts negative ? isNegativeMixedAmount :: MixedAmount -> Maybe Bool isNegativeMixedAmount m = - case amounts $ mixedAmountStripPrices m of + case amounts $ mixedAmountStripCosts m of [] -> Just False [a] -> Just $ isNegativeAmount a as | all isNegativeAmount as -> Just True @@ -875,7 +878,7 @@ -- | 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 +-- * amounts in the same commodity are combined unless they have different costs or total costs -- -- * multiple zero amounts, all with the same non-null commodity, are replaced by just the last of them, preserving the commodity and amount style (all but the last zero amount are discarded) -- @@ -921,8 +924,8 @@ -- | 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, --- i.e. lexicographically first by commodity, then by price commodity, then by --- unit price from most negative to most positive. +-- i.e. lexicographically first by commodity, then by cost commodity, then by +-- unit cost from most negative to most positive. amountsRaw :: MixedAmount -> [Amount] amountsRaw (Mixed ma) = toList ma @@ -946,31 +949,31 @@ | otherwise = Nothing -- | Sum same-commodity amounts in a lossy way, applying the first --- price to the result and discarding any other prices. Only used as a +-- cost to the result and discarding any other costs. Only used as a -- rendering helper. -sumSimilarAmountsUsingFirstPrice :: Amount -> Amount -> Amount -sumSimilarAmountsUsingFirstPrice a b = (a + b){aprice=p} +sumSimilarAmountsUsingFirstCost :: Amount -> Amount -> Amount +sumSimilarAmountsUsingFirstCost a b = (a + b){acost=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 --- -- rendering helper. --- sumSimilarAmountsNotingPriceDifference :: [Amount] -> Amount --- sumSimilarAmountsNotingPriceDifference [] = nullamt --- sumSimilarAmountsNotingPriceDifference as = undefined + p = case (acost a, acost b) of + (Just (TotalCost ap), Just (TotalCost bp)) + -> Just . TotalCost $ ap{aquantity = aquantity ap + aquantity bp } + _ -> acost a -- | Filter a mixed amount's component amounts by a predicate. filterMixedAmount :: (Amount -> Bool) -> MixedAmount -> MixedAmount filterMixedAmount p (Mixed ma) = Mixed $ M.filter p ma --- | Return an unnormalised MixedAmount containing exactly one Amount --- with the specified commodity and the quantity of that commodity --- found in the original. NB if Amount's quantity is zero it will be --- discarded next time the MixedAmount gets normalised. +-- | Return an unnormalised MixedAmount containing just the amounts in the +-- requested commodity from the original mixed amount. +-- +-- The result will contain at least one Amount of the requested commodity, +-- even if the original mixed amount did not (with quantity zero in that case, +-- and this would be discarded when the mixed amount is next normalised). +-- +-- The result can contain more than one Amount of the requested commodity, +-- eg because there were several with different costs, +-- or simply because the original mixed amount was was unnormalised. +-- filterMixedAmountByCommodity :: CommoditySymbol -> MixedAmount -> MixedAmount filterMixedAmountByCommodity c (Mixed ma) | M.null ma' = mixedAmount nullamt{acommodity=c} @@ -982,25 +985,24 @@ mapMixedAmount f (Mixed ma) = mixed . map f $ toList ma -- | Apply a transform to a mixed amount's component 'Amount's, which does not --- affect the key of the amount (i.e. doesn't change the commodity, price --- commodity, or unit price amount). This condition is not checked. +-- affect the key of the amount (i.e. doesn't change the commodity, cost +-- commodity, or unit cost amount). This condition is not checked. mapMixedAmountUnsafe :: (Amount -> Amount) -> MixedAmount -> MixedAmount mapMixedAmountUnsafe f (Mixed ma) = Mixed $ M.map f ma -- Use M.map instead of fmap to maintain strictness --- | Convert all component amounts to cost/selling price where --- possible (see amountCost). +-- | Convert all component amounts to cost where possible (see amountCost). mixedAmountCost :: MixedAmount -> MixedAmount mixedAmountCost (Mixed ma) = - foldl' (\m a -> maAddAmount m (amountCost a)) (Mixed noPrices) withPrices - where (noPrices, withPrices) = M.partition (isNothing . aprice) ma + foldl' (\m a -> maAddAmount m (amountCost a)) (Mixed noCosts) withCosts + where (noCosts, withCosts) = M.partition (isNothing . acost) ma -- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we -- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there. -- -- For now, use this when cross-commodity zero equality is important. -- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool -- mixedAmountEquals a b = amounts a' == amounts b' || (mixedAmountLooksZero a' && mixedAmountLooksZero b') --- where a' = mixedAmountStripPrices a --- b' = mixedAmountStripPrices b +-- where a' = mixedAmountStripCosts a +-- b' = mixedAmountStripCosts b -- Mixed amount styles @@ -1035,54 +1037,48 @@ -- Mixed amount rendering --- | 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. --- --- > showMixedAmount = wbUnpack . showMixedAmountB noColour + +-- | Render a mixed amount using its amount display styles and the default amount format, +-- after normalising it (to at most one amount in each of its commodities). +-- See showMixedAmountB for special cases. showMixedAmount :: MixedAmount -> String -showMixedAmount = wbUnpack . showMixedAmountB noColour +showMixedAmount = wbUnpack . showMixedAmountB defaultFmt --- | Like showMixedAmount but uses the given amount display options. +-- | Like showMixedAmount but uses the given amount format. -- See showMixedAmountB for special cases. -showMixedAmountWith :: AmountDisplayOpts -> MixedAmount -> String +showMixedAmountWith :: AmountFormat -> MixedAmount -> String showMixedAmountWith fmt = wbUnpack . showMixedAmountB fmt -- | Get the one-line string representation of a mixed amount (also showing any costs). --- --- > showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLine +-- See showMixedAmountB for special cases. showMixedAmountOneLine :: MixedAmount -> String -showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLine{displayCost=True} +showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLineNoCostFmt{displayCost=True} -- | Like showMixedAmount, but zero amounts are shown with their -- commodity if they have one. --- --- > showMixedAmountWithZeroCommodity = wbUnpack . showMixedAmountB noColour{displayZeroCommodity=True} +-- See showMixedAmountB for special cases. showMixedAmountWithZeroCommodity :: MixedAmount -> String -showMixedAmountWithZeroCommodity = wbUnpack . showMixedAmountB noColour{displayZeroCommodity=True} +showMixedAmountWithZeroCommodity = wbUnpack . showMixedAmountB defaultFmt{displayZeroCommodity=True} --- | Get the string representation of a mixed amount, without showing any transaction prices. +-- | Get the string representation of a mixed amount, without showing any costs. -- With a True argument, adds ANSI codes to show negative amounts in red. --- --- > showMixedAmountWithoutPrice c = wbUnpack . showMixedAmountB noCost{displayColour=c} -showMixedAmountWithoutPrice :: Bool -> MixedAmount -> String -showMixedAmountWithoutPrice c = wbUnpack . showMixedAmountB noCost{displayColour=c} +-- See showMixedAmountB for special cases. +showMixedAmountWithoutCost :: Bool -> MixedAmount -> String +showMixedAmountWithoutCost c = wbUnpack . showMixedAmountB noCostFmt{displayColour=c} -- | Get the one-line string representation of a mixed amount, but without --- any \@ prices. +-- any \@ costs. -- With a True argument, adds ANSI codes to show negative amounts in red. --- --- > showMixedAmountOneLineWithoutPrice c = wbUnpack . showMixedAmountB oneLine{displayColour=c} -showMixedAmountOneLineWithoutPrice :: Bool -> MixedAmount -> String -showMixedAmountOneLineWithoutPrice c = wbUnpack . showMixedAmountB oneLine{displayColour=c} +-- See showMixedAmountB for special cases. +showMixedAmountOneLineWithoutCost :: Bool -> MixedAmount -> String +showMixedAmountOneLineWithoutCost c = wbUnpack . showMixedAmountB oneLineNoCostFmt{displayColour=c} --- | Like showMixedAmountOneLineWithoutPrice, but show at most the given width, +-- | Like showMixedAmountOneLineWithoutCost, but show at most the given width, -- with an elision indicator if there are more. -- With a True argument, adds ANSI codes to show negative amounts in red. --- --- > showMixedAmountElided w c = wbUnpack . showMixedAmountB oneLine{displayColour=c, displayMaxWidth=Just w} +-- See showMixedAmountB for special cases. showMixedAmountElided :: Int -> Bool -> MixedAmount -> String -showMixedAmountElided w c = wbUnpack . showMixedAmountB oneLine{displayColour=c, displayMaxWidth=Just w} +showMixedAmountElided w c = wbUnpack . showMixedAmountB oneLineNoCostFmt{displayColour=c, displayMaxWidth=Just w} -- | Get an unambiguous string representation of a mixed amount for debugging. showMixedAmountDebug :: MixedAmount -> String @@ -1090,19 +1086,28 @@ | otherwise = "Mixed [" ++ as ++ "]" where as = intercalate "\n " $ map showAmountDebug $ amounts m --- | General function to generate a WideBuilder for a MixedAmount, according to the --- supplied AmountDisplayOpts. This is the main function to use for showing --- MixedAmounts, constructing a builder; it can then be converted to a Text with --- wbToText, or to a String with wbUnpack. +-- | Render a mixed amount using its amount display styles and the given amount format, +-- as a builder for efficiency. +-- (This can be converted to a Text with wbToText or to a String with wbUnpack). -- +-- Warning: this (and its showMixedAmount aliases above) basically assumes amounts have no costs. +-- It can show misleading costs or not show costs which are there. +-- -- If a maximum width is given then: +-- -- - If displayed on one line, it will display as many Amounts as can -- fit in the given width, and further Amounts will be elided. There -- will always be at least one amount displayed, even if this will -- exceed the requested maximum width. +-- -- - If displayed on multiple lines, any Amounts longer than the -- maximum width will be elided. -showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder +-- +-- Zero-equivalent amounts are shown as just \"0\". +-- +-- The special "missing" amount is shown as the empty string (?). +-- +showMixedAmountB :: AmountFormat -> MixedAmount -> WideBuilder showMixedAmountB opts ma | displayOneLine opts = showMixedAmountOneLineB opts ma | otherwise = WideBuilder (wbBuilder . mconcat $ intersperse sep ls) width @@ -1114,12 +1119,12 @@ -- | 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 = +showMixedAmountLinesB :: AmountFormat -> MixedAmount -> [WideBuilder] +showMixedAmountLinesB opts@AmountFormat{displayMaxWidth=mmax,displayMinWidth=mmin} ma = map (adBuilder . pad) elided where astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $ - if displayCost opts then ma else mixedAmountStripPrices ma + if displayCost opts then ma else mixedAmountStripCosts ma sep = WideBuilder (TB.singleton '\n') 0 width = maximum $ map (wbWidth . adBuilder) elided @@ -1138,14 +1143,14 @@ -- | Helper for showMixedAmountB to deal with single line displays. This does not -- honour displayOneLine: all amounts will be displayed as if displayOneLine -- were True. -showMixedAmountOneLineB :: AmountDisplayOpts -> MixedAmount -> WideBuilder -showMixedAmountOneLineB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWidth=mmin} ma = +showMixedAmountOneLineB :: AmountFormat -> MixedAmount -> WideBuilder +showMixedAmountOneLineB opts@AmountFormat{displayMaxWidth=mmax,displayMinWidth=mmin} ma = WideBuilder (wbBuilder . pad . mconcat . intersperse sep $ map adBuilder elided) . max width $ fromMaybe 0 mmin where width = maybe 0 adTotal $ lastMay elided astrs = amtDisplayList (wbWidth sep) (showAmountB opts) . orderedAmounts opts $ - if displayCost opts then ma else mixedAmountStripPrices ma + if displayCost opts then ma else mixedAmountStripCosts ma sep = WideBuilder (TB.fromString ", ") 2 n = length astrs @@ -1170,8 +1175,8 @@ -- 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 AmountDisplayOpts{displayZeroCommodity=preservezeros, displayCommodityOrder=mcommodityorder} = +orderedAmounts :: AmountFormat -> MixedAmount -> [Amount] +orderedAmounts AmountFormat{displayZeroCommodity=preservezeros, displayCommodityOrder=mcommodityorder} = if preservezeros then amountsPreservingZeros else amounts <&> maybe id (mapM findfirst) mcommodityorder -- maybe sort them (somehow..) where @@ -1226,6 +1231,14 @@ mixedAmountSetFullPrecision :: MixedAmount -> MixedAmount mixedAmountSetFullPrecision = mapMixedAmountUnsafe amountSetFullPrecision +-- | In each component amount, increase the display precision sufficiently +-- to render it exactly if possible, but not more than the given max precision, +-- and if no max precision is given and the amount has infinite decimals, +-- limit display precision to a hard-coded smaller number (8). +-- See amountSetFullPrecisionUpTo. +mixedAmountSetFullPrecisionUpTo :: Maybe Word8 -> MixedAmount -> MixedAmount +mixedAmountSetFullPrecisionUpTo mmaxp = mapMixedAmountUnsafe (amountSetFullPrecisionUpTo mmaxp) + -- | In each component amount, ensure the display precision is at least the given value. -- Makes all amounts have an explicit Precision. mixedAmountSetPrecisionMin :: Word8 -> MixedAmount -> MixedAmount @@ -1236,11 +1249,11 @@ mixedAmountSetPrecisionMax :: Word8 -> MixedAmount -> MixedAmount mixedAmountSetPrecisionMax p = mapMixedAmountUnsafe (amountSetPrecisionMax p) --- | Remove all prices from a MixedAmount. -mixedAmountStripPrices :: MixedAmount -> MixedAmount -mixedAmountStripPrices (Mixed ma) = - foldl' (\m a -> maAddAmount m a{aprice=Nothing}) (Mixed noPrices) withPrices - where (noPrices, withPrices) = M.partition (isNothing . aprice) ma +-- | Remove all costs from a MixedAmount. +mixedAmountStripCosts :: MixedAmount -> MixedAmount +mixedAmountStripCosts (Mixed ma) = + foldl' (\m a -> maAddAmount m a{acost=Nothing}) (Mixed noCosts) withCosts + where (noCosts, withCosts) = M.partition (isNothing . acost) ma ------------------------------------------------------------------------------- @@ -1251,9 +1264,9 @@ testCase "amountCost" $ do 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 2){acost=Just $ UnitCost $ usd 2} @?= usd 4 + amountCost (eur 1){acost=Just $ TotalCost $ usd 2} @?= usd 2 + amountCost (eur (-1)){acost=Just $ TotalCost $ usd (-2)} @?= usd (-2) ,testCase "amountLooksZero" $ do assertBool "" $ amountLooksZero nullamt @@ -1261,9 +1274,9 @@ ,testCase "negating amounts" $ do negate (usd 1) @?= (usd 1){aquantity= -1} - let b = (usd 1){aprice=Just $ UnitPrice $ eur 2} in negate b @?= b{aquantity= -1} + let b = (usd 1){acost=Just $ UnitCost $ eur 2} in negate b @?= b{aquantity= -1} - ,testCase "adding amounts without prices" $ do + ,testCase "adding amounts without costs" $ do (usd 1.23 + usd (-1.23)) @?= usd 0 (usd 1.23 + usd (-1.23)) @?= usd 0 (usd (-1.23) + usd (-1.23)) @?= usd (-2.46) @@ -1296,7 +1309,7 @@ ]) @?= mixedAmount (usd 0 `withPrecision` Precision 3) - ,testCase "adding mixed amounts with total prices" $ do + ,testCase "adding mixed amounts with total costs" $ do maSum (map mixedAmount [usd 1 @@ eur 1 ,usd (-2) @@ eur 1 @@ -1310,27 +1323,27 @@ showMixedAmount nullmixedamt @?= "0" showMixedAmount missingmixedamt @?= "" - ,testCase "showMixedAmountWithoutPrice" $ do + ,testCase "showMixedAmountWithoutCost" $ do let a = usd 1 `at` eur 2 - showMixedAmountWithoutPrice False (mixedAmount (a)) @?= "$1.00" - showMixedAmountWithoutPrice False (mixed [a, -a]) @?= "0" + showMixedAmountWithoutCost False (mixedAmount (a)) @?= "$1.00" + showMixedAmountWithoutCost False (mixed [a, -a]) @?= "0" ,testGroup "amounts" [ testCase "a missing amount overrides any other amounts" $ amounts (mixed [usd 1, missingamt]) @?= [missingamt] - ,testCase "unpriced same-commodity amounts are combined" $ + ,testCase "costless same-commodity amounts are combined" $ amounts (mixed [usd 0, usd 2]) @?= [usd 2] - ,testCase "amounts with same unit price are combined" $ + ,testCase "amounts with same unit cost are combined" $ amounts (mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= [usd 2 `at` eur 1] - ,testCase "amounts with different unit prices are not combined" $ + ,testCase "amounts with different unit costs are not combined" $ amounts (mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= [usd 1 `at` eur 1, usd 1 `at` eur 2] - ,testCase "amounts with total prices are combined" $ + ,testCase "amounts with total costs are combined" $ amounts (mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= [usd 2 @@ eur 2] ] - ,testCase "mixedAmountStripPrices" $ do - amounts (mixedAmountStripPrices nullmixedamt) @?= [nullamt] - assertBool "" $ mixedAmountLooksZero $ mixedAmountStripPrices + ,testCase "mixedAmountStripCosts" $ do + amounts (mixedAmountStripCosts nullmixedamt) @?= [nullamt] + assertBool "" $ mixedAmountLooksZero $ mixedAmountStripCosts (mixed [usd 10 ,usd 10 @@ eur 7 ,usd (-10) diff --git a/Hledger/Data/Balancing.hs b/Hledger/Data/Balancing.hs --- a/Hledger/Data/Balancing.hs +++ b/Hledger/Data/Balancing.hs @@ -46,6 +46,7 @@ import qualified Data.Text as T import Data.Time.Calendar (fromGregorian) import qualified Data.Map as M +import Safe (headErr) import Text.Printf (printf) import Hledger.Utils @@ -104,7 +105,7 @@ -- convert this posting's amount to cost, -- without getting confused by redundant costs/equity postings postingBalancingAmount p - | "_price-matched" `elem` map fst (ptags p) = mixedAmountStripPrices $ pamount p + | "_price-matched" `elem` map fst (ptags p) = mixedAmountStripCosts $ pamount p | otherwise = mixedAmountCost $ pamount p -- transaction balancedness is checked at each commodity's display precision @@ -130,11 +131,17 @@ rmsg | rsumok = "" | not rsignsok = "The real postings all have the same sign. Consider negating some of them." - | otherwise = "The real postings' sum should be 0 but is: " ++ showMixedAmountOneLineWithoutPrice False rsumcost + | otherwise = "The real postings' sum should be 0 but is: " ++ + (showMixedAmountWith oneLineNoCostFmt{displayCost=True, displayZeroCommodity=True} $ + mixedAmountSetFullPrecisionUpTo Nothing $ mixedAmountSetFullPrecision + rsumcost) bvmsg | bvsumok = "" | not bvsignsok = "The balanced virtual postings all have the same sign. Consider negating some of them." - | otherwise = "The balanced virtual postings' sum should be 0 but is: " ++ showMixedAmountOneLineWithoutPrice False bvsumcost + | otherwise = "The balanced virtual postings' sum should be 0 but is: " ++ + (showMixedAmountWith oneLineNoCostFmt{displayCost=True, displayZeroCommodity=True} $ + mixedAmountSetFullPrecisionUpTo Nothing $ mixedAmountSetFullPrecision + bvsumcost) -- | Legacy form of transactionCheckBalanced. isTransactionBalanced :: BalancingOpts -> Transaction -> Bool @@ -339,7 +346,7 @@ inferFromAndTo = case sumamounts of [a,b] | noprices, oppositesigns -> asum $ map orderIfMatches pcommodities where - noprices = all (isNothing . aprice) sumamounts + noprices = all (isNothing . acost) sumamounts oppositesigns = signum (aquantity a) /= signum (aquantity b) orderIfMatches x | x == acommodity a = Just (a,b) | x == acommodity b = Just (b,a) @@ -351,18 +358,18 @@ -- then set its cost based on the ratio between fromamount and toamount. infercost (fromamount, toamount) p | [a] <- amounts (pamount p), ptype p == pt, acommodity a == acommodity fromamount - = p{ pamount = mixedAmount a{aprice=Just conversionprice} + = p{ pamount = mixedAmount a{acost=Just conversionprice} & dbg9With (lbl "inferred cost".showMixedAmountOneLine) , poriginal = Just $ originalPosting p } | otherwise = p where - -- If only one Amount in the posting list matches fromamount we can use TotalPrice. + -- If only one Amount in the posting list matches fromamount we can use TotalCost. -- Otherwise divide the conversion equally among the Amounts by using a unit price. conversionprice = case filter (== acommodity fromamount) pcommodities of - [_] -> TotalPrice $ negate toamount - _ -> UnitPrice $ negate unitprice `withPrecision` unitprecision + [_] -> TotalCost $ negate toamount + _ -> UnitCost $ negate unitcost `withPrecision` unitprecision - unitprice = aquantity fromamount `divideAmount` toamount + unitcost = aquantity fromamount `divideAmount` toamount unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b _ -> NaturalPrecision @@ -539,8 +546,8 @@ balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s () balanceTransactionAndCheckAssertionsB (Left p@Posting{}) = -- Update the account's running balance and check the balance assertion if any. - -- Note, cost is ignored when checking balance assertions, currently. - void . addAmountAndCheckAssertionB $ postingStripPrices p + -- Cost is ignored when checking balance assertions currently. + void $ addAmountAndCheckAssertionB $ postingStripCosts p balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do -- make sure we can handle the balance assignments mapM_ checkIllegalBalanceAssignmentB ps @@ -670,7 +677,7 @@ "%s\n", "Balance assertion failed in %s", "%s at this point, %s, ignoring costs,", - "the expected balance is: %s", + "the asserted balance is: %s", "but the calculated balance is: %s", "(difference: %s)", "To troubleshoot, check this account's running balance with assertions disabled, eg:", @@ -682,9 +689,12 @@ acct -- asserted account (if istotal then "Across all commodities" else "In commodity " <> assertedcommstr) -- asserted commodity or all commodities ? (if isinclusive then "including subaccounts" else "excluding subaccounts" :: String) -- inclusive or exclusive balance asserted ? - (pad assertedstr) -- asserted amount, without cost - (pad actualstr) -- actual amount, without cost - -- <> " (with costs: " <> T.pack (showMixedAmountWith fmt actualcommbal) <> ")" -- debugging + (pad assertedstr -- asserted amount, without cost + <> if debugLevel >= 2 then " (with cost: " <> T.pack (showAmountWith fmt assertedcommbal) <> ")" else "" + ) + (pad actualstr -- actual amount, without cost + <> if debugLevel >= 2 then " (with costs: " <> T.pack (showMixedAmountWith fmt actualcommbal) <> ")" else "" + ) diffstr -- their difference (acct ++ if isinclusive then "" else "$") -- query matching the account(s) postings (if istotal then "" else (" cur:" ++ quoteForCommandLine (T.unpack assertedcomm))) -- query matching the commodity(ies) @@ -695,7 +705,7 @@ pos = baposition ass (_,_,_,ex) = makeBalanceAssertionErrorExcerpt p assertedcommstr = if T.null assertedcomm then "\"\"" else assertedcomm - fmt = oneLine{displayZeroCommodity=True} + fmt = oneLineFmt{displayZeroCommodity=True} assertedstr = showAmountWith fmt assertedcommbalcostless actualstr = showAmountWith fmt actualcommbalcostless diffstr = showAmountWith fmt $ assertedcommbalcostless - actualcommbalcostless @@ -831,7 +841,7 @@ [posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?= Right (mixedAmount $ usd (-1)) ,testCase "conversion price is inferred" $ - (pamount . head . tpostings <$> + (pamount . headErr . tpostings <$> -- PARTIAL headErr succeeds because non-null postings list balanceTransaction defbalancingopts (Transaction 0 @@ -1023,7 +1033,7 @@ transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ] ]} assertRight ej - case ej of Right j -> (jtxns j & head & tpostings & head & pamount & amountsRaw) @?= [num 1] + case ej of Right j -> (jtxns j & headErr & tpostings & headErr & pamount & amountsRaw) @?= [num 1] -- PARTIAL headErrs succeed because non-null txns & postings lists given Left _ -> error' "balance-assignment test: shouldn't happen" ,testCase "same-day-1" $ do diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -63,6 +63,7 @@ spanIntersect, spansIntersect, spanDefaultsFrom, + spanExtend, spanUnion, spansUnion, daysSpan, @@ -105,7 +106,7 @@ import Data.Time.Calendar.OrdinalDate (fromMondayStartWeek, mondayStartWeek) import Data.Time.Clock (UTCTime, diffUTCTime) import Data.Time.LocalTime (getZonedTime, localDay, zonedTimeToLocalTime) -import Safe (headMay, lastMay, maximumMay, minimumMay) +import Safe (headErr, headMay, lastMay, maximumMay, minimumMay) import Text.Megaparsec import Text.Megaparsec.Char (char, char', digitChar, string, string') import Text.Megaparsec.Char.Lexer (decimal, signed) @@ -314,8 +315,8 @@ where groupByCols [] _ = [] groupByCols (c:cs) [] = if showempty then (c, []) : groupByCols cs [] else [] - groupByCols (c:cs) ps = (c, map snd matches) : groupByCols cs later - where (matches, later) = span ((spanEnd c >) . Just . fst) ps + groupByCols (c:cs) ps = (c, map snd colps) : groupByCols cs laterps + where (colps, laterps) = span ((spanEnd c >) . Just . fst) ps beforeStart = maybe (const False) (>) $ spanStart =<< headMay colspans @@ -324,41 +325,83 @@ spansIntersect [d] = d spansIntersect (d:ds) = d `spanIntersect` (spansIntersect ds) +-- | Calculate the union of a number of datespans. +spansUnion [] = nulldatespan +spansUnion [d] = d +spansUnion (d:ds) = d `spanUnion` (spansUnion ds) + -- | Calculate the intersection of two datespans. -- -- For non-intersecting spans, gives an empty span beginning on the second's start date: -- >>> DateSpan (Just $ Flex $ fromGregorian 2018 01 01) (Just $ Flex $ fromGregorian 2018 01 03) `spanIntersect` DateSpan (Just $ Flex $ fromGregorian 2018 01 03) (Just $ Flex $ fromGregorian 2018 01 05) -- DateSpan 2018-01-03..2018-01-02 -spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e - where - b = latest b1 b2 - e = earliest e1 e2 +spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (laterDefinite b1 b2) (earlierDefinite e1 e2) -- | Fill any unspecified dates in the first span with the dates from --- the second one. Sort of a one-way spanIntersect. +-- the second one (if specified there). Sort of a one-way spanIntersect. spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b where a = if isJust a1 then a1 else a2 b = if isJust b1 then b1 else b2 --- | Calculate the union of a number of datespans. -spansUnion [] = nulldatespan -spansUnion [d] = d -spansUnion (d:ds) = d `spanUnion` (spansUnion ds) - -- | Calculate the union of two datespans. -spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e - where - b = earliest b1 b2 - e = latest e1 e2 +-- If either span is open-ended, the union will be too. +-- +-- >>> ys2024 = fromGregorian 2024 01 01 +-- >>> ys2025 = fromGregorian 2025 01 01 +-- >>> to2024 = DateSpan Nothing (Just $ Exact ys2024) +-- >>> in2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025) +-- >>> spanUnion to2024 in2024 +-- DateSpan ..2024-12-31 +-- >>> spanUnion in2024 to2024 +-- DateSpan ..2024-12-31 +spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (earlier b1 b2) (later e1 e2) -latest d Nothing = d -latest Nothing d = d -latest (Just d1) (Just d2) = Just $ max d1 d2 +-- | Extend the first span to include any definite end dates of the second. +-- Unlike spanUnion, open ends in the second are ignored. +-- If the first span was open-ended, it still will be after being extended. +-- +-- >>> ys2024 = fromGregorian 2024 01 01 +-- >>> ys2025 = fromGregorian 2025 01 01 +-- >>> to2024 = DateSpan Nothing (Just $ Exact ys2024) +-- >>> all2024 = DateSpan (Just $ Exact ys2024) (Just $ Exact ys2025) +-- >>> partof2024 = DateSpan (Just $ Exact $ fromGregorian 2024 03 01) (Just $ Exact $ fromGregorian 2024 09 01) +-- >>> spanExtend to2024 all2024 +-- DateSpan 2024 +-- >>> spanExtend all2024 to2024 +-- DateSpan 2024 +-- >>> spanExtend partof2024 all2024 +-- DateSpan 2024 +-- >>> spanExtend all2024 partof2024 +-- DateSpan 2024 +-- +spanExtend (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan (earlierDefinite b1 b2) (laterDefinite e1 e2) -earliest d Nothing = d -earliest Nothing d = d -earliest (Just d1) (Just d2) = Just $ min d1 d2 +-- | Pick the earlier of two DateSpan starts, treating Nothing as infinitely early. +-- An Exact and Flex with the same date are considered equal; the first argument wins. +earlier :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay +earlier = min +-- | Pick the later of two DateSpan starts, treating Nothing as infinitely late. +-- An Exact and Flex with the same date are considered equal; the second argument wins. +later :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay +later _ Nothing = Nothing +later Nothing _ = Nothing +later d1 d2 = max d1 d2 + +-- | Pick the earlier of two DateSpan ends that is a definite date (if any). +-- An Exact and Flex with the same date are considered equal; the first argument wins. +earlierDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay +earlierDefinite d1 Nothing = d1 +earlierDefinite Nothing d2 = d2 +earlierDefinite d1 d2 = min d1 d2 + +-- | Pick the later of two DateSpan ends that is a definite date (if any). +-- An Exact and Flex with the same date are considered equal; the second argument wins. +laterDefinite :: Maybe EFDay -> Maybe EFDay -> Maybe EFDay +laterDefinite d1 Nothing = d1 +laterDefinite Nothing d2 = d2 +laterDefinite d1 d2 = max d1 d2 + -- | Calculate the minimal DateSpan containing all of the given Days (in the -- usual exclusive-end-date sense: beginning on the earliest, and ending on -- the day after the latest). @@ -900,7 +943,7 @@ show wday <> " in " <> show (weekdays ++ weekdayabbrevs) weekdaysp :: TextParser m [Int] -weekdaysp = fmap head . group . sort <$> sepBy1 weekday (string' ",") +weekdaysp = fmap headErr . group . sort <$> sepBy1 weekday (string' ",") -- PARTIAL headErr will succeed because of sepBy1 -- | Parse a period expression, specifying a date span and optionally -- a reporting interval. Requires a reference "today" date for diff --git a/Hledger/Data/Errors.hs b/Hledger/Data/Errors.hs --- a/Hledger/Data/Errors.hs +++ b/Hledger/Data/Errors.hs @@ -21,7 +21,7 @@ import qualified Data.Text as T import Hledger.Data.Transaction (showTransaction) -import Hledger.Data.Posting (postingStripPrices) +import Hledger.Data.Posting (postingStripCosts) import Hledger.Data.Types import Hledger.Utils import Data.Maybe @@ -121,7 +121,7 @@ (SourcePos f tl _) = fst $ tsourcepos t -- p had cost removed in balanceTransactionAndCheckAssertionsB, -- must remove them from t's postings too (#2083) - mpindex = transactionFindPostingIndex ((==p).postingStripPrices) t + mpindex = transactionFindPostingIndex ((==p).postingStripCosts) t errrelline = case mpindex of Nothing -> 0 Just pindex -> diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -913,7 +913,7 @@ -- fixmixedamount = mapMixedAmount fixamount -- fixamount = fixprice -- fixprice a@Amount{price=Just _} = a --- fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalPriceDirectiveFor j d c} +-- fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitCost) $ journalPriceDirectiveFor j d c} -- -- | Get the price for a commodity on the specified day from the price database, if known. -- -- Does only one lookup step, ie will not look up the price of a price. @@ -980,10 +980,10 @@ -- -- | Get this amount's commodity and any commodities referenced in its price. -- amountCommodities :: Amount -> [CommoditySymbol] --- amountCommodities Amount{acommodity=c,aprice=p} = +-- amountCommodities Amount{acommodity=c,acost=p} = -- case p of Nothing -> [c] --- Just (UnitPrice ma) -> c:(concatMap amountCommodities $ amounts ma) --- Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma) +-- Just (UnitCost ma) -> c:(concatMap amountCommodities $ amounts ma) +-- Just (TotalCost ma) -> c:(concatMap amountCommodities $ amounts ma) -- | Get an ordered list of amounts in this journal which can -- influence canonical amount display styles. Those amounts are, in @@ -993,7 +993,7 @@ -- * posting amounts in transactions (in parse order) -- * the amount in the final default commodity (D) directive -- --- Transaction price amounts (posting amounts' aprice field) are not included. +-- Transaction price amounts (posting amounts' acost field) are not included. -- journalStyleInfluencingAmounts :: Journal -> [Amount] journalStyleInfluencingAmounts j = @@ -1033,7 +1033,7 @@ -- * posting amounts in transactions (in parse order) -- -- Transaction price amounts, which may be embedded in posting amounts --- (the aprice field), are left intact but not traversed/processed. +-- (the acost field), are left intact but not traversed/processed. -- -- traverseJournalAmounts :: Applicative f => (Amount -> f Amount) -> Journal -> f Journal -- traverseJournalAmounts f j = diff --git a/Hledger/Data/JournalChecks.hs b/Hledger/Data/JournalChecks.hs --- a/Hledger/Data/JournalChecks.hs +++ b/Hledger/Data/JournalChecks.hs @@ -198,16 +198,23 @@ ]) -- | Tag names which have special significance to hledger. +-- Keep synced with check-tags.test and hledger manual > Special tags. builtinTags = [ - "type" -- declares an account's type - ,"t" -- generated by timedot letters notation - -- optionally generated on periodic transactions and auto postings - ,"generated-transaction" - ,"generated-posting" - -- used internally, not shown (but queryable) - ,"_generated-transaction" - ,"_generated-posting" - ,"_conversion-matched" + "date" -- overrides a posting's date + ,"date2" -- overrides a posting's secondary date + ,"type" -- declares an account's type + ,"t" -- appears on postings generated by timedot letters + ,"assert" -- appears on txns generated by close --assert + ,"retain" -- appears on txns generated by close --retain + ,"start" -- appears on txns generated by close --migrate/--close/--open/--assign + ,"generated-transaction" -- with --verbose-tags, appears on generated periodic txns + ,"generated-posting" -- with --verbose-tags, appears on generated auto postings + ,"modified" -- with --verbose-tags, appears on txns which have had auto postings added + -- hidden tags used internally (and also queryable): + ,"_generated-transaction" -- always exists on generated periodic txns + ,"_generated-posting" -- always exists on generated auto postings + ,"_modified" -- always exists on txns which have had auto postings added + ,"_conversion-matched" -- exists on postings which have been matched with a nearby @/@@ cost notation ] -- | In each tranaction, check that any conversion postings occur in adjacent pairs. diff --git a/Hledger/Data/JournalChecks/Uniqueleafnames.hs b/Hledger/Data/JournalChecks/Uniqueleafnames.hs --- a/Hledger/Data/JournalChecks/Uniqueleafnames.hs +++ b/Hledger/Data/JournalChecks/Uniqueleafnames.hs @@ -9,6 +9,7 @@ import Data.List (groupBy, sortBy) import Data.Text (Text) import qualified Data.Text as T +import Safe (headErr) import Text.Printf (printf) import Hledger.Data.AccountName (accountLeafName) @@ -55,10 +56,14 @@ finddupes :: (Ord leaf, Eq full) => [(leaf, full)] -> [(leaf, [full])] finddupes leafandfullnames = zip dupLeafs dupAccountNames - where dupLeafs = map (fst . head) d - dupAccountNames = map (map snd) d - d = dupes' leafandfullnames - dupes' = filter ((> 1) . length) + where + dupAccountNames = map (map snd) dupes + dupLeafs = case dupes of + [] -> [] + _ -> map (fst . headErr) dupes -- PARTIAL headErr succeeds because of pattern + dupes = fnddupes leafandfullnames + where + fnddupes = filter ((> 1) . length) . groupBy ((==) `on` fst) . sortBy (compare `on` fst) diff --git a/Hledger/Data/Json.hs b/Hledger/Data/Json.hs --- a/Hledger/Data/Json.hs +++ b/Hledger/Data/Json.hs @@ -102,7 +102,7 @@ toEncoding = toEncoding . amountsRaw instance ToJSON BalanceAssertion -instance ToJSON AmountPrice +instance ToJSON AmountCost instance ToJSON MarketPrice instance ToJSON PostingType @@ -208,7 +208,7 @@ parseJSON = fmap (mixed :: [Amount] -> MixedAmount) . parseJSON instance FromJSON BalanceAssertion -instance FromJSON AmountPrice +instance FromJSON AmountCost instance FromJSON MarketPrice instance FromJSON PostingType instance FromJSON Posting diff --git a/Hledger/Data/Ledger.hs b/Hledger/Data/Ledger.hs --- a/Hledger/Data/Ledger.hs +++ b/Hledger/Data/Ledger.hs @@ -80,7 +80,7 @@ -- | List a ledger's top-level accounts (the ones below the root), in tree order. ledgerTopAccounts :: Ledger -> [Account] -ledgerTopAccounts = asubs . head . laccounts +ledgerTopAccounts = asubs . headDef nullacct . laccounts -- | List a ledger's bottom-level (subaccount-less) accounts, in tree order. ledgerLeafAccounts :: Ledger -> [Account] diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -36,7 +36,7 @@ postingAllTags, transactionAllTags, relatedPostings, - postingStripPrices, + postingStripCosts, postingApplyAliases, postingApplyCommodityStyles, postingStyleAmounts, @@ -188,7 +188,7 @@ -- | Render a balance assertion, as the =[=][*] symbol and expected amount. showBalanceAssertion :: BalanceAssertion -> WideBuilder showBalanceAssertion ba = - singleton '=' <> eq <> ast <> singleton ' ' <> showAmountB def{displayZeroCommodity=True} (baamount ba) + singleton '=' <> eq <> ast <> singleton ' ' <> showAmountB def{displayZeroCommodity=True, displayForceDecimalMark=True} (baamount ba) where eq = if batotal ba then singleton '=' else mempty ast = if bainclusive ba then singleton '*' else mempty @@ -292,7 +292,7 @@ shownAmounts | elideamount = [mempty] | otherwise = showMixedAmountLinesB displayopts $ pamount p - where displayopts = noColour{ + where displayopts = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True, displayOneLine=onelineamounts } thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts @@ -361,7 +361,7 @@ | elideamount = [mempty] | otherwise = showMixedAmountLinesB displayopts a' where - displayopts = noColour{ displayZeroCommodity=True, displayForceDecimalMark=True } + displayopts = defaultFmt{ displayZeroCommodity=True, displayForceDecimalMark=True } a' = mapMixedAmount amountToBeancount $ pamount p thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts @@ -386,7 +386,7 @@ -- in a way that Beancount can read: forces the commodity symbol to the right, -- converts a few currency symbols to names, capitalises all letters. amountToBeancount :: Amount -> BeancountAmount -amountToBeancount a@Amount{acommodity=c,astyle=s,aprice=mp} = a{acommodity=c', astyle=s', aprice=mp'} +amountToBeancount a@Amount{acommodity=c,astyle=s,acost=mp} = a{acommodity=c', astyle=s', acost=mp'} -- https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies where c' = T.toUpper $ @@ -398,8 +398,8 @@ s' = s{ascommodityside=R, ascommodityspaced=True} mp' = costToBeancount <$> mp where - costToBeancount (TotalPrice amt) = TotalPrice $ amountToBeancount amt - costToBeancount (UnitPrice amt) = UnitPrice $ amountToBeancount amt + costToBeancount (TotalCost amt) = TotalCost $ amountToBeancount amt + costToBeancount (UnitCost amt) = UnitCost $ amountToBeancount amt -- | Like showAccountName for Beancount journal format. -- Calls accountNameToBeancount first. @@ -451,8 +451,8 @@ sumPostings = foldl' (\amt p -> maPlus amt $ pamount p) nullmixedamt -- | Strip all prices from a Posting. -postingStripPrices :: Posting -> Posting -postingStripPrices = postingTransformAmount mixedAmountStripPrices +postingStripCosts :: Posting -> Posting +postingStripCosts = postingTransformAmount mixedAmountStripCosts -- | Get a posting's (primary) date - it's own primary date if specified, -- otherwise the parent transaction's primary date, or the null date if @@ -543,20 +543,20 @@ | "_conversion-matched" `elem` map fst (ptags p) && nocosts = Nothing | otherwise = Just $ postingTransformAmount mixedAmountCost p where - nocosts = (not . any (isJust . aprice) . amountsRaw) $ pamount p + nocosts = (not . any (isJust . acost) . amountsRaw) $ pamount p --- | Generate inferred equity postings from a 'Posting' using transaction prices. --- Make sure not to generate equity postings when there are already matched --- conversion postings. +-- | Generate inferred equity postings from a 'Posting''s costs. +-- Make sure not to duplicate them when matching ones exist already. postingAddInferredEquityPostings :: Bool -> Text -> Posting -> [Posting] postingAddInferredEquityPostings verbosetags equityAcct p | "_price-matched" `elem` map fst (ptags p) = [p] - | otherwise = taggedPosting : concatMap conversionPostings priceAmounts + | otherwise = taggedPosting : concatMap conversionPostings costs where + costs = filter (isJust . acost) . amountsRaw $ pamount p taggedPosting - | null priceAmounts = p - | otherwise = p{ ptags = ("_price-matched","") : ptags p } - conversionPostings amt = case aprice amt of + | null costs = p + | otherwise = p{ ptags = ("_price-matched","") : ptags p } + conversionPostings amt = case acost amt of Nothing -> [] Just _ -> [ cp{ paccount = accountPrefix <> amtCommodity , pamount = mixedAmount . negate $ amountStripCost amt @@ -580,8 +580,6 @@ accountPrefix = mconcat [ equityAcct, ":", T.intercalate "-" $ sort [amtCommodity, costCommodity], ":"] -- Take the commodity of an amount and collapse consecutive spaces to a single space commodity = T.unwords . filter (not . T.null) . T.words . acommodity - - priceAmounts = filter (isJust . aprice) . amountsRaw $ pamount p -- | Make a market price equivalent to this posting's amount's unit -- price, if any. diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -387,13 +387,13 @@ -- with the matching amount which must be present in another non-conversion posting. costfulPostingIfMatchesBothAmounts :: Amount -> Amount -> Posting -> Maybe Posting costfulPostingIfMatchesBothAmounts a1 a2 costfulp = do - a@Amount{aprice=Just _} <- postingSingleAmount costfulp + a@Amount{acost=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<>" ?") + dbgamtmatch n a b = dbg7 ("conversion posting " <>show n<>" "<>showAmount a<>" balances amount "<>showAmountWithoutCost 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 @@ -401,7 +401,7 @@ addCostIfMatchesOneAmount :: Amount -> Amount -> Posting -> Maybe (Posting, Amount) addCostIfMatchesOneAmount a1 a2 p = do a <- postingSingleAmount p - let newp cost = p{pamount = mixedAmount a{aprice = Just $ TotalPrice cost}} + let newp cost = p{pamount = mixedAmount a{acost = Just $ TotalCost cost}} if | amountsMatch (-a1) a -> Just (newp a2, a2) | amountsMatch (-a2) a -> Just (newp a1, a1) @@ -409,8 +409,8 @@ -- Get the single-commodity costless amount from a conversion posting, or raise an error. conversionPostingAmountNoCost p = case postingSingleAmount p of - Just a@Amount{aprice=Nothing} -> Right a - Just Amount{aprice=Just _} -> Left $ annotateWithPostings [p] "Conversion postings must not have a cost:" + Just a@Amount{acost=Nothing} -> Right a + Just Amount{acost=Just _} -> Left $ annotateWithPostings [p] "Conversion postings must not have a cost:" Nothing -> Left $ annotateWithPostings [p] "Conversion postings must have a single-commodity amount:" -- Do these amounts look the same when compared at the first's display precision ? @@ -457,7 +457,7 @@ | check = Left "Conversion postings must occur in adjacent pairs" | otherwise = Right ((cs, (ps, np:os)), Nothing) isConversion p = paccount p `elem` conversionaccts - hasCost p = isJust $ aprice =<< postingSingleAmount p + hasCost p = isJust $ acost =<< postingSingleAmount p -- | Get a posting's amount if it is single-commodity. postingSingleAmount :: Posting -> Maybe Amount diff --git a/Hledger/Data/TransactionModifier.hs b/Hledger/Data/TransactionModifier.hs --- a/Hledger/Data/TransactionModifier.hs +++ b/Hledger/Data/TransactionModifier.hs @@ -19,6 +19,7 @@ import Data.Maybe (catMaybes) import qualified Data.Text as T import Data.Time.Calendar (Day) +import Safe (headDef) import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.Dates @@ -127,11 +128,11 @@ Just n -> \p -> -- Multiply the old posting's amount by the posting rule's multiplier. let - pramount = dbg6 "pramount" . head . amountsRaw $ pamount pr + pramount = dbg6 "pramount" . headDef nullamt . amountsRaw $ pamount pr matchedamount = dbg6 "matchedamount" . filterMixedAmount (symq `matchesAmount`) $ pamount p -- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928). -- Approach 1: convert to a unit price and increase the display precision slightly - -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalPriceToUnitPrice matchedamount + -- Mixed as = dbg6 "multipliedamount" $ n `multiplyMixedAmount` mixedAmountTotalCostToUnitCost matchedamount -- Approach 2: multiply the total price (keeping it positive) as well as the quantity as = dbg6 "multipliedamount" $ multiplyMixedAmount n matchedamount in @@ -140,7 +141,7 @@ -- TODO multipliers with commodity symbols are not yet a documented feature. -- For now: in addition to multiplying the quantity, it also replaces the -- matched amount's commodity, display style, and price with those of the posting rule. - c -> mapMixedAmount (\a -> a{acommodity = c, astyle = astyle pramount, aprice = aprice pramount}) as + c -> mapMixedAmount (\a -> a{acommodity = c, astyle = astyle pramount, acost = acost pramount}) as postingRuleMultiplier :: TMPostingRule -> Maybe Quantity postingRuleMultiplier tmpr = case amountsRaw . pamount $ tmprPosting tmpr of diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -171,7 +171,7 @@ | Revenue | Expense | Cash -- ^ a subtype of Asset - liquid assets to show in cashflow report - | Conversion -- ^ a subtype of Equity - account in which to generate conversion postings for transaction prices + | Conversion -- ^ a subtype of Equity - account with which to balance commodity conversions deriving (Eq,Ord,Generic) instance Show AccountType where @@ -246,12 +246,20 @@ -- | An amount's per-unit or total cost/selling price in another -- commodity, as recorded in the journal entry eg with @ or @@. -- "Cost", formerly AKA "transaction price". The amount is always positive. -data AmountPrice = UnitPrice !Amount | TotalPrice !Amount +data AmountCost = UnitCost !Amount | TotalCost !Amount deriving (Eq,Ord,Generic,Show) --- | Every Amount has one of these, influencing how the amount is displayed. --- Also, each Commodity can have one, which can be applied to its amounts for consistent display. --- See also Amount.AmountDisplayOpts. +-- | Display styles for amounts - things which can be detected during parsing, such as +-- commodity side and spacing, digit group marks, decimal mark, number of decimal digits etc. +-- Every "Amount" has an AmountStyle. +-- After amounts are parsed from the input, for each "Commodity" a standard style is inferred +-- and then used when displaying amounts in that commodity. +-- Related to "AmountFormat" but higher level. +-- +-- See also: +-- - hledger manual > Commodity styles +-- - hledger manual > Amounts +-- - hledger manual > Commodity display style data AmountStyle = AmountStyle { ascommodityside :: !Side, -- ^ show the symbol on the left or the right ? ascommodityspaced :: !Bool, -- ^ show a space between symbol and quantity ? @@ -261,7 +269,7 @@ asrounding :: !Rounding -- ^ "rounding strategy" - kept here for convenience, for now: -- when displaying an amount, it is ignored, -- but when applying this style to another amount, it determines - -- how hard we should try to adjust the amount's display precision. + -- how hard we should try to adjust that amount's display precision. } deriving (Eq,Ord,Read,Generic) instance Show AmountStyle where @@ -312,7 +320,7 @@ acommodity :: !CommoditySymbol, -- commodity symbol, or special value "AUTO" aquantity :: !Quantity, -- numeric quantity, or zero in case of "AUTO" astyle :: !AmountStyle, - aprice :: !(Maybe AmountPrice) -- ^ the (fixed, transaction-specific) price for this amount, if any + acost :: !(Maybe AmountCost) -- ^ the (fixed, transaction-specific) cost in another commodity of this amount, if any } deriving (Eq,Ord,Generic,Show) -- | Types with this class have one or more amounts, @@ -350,41 +358,41 @@ go ((_,x):xs) [] = compareQuantities (Just x) Nothing <> go xs [] go [] ((_,y):ys) = compareQuantities Nothing (Just y) <> go [] ys go [] [] = EQ - compareQuantities = comparing (maybe 0 aquantity) <> comparing (maybe 0 totalprice) - totalprice x = case aprice x of - Just (TotalPrice p) -> aquantity p + compareQuantities = comparing (maybe 0 aquantity) <> comparing (maybe 0 totalcost) + totalcost x = case acost x of + Just (TotalCost p) -> aquantity p _ -> 0 -- | Stores the CommoditySymbol of the Amount, along with the CommoditySymbol of --- the price, and its unit price if being used. +-- the cost, and its unit cost if being used. data MixedAmountKey - = MixedAmountKeyNoPrice !CommoditySymbol - | MixedAmountKeyTotalPrice !CommoditySymbol !CommoditySymbol - | MixedAmountKeyUnitPrice !CommoditySymbol !CommoditySymbol !Quantity + = MixedAmountKeyNoCost !CommoditySymbol + | MixedAmountKeyTotalCost !CommoditySymbol !CommoditySymbol + | MixedAmountKeyUnitCost !CommoditySymbol !CommoditySymbol !Quantity deriving (Eq,Generic,Show) -- | We don't auto-derive the Ord instance because it would give an undesired ordering. -- We want the keys to be sorted lexicographically: -- (1) By the primary commodity of the amount. --- (2) By the commodity of the price, with no price being first. --- (3) By the unit price, from most negative to most positive, with total prices --- before unit prices. +-- (2) By the commodity of the cost, with no cost being first. +-- (3) By the unit cost, from most negative to most positive, with total costs +-- before unit costs. -- For example, we would like the ordering to give --- MixedAmountKeyNoPrice "X" < MixedAmountKeyTotalPrice "X" "Z" < MixedAmountKeyNoPrice "Y" +-- MixedAmountKeyNoCost "X" < MixedAmountKeyTotalCost "X" "Z" < MixedAmountKeyNoCost "Y" instance Ord MixedAmountKey where - compare = comparing commodity <> comparing pCommodity <> comparing pPrice + compare = comparing commodity <> comparing pCommodity <> comparing pCost where - commodity (MixedAmountKeyNoPrice c) = c - commodity (MixedAmountKeyTotalPrice c _) = c - commodity (MixedAmountKeyUnitPrice c _ _) = c + commodity (MixedAmountKeyNoCost c) = c + commodity (MixedAmountKeyTotalCost c _) = c + commodity (MixedAmountKeyUnitCost c _ _) = c - pCommodity (MixedAmountKeyNoPrice _) = Nothing - pCommodity (MixedAmountKeyTotalPrice _ pc) = Just pc - pCommodity (MixedAmountKeyUnitPrice _ pc _) = Just pc + pCommodity (MixedAmountKeyNoCost _) = Nothing + pCommodity (MixedAmountKeyTotalCost _ pc) = Just pc + pCommodity (MixedAmountKeyUnitCost _ pc _) = Just pc - pPrice (MixedAmountKeyNoPrice _) = Nothing - pPrice (MixedAmountKeyTotalPrice _ _) = Nothing - pPrice (MixedAmountKeyUnitPrice _ _ q) = Just q + pCost (MixedAmountKeyNoCost _) = Nothing + pCost (MixedAmountKeyTotalCost _ _) = Nothing + pCost (MixedAmountKeyUnitCost _ _ q) = Just q data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting deriving (Eq,Show,Generic) @@ -439,7 +447,7 @@ ptransaction :: Maybe Transaction, -- ^ this posting's parent transaction (co-recursive types). -- Tying this knot gets tedious, Maybe makes it easier/optional. poriginal :: Maybe Posting -- ^ When this posting has been transformed in some way - -- (eg its amount or price was inferred, or the account name was + -- (eg its amount or cost was inferred, or the account name was -- changed by a pivot or budget report), this references the original -- untransformed posting (which will have Nothing in this field). } deriving (Generic) @@ -614,9 +622,38 @@ -- The data is partial, and list fields are in reverse order. type ParsedJournal = Journal +-- | One of the standard *-separated value file types known by hledger, +data SepFormat + = Csv -- comma-separated + | Tsv -- tab-separated + | Ssv -- semicolon-separated + deriving Eq + -- | The id of a data format understood by hledger, eg @journal@ or @csv@. -- The --output-format option selects one of these for output. -type StorageFormat = String +data StorageFormat + = Rules + | Journal' + | Ledger' + | Timeclock + | Timedot + | Sep SepFormat + deriving Eq + +instance Show SepFormat where + show Csv = "csv" + show Ssv = "ssv" + show Tsv = "tsv" + +instance Show StorageFormat where + show Rules = "rules" + show Journal' = "journal" + show Ledger' = "ledger" + show Timeclock = "timeclock" + show Timedot = "timedot" + show (Sep Csv) = "csv" + show (Sep Ssv) = "ssv" + show (Sep Tsv) = "tsv" -- | Extra information found in a payee directive. data PayeeDeclarationInfo = PayeeDeclarationInfo { diff --git a/Hledger/Data/Valuation.hs b/Hledger/Data/Valuation.hs --- a/Hledger/Data/Valuation.hs +++ b/Hledger/Data/Valuation.hs @@ -112,10 +112,10 @@ -- The price's display precision will be set to show all significant -- decimal digits; or if they seem to be infinite, defaultPrecisionLimit. amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective -amountPriceDirectiveFromCost d amt@Amount{acommodity=fromcomm, aquantity=n} = case aprice amt of - Just (UnitPrice u) -> Just $ pd{pdamount=u} - Just (TotalPrice t) | n /= 0 -> Just $ pd{pdamount=u} - where u = amountSetFullPrecisionOr Nothing $ divideAmount n t +amountPriceDirectiveFromCost d amt@Amount{acommodity=fromcomm, aquantity=n} = case acost amt of + Just (UnitCost u) -> Just $ pd{pdamount=u} + Just (TotalCost t) | n /= 0 -> Just $ pd{pdamount=u} + where u = amountSetFullPrecisionUpTo Nothing $ divideAmount n t _ -> Nothing where pd = PriceDirective{pddate = d, pdcommodity = fromcomm, pdamount = nullamt} @@ -209,7 +209,7 @@ -- set the display precision to match the internal precision (showing all digits), -- unnormalised (don't strip trailing zeros); -- but if it looks like an infinite decimal, limit the precision to 8. - & amountSetFullPrecisionOr Nothing + & amountSetFullPrecisionUpTo Nothing & dbg9With (lbl "calculated value".showAmount) -- | Calculate the gain of each component amount, that is the difference diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -82,7 +82,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, fromGregorian ) -import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay) +import Safe (headErr, readDef, readMay, maximumByMay, maximumMay, minimumMay) import Text.Megaparsec (between, noneOf, sepBy, try, (), notFollowedBy) import Text.Megaparsec.Char (char, string, string') @@ -123,15 +123,15 @@ instance Default Query where def = Any --- | Construct a payee tag +-- | Construct a query for the payee: tag payeeTag :: Maybe Text -> Either RegexError Query payeeTag = fmap (Tag (toRegexCI' "payee")) . maybe (pure Nothing) (fmap Just . toRegexCI) --- | Construct a note tag +-- | Construct a query for the note: tag noteTag :: Maybe Text -> Either RegexError Query noteTag = fmap (Tag (toRegexCI' "note")) . maybe (pure Nothing) (fmap Just . toRegexCI) --- | Construct a generated-transaction tag +-- | Construct a query for the generated-transaction: tag generatedTransactionTag :: Query generatedTransactionTag = Tag (toRegexCI' "generated-transaction") Nothing @@ -201,11 +201,11 @@ parseQueryList d termstrs = do eterms <- mapM (parseQueryTerm d) termstrs let (pats, optss) = unzip eterms - q = combineQueryList pats + q = combineQueriesByType pats Right (q, concat optss) -combineQueryList :: [Query] -> Query -combineQueryList pats = q +combineQueriesByType :: [Query] -> Query +combineQueriesByType pats = q where (descpats, pats') = partition queryIsDesc pats (acctpats, pats'') = partition queryIsAcct pats' @@ -324,10 +324,12 @@ -- prefix-operator "NOT e" is always parsed before "e AND e", "e AND e" before "e OR e", -- and "e OR e" before "e e". -- --- The space-separation operator is left as it was the default before the introduction of --- boolean operators. It takes the behaviour defined in the interpretQueryList function, --- whereas the NOT, OR, and AND operators simply wrap a list of queries with the associated --- +-- The "space" operator still works as it did before the introduction of boolean operators: +-- it combines terms according to their types, using parseQueryList. +-- Whereas the new NOT, OR, and AND operators work uniformly for all term types. +-- There is an exception: queries being OR'd may not specify a date period, +-- because that can produce multiple, possibly disjoint, report periods and result sets, +-- and we don't have report semantics worked out for it yet. (#2178) -- -- The result of this function is either an error encountered during parsing of the -- expression or the combined query and query options. @@ -337,50 +339,90 @@ -- -- >>> parseBooleanQuery nulldate "expenses:dining AND desc:a OR desc:b" -- Right (Or [And [Acct (RegexpCI "expenses:dining"),Desc (RegexpCI "a")],Desc (RegexpCI "b")],[]) +-- parseBooleanQuery :: Day -> T.Text -> Either String (Query,[QueryOpt]) -parseBooleanQuery d t = either (Left . ("failed to parse query:" <>) . customErrorBundlePretty) Right $ parsewith spacedQueriesP t +parseBooleanQuery d t = + either (Left . ("failed to parse query:" <>) . customErrorBundlePretty) Right $ + parsewith spacedExprsP t + where - regexP :: SimpleTextParser T.Text - regexP = choice' - [ stripquotes . T.pack <$> between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])), - stripquotes . T.pack <$> between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])), - T.pack <$> (notFollowedBy keywordSpaceP >> (many $ noneOf (") \n\r" :: [Char]))) ] - queryPrefixP :: SimpleTextParser T.Text - queryPrefixP = (string "not:" <> (fromMaybe "" <$> optional queryPrefixP)) - <|> choice' (string <$> queryprefixes) - "query prefix" - queryTermP :: SimpleTextParser (Query, [QueryOpt]) - queryTermP = do - prefix <- optional queryPrefixP - queryRegex <- regexP + -- Our "boolean queries" are compound query expressions built with a hierarchy of combinators. + -- At the top level we have one or more query expressions separated by space. + -- These are combined in the default way according to their types (see combineQueriesByType). + spacedExprsP :: SimpleTextParser (Query, [QueryOpt]) + spacedExprsP = combineWith combineQueriesByType <$> orExprsP `sepBy` skipNonNewlineSpaces1 - case parseQueryTerm d (fromMaybe "" prefix <> queryRegex) of - Right q -> return q - Left err -> error' err + where + combineWith :: ([Query] -> Query) -> [(Query, [QueryOpt])] -> (Query, [QueryOpt]) + combineWith f res = + let (qs, qoptss) = unzip res + qoptss' = concat qoptss + in case qs of + [] -> (Any, qoptss') + (q:[]) -> (simplifyQuery q, qoptss') + _ -> (simplifyQuery $ f qs, qoptss') - keywordSpaceP :: SimpleTextParser T.Text - keywordSpaceP = choice' (string' <$> ["not ", "and ", "or "]) + -- Containing query expressions separated by "or". + -- If there's more than one, make sure none contains a "date:". + orExprsP :: SimpleTextParser (Query, [QueryOpt]) + orExprsP = do + exprs <- andExprsP `sepBy` (try $ skipNonNewlineSpaces >> string' "or" >> skipNonNewlineSpaces1) + if ( length exprs > 1 + && (any (/=Any) $ map (filterQuery queryIsDateOrDate2 . fst) exprs)) + then fail "sorry, using date: in OR expressions is not supported." + else return $ combineWith Or exprs - parQueryP,notQueryP :: SimpleTextParser (Query, [QueryOpt]) - parQueryP = between (char '(' >> skipNonNewlineSpaces) - (try $ skipNonNewlineSpaces >> char ')') - spacedQueriesP - <|> queryTermP - notQueryP = (maybe id (\_ (q, qopts) -> (Not q, qopts)) <$> optional (try $ string' "not" >> notFollowedBy (char ':') >> skipNonNewlineSpaces1)) <*> parQueryP + where + -- Containing query expressions separated by "and". + andExprsP :: SimpleTextParser (Query, [QueryOpt]) + andExprsP = combineWith And <$> maybeNotExprP `sepBy` (try $ skipNonNewlineSpaces >> string' "and" >> skipNonNewlineSpaces1) - andQueriesP,orQueriesP,spacedQueriesP :: SimpleTextParser (Query, [QueryOpt]) - andQueriesP = nArityOp And <$> notQueryP `sepBy` (try $ skipNonNewlineSpaces >> string' "and" >> skipNonNewlineSpaces1) - orQueriesP = nArityOp Or <$> andQueriesP `sepBy` (try $ skipNonNewlineSpaces >> string' "or" >> skipNonNewlineSpaces1) - spacedQueriesP = nArityOp combineQueryList <$> orQueriesP `sepBy` skipNonNewlineSpaces1 + where + -- Containing query expressions optionally preceded by "not". + maybeNotExprP :: SimpleTextParser (Query, [QueryOpt]) + maybeNotExprP = (maybe id (\_ (q, qopts) -> (Not q, qopts)) <$> + optional (try $ string' "not" >> notFollowedBy (char ':') >> skipNonNewlineSpaces1)) <*> termOrParenthesisedExprP - nArityOp :: ([Query] -> Query) -> [(Query, [QueryOpt])] -> (Query, [QueryOpt]) - nArityOp f res = let (qs, qoptss) = unzip res - qoptss' = concat qoptss - in case qs of - [] -> (Any, qoptss') - (q:[]) -> (simplifyQuery q, qoptss') - _ -> (simplifyQuery $ f qs, qoptss') + where + -- Each of which is a parenthesised query expression or a single query term. + termOrParenthesisedExprP :: SimpleTextParser (Query, [QueryOpt]) + termOrParenthesisedExprP = + between (char '(' >> skipNonNewlineSpaces) (try $ skipNonNewlineSpaces >> char ')') spacedExprsP + <|> queryTermP + where + -- A simple query term: foo, acct:foo, desc:foo, payee:foo etc. + queryTermP :: SimpleTextParser (Query, [QueryOpt]) + queryTermP = do + prefix <- optional queryPrefixP + arg <- queryArgP + case parseQueryTerm d (fromMaybe "" prefix <> arg) of + Right q -> return q + Left err -> error' err + + where + -- One of the query prefixes: acct:, desc:, payee: etc (plus zero or more not: prefixes). + queryPrefixP :: SimpleTextParser T.Text + queryPrefixP = + (string "not:" <> (fromMaybe "" <$> optional queryPrefixP)) + <|> choice' (string <$> queryprefixes) + "query prefix" + + -- A query term's argument, the part after the prefix: + -- any text enclosed in single quotes or double quotes, + -- or any text up to the next space, closing parenthesis, or end of line, + -- if it is not one of the keywords "not", "and", "or". + queryArgP :: SimpleTextParser T.Text + queryArgP = choice' + [ stripquotes . T.pack <$> between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])), + stripquotes . T.pack <$> between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])), + T.pack <$> (notFollowedBy keywordP >> (many $ noneOf (") \n\r" :: [Char]))) ] + + where + -- Any of the combinator keywords used above (not/and/or), terminated by a space. + keywordP :: SimpleTextParser T.Text + keywordP = choice' (string' <$> ["not ", "and ", "or "]) + -- | Parse the argument of an amt query term ([OP][SIGN]NUM), to an -- OrdPlus and a Quantity, or if parsing fails, an error message. OP -- can be <=, <, >=, >, or = . NUM can be a simple integer or decimal. @@ -494,14 +536,14 @@ where simplify (And []) = Any simplify (And [q]) = simplify q - simplify (And qs) | same qs = simplify $ head qs + simplify (And qs) | same qs = simplify $ headErr qs -- PARTIAL headErr succeeds because pattern ensures non-null qs | None `elem` qs = None | all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs | otherwise = And $ map simplify dateqs ++ map simplify otherqs where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs simplify (Or []) = Any simplify (Or [q]) = simplifyQuery q - simplify (Or qs) | same qs = simplify $ head qs + simplify (Or qs) | same qs = simplify $ headErr qs -- PARTIAL headErr succeeds because pattern ensures non-null qs | Any `elem` qs = Any -- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs ? | otherwise = Or $ map simplify $ filter (/=None) qs diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -140,7 +140,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time (Day) -import Safe (headDef) +import Safe (headDef, headMay) import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.Exit (exitFailure) @@ -184,8 +184,12 @@ -- determine a home directory). defaultJournalPath :: IO String defaultJournalPath = do - s <- envJournalPath - if null s then defpath else return s + p <- envJournalPath + if null p + then defpath + else do + ps <- expandGlob "." p `C.catch` (\(_::C.IOException) -> return []) + maybe defpath return $ headMay ps where envJournalPath = getEnv journalEnvVar @@ -331,16 +335,16 @@ orDieTrying :: MonadIO m => ExceptT String m a -> m a orDieTrying a = either (liftIO . fail) return =<< runExceptT a --- | If the specified journal file does not exist (and is not "-"), --- give a helpful error and quit. +-- | If the specified journal file does not exist (and is not "-"), give a helpful error and quit. +-- (Using "journal file" generically here; it could be in any of hledger's supported formats.) requireJournalFileExists :: FilePath -> IO () requireJournalFileExists "-" = return () requireJournalFileExists f = do exists <- doesFileExist f - unless exists $ do -- XXX might not be a journal file - hPutStr stderr $ "The hledger journal file \"" <> f <> "\" was not found.\n" + unless exists $ do + hPutStr stderr $ "The hledger data file \"" <> f <> "\" was not found.\n" hPutStr stderr "Please create it first, eg with \"hledger add\" or a text editor.\n" - hPutStr stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n" + hPutStr stderr "Or, specify an existing data file with -f or $LEDGER_FILE.\n" exitFailure -- | Ensure there is a journal file at the given path, creating an empty one if needed. @@ -348,7 +352,7 @@ -- which could cause data loss (see 'isWindowsUnsafeDotPath'). ensureJournalFileExists :: FilePath -> IO () ensureJournalFileExists f = do - when (os/="mingw32" && isWindowsUnsafeDotPath f) $ do + when (os=="mingw32" && isWindowsUnsafeDotPath f) $ do hPutStr stderr $ "Part of file path \"" <> show f <> "\"\n ends with a dot, which is unsafe on Windows; please use a different path.\n" exitFailure exists <- doesFileExist f diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -190,7 +190,7 @@ ,rParser :: MonadIO m => ErroringJournalParser m ParsedJournal } -instance Show (Reader m) where show r = rFormat r ++ " reader" +instance Show (Reader m) where show r = show (rFormat r) ++ " reader" -- | Parse an InputOpts from a RawOpts and a provided date. -- This will fail with a usage error if the forecast period expression cannot be parsed. @@ -517,41 +517,39 @@ sep <- datesepchar "date separator" d2 <- decimal "month or day" case d1 of - Left y -> fullDate startOffset y sep d2 - Right m -> partialDate startOffset mYear m sep d2 + Left y -> fullDate startOffset y sep d2 + Right m -> partialDate startOffset mYear m d2 "full or partial date" where fullDate :: Int -> Year -> Char -> Month -> TextParser m Day - fullDate startOffset year sep1 month = do + fullDate startOffset year sep month = do sep2 <- satisfy isDateSepChar "date separator" day <- decimal "day" endOffset <- getOffset - let dateStr = show year ++ [sep1] ++ show month ++ [sep2] ++ show day - - when (sep1 /= sep2) $ customFailure $ parseErrorAtRegion startOffset endOffset $ - "This date is malformed because the separators are different.\n" - ++"Please use consistent separators." - + when (sep /= sep2) $ + customFailure $ parseErrorAtRegion startOffset endOffset $ + "This date has different separators, please use consistent separators." case fromGregorianValid year month day of - Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ - "This date is invalid, please correct it: " ++ dateStr + Nothing -> + customFailure $ parseErrorAtRegion startOffset endOffset $ + "This is not a valid date, please fix it." Just date -> pure $! date - partialDate :: Int -> Maybe Year -> Month -> Char -> MonthDay -> TextParser m Day - partialDate startOffset myr month sep day = do + partialDate :: Int -> Maybe Year -> Month -> MonthDay -> TextParser m Day + partialDate startOffset myr month day = do endOffset <- getOffset case myr of Just year -> case fromGregorianValid year month day of - Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ - "This date is invalid, please correct it: " ++ dateStr + Nothing -> + customFailure $ parseErrorAtRegion startOffset endOffset $ + "This is not a valid date, please fix it." Just date -> pure $! date - where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day - Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ - "The partial date "++dateStr++" can not be parsed because the current year is unknown.\n" - ++"Consider making it a full date, or add a default year directive.\n" - where dateStr = show month ++ [sep] ++ show day + Nothing -> + customFailure $ parseErrorAtRegion startOffset endOffset $ + "This partial date can not be parsed because the current year is unknown.\n" + ++"Please make it a full date, or add a default year directive." {-# INLINABLE datep' #-} @@ -776,7 +774,7 @@ <*> toPermutationWithDefault Nothing (Just <$> lotcostp <* spaces) <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces) <*> toPermutationWithDefault Nothing (Just <$> lotnotep <* spaces) - pure $ amt { aprice = mcost } + pure $ amt { acost = mcost } -- An amount with optional cost, but no cost basis. amountnobasisp :: JournalParser m Amount @@ -787,7 +785,7 @@ amt <- simpleamountp False spaces mprice <- optional $ costp amt <* spaces - pure $ amt { aprice = mprice } + pure $ amt { acost = mprice } -- An amount with no cost or cost basis. -- A flag indicates whether we are parsing a multiplier amount; @@ -817,7 +815,7 @@ let numRegion = (offBeforeNum, offAfterNum) (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalmark=mdec, asdigitgroups=mgrps} - return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, aprice=Nothing} + return nullamt{acommodity=c, aquantity=sign (sign2 q), astyle=s, acost=Nothing} -- An amount with commodity symbol on the right or no commodity symbol. -- A no-symbol amount will have the default commodity applied to it @@ -839,7 +837,7 @@ let msuggestedStyle = mdecmarkStyle <|> mcommodityStyle (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalmark=mdec, asdigitgroups=mgrps} - return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing} + return nullamt{acommodity=c, aquantity=sign q, astyle=s, acost=Nothing} -- no symbol amount Nothing -> do -- look for a number style to use when parsing, based on @@ -856,7 +854,7 @@ let (c,s) = case (mult, defcs) of (False, Just (defc,defs)) -> (defc, defs{asprecision=max (asprecision defs) prec}) _ -> ("", amountstyle{asprecision=prec, asdecimalmark=mdec, asdigitgroups=mgrps}) - return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing} + return nullamt{acommodity=c, aquantity=sign q, astyle=s, acost=Nothing} -- For reducing code duplication. Doesn't parse anything. Has the type -- of a parser only in order to throw parse errors (for convenience). @@ -911,14 +909,14 @@ -- | Ledger-style cost notation: -- @ UNITAMT, @@ TOTALAMT, (@) UNITAMT, or (@@) TOTALAMT. The () are ignored. -costp :: Amount -> JournalParser m AmountPrice +costp :: Amount -> JournalParser m AmountCost costp baseAmt = -- dbg "costp" $ label "transaction price" $ do -- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs parenthesised <- option False $ char '(' >> pure True char '@' - totalPrice <- char '@' $> True <|> pure False + totalCost <- char '@' $> True <|> pure False when parenthesised $ void $ char ')' lift skipNonNewlineSpaces @@ -927,9 +925,9 @@ 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 + pure $ if totalCost + then TotalCost priceAmount{aquantity=amtsign * aquantity priceAmount} + else UnitCost priceAmount -- | A valuation function or value can be written in double parentheses after an amount. valuationexprp :: JournalParser m () @@ -1169,8 +1167,21 @@ pure $ NoSeparators grp1 (Just (decPt, mempty)) isDigitSeparatorChar :: Char -> Bool -isDigitSeparatorChar c = isDecimalMark c || c == ' ' +isDigitSeparatorChar c = isDecimalMark c || isDigitSeparatorSpaceChar c +-- | Kinds of unicode space character we accept as digit group marks. +-- See also https://en.wikipedia.org/wiki/Decimal_separator#Digit_grouping . +isDigitSeparatorSpaceChar :: Char -> Bool +isDigitSeparatorSpaceChar c = + c == ' ' -- space + || c == ' ' -- no-break space + || c == ' ' -- en space + || c == ' ' -- em space + || c == ' ' -- punctuation space + || c == ' ' -- thin space + || c == ' ' -- narrow no-break space + || c == ' ' -- medium mathematical space + -- | Some kinds of number literal we might parse. data RawNumber = NoSeparators DigitGrp (Maybe (Char, DigitGrp)) @@ -1504,10 +1515,10 @@ -- Left ...not a bracketed date... -- -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]" --- Left ...1:2:...This date is invalid... +-- Left ...1:2:...This is not a valid date... -- -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]" --- Left ...1:2:...The partial date 1/31 can not be parsed... +-- Left ...1:2:...This partial date can not be parsed because the current year is unknown... -- -- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]" -- Left ...1:13:...expecting month or day... @@ -1588,7 +1599,7 @@ acommodity="$" ,aquantity=10 -- need to test internal precision with roundTo ? I think not ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing} - ,aprice=Just $ UnitPrice $ + ,acost=Just $ UnitCost $ nullamt{ acommodity="€" ,aquantity=0.5 @@ -1600,7 +1611,7 @@ acommodity="$" ,aquantity=10 ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing} - ,aprice=Just $ TotalPrice $ + ,acost=Just $ TotalCost $ nullamt{ acommodity="€" ,aquantity=5 diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs --- a/Hledger/Read/CsvReader.hs +++ b/Hledger/Read/CsvReader.hs @@ -41,11 +41,11 @@ --- ** reader -reader :: MonadIO m => Reader m -reader = Reader - {rFormat = "csv" - ,rExtensions = ["csv","tsv","ssv"] - ,rReadFn = parse +reader :: MonadIO m => SepFormat -> Reader m +reader sep = Reader + {rFormat = Sep sep + ,rExtensions = [show sep] + ,rReadFn = parse sep ,rParser = error' "sorry, CSV files can't be included yet" -- PARTIAL: } @@ -54,10 +54,10 @@ -- This file path is normally the CSV(/SSV/TSV) data file, and a corresponding rules file is inferred. -- But it can also be the rules file, in which case the corresponding data file is inferred. -- This does not check balance assertions. -parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal -parse iopts f t = do +parse :: SepFormat -> InputOpts -> FilePath -> Text -> ExceptT String IO Journal +parse sep iopts f t = do let mrulesfile = mrules_file_ iopts - readJournalFromCsv (Right <$> mrulesfile) f t + readJournalFromCsv (Right <$> mrulesfile) f t (Just sep) -- apply any command line account aliases. Can fail with a bad replacement pattern. >>= liftEither . journalApplyAliases (aliasesFromOpts iopts) -- journalFinalise assumes the journal's items are diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -104,6 +104,7 @@ import qualified Hledger.Read.RulesReader as RulesReader (reader) import qualified Hledger.Read.TimeclockReader as TimeclockReader (reader) import qualified Hledger.Read.TimedotReader as TimedotReader (reader) +import System.Directory (canonicalizePath) --- ** doctest setup -- $setup @@ -139,21 +140,25 @@ ,TimeclockReader.reader ,TimedotReader.reader ,RulesReader.reader - ,CsvReader.reader + ,CsvReader.reader Csv + ,CsvReader.reader Tsv + ,CsvReader.reader Ssv -- ,LedgerReader.reader ] readerNames :: [String] -readerNames = map rFormat (readers'::[Reader IO]) +readerNames = map (show . rFormat) (readers'::[Reader IO]) -- | @findReader mformat mpath@ -- -- Find the reader named by @mformat@, if provided. +-- ("ssv" and "tsv" are recognised as alternate names for the csv reader, +-- which also handles those formats.) -- Or, if a file path is provided, find the first reader that handles -- its file extension, if any. findReader :: MonadIO m => Maybe StorageFormat -> Maybe FilePath -> Maybe (Reader m) findReader Nothing Nothing = Nothing -findReader (Just fmt) _ = headMay [r | r <- readers', rFormat r == fmt] +findReader (Just fmt) _ = headMay [r | r <- readers', let rname = rFormat r, rname == fmt] findReader Nothing (Just path) = case prefix of Just fmt -> headMay [r | r <- readers', rFormat r == fmt] @@ -168,16 +173,27 @@ -- | If a filepath is prefixed by one of the reader names and a colon, -- split that off. Eg "csv:-" -> (Just "csv", "-"). -splitReaderPrefix :: PrefixedFilePath -> (Maybe String, FilePath) +-- These reader prefixes can be used to force a specific reader, +-- overriding the file extension. +splitReaderPrefix :: PrefixedFilePath -> (Maybe StorageFormat, FilePath) splitReaderPrefix f = - headDef (Nothing, f) $ - [(Just r, drop (length r + 1) f) | r <- readerNames, (r++":") `isPrefixOf` f] + let + candidates = [(Just r, drop (length r + 1) f) | r <- readerNames ++ ["ssv","tsv"], (r++":") `isPrefixOf` f] + (strPrefix, newF) = headDef (Nothing, f) candidates + in case strPrefix of + Just "csv" -> (Just (Sep Csv), newF) + Just "tsv" -> (Just (Sep Tsv), newF) + Just "ssv" -> (Just (Sep Ssv), newF) + Just "journal" -> (Just Journal', newF) + Just "timeclock" -> (Just Timeclock, newF) + Just "timedot" -> (Just Timedot, newF) + _ -> (Nothing, f) --- ** reader reader :: MonadIO m => Reader m reader = Reader - {rFormat = "journal" + {rFormat = Journal' ,rExtensions = ["journal", "j", "hledger", "ledger"] ,rReadFn = parse ,rParser = journalp -- no need to add command line aliases like journalp' @@ -282,29 +298,31 @@ paths <- getFilePaths parentoff parentpos glb let prefixedpaths = case mprefix of Nothing -> paths - Just fmt -> map ((fmt++":")++) paths + Just fmt -> map ((show fmt++":")++) paths forM_ prefixedpaths $ parseChild parentpos void newline where getFilePaths :: MonadIO m => Int -> SourcePos -> FilePath -> JournalParser m [FilePath] - getFilePaths parseroff parserpos filename = do - let curdir = takeDirectory (sourceName parserpos) - filename' <- lift $ expandHomePath filename - `orRethrowIOError` (show parserpos ++ " locating " ++ filename) - -- Compiling filename as a glob pattern works even if it is a literal - fileglob <- case tryCompileWith compDefault{errorRecovery=False} filename' of + getFilePaths parseroff parserpos fileglobpattern = do + -- Expand a ~ at the start of the glob pattern, if any. + fileglobpattern' <- lift $ expandHomePath fileglobpattern + `orRethrowIOError` (show parserpos ++ " locating " ++ fileglobpattern) + -- Compile the glob pattern. + fileglob <- case tryCompileWith compDefault{errorRecovery=False} fileglobpattern' of Right x -> pure x - Left e -> customFailure $ - parseErrorAt parseroff $ "Invalid glob pattern: " ++ e - -- Get all matching files in the current working directory, sorting in - -- lexicographic order to simulate the output of 'ls'. + Left e -> customFailure $ parseErrorAt parseroff $ "Invalid glob pattern: " ++ e + -- Get the directory of the including file. This will be used to resolve relative paths. + let parentfilepath = sourceName parserpos + realparentfilepath <- liftIO $ canonicalizePath parentfilepath -- Follow a symlink. If the path is already absolute, the operation never fails. + let curdir = takeDirectory realparentfilepath + -- Find all matched files, in lexicographic order mimicking the output of 'ls'. filepaths <- liftIO $ sort <$> globDir1 fileglob curdir if (not . null) filepaths then pure filepaths else customFailure $ parseErrorAt parseroff $ - "No existing files match pattern: " ++ filename + "No existing files match pattern: " ++ fileglobpattern parseChild :: MonadIO m => SourcePos -> PrefixedFilePath -> ErroringJournalParser m () parseChild parentpos prefixedpath = do diff --git a/Hledger/Read/RulesReader.hs b/Hledger/Read/RulesReader.hs --- a/Hledger/Read/RulesReader.hs +++ b/Hledger/Read/RulesReader.hs @@ -20,3032 +20,1557 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - ---- ** exports -module Hledger.Read.RulesReader ( - -- * Reader - reader, - -- * Misc. - readJournalFromCsv, - -- readRulesFile, - -- parseCsvRules, - -- validateCsvRules, - -- CsvRules, - dataFileFor, - rulesFileFor, - -- * Tests - tests_RulesReader, -) -where - ---- ** imports -import Prelude hiding (Applicative(..)) -import Control.Applicative (Applicative(..)) -import Control.Monad (unless, when, void) -import Control.Monad.Except (ExceptT(..), liftEither, throwError) -import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.State.Strict (StateT, get, modify', evalStateT) -import Control.Monad.Trans.Class (lift) -import Data.Char (toLower, isDigit, isSpace, isAlphaNum, ord) -import Data.Bifunctor (first) -import Data.Functor ((<&>)) -import Data.List (elemIndex, foldl', mapAccumL, nub, sortOn) -import Data.List.Extra (groupOn) -import Data.Maybe (catMaybes, fromMaybe, isJust) -import Data.MemoUgly (memo) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import Data.Time ( Day, TimeZone, UTCTime, LocalTime, ZonedTime(ZonedTime), - defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC) -import Safe (atMay, headMay, lastMay, readMay) -import System.FilePath ((), takeDirectory, takeExtension, stripExtension, takeFileName) -import qualified Data.Csv as Cassava -import qualified Data.Csv.Parser.Megaparsec as CassavaMegaparsec -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Foldable (asum, toList) -import Text.Megaparsec hiding (match, parse) -import Text.Megaparsec.Char (char, newline, string, digitChar) -import Text.Megaparsec.Custom (parseErrorAt) -import Text.Printf (printf) - -import Hledger.Data -import Hledger.Utils -import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep, commenttagsp ) -import Hledger.Read.CsvUtils -import System.Directory (doesFileExist, getHomeDirectory) -import Data.Either (fromRight) - ---- ** doctest setup --- $setup --- >>> :set -XOverloadedStrings - ---- ** reader -_READER__________________________________________ = undefined -- VSCode outline separator - - -reader :: MonadIO m => Reader m -reader = Reader - {rFormat = "rules" - ,rExtensions = ["rules"] - ,rReadFn = parse - ,rParser = error' "sorry, rules files can't be included" -- PARTIAL: - } - -isFileName f = takeFileName f == f - -getDownloadDir = do - home <- getHomeDirectory - return $ home "Downloads" -- XXX - --- | Parse and post-process a "Journal" from the given rules file path, or give an error. --- A data file is inferred from the @source@ rule, otherwise from a similarly-named file --- in the same directory. --- The source rule can specify a glob pattern and supports ~ for home directory. --- If it is a bare filename it will be relative to the defaut download directory --- on this system. If is a relative file path it will be relative to the rules --- file's directory. When a glob pattern matches multiple files, the alphabetically --- last is used. (Eg in case of multiple numbered downloads, the highest-numbered --- will be used.) --- The provided text, or a --rules-file option, are ignored by this reader. --- Balance assertions are not checked. -parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal -parse iopts f _ = do - rules <- readRulesFile $ dbg4 "reading rules file" f - -- XXX higher-than usual debug level for file reading to bypass excessive noise from elsewhere, normally 6 or 7 - mdatafile <- liftIO $ do - dldir <- getDownloadDir - let rulesdir = takeDirectory f - let msource = T.unpack <$> getDirective "source" rules - fs <- case msource of - Just src -> expandGlob dir (dbg4 "source" src) >>= sortByModTime <&> dbg4 ("matched files"<>desc<>", newest first") - where (dir,desc) = if isFileName src then (dldir," in download directory") else (rulesdir,"") - Nothing -> return [maybe err (dbg4 "inferred source") $ dataFileFor f] -- shouldn't fail, f has .rules extension - where err = error' $ "could not infer a data file for " <> f - return $ dbg4 "data file" $ headMay fs - case mdatafile of - Nothing -> return nulljournal -- data file specified by source rule was not found - Just dat -> do - exists <- liftIO $ doesFileExist dat - if not (dat=="-" || exists) - then return nulljournal -- data file inferred from rules file name was not found - else do - t <- liftIO $ readFileOrStdinPortably dat - readJournalFromCsv (Just $ Left rules) dat t - -- apply any command line account aliases. Can fail with a bad replacement pattern. - >>= liftEither . journalApplyAliases (aliasesFromOpts iopts) - -- journalFinalise assumes the journal's items are - -- reversed, as produced by JournalReader's parser. - -- But here they are already properly ordered. So we'd - -- better preemptively reverse them once more. XXX inefficient - . journalReverse - >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f "" - ---- ** reading rules files ---- *** rules utilities -_RULES_READING__________________________________________ = undefined - --- | Given a rules file path, what would be the corresponding data file ? --- (Remove a .rules extension.) -dataFileFor :: FilePath -> Maybe FilePath -dataFileFor = stripExtension "rules" - --- | Given a csv file path, what would be the corresponding rules file ? --- (Add a .rules extension.) -rulesFileFor :: FilePath -> FilePath -rulesFileFor = (++ ".rules") - --- | An exception-throwing IO action that reads and validates --- the specified CSV rules file (which may include other rules files). -readRulesFile :: FilePath -> ExceptT String IO CsvRules -readRulesFile f = - liftIO (do - dbg6IO "using conversion rules file" f - readFilePortably f >>= expandIncludes (takeDirectory f) - ) >>= either throwError return . parseAndValidateCsvRules f - --- | Inline all files referenced by include directives in this hledger CSV rules text, recursively. --- Included file paths may be relative to the directory of the provided file path. --- This is done as a pre-parse step to simplify the CSV rules parser. -expandIncludes :: FilePath -> Text -> IO Text -expandIncludes dir0 content = mapM (expandLine dir0) (T.lines content) <&> T.unlines - where - expandLine dir1 line = - case line of - (T.stripPrefix "include " -> Just f) -> expandIncludes dir2 =<< T.readFile f' - where - f' = dir1 T.unpack (T.dropWhile isSpace f) - dir2 = takeDirectory f' - _ -> return line - --- defaultRulesText :: FilePath -> Text --- defaultRulesText _csvfile = T.pack $ unlines --- ["# hledger csv conversion rules" -- for " ++ csvFileFor (takeFileName csvfile) --- ,"# cf http://hledger.org/hledger.html#csv" --- ,"" --- ,"account1 assets:bank:checking" --- ,"" --- ,"fields date, description, amount1" --- ,"" --- ,"#skip 1" --- ,"#newest-first" --- ,"" --- ,"#date-format %-d/%-m/%Y" --- ,"#date-format %-m/%-d/%Y" --- ,"#date-format %Y-%h-%d" --- ,"" --- ,"#currency $" --- ,"" --- ,"if ITUNES" --- ," account2 expenses:entertainment" --- ,"" --- ,"if (TO|FROM) SAVINGS" --- ," account2 assets:bank:savings\n" --- ] - --- | An error-throwing IO action that parses this text as CSV conversion rules --- and runs some extra validation checks. The file path is used in error messages. -parseAndValidateCsvRules :: FilePath -> T.Text -> Either String CsvRules -parseAndValidateCsvRules rulesfile s = - case parseCsvRules rulesfile s of - Left err -> Left $ customErrorBundlePretty err - Right rules -> first makeFancyParseError $ validateCsvRules rules - where - makeFancyParseError :: String -> String - makeFancyParseError errorString = - parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String) - -instance ShowErrorComponent String where - showErrorComponent = id - --- | Parse this text as CSV conversion rules. The file path is for error messages. -parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text HledgerParseErrorData) CsvRules --- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s -parseCsvRules = runParser (evalStateT rulesp defrules) - --- | Return the validated rules, or an error. -validateCsvRules :: CsvRules -> Either String CsvRules -validateCsvRules rules = do - unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1" - Right rules - where - isAssigned f = isJust $ getEffectiveAssignment rules [] f - ---- *** rules types -_RULES_TYPES__________________________________________ = undefined - --- | A set of data definitions and account-matching patterns sufficient to --- convert a particular CSV data file into meaningful journal transactions. -data CsvRules' a = CsvRules' { - rdirectives :: [(DirectiveName,Text)], - -- ^ top-level rules, as (keyword, value) pairs - rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)], - -- ^ csv field names and their column number, if declared by a fields list - rassignments :: [(HledgerFieldName, FieldTemplate)], - -- ^ top-level assignments to hledger fields, as (field name, value template) pairs - rconditionalblocks :: [ConditionalBlock], - -- ^ conditional blocks, which containing additional assignments/rules to apply to matched csv records - rblocksassigning :: a -- (String -> [ConditionalBlock]) - -- ^ all conditional blocks which can potentially assign field with a given name (memoized) -} - --- | Type used by parsers. Directives, assignments and conditional blocks --- are in the reverse order compared to what is in the file and rblocksassigning is non-functional, --- could not be used for processing CSV records yet -type CsvRulesParsed = CsvRules' () - --- | Type used after parsing is done. Directives, assignments and conditional blocks --- are in the same order as they were in the input file and rblocksassigning is functional. --- Ready to be used for CSV record processing -type CsvRules = CsvRules' (Text -> [ConditionalBlock]) -- XXX simplify - -instance Eq CsvRules where - r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) == - (rdirectives r2, rcsvfieldindexes r2, rassignments r2) - --- Custom Show instance used for debug output: omit the rblocksassigning field, which isn't showable. -instance Show CsvRules where - show r = "CsvRules { rdirectives = " ++ show (rdirectives r) ++ - ", rcsvfieldindexes = " ++ show (rcsvfieldindexes r) ++ - ", rassignments = " ++ show (rassignments r) ++ - ", rconditionalblocks = " ++ show (rconditionalblocks r) ++ - " }" - -type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a - --- | The keyword of a CSV rule - "fields", "skip", "if", etc. -type DirectiveName = Text - --- | CSV field name. -type CsvFieldName = Text - --- | 1-based CSV column number. -type CsvFieldIndex = Int - --- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1. -type CsvFieldReference = Text - --- | One of the standard hledger fields or pseudo-fields that can be assigned to. --- Eg date, account1, amount, amount1-in, date-format. -type HledgerFieldName = Text - --- | A text value to be assigned to a hledger field, possibly --- containing csv field references to be interpolated. -type FieldTemplate = Text - --- | A reference to a regular expression match group. Eg \1. -type MatchGroupReference = Text - --- | A strptime date parsing pattern, as supported by Data.Time.Format. -type DateFormat = Text - --- | A prefix for a matcher test, either & or none (implicit or). -data MatcherPrefix = And | Not | None - deriving (Show, Eq) - --- | A single test for matching a CSV record, in one way or another. -data Matcher = - RecordMatcher MatcherPrefix Regexp -- ^ match if this regexp matches the overall CSV record - | FieldMatcher MatcherPrefix CsvFieldReference Regexp -- ^ match if this regexp matches the referenced CSV field's value - deriving (Show, Eq) - --- | A conditional block: a set of CSV record matchers, and a sequence --- of rules which will be enabled only if one or more of the matchers --- succeeds. --- --- Three types of rule are allowed inside conditional blocks: field --- assignments, skip, end. (A skip or end rule is stored as if it was --- a field assignment, and executed in validateCsv. XXX) -data ConditionalBlock = CB { - cbMatchers :: [Matcher] - ,cbAssignments :: [(HledgerFieldName, FieldTemplate)] - } deriving (Show, Eq) - -defrules :: CsvRulesParsed -defrules = CsvRules' { - rdirectives=[], - rcsvfieldindexes=[], - rassignments=[], - rconditionalblocks=[], - rblocksassigning = () - } - --- | Create CsvRules from the content parsed out of the rules file -mkrules :: CsvRulesParsed -> CsvRules -mkrules rules = - let conditionalblocks = reverse $ rconditionalblocks rules - maybeMemo = if length conditionalblocks >= 15 then memo else id - in - CsvRules' { - rdirectives=reverse $ rdirectives rules, - rcsvfieldindexes=rcsvfieldindexes rules, - rassignments=reverse $ rassignments rules, - rconditionalblocks=conditionalblocks, - rblocksassigning = maybeMemo (\f -> filter (any ((==f).fst) . cbAssignments) conditionalblocks) - } - ---- *** rules parsers -_RULES_PARSING__________________________________________ = undefined - -{- -Grammar for the CSV conversion rules, more or less: - -RULES: RULE* - -RULE: ( SOURCE | FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE - -SOURCE: source SPACE FILEPATH - -FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )* - -FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME - -QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ " - -BARE-FIELD-NAME: any CHAR except space, tab, #, ; - -FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE - -JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD - -JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency - -ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? ) - -FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs and REGEX-MATCHGROUP-REFERENCEs) - -CSV-FIELD-REFERENCE: % CSV-FIELD - -REGEX-MATCHGROUP-REFERENCE: \ DIGIT+ - -CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field) - -FIELD-NUMBER: DIGIT+ - -CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK - -FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS - -MATCHOP: ~ - -PATTERNS: ( NEWLINE REGEXP )* REGEXP - -INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+ - -REGEXP: ( NONSPACE CHAR* ) SPACE? - -VALUE: SPACE? ( CHAR* ) SPACE? - -COMMENT: SPACE? COMMENT-CHAR VALUE - -COMMENT-CHAR: # | ; | * - -NONSPACE: any CHAR not a SPACE-CHAR - -BLANK: SPACE? - -SPACE: SPACE-CHAR+ - -SPACE-CHAR: space | tab - -CHAR: any character except newline - -DIGIT: 0-9 - --} - -addDirective :: (DirectiveName, Text) -> CsvRulesParsed -> CsvRulesParsed -addDirective d r = r{rdirectives=d:rdirectives r} - -addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed -addAssignment a r = r{rassignments=a:rassignments r} - -setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed -setIndexesAndAssignmentsFromList fs = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs - where - setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed - setCsvFieldIndexesFromList fs' r = r{rcsvfieldindexes=zip fs' [1..]} - - addAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed - addAssignmentsFromList fs' r = foldl' maybeAddAssignment r journalfieldnames - where - maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs') rules - where - addAssignmentFromIndex i = addAssignment (f, T.pack $ '%':show (i+1)) - -addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed -addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r} - -addConditionalBlocks :: [ConditionalBlock] -> CsvRulesParsed -> CsvRulesParsed -addConditionalBlocks bs r = r{rconditionalblocks=bs++rconditionalblocks r} - -rulesp :: CsvRulesParser CsvRules -rulesp = do - _ <- many $ choice - [blankorcommentlinep "blank or comment line" - ,(directivep >>= modify' . addDirective) "directive" - ,(fieldnamelistp >>= modify' . setIndexesAndAssignmentsFromList) "field name list" - ,(fieldassignmentp >>= modify' . addAssignment) "field assignment" - -- conditionalblockp backtracks because it shares "if" prefix with conditionaltablep. - ,try (conditionalblockp >>= modify' . addConditionalBlock) "conditional block" - -- 'reverse' is there to ensure that conditions are added in the order they listed in the file - ,(conditionaltablep >>= modify' . addConditionalBlocks . reverse) "conditional table" - ] - eof - mkrules <$> get - -blankorcommentlinep :: CsvRulesParser () -blankorcommentlinep = lift (dbgparse 8 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep] - -blanklinep :: CsvRulesParser () -blanklinep = lift skipNonNewlineSpaces >> newline >> return () "blank line" - -commentlinep :: CsvRulesParser () -commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> return () "comment line" - -commentcharp :: CsvRulesParser Char -commentcharp = oneOf (";#*" :: [Char]) - -directivep :: CsvRulesParser (DirectiveName, Text) -directivep = (do - lift $ dbgparse 8 "trying directive" - d <- choiceInState $ map (lift . string) directives - v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp) - <|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "") - return (d, v) - ) "directive" - -directives :: [Text] -directives = - ["source" - ,"date-format" - ,"decimal-mark" - ,"separator" - -- ,"default-account" - -- ,"default-currency" - ,"skip" - ,"timezone" - ,"newest-first" - ,"intra-day-reversed" - , "balance-type" - ] - -directivevalp :: CsvRulesParser Text -directivevalp = T.pack <$> anySingle `manyTill` lift eolof - -fieldnamelistp :: CsvRulesParser [CsvFieldName] -fieldnamelistp = (do - lift $ dbgparse 8 "trying fieldnamelist" - string "fields" - optional $ char ':' - lift skipNonNewlineSpaces1 - let separator = lift skipNonNewlineSpaces >> char ',' >> lift skipNonNewlineSpaces - f <- fromMaybe "" <$> optional fieldnamep - fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep) - lift restofline - return . map T.toLower $ f:fs - ) "field name list" - -fieldnamep :: CsvRulesParser Text -fieldnamep = quotedfieldnamep <|> barefieldnamep - -quotedfieldnamep :: CsvRulesParser Text -quotedfieldnamep = - char '"' *> takeWhile1P Nothing (`notElem` ("\"\n:;#~" :: [Char])) <* char '"' - -barefieldnamep :: CsvRulesParser Text -barefieldnamep = takeWhile1P Nothing (`notElem` (" \t\n,;#~" :: [Char])) - -fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate) -fieldassignmentp = do - lift $ dbgparse 8 "trying fieldassignmentp" - f <- journalfieldnamep - v <- choiceInState [ assignmentseparatorp >> fieldvalp - , lift eolof >> return "" - ] - return (f,v) - "field assignment" - -journalfieldnamep :: CsvRulesParser Text -journalfieldnamep = do - lift (dbgparse 8 "trying journalfieldnamep") - choiceInState $ map (lift . string) journalfieldnames - -maxpostings = 99 - --- Transaction fields and pseudo fields for CSV conversion. --- Names must precede any other name they contain, for the parser --- (amount-in before amount; date2 before date). TODO: fix -journalfieldnames = - concat [[ "account" <> i - ,"amount" <> i <> "-in" - ,"amount" <> i <> "-out" - ,"amount" <> i - ,"balance" <> i - ,"comment" <> i - ,"currency" <> i - ] | x <- [maxpostings, (maxpostings-1)..1], let i = T.pack $ show x] - ++ - ["amount-in" - ,"amount-out" - ,"amount" - ,"balance" - ,"code" - ,"comment" - ,"currency" - ,"date2" - ,"date" - ,"description" - ,"status" - ,"skip" -- skip and end are not really fields, but we list it here to allow conditional rules that skip records - ,"end" - ] - -assignmentseparatorp :: CsvRulesParser () -assignmentseparatorp = do - lift $ dbgparse 8 "trying assignmentseparatorp" - _ <- choiceInState [ lift skipNonNewlineSpaces >> char ':' >> lift skipNonNewlineSpaces - , lift skipNonNewlineSpaces1 - ] - return () - -fieldvalp :: CsvRulesParser Text -fieldvalp = do - lift $ dbgparse 8 "trying fieldvalp" - T.pack <$> anySingle `manyTill` lift eolof - --- A conditional block: one or more matchers, one per line, followed by one or more indented rules. -conditionalblockp :: CsvRulesParser ConditionalBlock -conditionalblockp = do - lift $ dbgparse 8 "trying conditionalblockp" - -- "if\nMATCHER" or "if \nMATCHER" or "if MATCHER" - start <- getOffset - string "if" >> ( (newline >> return Nothing) - <|> (lift skipNonNewlineSpaces1 >> optional newline)) - ms <- some matcherp - as <- catMaybes <$> - many (lift skipNonNewlineSpaces1 >> - choice [ lift eolof >> return Nothing - , fmap Just fieldassignmentp - ]) - when (null as) $ - customFailure $ parseErrorAt start $ "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)" - return $ CB{cbMatchers=ms, cbAssignments=as} - "conditional block" - --- A conditional table: "if" followed by separator, followed by some field names, --- followed by many lines, each of which has: --- one matchers, followed by field assignments (as many as there were fields) -conditionaltablep :: CsvRulesParser [ConditionalBlock] -conditionaltablep = do - lift $ dbgparse 8 "trying conditionaltablep" - start <- getOffset - string "if" - sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c)) - fields <- journalfieldnamep `sepBy1` (char sep) - newline - body <- flip manyTill (lift eolof) $ do - off <- getOffset - m <- matcherp' $ void $ char sep - vs <- T.split (==sep) . T.pack <$> lift restofline - if (length vs /= length fields) - then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String) - else return (m,vs) - when (null body) $ - customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward" - return $ flip map body $ \(m,vs) -> - CB{cbMatchers=[m], cbAssignments=zip fields vs} - "conditional table" - --- A single matcher, on one line. -matcherp' :: CsvRulesParser () -> CsvRulesParser Matcher -matcherp' end = try (fieldmatcherp end) <|> recordmatcherp end - -matcherp :: CsvRulesParser Matcher -matcherp = matcherp' (lift eolof) - --- A single whole-record matcher. --- A pattern on the whole line, not beginning with a csv field reference. -recordmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher -recordmatcherp end = do - lift $ dbgparse 8 "trying recordmatcherp" - -- pos <- currentPos - -- _ <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline) - p <- matcherprefixp - r <- regexp end - return $ RecordMatcher p r - -- when (null ps) $ - -- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)" - "record matcher" - --- | A single matcher for a specific field. A csv field reference --- (like %date or %1), and a pattern on the rest of the line, --- optionally space-separated. Eg: --- %description chez jacques -fieldmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher -fieldmatcherp end = do - lift $ dbgparse 8 "trying fieldmatcher" - -- An optional fieldname (default: "all") - -- f <- fromMaybe "all" `fmap` (optional $ do - -- f' <- fieldnamep - -- lift skipNonNewlineSpaces - -- return f') - p <- matcherprefixp - f <- csvfieldreferencep <* lift skipNonNewlineSpaces - -- optional operator.. just ~ (case insensitive infix regex) for now - -- _op <- fromMaybe "~" <$> optional matchoperatorp - lift skipNonNewlineSpaces - r <- regexp end - return $ FieldMatcher p f r - "field matcher" - -matcherprefixp :: CsvRulesParser MatcherPrefix -matcherprefixp = do - lift $ dbgparse 8 "trying matcherprefixp" - (char '&' >> lift skipNonNewlineSpaces >> return And) <|> (char '!' >> lift skipNonNewlineSpaces >> return Not) <|> return None - -csvfieldreferencep :: CsvRulesParser CsvFieldReference -csvfieldreferencep = do - lift $ dbgparse 8 "trying csvfieldreferencep" - char '%' - T.cons '%' . textQuoteIfNeeded <$> fieldnamep - --- A single regular expression -regexp :: CsvRulesParser () -> CsvRulesParser Regexp -regexp end = do - lift $ dbgparse 8 "trying regexp" - -- notFollowedBy matchoperatorp - c <- lift nonspace - cs <- anySingle `manyTill` end - case toRegexCI . T.strip . T.pack $ c:cs of - Left x -> Fail.fail $ "CSV parser: " ++ x - Right x -> return x - --- -- A match operator, indicating the type of match to perform. --- -- Currently just ~ meaning case insensitive infix regex match. --- matchoperatorp :: CsvRulesParser String --- matchoperatorp = fmap T.unpack $ choiceInState $ map string --- ["~" --- -- ,"!~" --- -- ,"=" --- -- ,"!=" --- ] - -_RULES_LOOKUP__________________________________________ = undefined - -getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate -getDirective directivename = lookup directivename . rdirectives - --- | Look up the value (template) of a csv rule by rule keyword. -csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate -csvRule rules = (`getDirective` rules) - --- | Look up the value template assigned to a hledger field by field --- list/field assignment rules, taking into account the current record and --- conditional rules. -hledgerField :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate -hledgerField = getEffectiveAssignment - --- | Look up the final value assigned to a hledger field, with csv field --- references interpolated. -hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text -hledgerFieldValue rules record f = (fmap (renderTemplate rules record f) . hledgerField rules record) f - -maybeNegate :: MatcherPrefix -> Bool -> Bool -maybeNegate Not origbool = not origbool -maybeNegate _ origbool = origbool - --- | Given the conversion rules, a CSV record and a hledger field name, find --- the value template ultimately assigned to this field, if any, by a field --- assignment at top level or in a conditional block matching this record. --- --- Note conditional blocks' patterns are matched against an approximation of the --- CSV record: all the field values, without enclosing quotes, comma-separated. --- -getEffectiveAssignment :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate -getEffectiveAssignment rules record f = lastMay $ map snd $ assignments - where - -- all active assignments to field f, in order - assignments = dbg9 "csv assignments" $ filter ((==f).fst) $ toplevelassignments ++ conditionalassignments - -- all top level field assignments - toplevelassignments = rassignments rules - -- all field assignments in conditional blocks assigning to field f and active for the current csv record - conditionalassignments = concatMap cbAssignments $ filter (isBlockActive rules record) $ (rblocksassigning rules) f - --- does this conditional block match the current csv record ? -isBlockActive :: CsvRules -> CsvRecord -> ConditionalBlock -> Bool -isBlockActive rules record CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers - where - -- does this individual matcher match the current csv record ? - matcherMatches :: Matcher -> Bool - matcherMatches (RecordMatcher prefix pat) = maybeNegate prefix origbool - where - pat' = dbg7 "regex" pat - -- A synthetic whole CSV record to match against. Note, this can be - -- different from the original CSV data: - -- - any whitespace surrounding field values is preserved - -- - any quotes enclosing field values are removed - -- - and the field separator is always comma - -- which means that a field containing a comma will look like two fields. - wholecsvline = dbg7 "wholecsvline" $ T.intercalate "," record - origbool = regexMatchText pat' wholecsvline - matcherMatches (FieldMatcher prefix csvfieldref pat) = maybeNegate prefix origbool - where - -- the value of the referenced CSV field to match against. - csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref - origbool = regexMatchText pat csvfieldvalue - - -- | Group matchers into associative pairs based on prefix, e.g.: - -- A - -- & B - -- C - -- D - -- & E - -- => [[A, B], [C], [D, E]] - groupedMatchers :: [Matcher] -> [[Matcher]] - groupedMatchers [] = [] - groupedMatchers (x:xs) = (x:ys) : groupedMatchers zs - where - (ys, zs) = span (\y -> matcherPrefix y == And) xs - matcherPrefix :: Matcher -> MatcherPrefix - matcherPrefix (RecordMatcher prefix _) = prefix - matcherPrefix (FieldMatcher prefix _ _) = prefix - --- | Render a field assignment's template, possibly interpolating referenced --- CSV field values or match groups. Outer whitespace is removed from interpolated values. -renderTemplate :: CsvRules -> CsvRecord -> HledgerFieldName -> FieldTemplate -> Text -renderTemplate rules record f t = - maybe t mconcat $ parseMaybe - (many - ( literaltextp - <|> (matchrefp <&> replaceRegexGroupReference rules record f) - <|> (fieldrefp <&> replaceCsvFieldReference rules record) - ) - ) - t - where - literaltextp :: SimpleTextParser Text - literaltextp = some (nonBackslashOrPercent <|> nonRefBackslash <|> nonRefPercent) <&> T.pack - where - nonBackslashOrPercent = noneOf ['\\', '%'] "character other than backslash or percent" - nonRefBackslash = try (char '\\' <* notFollowedBy digitChar) "backslash that does not begin a match group reference" - nonRefPercent = try (char '%' <* notFollowedBy (satisfy isFieldNameChar)) "percent that does not begin a field reference" - matchrefp = liftA2 T.cons (char '\\') (takeWhile1P (Just "matchref") isDigit) - fieldrefp = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) - isFieldNameChar c = isAlphaNum c || c == '_' || c == '-' - --- | Replace something that looks like a Regex match group reference with the --- resulting match group value after applying the Regex. -replaceRegexGroupReference :: CsvRules -> CsvRecord -> HledgerFieldName -> MatchGroupReference -> Text -replaceRegexGroupReference rules record f s = case T.uncons s of - Just ('\\', group) -> fromMaybe "" $ regexMatchValue rules record f group - _ -> s - -regexMatchValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Text -> Maybe Text -regexMatchValue rules record f sgroup = let - matchgroups = concatMap (getMatchGroups rules record) - $ concatMap cbMatchers - $ filter (isBlockActive rules record) - $ rblocksassigning rules f - group = (read (T.unpack sgroup) :: Int) - 1 -- adjust to 0-indexing - in atMay matchgroups group - -getMatchGroups :: CsvRules -> CsvRecord -> Matcher -> [Text] -getMatchGroups _ record (RecordMatcher _ regex) = let - txt = T.intercalate "," record -- see caveats of wholecsvline, in `isBlockActive` - in regexMatchTextGroups regex txt -getMatchGroups rules record (FieldMatcher _ fieldref regex) = let - txt = replaceCsvFieldReference rules record fieldref - in regexMatchTextGroups regex txt - --- | Replace something that looks like a reference to a csv field ("%date" or "%1) --- with that field's value. If it doesn't look like a field reference, or if we --- can't find such a field, replace it with the empty string. -replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> Text -replaceCsvFieldReference rules record s = case T.uncons s of - Just ('%', fieldname) -> fromMaybe "" $ csvFieldValue rules record fieldname - _ -> s - --- | Get the (whitespace-stripped) value of a CSV field, identified by its name or --- column number, ("date" or "1"), from the given CSV record, if such a field exists. -csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text -csvFieldValue rules record fieldname = do - fieldindex <- - if T.all isDigit fieldname - then readMay $ T.unpack fieldname - else lookup (T.toLower fieldname) $ rcsvfieldindexes rules - T.strip <$> atMay record (fieldindex-1) - -_CSV_READING__________________________________________ = undefined - --- | Read a Journal from the given CSV data (and filename, used for error --- messages), or return an error. Proceed as follows: --- --- 1. Conversion rules are provided, or they are parsed from the specified --- rules file, or from the default rules file for the CSV data file. --- If rules parsing fails, or the required rules file does not exist, throw an error. --- --- 2. Parse the CSV data using the rules, or throw an error. --- --- 3. Convert the CSV records to hledger transactions using the rules. --- --- 4. Return the transactions as a Journal. --- -readJournalFromCsv :: Maybe (Either CsvRules FilePath) -> FilePath -> Text -> ExceptT String IO Journal -readJournalFromCsv Nothing "-" _ = throwError "please use --rules-file when reading CSV from stdin" -readJournalFromCsv merulesfile csvfile csvtext = do - -- for now, correctness is the priority here, efficiency not so much - - rules <- case merulesfile of - Just (Left rs) -> return rs - Just (Right rulesfile) -> readRulesFile rulesfile - Nothing -> readRulesFile $ rulesFileFor csvfile - dbg6IO "csv rules" rules - - -- convert the csv data to lines and remove all empty/blank lines - let csvlines1 = dbg9 "csvlines1" $ filter (not . T.null . T.strip) $ dbg9 "csvlines0" $ T.lines csvtext - - -- if there is a top-level skip rule, skip the specified number of non-empty lines - skiplines <- case getDirective "skip" rules of - Nothing -> return 0 - Just "" -> return 1 - Just s -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s - let csvlines2 = dbg9 "csvlines2" $ drop skiplines csvlines1 - - -- convert back to text and parse as csv records - let - csvtext1 = T.unlines csvlines2 - separator = - case getDirective "separator" rules >>= parseSeparator of - Just c -> c - _ | ext == "ssv" -> ';' - _ | ext == "tsv" -> '\t' - _ -> ',' - where - ext = map toLower $ drop 1 $ takeExtension csvfile - -- parsec seemed to fail if you pass it "-" here -- TODO: try again with megaparsec - parsecfilename = if csvfile == "-" then "(stdin)" else csvfile - dbg6IO "using separator" separator - -- parse csv records - csvrecords0 <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvtext1 - -- remove any records skipped by conditional skip or end rules - let csvrecords1 = applyConditionalSkips rules csvrecords0 - -- and check the remaining records for any obvious problems - csvrecords <- liftEither $ dbg7 "validateCsv" <$> validateCsv csvrecords1 - dbg6IO "first 3 csv records" $ take 3 csvrecords - - -- XXX identify header lines some day ? - -- let (headerlines, datalines) = identifyHeaderLines csvrecords' - -- mfieldnames = lastMay headerlines - - tzout <- liftIO getCurrentTimeZone - mtzin <- case getDirective "timezone" rules of - Nothing -> return Nothing - Just s -> - maybe (throwError $ "could not parse time zone: " ++ T.unpack s) (return.Just) $ - parseTimeM False defaultTimeLocale "%Z" $ T.unpack s - let - -- convert CSV records to transactions, saving the CSV line numbers for error positions - txns = dbg7 "csv txns" $ snd $ mapAccumL - (\pos r -> - let - SourcePos name line col = pos - line' = (mkPos . (+1) . unPos) line - pos' = SourcePos name line' col - in - (pos', transactionFromCsvRecord timesarezoned mtzin tzout pos rules r) - ) - (initialPos parsecfilename) csvrecords - where - timesarezoned = - case csvRule rules "date-format" of - Just f | any (`T.isInfixOf` f) ["%Z","%z","%EZ","%Ez"] -> True - _ -> False - - -- Do our best to ensure transactions will be ordered chronologically, - -- from oldest to newest. This is done in several steps: - -- 1. Intra-day order: if there's an "intra-day-reversed" rule, - -- assume each day's CSV records were ordered in reverse of the overall date order, - -- so reverse each day's txns. - intradayreversed = dbg6 "intra-day-reversed" $ isJust $ getDirective "intra-day-reversed" rules - txns1 = dbg7 "txns1" $ - (if intradayreversed then concatMap reverse . groupOn tdate else id) txns - -- 2. Overall date order: now if there's a "newest-first" rule, - -- or if there's multiple dates and the first is more recent than the last, - -- assume CSV records were ordered newest dates first, - -- so reverse all txns. - newestfirst = dbg6 "newest-first" $ isJust $ getDirective "newest-first" rules - mdatalooksnewestfirst = dbg6 "mdatalooksnewestfirst" $ - case nub $ map tdate txns of - ds | length ds > 1 -> Just $ head ds > last ds - _ -> Nothing - txns2 = dbg7 "txns2" $ - (if newestfirst || mdatalooksnewestfirst == Just True then reverse else id) txns1 - -- 3. Disordered dates: in case the CSV records were ordered by chaos, - -- do a final sort by date. If it was only a few records out of order, - -- this will hopefully refine any good ordering done by steps 1 and 2. - txns3 = dbg7 "date-sorted csv txns" $ sortOn tdate txns2 - - return nulljournal{jtxns=txns3} - --- | Parse special separator names TAB and SPACE, or return the first --- character. Return Nothing on empty string -parseSeparator :: Text -> Maybe Char -parseSeparator = specials . T.toLower - where specials "space" = Just ' ' - specials "tab" = Just '\t' - specials xs = fst <$> T.uncons xs - --- Call parseCassava on a file or stdin, converting the result to ExceptT. -parseCsv :: Char -> FilePath -> Text -> ExceptT String IO [CsvRecord] -parseCsv separator filePath csvtext = ExceptT $ - case filePath of - "-" -> parseCassava separator "(stdin)" <$> T.getContents - _ -> return $ if T.null csvtext then Right mempty else parseCassava separator filePath csvtext - --- Parse text into CSV records, using Cassava and the given field separator. -parseCassava :: Char -> FilePath -> Text -> Either String [CsvRecord] -parseCassava separator path content = - -- XXX we now remove all blank lines before parsing; will Cassava will still produce [""] records ? - -- filter (/=[""]) - either (Left . errorBundlePretty) (Right . parseResultToCsv) <$> - CassavaMegaparsec.decodeWith decodeOptions Cassava.NoHeader path $ - BL.fromStrict $ T.encodeUtf8 content - where - decodeOptions = Cassava.defaultDecodeOptions { - Cassava.decDelimiter = fromIntegral (ord separator) - } - parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> [CsvRecord] - parseResultToCsv = toListList . unpackFields - where - toListList = toList . fmap toList - unpackFields = (fmap . fmap) T.decodeUtf8 - --- | Scan for csv records where a conditional `skip` or `end` rule applies, --- and apply that rule, removing one or more following records. -applyConditionalSkips :: CsvRules -> [CsvRecord] -> [CsvRecord] -applyConditionalSkips _ [] = [] -applyConditionalSkips rules (r:rest) = - case skipnum r of - Nothing -> r : applyConditionalSkips rules rest - Just cnt -> applyConditionalSkips rules $ drop (cnt-1) rest - where - skipnum r1 = - case (getEffectiveAssignment rules r1 "end", getEffectiveAssignment rules r1 "skip") of - (Nothing, Nothing) -> Nothing - (Just _, _) -> Just maxBound - (Nothing, Just "") -> Just 1 - (Nothing, Just x) -> Just (read $ T.unpack x) - --- | Do some validation on the parsed CSV records: --- check that they all have at least two fields. -validateCsv :: [CsvRecord] -> Either String [CsvRecord] -validateCsv [] = Right [] -validateCsv rs@(_first:_) = - case lessthan2 of - Just r -> Left $ printf "CSV record %s has less than two fields" (show r) - Nothing -> Right rs - where - lessthan2 = headMay $ filter ((<2).length) rs - --- -- | The highest (0-based) field index referenced in the field --- -- definitions, or -1 if no fields are defined. --- maxFieldIndex :: CsvRules -> Int --- maxFieldIndex r = maximumDef (-1) $ catMaybes [ --- dateField r --- ,statusField r --- ,codeField r --- ,amountField r --- ,amountInField r --- ,amountOutField r --- ,currencyField r --- ,accountField r --- ,account2Field r --- ,date2Field r --- ] - ---- ** converting csv records to transactions - -transactionFromCsvRecord :: Bool -> Maybe TimeZone -> TimeZone -> SourcePos -> CsvRules -> CsvRecord -> Transaction -transactionFromCsvRecord timesarezoned mtzin tzout sourcepos rules record = t - where - ---------------------------------------------------------------------- - -- 1. Define some helpers: - - rule = csvRule rules :: DirectiveName -> Maybe FieldTemplate - -- ruleval = csvRuleValue rules record :: DirectiveName -> Maybe String - field = hledgerField rules record :: HledgerFieldName -> Maybe FieldTemplate - fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text - mdateformat = rule "date-format" - parsedate = parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mdateformat - mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines - ["error: could not parse \""<>datevalue<>"\" as a date using date format " - <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat' - ,showRecord record - ,"the "<>datefield<>" rule is: "<>(fromMaybe "required, but missing" $ field datefield) - ,"the date-format is: "<>fromMaybe "unspecified" mdateformat' - ,"you may need to " - <>"change your "<>datefield<>" rule, " - <>maybe "add a" (const "change your") mdateformat'<>" date-format rule, " - <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule" - ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y" - ] - where - mskip = rule "skip" - - ---------------------------------------------------------------------- - -- 2. Gather values needed for the transaction itself, by evaluating the - -- field assignment rules using the CSV record's data, and parsing a bit - -- more where needed (dates, status). - - date = fromMaybe "" $ fieldval "date" - -- PARTIAL: - date' = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date - mdate2 = fieldval "date2" - mdate2' = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) =<< mdate2 - status = - case fieldval "status" of - Nothing -> Unmarked - Just s -> either statuserror id $ runParser (statusp <* eof) "" s - where - statuserror err = error' . T.unpack $ T.unlines - ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)" - ,"the parse error is: "<>T.pack (customErrorBundlePretty err) - ] - code = maybe "" singleline' $ fieldval "code" - description = maybe "" singleline' $ fieldval "description" - comment = maybe "" unescapeNewlines $ fieldval "comment" - ttags = fromRight [] $ rtp commenttagsp comment - precomment = maybe "" unescapeNewlines $ fieldval "precomment" - - singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines - unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n" - - ---------------------------------------------------------------------- - -- 3. Generate the postings for which an account has been assigned - -- (possibly indirectly due to an amount or balance assignment) - - p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting - ps = [p | n <- [1..maxpostings] - ,let cmt = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n)) - ,let ptags = fromRight [] $ rtp commenttagsp cmt - ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency") - ,let mamount = getAmount rules record currency p1IsVirtual n - ,let mbalance = getBalance rules record currency n - ,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n] -- skips Nothings - ,let acct' | not isfinal && acct==unknownExpenseAccount && - fromMaybe False (mamount >>= isNegativeMixedAmount) = unknownIncomeAccount - | otherwise = acct - ,let p = nullposting{paccount = accountNameWithoutPostingType acct' - ,pamount = fromMaybe missingmixedamt mamount - ,ptransaction = Just t - ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance - ,pcomment = cmt - ,ptags = ptags - ,ptype = accountNamePostingType acct - } - ] - - ---------------------------------------------------------------------- - -- 4. Build the transaction (and name it, so the postings can reference it). - - t = nulltransaction{ - tsourcepos = (sourcepos, sourcepos) -- the CSV line number - ,tdate = date' - ,tdate2 = mdate2' - ,tstatus = status - ,tcode = code - ,tdescription = description - ,tcomment = comment - ,ttags = ttags - ,tprecedingcomment = precomment - ,tpostings = ps - } - --- | Parse the date string using the specified date-format, or if unspecified --- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading --- zeroes optional). If a timezone is provided, we assume the DateFormat --- produces a zoned time and we localise that to the given timezone. -parseDateWithCustomOrDefaultFormats :: Bool -> Maybe TimeZone -> TimeZone -> Maybe DateFormat -> Text -> Maybe Day -parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mformat s = localdate <$> mutctime - -- this time code can probably be simpler, I'm just happy to get out alive - where - localdate :: UTCTime -> Day = - localDay . - dbg7 ("time in output timezone "++show tzout) . - utcToLocalTime tzout - mutctime :: Maybe UTCTime = asum $ map parseWithFormat formats - - parseWithFormat :: String -> Maybe UTCTime - parseWithFormat fmt = - if timesarezoned - then - dbg7 "zoned CSV time, expressed as UTC" $ - parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe UTCTime - else - -- parse as a local day and time; then if an input timezone is provided, - -- assume it's in that, otherwise assume it's in the output timezone; - -- then convert to UTC like the above - let - mlocaltime = - fmap (dbg7 "unzoned CSV time") $ - parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe LocalTime - localTimeAsZonedTime tz lt = ZonedTime lt tz - in - case mtzin of - Just tzin -> - (dbg7 ("unzoned CSV time, declared as "++show tzin++ ", expressed as UTC") . - localTimeToUTC tzin) - <$> mlocaltime - Nothing -> - (dbg7 ("unzoned CSV time, treated as "++show tzout++ ", expressed as UTC") . - zonedTimeToUTC . - localTimeAsZonedTime tzout) - <$> mlocaltime - - formats = map T.unpack $ maybe - ["%Y/%-m/%-d" - ,"%Y-%-m-%-d" - ,"%Y.%-m.%-d" - -- ,"%-m/%-d/%Y" - -- ,parseTimeM TruedefaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s) - -- ,parseTimeM TruedefaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s) - -- ,parseTimeM TruedefaultTimeLocale "%m/%e/%Y" ('0':s) - -- ,parseTimeM TruedefaultTimeLocale "%m-%e-%Y" ('0':s) - ] - (:[]) - mformat - --- | Figure out the amount specified for posting N, if any. --- A currency symbol to prepend to the amount, if any, is provided, --- and whether posting 1 requires balancing or not. --- This looks for a non-empty amount value assigned to "amountN", "amountN-in", or "amountN-out". --- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out". --- If more than one of these has a value, it looks for one that is non-zero. --- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error. -getAmount :: CsvRules -> CsvRecord -> Text -> Bool -> Int -> Maybe MixedAmount -getAmount rules record currency p1IsVirtual n = - -- Warning! Many tricky corner cases here. - -- Keep synced with: - -- hledger_csv.m4.md -> CSV FORMAT -> "amount", "Setting amounts", - -- hledger/test/csv.test -> 13, 31-34 - let - unnumberedfieldnames = ["amount","amount-in","amount-out"] - - -- amount field names which can affect this posting - fieldnames = map (("amount"<> T.pack (show n))<>) ["","-in","-out"] - -- For posting 1, also recognise the old amount/amount-in/amount-out names. - -- For posting 2, the same but only if posting 1 needs balancing. - ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else [] - - -- assignments to any of these field names with non-empty values - assignments = [(f,a') | f <- fieldnames - , Just v <- [T.strip . renderTemplate rules record f <$> hledgerField rules record f] - , not $ T.null v - -- XXX maybe ignore rule-generated values like "", "-", "$", "-$", "$-" ? cf CSV FORMAT -> "amount", "Setting amounts", - , let a = parseAmount rules record currency v - -- With amount/amount-in/amount-out, in posting 2, - -- flip the sign and convert to cost, as they did before 1.17 - , let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (maNegate a) else a - ] - - -- if any of the numbered field names are present, discard all the unnumbered ones - discardUnnumbered xs = if null numbered then xs else numbered - where - numbered = filter (T.any isDigit . fst) xs - - -- discard all zero amounts, unless all amounts are zero, in which case discard all but the first - discardExcessZeros xs = if null nonzeros then take 1 xs else nonzeros - where - nonzeros = filter (not . mixedAmountLooksZero . snd) xs - - -- for -out fields, flip the sign XXX unless it's already negative ? back compat issues / too confusing ? - negateIfOut f = if "-out" `T.isSuffixOf` f then maNegate else id - - in case discardExcessZeros $ discardUnnumbered assignments of - [] -> Nothing - [(f,a)] -> Just $ negateIfOut f a - fs -> error' . T.unpack . textChomp . T.unlines $ -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - ["in CSV rules:" - ,"While processing " <> showRecord record - ,"while calculating amount for posting " <> T.pack (show n) - ] ++ - ["rule \"" <> f <> " " <> - fromMaybe "" (hledgerField rules record f) <> - "\" assigned value \"" <> wbToText (showMixedAmountB noColour a) <> "\"" -- XXX not sure this is showing all the right info - | (f,a) <- fs - ] ++ - ["" - ,"Multiple non-zero amounts were assigned for an amount field." - ,"Please ensure just one non-zero amount is assigned, perhaps with an if rule." - ,"See also: https://hledger.org/hledger.html#setting-amounts" - ,"(hledger manual -> CSV format -> Tips -> Setting amounts)" - ] --- | Figure out the expected balance (assertion or assignment) specified for posting N, --- if any (and its parse position). -getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, SourcePos) -getBalance rules record currency n = do - v <- (fieldval ("balance"<> T.pack (show n)) - -- for posting 1, also recognise the old field name - <|> if n==1 then fieldval "balance" else Nothing) - case v of - "" -> Nothing - s -> Just ( - parseBalanceAmount rules record currency n s - ,initialPos "" -- parse position to show when assertion fails, - ) -- XXX the csv record's line number would be good - where - fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text - --- | Given a non-empty amount string (from CSV) to parse, along with a --- possibly non-empty currency symbol to prepend, --- parse as a hledger MixedAmount (as in journal format), or raise an error. --- The whole CSV record is provided for the error message. -parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount -parseAmount rules record currency s = - either mkerror mixedAmount $ -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - -- PARTIAL: - runParser (evalStateT (amountp <* eof) journalparsestate) "" $ - currency <> simplifySign s - where - journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} - mkerror e = error' . T.unpack $ T.unlines - ["error: could not parse \"" <> s <> "\" as an amount" - ,showRecord record - ,showRules rules record - -- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules) - ,"the parse error is: " <> T.pack (customErrorBundlePretty e) - ,"you may need to \ - \change your amount*, balance*, or currency* rules, \ - \or add or change your skip rule" - ] - --- | Show the values assigned to each journal field. -showRules rules record = T.unlines $ catMaybes - [ (("the "<>fld<>" rule is: ")<>) <$> - getEffectiveAssignment rules record fld | fld <- journalfieldnames ] - --- | Show a (approximate) recreation of the original CSV record. -showRecord :: CsvRecord -> Text -showRecord r = "CSV record: "<>T.intercalate "," (map (wrap "\"" "\"") r) - --- XXX unify these ^v - --- | Almost but not quite the same as parseAmount. --- Given a non-empty amount string (from CSV) to parse, along with a --- possibly non-empty currency symbol to prepend, --- parse as a hledger Amount (as in journal format), or raise an error. --- The CSV record and the field's numeric suffix are provided for the error message. -parseBalanceAmount :: CsvRules -> CsvRecord -> Text -> Int -> Text -> Amount -parseBalanceAmount rules record currency n s = - either (mkerror n s) id $ - runParser (evalStateT (amountp <* eof) journalparsestate) "" $ - currency <> simplifySign s - -- the csv record's line number would be good - where - journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} - mkerror n' s' e = error' . T.unpack $ T.unlines - ["error: could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount" - ,showRecord record - ,showRules rules record - -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency - ,"the parse error is: "<> T.pack (customErrorBundlePretty e) - ] - --- Read a valid decimal mark from the decimal-mark rule, if any. --- If the rule is present with an invalid argument, raise an error. -parseDecimalMark :: CsvRules -> Maybe DecimalMark -parseDecimalMark rules = do - s <- rules `csvRule` "decimal-mark" - case T.uncons s of - Just (c, rest) | T.null rest && isDecimalMark c -> return c - _ -> error' . T.unpack $ "decimal-mark's argument should be \".\" or \",\" (not \""<>s<>"\")" - --- | Make a balance assertion for the given amount, with the given parse --- position (to be shown in assertion failures), with the assertion type --- possibly set by a balance-type rule. --- The CSV rules and current record are also provided, to be shown in case --- balance-type's argument is bad (XXX refactor). -mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, SourcePos) -> BalanceAssertion -mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos} - where - assrt = - case getDirective "balance-type" rules of - Nothing -> nullassertion - Just "=" -> nullassertion - Just "==" -> nullassertion{batotal=True} - Just "=*" -> nullassertion{bainclusive=True} - Just "==*" -> nullassertion{batotal=True, bainclusive=True} - Just x -> error' . T.unpack $ T.unlines -- PARTIAL: - [ "balance-type \"" <> x <>"\" is invalid. Use =, ==, =* or ==*." - , showRecord record - , showRules rules record - ] - --- | Figure out the account name specified for posting N, if any. --- And whether it is the default unknown account (which may be --- improved later) or an explicitly set account (which may not). -getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, SourcePos) -> Int -> Maybe (AccountName, Bool) -getAccount rules record mamount mbalance n = - let - fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text - maccount = T.strip <$> fieldval ("account"<> T.pack (show n)) - in case maccount of - -- accountN is set to the empty string - no posting will be generated - Just "" -> Nothing - -- accountN is set (possibly to "expenses:unknown"! #1192) - mark it final - Just a -> - -- Check it and reject if invalid.. sometimes people try - -- to set an amount or comment along with the account name. - case parsewith (accountnamep >> eof) a of - Left e -> usageError $ errorBundlePretty e - Right _ -> Just (a, True) - -- accountN is unset - Nothing -> - case (mamount, mbalance) of - -- amountN is set, or implied by balanceN - set accountN to - -- the default unknown account ("expenses:unknown") and - -- allow it to be improved later - (Just _, _) -> Just (unknownExpenseAccount, False) - (_, Just _) -> Just (unknownExpenseAccount, False) - -- amountN is also unset - no posting will be generated - (Nothing, Nothing) -> Nothing - --- | Default account names to use when needed. -unknownExpenseAccount = "expenses:unknown" -unknownIncomeAccount = "income:unknown" - -type CsvAmountString = Text - --- | Canonicalise the sign in a CSV amount string. --- Such strings can have a minus sign, parentheses (equivalent to minus), --- or any two of these (which cancel out), --- or a plus sign (which is removed), --- or any sign by itself with no following number (which is removed). --- See hledger > CSV FORMAT > Tips > Setting amounts. --- --- These are supported (note, not every possibile combination): --- --- >>> simplifySign "1" --- "1" --- >>> simplifySign "+1" --- "1" --- >>> simplifySign "-1" --- "-1" --- >>> simplifySign "(1)" --- "-1" --- >>> simplifySign "--1" --- "1" --- >>> simplifySign "-(1)" --- "1" --- >>> simplifySign "-+1" --- "-1" --- >>> simplifySign "(-1)" --- "1" --- >>> simplifySign "((1))" --- "1" --- >>> simplifySign "-" --- "" --- >>> simplifySign "()" --- "" --- >>> simplifySign "+" --- "" -simplifySign :: CsvAmountString -> CsvAmountString -simplifySign amtstr - | Just (' ',t) <- T.uncons amtstr = simplifySign t - | Just (t,' ') <- T.unsnoc amtstr = simplifySign t - | Just ('(',t) <- T.uncons amtstr, Just (amt,')') <- T.unsnoc t = simplifySign $ negateStr amt - | Just ('-',b) <- T.uncons amtstr, Just ('(',t) <- T.uncons b, Just (amt,')') <- T.unsnoc t = simplifySign amt - | Just ('-',m) <- T.uncons amtstr, Just ('-',amt) <- T.uncons m = amt - | Just ('-',m) <- T.uncons amtstr, Just ('+',amt) <- T.uncons m = negateStr amt - | amtstr `elem` ["-","+","()"] = "" - | Just ('+',amt) <- T.uncons amtstr = simplifySign amt - | otherwise = amtstr - -negateStr :: Text -> Text -negateStr amtstr = case T.uncons amtstr of - Just ('-',s) -> s - _ -> T.cons '-' amtstr - ---- ** tests -_TESTS__________________________________________ = undefined - -tests_RulesReader = testGroup "RulesReader" [ - testGroup "parseCsvRules" [ - testCase "empty file" $ - parseCsvRules "unknown" "" @?= Right (mkrules defrules) - ] - ,testGroup "rulesp" [ - testCase "trailing comments" $ - parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right (mkrules $ defrules{rdirectives = [("skip","")]}) - - ,testCase "trailing blank lines" $ - parseWithState' defrules rulesp "skip\n\n \n" @?= (Right (mkrules $ defrules{rdirectives = [("skip","")]})) - - ,testCase "no final newline" $ - parseWithState' defrules rulesp "skip" @?= (Right (mkrules $ defrules{rdirectives=[("skip","")]})) - - ,testCase "assignment with empty value" $ - parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?= - (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None (toRegex' "foo")],cbAssignments=[("account2","foo")]}]})) - ] - ,testGroup "conditionalblockp" [ - testCase "space after conditional" $ -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - -- #1120 - parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= - (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]}) - - ], - - testGroup "csvfieldreferencep" [ - testCase "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1") - ,testCase "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date") - ,testCase "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"") - ] - - ,testGroup "matcherp" [ - - testCase "recordmatcherp" $ - parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "A A") - - ,testCase "recordmatcherp.starts-with-&" $ - parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A") - - ,testCase "fieldmatcherp.starts-with-%" $ - parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "description A A") - - ,testCase "fieldmatcherp" $ - parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A") - - ,testCase "fieldmatcherp.starts-with-&" $ - parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A") - - -- ,testCase "fieldmatcherp with operator" $ - -- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A") - - ] - - ,testGroup "getEffectiveAssignment" [ - let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]} - - in testCase "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") - - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]} - in testCase "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") - - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]} - in testCase "negated-conditional-false" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Nothing) - - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "b"] [("date","%csvdate")]]} - in testCase "negated-conditional-true" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") - - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} - in testCase "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate") - - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} - in testCase "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate") - - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]} - in testCase "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate") - - ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]} - in testCase "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate") - - ] - +{-# LANGUAGE LambdaCase #-} + +--- ** exports +module Hledger.Read.RulesReader ( + -- * Reader + reader, + -- * Misc. + readJournalFromCsv, + -- readRulesFile, + -- parseCsvRules, + -- validateCsvRules, + -- CsvRules, + dataFileFor, + rulesFileFor, + parseBalanceAssertionType, + -- * Tests + tests_RulesReader, +) +where + +--- ** imports +import Prelude hiding (Applicative(..)) +import Control.Applicative (Applicative(..)) +import Control.Monad (unless, when, void) +import Control.Monad.Except (ExceptT(..), liftEither, throwError) +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State.Strict (StateT, get, modify', evalStateT) +import Control.Monad.Trans.Class (lift) +import Data.Char (toLower, isDigit, isSpace, isAlphaNum, ord) +import Data.Bifunctor (first) +import Data.Functor ((<&>)) +import Data.List (elemIndex, foldl', mapAccumL, nub, sortOn) +import Data.List.Extra (groupOn) +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.MemoUgly (memo) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Data.Time ( Day, TimeZone, UTCTime, LocalTime, ZonedTime(ZonedTime), + defaultTimeLocale, getCurrentTimeZone, localDay, parseTimeM, utcToLocalTime, localTimeToUTC, zonedTimeToUTC) +import Safe (atMay, headMay, lastMay, readMay) +import System.FilePath ((), takeDirectory, takeExtension, stripExtension, takeFileName) +import qualified Data.Csv as Cassava +import qualified Data.Csv.Parser.Megaparsec as CassavaMegaparsec +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Foldable (asum, toList) +import Text.Megaparsec hiding (match, parse) +import Text.Megaparsec.Char (char, newline, string, digitChar) +import Text.Megaparsec.Custom (parseErrorAt) +import Text.Printf (printf) + +import Hledger.Data +import Hledger.Utils +import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep, commenttagsp ) +import Hledger.Read.CsvUtils +import System.Directory (doesFileExist, getHomeDirectory) +import Data.Either (fromRight) + +--- ** doctest setup +-- $setup +-- >>> :set -XOverloadedStrings + +--- ** reader +_READER__________________________________________ = undefined -- VSCode outline separator + + +reader :: MonadIO m => Reader m +reader = Reader + {rFormat = Rules + ,rExtensions = ["rules"] + ,rReadFn = parse + ,rParser = error' "sorry, rules files can't be included" -- PARTIAL: + } + +isFileName f = takeFileName f == f + +getDownloadDir = do + home <- getHomeDirectory + return $ home "Downloads" -- XXX + +-- | Parse and post-process a "Journal" from the given rules file path, or give an error. +-- A data file is inferred from the @source@ rule, otherwise from a similarly-named file +-- in the same directory. +-- The source rule can specify a glob pattern and supports ~ for home directory. +-- If it is a bare filename it will be relative to the defaut download directory +-- on this system. If is a relative file path it will be relative to the rules +-- file's directory. When a glob pattern matches multiple files, the alphabetically +-- last is used. (Eg in case of multiple numbered downloads, the highest-numbered +-- will be used.) +-- The provided text, or a --rules-file option, are ignored by this reader. +-- Balance assertions are not checked. +parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal +parse iopts f _ = do + rules <- readRulesFile $ dbg4 "reading rules file" f + -- XXX higher-than usual debug level for file reading to bypass excessive noise from elsewhere, normally 6 or 7 + mdatafile <- liftIO $ do + dldir <- getDownloadDir + let rulesdir = takeDirectory f + let msource = T.unpack <$> getDirective "source" rules + fs <- case msource of + Just src -> expandGlob dir (dbg4 "source" src) >>= sortByModTime <&> dbg4 ("matched files"<>desc<>", newest first") + where (dir,desc) = if isFileName src then (dldir," in download directory") else (rulesdir,"") + Nothing -> return [maybe err (dbg4 "inferred source") $ dataFileFor f] -- shouldn't fail, f has .rules extension + where err = error' $ "could not infer a data file for " <> f + return $ dbg4 "data file" $ headMay fs + case mdatafile of + Nothing -> return nulljournal -- data file specified by source rule was not found + Just dat -> do + exists <- liftIO $ doesFileExist dat + if not (dat=="-" || exists) + then return nulljournal -- data file inferred from rules file name was not found + else do + t <- liftIO $ readFileOrStdinPortably dat + readJournalFromCsv (Just $ Left rules) dat t Nothing + -- apply any command line account aliases. Can fail with a bad replacement pattern. + >>= liftEither . journalApplyAliases (aliasesFromOpts iopts) + -- journalFinalise assumes the journal's items are + -- reversed, as produced by JournalReader's parser. + -- But here they are already properly ordered. So we'd + -- better preemptively reverse them once more. XXX inefficient + . journalReverse + >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f "" + +--- ** reading rules files +--- *** rules utilities +_RULES_READING__________________________________________ = undefined + +-- | Given a rules file path, what would be the corresponding data file ? +-- (Remove a .rules extension.) +dataFileFor :: FilePath -> Maybe FilePath +dataFileFor = stripExtension "rules" + +-- | Given a csv file path, what would be the corresponding rules file ? +-- (Add a .rules extension.) +rulesFileFor :: FilePath -> FilePath +rulesFileFor = (++ ".rules") + +-- | An exception-throwing IO action that reads and validates +-- the specified CSV rules file (which may include other rules files). +readRulesFile :: FilePath -> ExceptT String IO CsvRules +readRulesFile f = + liftIO (do + dbg6IO "using conversion rules file" f + readFilePortably f >>= expandIncludes (takeDirectory f) + ) >>= either throwError return . parseAndValidateCsvRules f + +-- | Inline all files referenced by include directives in this hledger CSV rules text, recursively. +-- Included file paths may be relative to the directory of the provided file path. +-- This is done as a pre-parse step to simplify the CSV rules parser. +expandIncludes :: FilePath -> Text -> IO Text +expandIncludes dir0 content = mapM (expandLine dir0) (T.lines content) <&> T.unlines + where + expandLine dir1 line = + case line of + (T.stripPrefix "include " -> Just f) -> expandIncludes dir2 =<< T.readFile f' + where + f' = dir1 T.unpack (T.dropWhile isSpace f) + dir2 = takeDirectory f' + _ -> return line + +-- defaultRulesText :: FilePath -> Text +-- defaultRulesText _csvfile = T.pack $ unlines +-- ["# hledger csv conversion rules" -- for " ++ csvFileFor (takeFileName csvfile) +-- ,"# cf http://hledger.org/hledger.html#csv" +-- ,"" +-- ,"account1 assets:bank:checking" +-- ,"" +-- ,"fields date, description, amount1" +-- ,"" +-- ,"#skip 1" +-- ,"#newest-first" +-- ,"" +-- ,"#date-format %-d/%-m/%Y" +-- ,"#date-format %-m/%-d/%Y" +-- ,"#date-format %Y-%h-%d" +-- ,"" +-- ,"#currency $" +-- ,"" +-- ,"if ITUNES" +-- ," account2 expenses:entertainment" +-- ,"" +-- ,"if (TO|FROM) SAVINGS" +-- ," account2 assets:bank:savings\n" +-- ] + +-- | An error-throwing IO action that parses this text as CSV conversion rules +-- and runs some extra validation checks. The file path is used in error messages. +parseAndValidateCsvRules :: FilePath -> T.Text -> Either String CsvRules +parseAndValidateCsvRules rulesfile s = + case parseCsvRules rulesfile s of + Left err -> Left $ customErrorBundlePretty err + Right rules -> first makeFancyParseError $ validateCsvRules rules + where + makeFancyParseError :: String -> String + makeFancyParseError errorString = + parseErrorPretty (FancyError 0 (S.singleton $ ErrorFail errorString) :: ParseError Text String) + +instance ShowErrorComponent String where + showErrorComponent = id + +-- | Parse this text as CSV conversion rules. The file path is for error messages. +parseCsvRules :: FilePath -> T.Text -> Either (ParseErrorBundle T.Text HledgerParseErrorData) CsvRules +-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s +parseCsvRules = runParser (evalStateT rulesp defrules) + +-- | Return the validated rules, or an error. +validateCsvRules :: CsvRules -> Either String CsvRules +validateCsvRules rules = do + unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1" + Right rules + where + isAssigned f = isJust $ hledgerField rules [] f + +--- *** rules types +_RULES_TYPES__________________________________________ = undefined + +-- | A set of data definitions and account-matching patterns sufficient to +-- convert a particular CSV data file into meaningful journal transactions. +data CsvRules' a = CsvRules' { + rdirectives :: [(DirectiveName,Text)], + -- ^ top-level rules, as (keyword, value) pairs + rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)], + -- ^ csv field names and their column number, if declared by a fields list + rassignments :: [(HledgerFieldName, FieldTemplate)], + -- ^ top-level assignments to hledger fields, as (field name, value template) pairs + rconditionalblocks :: [ConditionalBlock], + -- ^ conditional blocks, which containing additional assignments/rules to apply to matched csv records + rblocksassigning :: a -- (String -> [ConditionalBlock]) + -- ^ all conditional blocks which can potentially assign field with a given name (memoized) +} + +-- | Type used by parsers. Directives, assignments and conditional blocks +-- are in the reverse order compared to what is in the file and rblocksassigning is non-functional, +-- could not be used for processing CSV records yet +type CsvRulesParsed = CsvRules' () + +-- | Type used after parsing is done. Directives, assignments and conditional blocks +-- are in the same order as they were in the input file and rblocksassigning is functional. +-- Ready to be used for CSV record processing +type CsvRules = CsvRules' (Text -> [ConditionalBlock]) -- XXX simplify + +instance Eq CsvRules where + r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) == + (rdirectives r2, rcsvfieldindexes r2, rassignments r2) + +-- Custom Show instance used for debug output: omit the rblocksassigning field, which isn't showable. +instance Show CsvRules where + show r = "CsvRules { rdirectives = " ++ show (rdirectives r) ++ + ", rcsvfieldindexes = " ++ show (rcsvfieldindexes r) ++ + ", rassignments = " ++ show (rassignments r) ++ + ", rconditionalblocks = " ++ show (rconditionalblocks r) ++ + " }" + +type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a + +-- | The keyword of a CSV rule - "fields", "skip", "if", etc. +type DirectiveName = Text + +-- | CSV field name. +type CsvFieldName = Text + +-- | 1-based CSV column number. +type CsvFieldIndex = Int + +-- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1. +type CsvFieldReference = Text + +-- | One of the standard hledger fields or pseudo-fields that can be assigned to. +-- Eg date, account1, amount, amount1-in, date-format. +type HledgerFieldName = Text + +-- | A text value to be assigned to a hledger field, possibly +-- containing csv field references to be interpolated. +type FieldTemplate = Text + +-- | A reference to a regular expression match group. Eg \1. +type MatchGroupReference = Text + +-- | A strptime date parsing pattern, as supported by Data.Time.Format. +type DateFormat = Text + +-- | A prefix for a matcher test, either & or none (implicit or). +data MatcherPrefix = And | Not | None + deriving (Show, Eq) + +-- | A single test for matching a CSV record, in one way or another. +data Matcher = + RecordMatcher MatcherPrefix Regexp -- ^ match if this regexp matches the overall CSV record + | FieldMatcher MatcherPrefix CsvFieldReference Regexp -- ^ match if this regexp matches the referenced CSV field's value + deriving (Show, Eq) + +-- | A conditional block: a set of CSV record matchers, and a sequence +-- of rules which will be enabled only if one or more of the matchers +-- succeeds. +-- +-- Three types of rule are allowed inside conditional blocks: field +-- assignments, skip, end. (A skip or end rule is stored as if it was +-- a field assignment, and executed in validateCsv. XXX) +data ConditionalBlock = CB { + cbMatchers :: [Matcher] + ,cbAssignments :: [(HledgerFieldName, FieldTemplate)] + } deriving (Show, Eq) + +defrules :: CsvRulesParsed +defrules = CsvRules' { + rdirectives=[], + rcsvfieldindexes=[], + rassignments=[], + rconditionalblocks=[], + rblocksassigning = () + } + +-- | Create CsvRules from the content parsed out of the rules file +mkrules :: CsvRulesParsed -> CsvRules +mkrules rules = + let conditionalblocks = reverse $ rconditionalblocks rules + maybeMemo = if length conditionalblocks >= 15 then memo else id + in + CsvRules' { + rdirectives=reverse $ rdirectives rules, + rcsvfieldindexes=rcsvfieldindexes rules, + rassignments=reverse $ rassignments rules, + rconditionalblocks=conditionalblocks, + rblocksassigning = maybeMemo (\f -> filter (any ((==f).fst) . cbAssignments) conditionalblocks) + } + +--- *** rules parsers +_RULES_PARSING__________________________________________ = undefined + +{- +Grammar for the CSV conversion rules, more or less: + +RULES: RULE* + +RULE: ( SOURCE | FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | TIMEZONE | NEWEST-FIRST | INTRA-DAY-REVERSED | DATE-FORMAT | DECIMAL-MARK | COMMENT | BLANK ) NEWLINE + +SOURCE: source SPACE FILEPATH + +FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )* + +FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME + +QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ " + +BARE-FIELD-NAME: any CHAR except space, tab, #, ; + +FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE + +JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD + +JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency + +ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? ) + +FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs and REGEX-MATCHGROUP-REFERENCEs) + +CSV-FIELD-REFERENCE: % CSV-FIELD + +REGEX-MATCHGROUP-REFERENCE: \ DIGIT+ + +CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field) + +FIELD-NUMBER: DIGIT+ + +CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK + +FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS + +MATCHOP: ~ + +PATTERNS: ( NEWLINE REGEXP )* REGEXP + +INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+ + +REGEXP: ( NONSPACE CHAR* ) SPACE? + +VALUE: SPACE? ( CHAR* ) SPACE? + +COMMENT: SPACE? COMMENT-CHAR VALUE + +COMMENT-CHAR: # | ; | * + +NONSPACE: any CHAR not a SPACE-CHAR + +BLANK: SPACE? + +SPACE: SPACE-CHAR+ + +SPACE-CHAR: space | tab + +CHAR: any character except newline + +DIGIT: 0-9 + +-} + +addDirective :: (DirectiveName, Text) -> CsvRulesParsed -> CsvRulesParsed +addDirective d r = r{rdirectives=d:rdirectives r} + +addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed +addAssignment a r = r{rassignments=a:rassignments r} + +setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed +setIndexesAndAssignmentsFromList fs = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs + where + setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed + setCsvFieldIndexesFromList fs' r = r{rcsvfieldindexes=zip fs' [1..]} + + addAssignmentsFromList :: [CsvFieldName] -> CsvRulesParsed -> CsvRulesParsed + addAssignmentsFromList fs' r = foldl' maybeAddAssignment r journalfieldnames + where + maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs') rules + where + addAssignmentFromIndex i = addAssignment (f, T.pack $ '%':show (i+1)) + +addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed +addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r} + +addConditionalBlocks :: [ConditionalBlock] -> CsvRulesParsed -> CsvRulesParsed +addConditionalBlocks bs r = r{rconditionalblocks=bs++rconditionalblocks r} + +rulesp :: CsvRulesParser CsvRules +rulesp = do + _ <- many $ choice + [blankorcommentlinep "blank or comment line" + ,(directivep >>= modify' . addDirective) "directive" + ,(fieldnamelistp >>= modify' . setIndexesAndAssignmentsFromList) "field name list" + ,(fieldassignmentp >>= modify' . addAssignment) "field assignment" + -- conditionalblockp backtracks because it shares "if" prefix with conditionaltablep. + ,try (conditionalblockp >>= modify' . addConditionalBlock) "conditional block" + -- 'reverse' is there to ensure that conditions are added in the order they listed in the file + ,(conditionaltablep >>= modify' . addConditionalBlocks . reverse) "conditional table" + ] + eof + mkrules <$> get + +blankorcommentlinep :: CsvRulesParser () +blankorcommentlinep = lift (dbgparse 8 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep] + +blanklinep :: CsvRulesParser () +blanklinep = lift skipNonNewlineSpaces >> newline >> return () "blank line" + +commentlinep :: CsvRulesParser () +commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> return () "comment line" + +commentcharp :: CsvRulesParser Char +commentcharp = oneOf (";#*" :: [Char]) + +directivep :: CsvRulesParser (DirectiveName, Text) +directivep = (do + lift $ dbgparse 8 "trying directive" + d <- choiceInState $ map (lift . string) directives + v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp) + <|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "") + return (d, v) + ) "directive" + +directives :: [Text] +directives = + ["source" + ,"date-format" + ,"decimal-mark" + ,"separator" + -- ,"default-account" + -- ,"default-currency" + ,"skip" + ,"timezone" + ,"newest-first" + ,"intra-day-reversed" + , "balance-type" + ] + +directivevalp :: CsvRulesParser Text +directivevalp = T.pack <$> anySingle `manyTill` lift eolof + +fieldnamelistp :: CsvRulesParser [CsvFieldName] +fieldnamelistp = (do + lift $ dbgparse 8 "trying fieldnamelist" + string "fields" + optional $ char ':' + lift skipNonNewlineSpaces1 + let separator = lift skipNonNewlineSpaces >> char ',' >> lift skipNonNewlineSpaces + f <- fromMaybe "" <$> optional fieldnamep + fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep) + lift restofline + return . map T.toLower $ f:fs + ) "field name list" + +fieldnamep :: CsvRulesParser Text +fieldnamep = quotedfieldnamep <|> barefieldnamep + +quotedfieldnamep :: CsvRulesParser Text +quotedfieldnamep = + char '"' *> takeWhile1P Nothing (`notElem` ("\"\n:;#~" :: [Char])) <* char '"' + +barefieldnamep :: CsvRulesParser Text +barefieldnamep = takeWhile1P Nothing (`notElem` (" \t\n,;#~" :: [Char])) + +fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate) +fieldassignmentp = do + lift $ dbgparse 8 "trying fieldassignmentp" + f <- journalfieldnamep + v <- choiceInState [ assignmentseparatorp >> fieldvalp + , lift eolof >> return "" + ] + return (f,v) + "field assignment" + +journalfieldnamep :: CsvRulesParser Text +journalfieldnamep = do + lift (dbgparse 8 "trying journalfieldnamep") + choiceInState $ map (lift . string) journalfieldnames + +maxpostings = 99 + +-- Transaction fields and pseudo fields for CSV conversion. +-- Names must precede any other name they contain, for the parser +-- (amount-in before amount; date2 before date). TODO: fix +journalfieldnames = + concat [[ "account" <> i + ,"amount" <> i <> "-in" + ,"amount" <> i <> "-out" + ,"amount" <> i + ,"balance" <> i + ,"comment" <> i + ,"currency" <> i + ] | x <- [maxpostings, (maxpostings-1)..1], let i = T.pack $ show x] + ++ + ["amount-in" + ,"amount-out" + ,"amount" + ,"balance" + ,"code" + ,"comment" + ,"currency" + ,"date2" + ,"date" + ,"description" + ,"status" + ,"skip" -- skip and end are not really fields, but we list it here to allow conditional rules that skip records + ,"end" + ] + +assignmentseparatorp :: CsvRulesParser () +assignmentseparatorp = do + lift $ dbgparse 8 "trying assignmentseparatorp" + _ <- choiceInState [ lift skipNonNewlineSpaces >> char ':' >> lift skipNonNewlineSpaces + , lift skipNonNewlineSpaces1 + ] + return () + +fieldvalp :: CsvRulesParser Text +fieldvalp = do + lift $ dbgparse 8 "trying fieldvalp" + T.pack <$> anySingle `manyTill` lift eolof + +-- A conditional block: one or more matchers, one per line, followed by one or more indented rules. +conditionalblockp :: CsvRulesParser ConditionalBlock +conditionalblockp = do + lift $ dbgparse 8 "trying conditionalblockp" + -- "if\nMATCHER" or "if \nMATCHER" or "if MATCHER" + start <- getOffset + string "if" >> ( (newline >> return Nothing) + <|> (lift skipNonNewlineSpaces1 >> optional newline)) + ms <- some matcherp + as <- catMaybes <$> + many (lift skipNonNewlineSpaces1 >> + choice [ lift eolof >> return Nothing + , fmap Just fieldassignmentp + ]) + when (null as) $ + customFailure $ parseErrorAt start $ "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)" + return $ CB{cbMatchers=ms, cbAssignments=as} + "conditional block" + +-- A conditional table: "if" followed by separator, followed by some field names, +-- followed by many lines, each of which is either: +-- a comment line, or ... +-- one matcher, followed by field assignments (as many as there were fields in the header) +conditionaltablep :: CsvRulesParser [ConditionalBlock] +conditionaltablep = do + lift $ dbgparse 8 "trying conditionaltablep" + start <- getOffset + string "if" + sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c)) + fields <- journalfieldnamep `sepBy1` (char sep) + newline + body <- catMaybes <$> (flip manyTill (lift eolof) $ + choice [ commentlinep >> return Nothing + , fmap Just $ bodylinep sep fields + ]) + when (null body) $ + customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward" + return $ flip map body $ \(m,vs) -> + CB{cbMatchers=[m], cbAssignments=zip fields vs} + "conditional table" + where + bodylinep :: Char -> [Text] -> CsvRulesParser (Matcher,[FieldTemplate]) + bodylinep sep fields = do + off <- getOffset + m <- matcherp' $ void $ char sep + vs <- T.split (==sep) . T.pack <$> lift restofline + if (length vs /= length fields) + then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String) + else return (m,vs) + + +-- A single matcher, on one line. +matcherp' :: CsvRulesParser () -> CsvRulesParser Matcher +matcherp' end = try (fieldmatcherp end) <|> recordmatcherp end + +matcherp :: CsvRulesParser Matcher +matcherp = matcherp' (lift eolof) + +-- A single whole-record matcher. +-- A pattern on the whole line, not beginning with a csv field reference. +recordmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher +recordmatcherp end = do + lift $ dbgparse 8 "trying recordmatcherp" + -- pos <- currentPos + -- _ <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline) + p <- matcherprefixp + r <- regexp end + return $ RecordMatcher p r + -- when (null ps) $ + -- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)" + "record matcher" + +-- | A single matcher for a specific field. A csv field reference +-- (like %date or %1), and a pattern on the rest of the line, +-- optionally space-separated. Eg: +-- %description chez jacques +fieldmatcherp :: CsvRulesParser () -> CsvRulesParser Matcher +fieldmatcherp end = do + lift $ dbgparse 8 "trying fieldmatcher" + -- An optional fieldname (default: "all") + -- f <- fromMaybe "all" `fmap` (optional $ do + -- f' <- fieldnamep + -- lift skipNonNewlineSpaces + -- return f') + p <- matcherprefixp + f <- csvfieldreferencep <* lift skipNonNewlineSpaces + -- optional operator.. just ~ (case insensitive infix regex) for now + -- _op <- fromMaybe "~" <$> optional matchoperatorp + lift skipNonNewlineSpaces + r <- regexp end + return $ FieldMatcher p f r + "field matcher" + +matcherprefixp :: CsvRulesParser MatcherPrefix +matcherprefixp = do + lift $ dbgparse 8 "trying matcherprefixp" + (char '&' >> lift skipNonNewlineSpaces >> return And) <|> (char '!' >> lift skipNonNewlineSpaces >> return Not) <|> return None + +csvfieldreferencep :: CsvRulesParser CsvFieldReference +csvfieldreferencep = do + lift $ dbgparse 8 "trying csvfieldreferencep" + char '%' + T.cons '%' . textQuoteIfNeeded <$> fieldnamep + +-- A single regular expression +regexp :: CsvRulesParser () -> CsvRulesParser Regexp +regexp end = do + lift $ dbgparse 8 "trying regexp" + -- notFollowedBy matchoperatorp + c <- lift nonspace + cs <- anySingle `manyTill` end + case toRegexCI . T.strip . T.pack $ c:cs of + Left x -> Fail.fail $ "CSV parser: " ++ x + Right x -> return x + +-- -- A match operator, indicating the type of match to perform. +-- -- Currently just ~ meaning case insensitive infix regex match. +-- matchoperatorp :: CsvRulesParser String +-- matchoperatorp = fmap T.unpack $ choiceInState $ map string +-- ["~" +-- -- ,"!~" +-- -- ,"=" +-- -- ,"!=" +-- ] + +_RULES_LOOKUP__________________________________________ = undefined + +getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate +getDirective directivename = lookup directivename . rdirectives + +-- | Look up the value (template) of a csv rule by rule keyword. +csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate +csvRule rules = (`getDirective` rules) + +-- | Look up the value template assigned to a hledger field by field +-- list/field assignment rules, taking into account the current record and +-- conditional rules. +hledgerField :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe FieldTemplate +hledgerField rules record f = fmap + (either id (lastCBAssignmentTemplate f)) + (getEffectiveAssignment rules record f) + +-- | Look up the final value assigned to a hledger field, with csv field +-- references and regular expression match group references interpolated. +hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text +hledgerFieldValue rules record f = (flip fmap) (getEffectiveAssignment rules record f) + $ either (renderTemplate rules record) + $ \cb -> let + t = lastCBAssignmentTemplate f cb + r = rules { rconditionalblocks = [cb] } -- XXX handle rblocksassigning + in renderTemplate r record t + +lastCBAssignmentTemplate :: HledgerFieldName -> ConditionalBlock -> FieldTemplate +lastCBAssignmentTemplate f = snd . last . filter ((==f).fst) . cbAssignments + +maybeNegate :: MatcherPrefix -> Bool -> Bool +maybeNegate Not origbool = not origbool +maybeNegate _ origbool = origbool + +-- | Given the conversion rules, a CSV record and a hledger field name, find +-- either the last applicable `ConditionalBlock`, or the final value template +-- assigned to this field by a top-level field assignment, if any exist. +-- +-- Note conditional blocks' patterns are matched against an approximation of the +-- CSV record: all the field values, without enclosing quotes, comma-separated. +-- +getEffectiveAssignment + :: CsvRules + -> CsvRecord + -> HledgerFieldName + -> Maybe (Either FieldTemplate ConditionalBlock) +getEffectiveAssignment rules record f = lastMay assignments + where + -- all active assignments to field f, in order + assignments = dbg9 "csv assignments" $ toplevelassignments ++ conditionalassignments + -- all top level field assignments + toplevelassignments = map (Left . snd) $ filter ((==f).fst) $ rassignments rules + -- all conditional blocks assigning to field f and active for the current csv record + conditionalassignments = map Right + $ filter (any (==f) . map fst . cbAssignments) + $ filter (isBlockActive rules record) + $ (rblocksassigning rules) f + +-- does this conditional block match the current csv record ? +isBlockActive :: CsvRules -> CsvRecord -> ConditionalBlock -> Bool +isBlockActive rules record CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers + where + -- does this individual matcher match the current csv record ? + matcherMatches :: Matcher -> Bool + matcherMatches (RecordMatcher prefix pat) = maybeNegate prefix origbool + where + pat' = dbg7 "regex" pat + -- A synthetic whole CSV record to match against. Note, this can be + -- different from the original CSV data: + -- - any whitespace surrounding field values is preserved + -- - any quotes enclosing field values are removed + -- - and the field separator is always comma + -- which means that a field containing a comma will look like two fields. + wholecsvline = dbg7 "wholecsvline" $ T.intercalate "," record + origbool = regexMatchText pat' wholecsvline + matcherMatches (FieldMatcher prefix csvfieldref pat) = maybeNegate prefix origbool + where + -- the value of the referenced CSV field to match against. + csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref + origbool = regexMatchText pat csvfieldvalue + + -- | Group matchers into associative pairs based on prefix, e.g.: + -- A + -- & B + -- C + -- D + -- & E + -- => [[A, B], [C], [D, E]] + groupedMatchers :: [Matcher] -> [[Matcher]] + groupedMatchers [] = [] + groupedMatchers (x:xs) = (x:ys) : groupedMatchers zs + where + (ys, zs) = span (\y -> matcherPrefix y == And) xs + matcherPrefix :: Matcher -> MatcherPrefix + matcherPrefix (RecordMatcher prefix _) = prefix + matcherPrefix (FieldMatcher prefix _ _) = prefix + +-- | Render a field assignment's template, possibly interpolating referenced +-- CSV field values or match groups. Outer whitespace is removed from interpolated values. +renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> Text +renderTemplate rules record t = + maybe t mconcat $ parseMaybe + (many + ( literaltextp + <|> (matchrefp <&> replaceRegexGroupReference rules record) + <|> (fieldrefp <&> replaceCsvFieldReference rules record) + ) + ) + t + where + literaltextp :: SimpleTextParser Text + literaltextp = some (nonBackslashOrPercent <|> nonRefBackslash <|> nonRefPercent) <&> T.pack + where + nonBackslashOrPercent = noneOf ['\\', '%'] "character other than backslash or percent" + nonRefBackslash = try (char '\\' <* notFollowedBy digitChar) "backslash that does not begin a match group reference" + nonRefPercent = try (char '%' <* notFollowedBy (satisfy isFieldNameChar)) "percent that does not begin a field reference" + matchrefp = liftA2 T.cons (char '\\') (takeWhile1P (Just "matchref") isDigit) + fieldrefp = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) + isFieldNameChar c = isAlphaNum c || c == '_' || c == '-' + +-- | Replace something that looks like a Regex match group reference with the +-- resulting match group value after applying the Regex. +replaceRegexGroupReference :: CsvRules -> CsvRecord -> MatchGroupReference -> Text +replaceRegexGroupReference rules record s = case T.uncons s of + Just ('\\', group) -> fromMaybe "" $ regexMatchValue rules record group + _ -> s + +regexMatchValue :: CsvRules -> CsvRecord -> Text -> Maybe Text +regexMatchValue rules record sgroup = let + matchgroups = concatMap (getMatchGroups rules record) + $ concatMap cbMatchers + $ filter (isBlockActive rules record) + $ rconditionalblocks rules + -- ^ XXX adjusted to not use memoized field as caller might be sending a subset of rules with just one CB (hacky) + group = (read (T.unpack sgroup) :: Int) - 1 -- adjust to 0-indexing + in atMay matchgroups group + +getMatchGroups :: CsvRules -> CsvRecord -> Matcher -> [Text] +getMatchGroups _ record (RecordMatcher _ regex) = let + txt = T.intercalate "," record -- see caveats of wholecsvline, in `isBlockActive` + in regexMatchTextGroups regex txt +getMatchGroups rules record (FieldMatcher _ fieldref regex) = let + txt = replaceCsvFieldReference rules record fieldref + in regexMatchTextGroups regex txt + +-- | Replace something that looks like a reference to a csv field ("%date" or "%1) +-- with that field's value. If it doesn't look like a field reference, or if we +-- can't find such a field, replace it with the empty string. +replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> Text +replaceCsvFieldReference rules record s = case T.uncons s of + Just ('%', fieldname) -> fromMaybe "" $ csvFieldValue rules record fieldname + _ -> s + +-- | Get the (whitespace-stripped) value of a CSV field, identified by its name or +-- column number, ("date" or "1"), from the given CSV record, if such a field exists. +csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text +csvFieldValue rules record fieldname = do + fieldindex <- + if T.all isDigit fieldname + then readMay $ T.unpack fieldname + else lookup (T.toLower fieldname) $ rcsvfieldindexes rules + T.strip <$> atMay record (fieldindex-1) + +_CSV_READING__________________________________________ = undefined + +-- | Read a Journal from the given CSV data (and filename, used for error +-- messages), or return an error. Proceed as follows: +-- +-- 1. Conversion rules are provided, or they are parsed from the specified +-- rules file, or from the default rules file for the CSV data file. +-- If rules parsing fails, or the required rules file does not exist, throw an error. +-- +-- 2. Parse the CSV data using the rules, or throw an error. +-- +-- 3. Convert the CSV records to hledger transactions using the rules. +-- +-- 4. Return the transactions as a Journal. +-- +readJournalFromCsv :: Maybe (Either CsvRules FilePath) -> FilePath -> Text -> Maybe SepFormat -> ExceptT String IO Journal +readJournalFromCsv Nothing "-" _ _ = throwError "please use --rules-file when reading CSV from stdin" +readJournalFromCsv merulesfile csvfile csvtext sep = do + -- for now, correctness is the priority here, efficiency not so much + + rules <- case merulesfile of + Just (Left rs) -> return rs + Just (Right rulesfile) -> readRulesFile rulesfile + Nothing -> readRulesFile $ rulesFileFor csvfile + dbg6IO "csv rules" rules + + -- convert the csv data to lines and remove all empty/blank lines + let csvlines1 = dbg9 "csvlines1" $ filter (not . T.null . T.strip) $ dbg9 "csvlines0" $ T.lines csvtext + + -- if there is a top-level skip rule, skip the specified number of non-empty lines + skiplines <- case getDirective "skip" rules of + Nothing -> return 0 + Just "" -> return 1 + Just s -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s + let csvlines2 = dbg9 "csvlines2" $ drop skiplines csvlines1 + + -- convert back to text and parse as csv records + let + csvtext1 = T.unlines csvlines2 + -- The separator in the rules file takes precedence over the extension or prefix + separator = case getDirective "separator" rules >>= parseSeparator of + Just c -> c + _ | ext == "ssv" -> ';' + _ | ext == "tsv" -> '\t' + _ -> + case sep of + Just Csv -> ',' + Just Ssv -> ';' + Just Tsv -> '\t' + Nothing -> ',' + where + ext = map toLower $ drop 1 $ takeExtension csvfile + -- parsec seemed to fail if you pass it "-" here -- TODO: try again with megaparsec + parsecfilename = if csvfile == "-" then "(stdin)" else csvfile + dbg6IO "using separator" separator + -- parse csv records + csvrecords0 <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvtext1 + -- remove any records skipped by conditional skip or end rules + let csvrecords1 = applyConditionalSkips rules csvrecords0 + -- and check the remaining records for any obvious problems + csvrecords <- liftEither $ dbg7 "validateCsv" <$> validateCsv csvrecords1 + dbg6IO "first 3 csv records" $ take 3 csvrecords + + -- XXX identify header lines some day ? + -- let (headerlines, datalines) = identifyHeaderLines csvrecords' + -- mfieldnames = lastMay headerlines + + tzout <- liftIO getCurrentTimeZone + mtzin <- case getDirective "timezone" rules of + Nothing -> return Nothing + Just s -> + maybe (throwError $ "could not parse time zone: " ++ T.unpack s) (return.Just) $ + parseTimeM False defaultTimeLocale "%Z" $ T.unpack s + let + -- convert CSV records to transactions, saving the CSV line numbers for error positions + txns = dbg7 "csv txns" $ snd $ mapAccumL + (\pos r -> + let + SourcePos name line col = pos + line' = (mkPos . (+1) . unPos) line + pos' = SourcePos name line' col + in + (pos', transactionFromCsvRecord timesarezoned mtzin tzout pos rules r) + ) + (initialPos parsecfilename) csvrecords + where + timesarezoned = + case csvRule rules "date-format" of + Just f | any (`T.isInfixOf` f) ["%Z","%z","%EZ","%Ez"] -> True + _ -> False + + -- Do our best to ensure transactions will be ordered chronologically, + -- from oldest to newest. This is done in several steps: + -- 1. Intra-day order: if there's an "intra-day-reversed" rule, + -- assume each day's CSV records were ordered in reverse of the overall date order, + -- so reverse each day's txns. + intradayreversed = dbg6 "intra-day-reversed" $ isJust $ getDirective "intra-day-reversed" rules + txns1 = dbg7 "txns1" $ + (if intradayreversed then concatMap reverse . groupOn tdate else id) txns + -- 2. Overall date order: now if there's a "newest-first" rule, + -- or if there's multiple dates and the first is more recent than the last, + -- assume CSV records were ordered newest dates first, + -- so reverse all txns. + newestfirst = dbg6 "newest-first" $ isJust $ getDirective "newest-first" rules + mdatalooksnewestfirst = dbg6 "mdatalooksnewestfirst" $ + case nub $ map tdate txns of + ds@(d:_) -> Just $ d > last ds + [] -> Nothing + txns2 = dbg7 "txns2" $ + (if newestfirst || mdatalooksnewestfirst == Just True then reverse else id) txns1 + -- 3. Disordered dates: in case the CSV records were ordered by chaos, + -- do a final sort by date. If it was only a few records out of order, + -- this will hopefully refine any good ordering done by steps 1 and 2. + txns3 = dbg7 "date-sorted csv txns" $ sortOn tdate txns2 + + return nulljournal{jtxns=txns3} + +-- | Parse special separator names TAB and SPACE, or return the first +-- character. Return Nothing on empty string +parseSeparator :: Text -> Maybe Char +parseSeparator = specials . T.toLower + where specials "space" = Just ' ' + specials "tab" = Just '\t' + specials xs = fst <$> T.uncons xs + +-- Call parseCassava on a file or stdin, converting the result to ExceptT. +parseCsv :: Char -> FilePath -> Text -> ExceptT String IO [CsvRecord] +parseCsv separator filePath csvtext = ExceptT $ + case filePath of + "-" -> parseCassava separator "(stdin)" <$> T.getContents + _ -> return $ if T.null csvtext then Right mempty else parseCassava separator filePath csvtext + +-- Parse text into CSV records, using Cassava and the given field separator. +parseCassava :: Char -> FilePath -> Text -> Either String [CsvRecord] +parseCassava separator path content = + -- XXX we now remove all blank lines before parsing; will Cassava will still produce [""] records ? + -- filter (/=[""]) + either (Left . errorBundlePretty) (Right . parseResultToCsv) <$> + CassavaMegaparsec.decodeWith decodeOptions Cassava.NoHeader path $ + BL.fromStrict $ T.encodeUtf8 content + where + decodeOptions = Cassava.defaultDecodeOptions { + Cassava.decDelimiter = fromIntegral (ord separator) + } + parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> [CsvRecord] + parseResultToCsv = toListList . unpackFields + where + toListList = toList . fmap toList + unpackFields = (fmap . fmap) T.decodeUtf8 + +-- | Scan for csv records where a conditional `skip` or `end` rule applies, +-- and apply that rule, removing one or more following records. +applyConditionalSkips :: CsvRules -> [CsvRecord] -> [CsvRecord] +applyConditionalSkips _ [] = [] +applyConditionalSkips rules (r:rest) = + case skipnum r of + Nothing -> r : applyConditionalSkips rules rest + Just cnt -> applyConditionalSkips rules $ drop (cnt-1) rest + where + skipnum r1 = + case (hledgerField rules r1 "end", hledgerField rules r1 "skip") of + (Nothing, Nothing) -> Nothing + (Just _, _) -> Just maxBound + (Nothing, Just "") -> Just 1 + (Nothing, Just x) -> Just (read $ T.unpack x) + +-- | Do some validation on the parsed CSV records: +-- check that they all have at least two fields. +validateCsv :: [CsvRecord] -> Either String [CsvRecord] +validateCsv [] = Right [] +validateCsv rs@(_first:_) = + case lessthan2 of + Just r -> Left $ printf "CSV record %s has less than two fields" (show r) + Nothing -> Right rs + where + lessthan2 = headMay $ filter ((<2).length) rs + +-- -- | The highest (0-based) field index referenced in the field +-- -- definitions, or -1 if no fields are defined. +-- maxFieldIndex :: CsvRules -> Int +-- maxFieldIndex r = maximumDef (-1) $ catMaybes [ +-- dateField r +-- ,statusField r +-- ,codeField r +-- ,amountField r +-- ,amountInField r +-- ,amountOutField r +-- ,currencyField r +-- ,accountField r +-- ,account2Field r +-- ,date2Field r +-- ] + +--- ** converting csv records to transactions + +transactionFromCsvRecord :: Bool -> Maybe TimeZone -> TimeZone -> SourcePos -> CsvRules -> CsvRecord -> Transaction +transactionFromCsvRecord timesarezoned mtzin tzout sourcepos rules record = t + where + ---------------------------------------------------------------------- + -- 1. Define some helpers: + + rule = csvRule rules :: DirectiveName -> Maybe FieldTemplate + -- ruleval = csvRuleValue rules record :: DirectiveName -> Maybe String + field = hledgerField rules record :: HledgerFieldName -> Maybe FieldTemplate + fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text + mdateformat = rule "date-format" + parsedate = parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mdateformat + mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines + ["error: could not parse \""<>datevalue<>"\" as a date using date format " + <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat' + ,showRecord record + ,"the "<>datefield<>" rule is: "<>(fromMaybe "required, but missing" $ field datefield) + ,"the date-format is: "<>fromMaybe "unspecified" mdateformat' + ,"you may need to " + <>"change your "<>datefield<>" rule, " + <>maybe "add a" (const "change your") mdateformat'<>" date-format rule, " + <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule" + ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y" + ] + where + mskip = rule "skip" + + ---------------------------------------------------------------------- + -- 2. Gather values needed for the transaction itself, by evaluating the + -- field assignment rules using the CSV record's data, and parsing a bit + -- more where needed (dates, status). + + date = fromMaybe "" $ fieldval "date" + -- PARTIAL: + date' = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date + mdate2 = fieldval "date2" + mdate2' = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) =<< mdate2 + status = + case fieldval "status" of + Nothing -> Unmarked + Just s -> either statuserror id $ runParser (statusp <* eof) "" s + where + statuserror err = error' . T.unpack $ T.unlines + ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)" + ,"the parse error is: "<>T.pack (customErrorBundlePretty err) + ] + code = maybe "" singleline' $ fieldval "code" + description = maybe "" singleline' $ fieldval "description" + comment = maybe "" unescapeNewlines $ fieldval "comment" + ttags = fromRight [] $ rtp commenttagsp comment + precomment = maybe "" unescapeNewlines $ fieldval "precomment" + + singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines + unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n" + + ---------------------------------------------------------------------- + -- 3. Generate the postings for which an account has been assigned + -- (possibly indirectly due to an amount or balance assignment) + + p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting + ps = [p | n <- [1..maxpostings] + ,let cmt = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n)) + ,let ptags = fromRight [] $ rtp commenttagsp cmt + ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency") + ,let mamount = getAmount rules record currency p1IsVirtual n + ,let mbalance = getBalance rules record currency n + ,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n] -- skips Nothings + ,let acct' | not isfinal && acct==unknownExpenseAccount && + fromMaybe False (mamount >>= isNegativeMixedAmount) = unknownIncomeAccount + | otherwise = acct + ,let p = nullposting{paccount = accountNameWithoutPostingType acct' + ,pamount = fromMaybe missingmixedamt mamount + ,ptransaction = Just t + ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance + ,pcomment = cmt + ,ptags = ptags + ,ptype = accountNamePostingType acct + } + ] + + ---------------------------------------------------------------------- + -- 4. Build the transaction (and name it, so the postings can reference it). + + t = nulltransaction{ + tsourcepos = (sourcepos, sourcepos) -- the CSV line number + ,tdate = date' + ,tdate2 = mdate2' + ,tstatus = status + ,tcode = code + ,tdescription = description + ,tcomment = comment + ,ttags = ttags + ,tprecedingcomment = precomment + ,tpostings = ps + } + +-- | Parse the date string using the specified date-format, or if unspecified +-- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading +-- zeroes optional). If a timezone is provided, we assume the DateFormat +-- produces a zoned time and we localise that to the given timezone. +parseDateWithCustomOrDefaultFormats :: Bool -> Maybe TimeZone -> TimeZone -> Maybe DateFormat -> Text -> Maybe Day +parseDateWithCustomOrDefaultFormats timesarezoned mtzin tzout mformat s = localdate <$> mutctime + -- this time code can probably be simpler, I'm just happy to get out alive + where + localdate :: UTCTime -> Day = + localDay . + dbg7 ("time in output timezone "++show tzout) . + utcToLocalTime tzout + mutctime :: Maybe UTCTime = asum $ map parseWithFormat formats + + parseWithFormat :: String -> Maybe UTCTime + parseWithFormat fmt = + if timesarezoned + then + dbg7 "zoned CSV time, expressed as UTC" $ + parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe UTCTime + else + -- parse as a local day and time; then if an input timezone is provided, + -- assume it's in that, otherwise assume it's in the output timezone; + -- then convert to UTC like the above + let + mlocaltime = + fmap (dbg7 "unzoned CSV time") $ + parseTimeM True defaultTimeLocale fmt $ T.unpack s :: Maybe LocalTime + localTimeAsZonedTime tz lt = ZonedTime lt tz + in + case mtzin of + Just tzin -> + (dbg7 ("unzoned CSV time, declared as "++show tzin++ ", expressed as UTC") . + localTimeToUTC tzin) + <$> mlocaltime + Nothing -> + (dbg7 ("unzoned CSV time, treated as "++show tzout++ ", expressed as UTC") . + zonedTimeToUTC . + localTimeAsZonedTime tzout) + <$> mlocaltime + + formats = map T.unpack $ maybe + ["%Y/%-m/%-d" + ,"%Y-%-m-%-d" + ,"%Y.%-m.%-d" + -- ,"%-m/%-d/%Y" + -- ,parseTimeM TruedefaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s) + -- ,parseTimeM TruedefaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s) + -- ,parseTimeM TruedefaultTimeLocale "%m/%e/%Y" ('0':s) + -- ,parseTimeM TruedefaultTimeLocale "%m-%e-%Y" ('0':s) + ] + (:[]) + mformat + +-- | Figure out the amount specified for posting N, if any. +-- A currency symbol to prepend to the amount, if any, is provided, +-- and whether posting 1 requires balancing or not. +-- This looks for a non-empty amount value assigned to "amountN", "amountN-in", or "amountN-out". +-- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out". +-- If more than one of these has a value, it looks for one that is non-zero. +-- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error. +getAmount :: CsvRules -> CsvRecord -> Text -> Bool -> Int -> Maybe MixedAmount +getAmount rules record currency p1IsVirtual n = + -- Warning! Many tricky corner cases here. + -- Keep synced with: + -- hledger_csv.m4.md -> CSV FORMAT -> "amount", "Setting amounts", + -- hledger/test/csv.test -> 13, 31-34 + let + unnumberedfieldnames = ["amount","amount-in","amount-out"] + + -- amount field names which can affect this posting + fieldnames = map (("amount"<> T.pack (show n))<>) ["","-in","-out"] + -- For posting 1, also recognise the old amount/amount-in/amount-out names. + -- For posting 2, the same but only if posting 1 needs balancing. + ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else [] + + -- assignments to any of these field names with non-empty values + assignments = [(f,a') | f <- fieldnames + , Just v <- [T.strip <$> hledgerFieldValue rules record f] + , not $ T.null v + -- XXX maybe ignore rule-generated values like "", "-", "$", "-$", "$-" ? cf CSV FORMAT -> "amount", "Setting amounts", + , let a = parseAmount rules record currency v + -- With amount/amount-in/amount-out, in posting 2, + -- flip the sign and convert to cost, as they did before 1.17 + , let a' = if f `elem` unnumberedfieldnames && n==2 then mixedAmountCost (maNegate a) else a + ] + + -- if any of the numbered field names are present, discard all the unnumbered ones + discardUnnumbered xs = if null numbered then xs else numbered + where + numbered = filter (T.any isDigit . fst) xs + + -- discard all zero amounts, unless all amounts are zero, in which case discard all but the first + discardExcessZeros xs = if null nonzeros then take 1 xs else nonzeros + where + nonzeros = filter (not . mixedAmountLooksZero . snd) xs + + -- for -out fields, flip the sign XXX unless it's already negative ? back compat issues / too confusing ? + negateIfOut f = if "-out" `T.isSuffixOf` f then maNegate else id + + in case discardExcessZeros $ discardUnnumbered assignments of + [] -> Nothing + [(f,a)] -> Just $ negateIfOut f a + fs -> error' . T.unpack . textChomp . T.unlines $ + ["in CSV rules:" + ,"While processing " <> showRecord record + ,"while calculating amount for posting " <> T.pack (show n) + ] ++ + ["rule \"" <> f <> " " <> + fromMaybe "" (hledgerField rules record f) <> + "\" assigned value \"" <> wbToText (showMixedAmountB defaultFmt a) <> "\"" -- XXX not sure this is showing all the right info + | (f,a) <- fs + ] ++ + ["" + ,"Multiple non-zero amounts were assigned for an amount field." + ,"Please ensure just one non-zero amount is assigned, perhaps with an if rule." + ,"See also: https://hledger.org/hledger.html#setting-amounts" + ,"(hledger manual -> CSV format -> Tips -> Setting amounts)" + ] +-- | Figure out the expected balance (assertion or assignment) specified for posting N, +-- if any (and its parse position). +getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, SourcePos) +getBalance rules record currency n = do + v <- (fieldval ("balance"<> T.pack (show n)) + -- for posting 1, also recognise the old field name + <|> if n==1 then fieldval "balance" else Nothing) + case v of + "" -> Nothing + s -> Just ( + parseBalanceAmount rules record currency n s + ,initialPos "" -- parse position to show when assertion fails, + ) -- XXX the csv record's line number would be good + where + fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text + +-- | Given a non-empty amount string (from CSV) to parse, along with a +-- possibly non-empty currency symbol to prepend, +-- parse as a hledger MixedAmount (as in journal format), or raise an error. +-- The whole CSV record is provided for the error message. +parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount +parseAmount rules record currency s = + either mkerror mixedAmount $ + runParser (evalStateT (amountp <* eof) journalparsestate) "" $ + currency <> simplifySign s + where + journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} + mkerror e = error' . T.unpack $ T.unlines + ["error: could not parse \"" <> s <> "\" as an amount" + ,showRecord record + ,showRules rules record + -- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules) + ,"the parse error is: " <> T.pack (customErrorBundlePretty e) + ,"you may need to \ + \change your amount*, balance*, or currency* rules, \ + \or add or change your skip rule" + ] + +-- | Show the values assigned to each journal field. +showRules rules record = T.unlines $ catMaybes + [ (("the "<>fld<>" rule is: ")<>) <$> + hledgerField rules record fld | fld <- journalfieldnames ] + +-- | Show a (approximate) recreation of the original CSV record. +showRecord :: CsvRecord -> Text +showRecord r = "CSV record: "<>T.intercalate "," (map (wrap "\"" "\"") r) + +-- XXX unify these ^v + +-- | Almost but not quite the same as parseAmount. +-- Given a non-empty amount string (from CSV) to parse, along with a +-- possibly non-empty currency symbol to prepend, +-- parse as a hledger Amount (as in journal format), or raise an error. +-- The CSV record and the field's numeric suffix are provided for the error message. +parseBalanceAmount :: CsvRules -> CsvRecord -> Text -> Int -> Text -> Amount +parseBalanceAmount rules record currency n s = + either (mkerror n s) id $ + runParser (evalStateT (amountp <* eof) journalparsestate) "" $ + currency <> simplifySign s + -- the csv record's line number would be good + where + journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} + mkerror n' s' e = error' . T.unpack $ T.unlines + ["error: could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount" + ,showRecord record + ,showRules rules record + -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency + ,"the parse error is: "<> T.pack (customErrorBundlePretty e) + ] + +-- Read a valid decimal mark from the decimal-mark rule, if any. +-- If the rule is present with an invalid argument, raise an error. +parseDecimalMark :: CsvRules -> Maybe DecimalMark +parseDecimalMark rules = do + s <- rules `csvRule` "decimal-mark" + case T.uncons s of + Just (c, rest) | T.null rest && isDecimalMark c -> return c + _ -> error' . T.unpack $ "decimal-mark's argument should be \".\" or \",\" (not \""<>s<>"\")" + +-- | Make a balance assertion for the given amount, with the given parse +-- position (to be shown in assertion failures), with the assertion type +-- possibly set by a balance-type rule. +-- The CSV rules and current record are also provided, to be shown in case +-- balance-type's argument is bad (XXX refactor). +mkBalanceAssertion :: CsvRules -> CsvRecord -> (Amount, SourcePos) -> BalanceAssertion +mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos} + where + assrt = + case getDirective "balance-type" rules of + Nothing -> nullassertion + Just x -> + case parseBalanceAssertionType $ T.unpack x of + Just (total, inclusive) -> nullassertion{batotal=total, bainclusive=inclusive} + Nothing -> error' . T.unpack $ T.unlines -- PARTIAL: + [ "balance-type \"" <> x <>"\" is invalid. Use =, ==, =* or ==*." + , showRecord record + , showRules rules record + ] + +-- | Detect from a balance assertion's syntax (=, ==, =*, ==*) +-- whether it is (a) total (multi-commodity) and (b) subaccount-inclusive. +-- Returns nothing if invalid syntax was provided. +parseBalanceAssertionType :: String -> Maybe (Bool, Bool) +parseBalanceAssertionType = \case + "=" -> Just (False, False) + "==" -> Just (True, False) + "=*" -> Just (False, True ) + "==*" -> Just (True, True ) + _ -> Nothing + +-- | Figure out the account name specified for posting N, if any. +-- And whether it is the default unknown account (which may be +-- improved later) or an explicitly set account (which may not). +getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, SourcePos) -> Int -> Maybe (AccountName, Bool) +getAccount rules record mamount mbalance n = + let + fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text + maccount = T.strip <$> fieldval ("account"<> T.pack (show n)) + in case maccount of + -- accountN is set to the empty string - no posting will be generated + Just "" -> Nothing + -- accountN is set (possibly to "expenses:unknown"! #1192) - mark it final + Just a -> + -- Check it and reject if invalid.. sometimes people try + -- to set an amount or comment along with the account name. + case parsewith (accountnamep >> eof) a of + Left e -> usageError $ errorBundlePretty e + Right _ -> Just (a, True) + -- accountN is unset + Nothing -> + case (mamount, mbalance) of + -- amountN is set, or implied by balanceN - set accountN to + -- the default unknown account ("expenses:unknown") and + -- allow it to be improved later + (Just _, _) -> Just (unknownExpenseAccount, False) + (_, Just _) -> Just (unknownExpenseAccount, False) + -- amountN is also unset - no posting will be generated + (Nothing, Nothing) -> Nothing + +-- | Default account names to use when needed. +unknownExpenseAccount = "expenses:unknown" +unknownIncomeAccount = "income:unknown" + +type CsvAmountString = Text + +-- | Canonicalise the sign in a CSV amount string. +-- Such strings can have a minus sign, parentheses (equivalent to minus), +-- or any two of these (which cancel out), +-- or a plus sign (which is removed), +-- or any sign by itself with no following number (which is removed). +-- See hledger > CSV FORMAT > Tips > Setting amounts. +-- +-- These are supported (note, not every possibile combination): +-- +-- >>> simplifySign "1" +-- "1" +-- >>> simplifySign "+1" +-- "1" +-- >>> simplifySign "-1" +-- "-1" +-- >>> simplifySign "(1)" +-- "-1" +-- >>> simplifySign "--1" +-- "1" +-- >>> simplifySign "-(1)" +-- "1" +-- >>> simplifySign "-+1" +-- "-1" +-- >>> simplifySign "(-1)" +-- "1" +-- >>> simplifySign "((1))" +-- "1" +-- >>> simplifySign "-" +-- "" +-- >>> simplifySign "()" +-- "" +-- >>> simplifySign "+" +-- "" +simplifySign :: CsvAmountString -> CsvAmountString +simplifySign amtstr + | Just (' ',t) <- T.uncons amtstr = simplifySign t + | Just (t,' ') <- T.unsnoc amtstr = simplifySign t + | Just ('(',t) <- T.uncons amtstr, Just (amt,')') <- T.unsnoc t = simplifySign $ negateStr amt + | Just ('-',b) <- T.uncons amtstr, Just ('(',t) <- T.uncons b, Just (amt,')') <- T.unsnoc t = simplifySign amt + | Just ('-',m) <- T.uncons amtstr, Just ('-',amt) <- T.uncons m = amt + | Just ('-',m) <- T.uncons amtstr, Just ('+',amt) <- T.uncons m = negateStr amt + | amtstr `elem` ["-","+","()"] = "" + | Just ('+',amt) <- T.uncons amtstr = simplifySign amt + | otherwise = amtstr + +negateStr :: Text -> Text +negateStr amtstr = case T.uncons amtstr of + Just ('-',s) -> s + _ -> T.cons '-' amtstr + +--- ** tests +_TESTS__________________________________________ = undefined + +tests_RulesReader = testGroup "RulesReader" [ + testGroup "parseCsvRules" [ + testCase "empty file" $ + parseCsvRules "unknown" "" @?= Right (mkrules defrules) + ] + ,testGroup "rulesp" [ + testCase "trailing comments" $ + parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right (mkrules $ defrules{rdirectives = [("skip","")]}) + + ,testCase "trailing blank lines" $ + parseWithState' defrules rulesp "skip\n\n \n" @?= (Right (mkrules $ defrules{rdirectives = [("skip","")]})) + + ,testCase "no final newline" $ + parseWithState' defrules rulesp "skip" @?= (Right (mkrules $ defrules{rdirectives=[("skip","")]})) + + ,testCase "assignment with empty value" $ + parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?= + (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None (toRegex' "foo")],cbAssignments=[("account2","foo")]}]})) + ] + ,testGroup "conditionalblockp" [ + testCase "space after conditional" $ + parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= + (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]}) + ], + + testGroup "csvfieldreferencep" [ + testCase "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1") + ,testCase "name" $ parseWithState' defrules csvfieldreferencep "%date" @?= (Right "%date") + ,testCase "quoted name" $ parseWithState' defrules csvfieldreferencep "%\"csv date\"" @?= (Right "%\"csv date\"") + ] + + ,testGroup "matcherp" [ + + testCase "recordmatcherp" $ + parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "A A") + + ,testCase "recordmatcherp.starts-with-&" $ + parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A") + + ,testCase "fieldmatcherp.starts-with-%" $ + parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "description A A") + + ,testCase "fieldmatcherp" $ + parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A") + + ,testCase "fieldmatcherp.starts-with-&" $ + parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A") + + -- ,testCase "fieldmatcherp with operator" $ + -- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A") + + ] + + ,testGroup "hledgerField" [ + let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]} + + in testCase "toplevel" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate") + + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]} + in testCase "conditional" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate") + + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]} + in testCase "negated-conditional-false" $ hledgerField rules ["a","b"] "date" @?= (Nothing) + + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher Not "%csvdate" $ toRegex' "b"] [("date","%csvdate")]]} + in testCase "negated-conditional-true" $ hledgerField rules ["a","b"] "date" @?= (Just "%csvdate") + + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} + in testCase "conditional-with-or-a" $ hledgerField rules ["a"] "date" @?= (Just "%csvdate") + + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]} + in testCase "conditional-with-or-b" $ hledgerField rules ["_", "b"] "date" @?= (Just "%csvdate") + + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]} + in testCase "conditional.with-and" $ hledgerField rules ["a", "b"] "date" @?= (Just "%csvdate") + + ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]} + in testCase "conditional.with-and-or" $ hledgerField rules ["_", "c"] "date" @?= (Just "%csvdate") + + ] + + -- testing match groups (#2158) + ,testGroup "hledgerFieldValue" $ + let rules = mkrules $ defrules + { rcsvfieldindexes=[ ("date",1), ("description",2) ] + , rassignments=[ ("account2","equity"), ("amount1","1") ] + -- ConditionalBlocks here are in reverse order: mkrules reverses the list + , rconditionalblocks=[ CB { cbMatchers=[FieldMatcher None "%description" (toRegex' "PREFIX (.*) - (.*)")] + , cbAssignments=[("account1","account:\\1:\\2")] } + , CB { cbMatchers=[FieldMatcher None "%description" (toRegex' "PREFIX (.*)")] + , cbAssignments=[("account1","account:\\1"), ("comment1","\\1")] } + ] + } + record = ["2019-02-01","PREFIX Text 1 - Text 2"] + in [ testCase "scoped match groups forwards" $ hledgerFieldValue rules record "account1" @?= (Just "account:Text 1:Text 2") + , testCase "scoped match groups backwards" $ hledgerFieldValue rules record "comment1" @?= (Just "Text 1 - Text 2") + ] ] diff --git a/Hledger/Read/TimeclockReader.hs b/Hledger/Read/TimeclockReader.hs --- a/Hledger/Read/TimeclockReader.hs +++ b/Hledger/Read/TimeclockReader.hs @@ -77,7 +77,7 @@ reader :: MonadIO m => Reader m reader = Reader - {rFormat = "timeclock" + {rFormat = Timeclock ,rExtensions = ["timeclock"] ,rReadFn = parse ,rParser = timeclockfilep diff --git a/Hledger/Read/TimedotReader.hs b/Hledger/Read/TimedotReader.hs --- a/Hledger/Read/TimedotReader.hs +++ b/Hledger/Read/TimedotReader.hs @@ -66,7 +66,7 @@ reader :: MonadIO m => Reader m reader = Reader - {rFormat = "timedot" + {rFormat = Timedot ,rExtensions = ["timedot"] ,rReadFn = parse ,rParser = timedotp diff --git a/Hledger/Reports/AccountTransactionsReport.hs b/Hledger/Reports/AccountTransactionsReport.hs --- a/Hledger/Reports/AccountTransactionsReport.hs +++ b/Hledger/Reports/AccountTransactionsReport.hs @@ -124,7 +124,7 @@ -- speed improvement by stripping them early. In some cases, such as in hledger-ui, we still -- want to keep prices around, so we can toggle between cost and no cost quickly. We can use -- the show_costs_ flag to be efficient when we can, and detailed when we have to. - (if show_costs_ ropts then id else journalMapPostingAmounts mixedAmountStripPrices) + (if show_costs_ ropts then id else journalMapPostingAmounts mixedAmountStripCosts) . traceOrLogAtWith 5 (("ts3:\n"++).pshowTransactions.jtxns) -- maybe convert these transactions to cost or value . journalApplyValuationFromOpts rspec diff --git a/Hledger/Reports/BudgetReport.hs b/Hledger/Reports/BudgetReport.hs --- a/Hledger/Reports/BudgetReport.hs +++ b/Hledger/Reports/BudgetReport.hs @@ -26,7 +26,7 @@ import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -import Data.List (find, partition, transpose, foldl', maximumBy) +import Data.List (find, partition, transpose, foldl', maximumBy, intercalate) import Data.List.Extra (nubSort) import Data.Maybe (fromMaybe, catMaybes, isJust) import Data.Map (Map) @@ -49,21 +49,40 @@ import Data.Ord (comparing) import Control.Monad ((>=>)) - +-- All MixedAmounts: type BudgetGoal = Change type BudgetTotal = Total type BudgetAverage = Average -- | A budget report tracks expected and actual changes per account and subperiod. +-- Each table cell has an actual change amount and/or a budget goal amount. type BudgetCell = (Maybe Change, Maybe BudgetGoal) +-- | A row in a budget report table - account name and data cells. type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell +-- | A full budget report table. type BudgetReport = PeriodicReport DisplayName BudgetCell +-- A BudgetCell's data values rendered for display - the actual change amount, +-- the budget goal amount if any, and the corresponding goal percentage if possible. type BudgetDisplayCell = (WideBuilder, Maybe (WideBuilder, Maybe WideBuilder)) +-- | A row of rendered budget data cells. type BudgetDisplayRow = [BudgetDisplayCell] -type BudgetShowMixed = MixedAmount -> [WideBuilder] -type BudgetPercBudget = Change -> BudgetGoal -> [Maybe Percentage] +-- | An amount render helper for the budget report. Renders each commodity separately. +type BudgetShowAmountsFn = MixedAmount -> [WideBuilder] +-- | A goal percentage calculating helper for the budget report. +type BudgetCalcPercentagesFn = Change -> BudgetGoal -> [Maybe Percentage] + +_brrShowDebug :: BudgetReportRow -> String +_brrShowDebug (PeriodicReportRow dname budgetpairs _tot _avg) = + unwords [ + T.unpack $ displayFull dname, + "", + intercalate " | " + [ maybe "-" showMixedAmount mactual <> " [" <> maybe "-" showMixedAmount mgoal <> "]" + | (mactual,mgoal) <- budgetpairs ] + ] + -- | Calculate per-account, per-period budget (balance change) goals -- from all periodic transactions, calculate actual balance changes -- from the regular transactions, and compare these to get a 'BudgetReport'. @@ -201,54 +220,62 @@ combineBudgetAndActual ropts j (PeriodicReport budgetperiods budgetrows (PeriodicReportRow _ budgettots budgetgrandtot budgetgrandavg)) (PeriodicReport actualperiods actualrows (PeriodicReportRow _ actualtots actualgrandtot actualgrandavg)) = - PeriodicReport periods sortedrows totalrow + PeriodicReport periods combinedrows totalrow where periods = nubSort . filter (/= nulldatespan) $ budgetperiods ++ actualperiods -- first, combine any corresponding budget goals with actual changes - rows1 = - [ PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal + actualsplusgoals = [ + -- dbg0With (("actualsplusgoals: "<>)._brrShowDebug) $ + PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal | PeriodicReportRow acct actualamts actualtot actualavg <- actualrows + , let mbudgetgoals = HM.lookup (displayFull acct) budgetGoalsByAcct :: Maybe ([BudgetGoal], BudgetTotal, BudgetAverage) , let budgetmamts = maybe (Nothing <$ periods) (map Just . first3) mbudgetgoals :: [Maybe BudgetGoal] , let mbudgettot = second3 <$> mbudgetgoals :: Maybe BudgetTotal , let mbudgetavg = third3 <$> mbudgetgoals :: Maybe BudgetAverage - , let acctBudgetByPeriod = Map.fromList [ (p,budgetamt) | (p, Just budgetamt) <- zip budgetperiods budgetmamts ] :: Map DateSpan BudgetGoal + , let acctGoalByPeriod = Map.fromList [ (p,budgetamt) | (p, Just budgetamt) <- zip budgetperiods budgetmamts ] :: Map DateSpan BudgetGoal , let acctActualByPeriod = Map.fromList [ (p,actualamt) | (p, Just actualamt) <- zip actualperiods (map Just actualamts) ] :: Map DateSpan Change - , let amtandgoals = [ (Map.lookup p acctActualByPeriod, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [BudgetCell] + , let amtandgoals = [ (Map.lookup p acctActualByPeriod, Map.lookup p acctGoalByPeriod) | p <- periods ] :: [BudgetCell] , let totamtandgoal = (Just actualtot, mbudgettot) , let avgamtandgoal = (Just actualavg, mbudgetavg) ] where budgetGoalsByAcct :: HashMap AccountName ([BudgetGoal], BudgetTotal, BudgetAverage) = HM.fromList [ (displayFull acct, (amts, tot, avg)) - | PeriodicReportRow acct amts tot avg <- budgetrows ] + | PeriodicReportRow acct amts tot avg <- + -- dbg0With (unlines.map (("budgetgoals: "<>).prrShowDebug)) $ + budgetrows + ] -- next, make rows for budget goals with no actual changes - rows2 = - [ PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal + othergoals = [ + -- dbg0With (("othergoals: "<>)._brrShowDebug) $ + PeriodicReportRow acct amtandgoals totamtandgoal avgamtandgoal | PeriodicReportRow acct budgetgoals budgettot budgetavg <- budgetrows - , displayFull acct `notElem` map prrFullName rows1 - , let acctBudgetByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal - , let amtandgoals = [ (Nothing, Map.lookup p acctBudgetByPeriod) | p <- periods ] :: [BudgetCell] - , let totamtandgoal = (Nothing, Just budgettot) - , let avgamtandgoal = (Nothing, Just budgetavg) + , displayFull acct `notElem` map prrFullName actualsplusgoals + , let acctGoalByPeriod = Map.fromList $ zip budgetperiods budgetgoals :: Map DateSpan BudgetGoal + , let amtandgoals = [ (Just 0, Map.lookup p acctGoalByPeriod) | p <- periods ] :: [BudgetCell] + , let totamtandgoal = (Just 0, Just budgettot) + , let avgamtandgoal = (Just 0, Just budgetavg) ] -- combine and re-sort rows -- TODO: add --sort-budget to sort by budget goal amount - sortedrows :: [BudgetReportRow] = sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows + combinedrows :: [BudgetReportRow] = + -- map (dbg0With (("combinedrows: "<>)._brrShowDebug)) $ + sortRowsLike (mbrsorted unbudgetedrows ++ mbrsorted rows') rows where (unbudgetedrows, rows') = partition ((==unbudgetedAccountName) . prrFullName) rows mbrsorted = map prrFullName . sortRows ropts j . map (fmap $ fromMaybe nullmixedamt . fst) - rows = rows1 ++ rows2 + rows = actualsplusgoals ++ othergoals totalrow = PeriodicReportRow () - [ (Map.lookup p totActualByPeriod, Map.lookup p totBudgetByPeriod) | p <- periods ] + [ (Map.lookup p totActualByPeriod, Map.lookup p totGoalByPeriod) | p <- periods ] ( Just actualgrandtot, budget budgetgrandtot ) ( Just actualgrandavg, budget budgetgrandavg ) where - totBudgetByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal + totGoalByPeriod = Map.fromList $ zip budgetperiods budgettots :: Map DateSpan BudgetTotal totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change budget b = if mixedAmountLooksZero b then Nothing else Just b @@ -272,27 +299,17 @@ -- | Build a 'Table' from a multi-column balance report. budgetReportAsTable :: ReportOpts -> BudgetReport -> Tab.Table Text Text WideBuilder -budgetReportAsTable - ReportOpts{..} - (PeriodicReport spans items tr) = - maybetransposetable $ - addtotalrow $ +budgetReportAsTable ReportOpts{..} (PeriodicReport spans items totrow) = + maybetransposetable $ + addtotalrow $ Tab.Table (Tab.Group Tab.NoLine $ map Tab.Header accts) (Tab.Group Tab.NoLine $ map Tab.Header colheadings) rows where - colheadings = ["Commodity" | layout_ == LayoutBare] - ++ map (reportPeriodName balanceaccum_ spans) spans - ++ [" Total" | row_total_] - ++ ["Average" | average_] - - -- FIXME. Have to check explicitly for which to render here, since - -- budgetReport sets accountlistmode to ALTree. Find a principled way to do - -- this. - renderacct row = case accountlistmode_ of - ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row - ALFlat -> accountNameDrop (drop_) $ prrFullName row + maybetransposetable + | transpose_ = \(Tab.Table rh ch vals) -> Tab.Table ch rh (transpose vals) + | otherwise = id addtotalrow | no_total_ = id @@ -300,154 +317,206 @@ ch = Tab.Header [] -- ignored in (flip (Tab.concatTables Tab.SingleLine) $ Tab.Table rh ch totalrows) - maybetranspose - | transpose_ = transpose - | otherwise = id - - maybetransposetable - | transpose_ = \(Tab.Table rh ch vals) -> Tab.Table ch rh (transpose vals) - | otherwise = id + colheadings = ["Commodity" | layout_ == LayoutBare] + ++ map (reportPeriodName balanceaccum_ spans) spans + ++ [" Total" | row_total_] + ++ ["Average" | average_] - (accts, rows, totalrows) = (accts', prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts)) + (accts, rows, totalrows) = + (accts' + ,maybecommcol itemscs $ showcells texts + ,maybecommcol totrowcs $ showtotrow totrowtexts) where - shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]] - shownitems = (fmap (\i -> fmap (\(cs, cvals) -> (renderacct i, cs, cvals)) . showrow $ rowToBudgetCells i) items) - (accts', itemscs, texts) = unzip3 $ concat shownitems - - showntr :: [[(WideBuilder, BudgetDisplayRow)]] - showntr = [showrow $ rowToBudgetCells tr] - (trcs, trtexts) = unzip $ concat showntr - trwidths - | transpose_ = drop (length texts) widths - | otherwise = widths - - padcells = maybetranspose . fmap (fmap (uncurry paddisplaycell) . zip widths) . maybetranspose - padtr = maybetranspose . fmap (fmap (uncurry paddisplaycell) . zip trwidths) . maybetranspose - - -- with --layout=bare, begin with a commodity column - prependcs cs + -- If --layout=bare, prepend a commodities column. + maybecommcol :: [WideBuilder] -> [[WideBuilder]] -> [[WideBuilder]] + maybecommcol cs | layout_ == LayoutBare = zipWith (:) cs | otherwise = id - rowToBudgetCells (PeriodicReportRow _ as rowtot rowavg) = as - ++ [rowtot | row_total_ && not (null as)] - ++ [rowavg | average_ && not (null as)] + showcells, showtotrow :: [[BudgetDisplayCell]] -> [[WideBuilder]] + (showcells, showtotrow) = + (maybetranspose . map (zipWith showBudgetDisplayCell widths) . maybetranspose + ,maybetranspose . map (zipWith showBudgetDisplayCell totrowwidths) . maybetranspose) + where + -- | Combine a BudgetDisplayCell's rendered values into a "[PERCENT of GOAL]" rendering, + -- respecting the given widths. + showBudgetDisplayCell :: (Int, Int, Int) -> BudgetDisplayCell -> WideBuilder + showBudgetDisplayCell (actualwidth, budgetwidth, percentwidth) (actual, mbudget) = + flip WideBuilder (actualwidth + totalbudgetwidth) $ + toPadded actual <> maybe emptycell showBudgetGoalAndPercentage mbudget - -- functions for displaying budget cells depending on `commodity-layout_` option - rowfuncs :: [CommoditySymbol] -> (BudgetShowMixed, BudgetPercBudget) - rowfuncs cs = case layout_ of - LayoutWide width -> - ( pure . showMixedAmountB oneLine{displayMaxWidth=width, displayColour=color_} - , \a -> pure . percentage a) - _ -> ( showMixedAmountLinesB noCost{displayCommodity=layout_/=LayoutBare, displayCommodityOrder=Just cs, displayMinWidth=Nothing, displayColour=color_} - , \a b -> fmap (percentage' a b) cs) + where + toPadded (WideBuilder b w) = (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b - showrow :: [BudgetCell] -> [(WideBuilder, BudgetDisplayRow)] - showrow row = - let cs = budgetCellsCommodities row - (showmixed, percbudget) = rowfuncs cs - in zip (fmap wbFromText cs) - . transpose - . fmap (showcell showmixed percbudget) - $ row + (totalpercentwidth, totalbudgetwidth) = + let totalpercentwidth' = if percentwidth == 0 then 0 else percentwidth + 5 + in ( totalpercentwidth' + , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth' + 3 + ) - budgetCellsCommodities = S.toList . foldl' S.union mempty . fmap budgetCellCommodities - budgetCellCommodities :: BudgetCell -> S.Set CommoditySymbol - budgetCellCommodities (am, bm) = f am `S.union` f bm - where f = maybe mempty maCommodities + emptycell :: TB.Builder + emptycell = TB.fromText $ T.replicate totalbudgetwidth " " - cellswidth :: [BudgetCell] -> [[(Int, Int, Int)]] - cellswidth row = - let cs = budgetCellsCommodities row - (showmixed, percbudget) = rowfuncs cs - disp = showcell showmixed percbudget - budgetpercwidth = wbWidth *** maybe 0 wbWidth - cellwidth (am, bm) = let (bw, pw) = maybe (0, 0) budgetpercwidth bm in (wbWidth am, bw, pw) - in fmap (fmap cellwidth . disp) row + showBudgetGoalAndPercentage :: (WideBuilder, Maybe WideBuilder) -> TB.Builder + showBudgetGoalAndPercentage (goal, perc) = + let perct = case perc of + Nothing -> T.replicate totalpercentwidth " " + Just pct -> T.replicate (percentwidth - wbWidth pct) " " <> wbToText pct <> "% of " + in TB.fromText $ " [" <> perct <> T.replicate (budgetwidth - wbWidth goal) " " <> wbToText goal <> "]" - -- build a list of widths for each column. In the case of transposed budget - -- reports, the total 'row' must be included in this list - widths = zip3 actualwidths budgetwidths percentwidths - where - actualwidths = map (maximum' . map first3 ) $ cols - budgetwidths = map (maximum' . map second3) $ cols - percentwidths = map (maximum' . map third3 ) $ cols - catcolumnwidths = foldl' (zipWith (++)) $ repeat [] - cols = maybetranspose $ catcolumnwidths $ map (cellswidth . rowToBudgetCells) items ++ [cellswidth $ rowToBudgetCells tr] + -- | Build a list of widths for each column. + -- When --transpose is used, the totals row must be included in this list. + widths :: [(Int, Int, Int)] + widths = zip3 actualwidths budgetwidths percentwidths + where + actualwidths = map (maximum' . map first3 ) $ cols + budgetwidths = map (maximum' . map second3) $ cols + percentwidths = map (maximum' . map third3 ) $ cols + catcolumnwidths = foldl' (zipWith (++)) $ repeat [] + cols = maybetranspose $ catcolumnwidths $ map (cellswidth . rowToBudgetCells) items ++ [cellswidth $ rowToBudgetCells totrow] - -- split a BudgetCell into BudgetDisplayCell's (one per commodity when applicable) - showcell :: BudgetShowMixed -> BudgetPercBudget -> BudgetCell -> BudgetDisplayRow - showcell showmixed percbudget (actual, mbudget) = zip (showmixed actual') full - where - actual' = fromMaybe nullmixedamt actual + cellswidth :: [BudgetCell] -> [[(Int, Int, Int)]] + cellswidth row = + let cs = budgetCellsCommodities row + (showmixed, percbudget) = mkBudgetDisplayFns cs + disp = showcell showmixed percbudget + budgetpercwidth = wbWidth *** maybe 0 wbWidth + cellwidth (am, bm) = let (bw, pw) = maybe (0, 0) budgetpercwidth bm in (wbWidth am, bw, pw) + in map (map cellwidth . disp) row - budgetAndPerc b = - zip (showmixed b) (fmap (wbFromText . T.pack . show . roundTo 0) <$> percbudget actual' b) + totrowwidths :: [(Int, Int, Int)] + totrowwidths + | transpose_ = drop (length texts) widths + | otherwise = widths - full - | Just b <- mbudget = Just <$> budgetAndPerc b - | otherwise = repeat Nothing + maybetranspose + | transpose_ = transpose + | otherwise = id - paddisplaycell :: (Int, Int, Int) -> BudgetDisplayCell -> WideBuilder - paddisplaycell (actualwidth, budgetwidth, percentwidth) (actual, mbudget) = full - where - toPadded (WideBuilder b w) = - (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b + (accts', itemscs, texts) = unzip3 $ concat shownitems + where + shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]] + shownitems = + map (\i -> + let + addacctcolumn = map (\(cs, cvals) -> (renderacct i, cs, cvals)) + isunbudgetedrow = displayFull (prrName i) == unbudgetedAccountName + in addacctcolumn $ showrow isunbudgetedrow $ rowToBudgetCells i) + items + where + -- FIXME. Have to check explicitly for which to render here, since + -- budgetReport sets accountlistmode to ALTree. Find a principled way to do + -- this. + renderacct row = case accountlistmode_ of + ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row + ALFlat -> accountNameDrop (drop_) $ prrFullName row - (totalpercentwidth, totalbudgetwidth) = - let totalpercentwidth' = if percentwidth == 0 then 0 else percentwidth + 5 - in ( totalpercentwidth' - , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth' + 3 - ) + (totrowcs, totrowtexts) = unzip $ concat showntotrow + where + showntotrow :: [[(WideBuilder, BudgetDisplayRow)]] + showntotrow = [showrow False $ rowToBudgetCells totrow] - -- | Display a padded budget string - budgetb (budget, perc) = - let perct = case perc of - Nothing -> T.replicate totalpercentwidth " " - Just pct -> T.replicate (percentwidth - wbWidth pct) " " <> wbToText pct <> "% of " - in TB.fromText $ " [" <> perct <> T.replicate (budgetwidth - wbWidth budget) " " <> wbToText budget <> "]" + -- | Get the data cells from a row or totals row, maybe adding + -- the row total and/or row average depending on options. + rowToBudgetCells :: PeriodicReportRow a BudgetCell -> [BudgetCell] + rowToBudgetCells (PeriodicReportRow _ as rowtot rowavg) = as + ++ [rowtot | row_total_ && not (null as)] + ++ [rowavg | average_ && not (null as)] - emptyBudget = TB.fromText $ T.replicate totalbudgetwidth " " + -- | Render a row's data cells as "BudgetDisplayCell"s, and a rendered list of commodity symbols. + -- Also requires a flag indicating whether this is the special row. + -- (The types make that hard to check here.) + showrow :: Bool -> [BudgetCell] -> [(WideBuilder, BudgetDisplayRow)] + showrow isunbudgetedrow cells = + let + cs = budgetCellsCommodities cells + -- #2071 If there are no commodities - because there are no actual or goal amounts - + -- the zipped list would be empty, causing this row not to be shown. + -- But rows like this sometimes need to be shown to preserve the account tree structure. + -- So, ensure 0 will be shown as actual amount(s). + -- Unfortunately this disables boring parent eliding, as if --no-elide had been used. + -- (Just turning on --no-elide higher up doesn't work right.) + -- Note, no goal amount will be shown for these rows, + -- whereas --no-elide is likely to show a goal amount aggregated from children. + cs1 = if null cs && not isunbudgetedrow then [""] else cs + (showmixed, percbudget) = mkBudgetDisplayFns cs1 + in + zip (map wbFromText cs1) $ + transpose $ + map (showcell showmixed percbudget) + cells - full = flip WideBuilder (actualwidth + totalbudgetwidth) $ - toPadded actual <> maybe emptyBudget budgetb mbudget + budgetCellsCommodities :: [BudgetCell] -> [CommoditySymbol] + budgetCellsCommodities = S.toList . foldl' S.union mempty . map budgetCellCommodities + where + budgetCellCommodities :: BudgetCell -> S.Set CommoditySymbol + budgetCellCommodities (am, bm) = f am `S.union` f bm + where f = maybe mempty maCommodities - -- | Calculate the percentage of actual change to budget goal to show, if any. - -- If valuing at cost, both amounts are converted to cost before comparing. - -- A percentage will not be shown if: - -- - actual or goal are not the same, single, commodity - -- - the goal is zero - percentage :: Change -> BudgetGoal -> Maybe Percentage - percentage actual budget = - case (costedAmounts actual, costedAmounts budget) of - ([a], [b]) | (acommodity a == acommodity b || amountLooksZero a) && not (amountLooksZero b) - -> Just $ 100 * aquantity a / aquantity b - _ -> -- trace (pshow $ (maybecost actual, maybecost budget)) -- debug missing percentage - Nothing - where - costedAmounts = case conversionop_ of - Just ToCost -> amounts . mixedAmountCost - _ -> amounts + -- | Render a "BudgetCell"'s amounts as "BudgetDisplayCell"s (one per commodity). + showcell :: BudgetShowAmountsFn -> BudgetCalcPercentagesFn -> BudgetCell -> BudgetDisplayRow + showcell showCommodityAmounts calcCommodityPercentages (mactual, mbudget) = + zip actualamts budgetinfos + where + actual = fromMaybe nullmixedamt mactual + actualamts = showCommodityAmounts actual + budgetinfos = + case mbudget of + Nothing -> repeat Nothing + Just goal -> map Just $ showGoalAmountsAndPercentages goal + where + showGoalAmountsAndPercentages :: MixedAmount -> [(WideBuilder, Maybe WideBuilder)] + showGoalAmountsAndPercentages goal = zip amts mpcts + where + amts = showCommodityAmounts goal + mpcts = map (showrounded <$>) $ calcCommodityPercentages actual goal + where showrounded = wbFromText . T.pack . show . roundTo 0 - -- | Calculate the percentage of actual change to budget goal for a particular commodity - percentage' :: Change -> BudgetGoal -> CommoditySymbol -> Maybe Percentage - percentage' am bm c = case ((,) `on` find ((==) c . acommodity) . amounts) am bm of - (Just a, Just b) -> percentage (mixedAmount a) (mixedAmount b) - _ -> Nothing + -- | Make budget info display helpers that adapt to --layout=wide. + mkBudgetDisplayFns :: [CommoditySymbol] -> (BudgetShowAmountsFn, BudgetCalcPercentagesFn) + mkBudgetDisplayFns cs = case layout_ of + LayoutWide width -> + ( pure . showMixedAmountB oneLineNoCostFmt{displayMaxWidth=width, displayColour=color_} + , \a -> pure . percentage a) + _ -> ( showMixedAmountLinesB noCostFmt{displayCommodity=layout_/=LayoutBare, displayCommodityOrder=Just cs, displayMinWidth=Nothing, displayColour=color_} + , \a b -> map (percentage' a b) cs) + where + -- | Calculate the percentage of actual change to budget goal to show, if any. + -- If valuing at cost, both amounts are converted to cost before comparing. + -- A percentage will not be shown if: + -- + -- - actual or goal are not the same, single, commodity + -- + -- - the goal is zero + -- + percentage :: Change -> BudgetGoal -> Maybe Percentage + percentage actual budget = + case (costedAmounts actual, costedAmounts budget) of + ([a], [b]) | (acommodity a == acommodity b || amountLooksZero a) && not (amountLooksZero b) + -> Just $ 100 * aquantity a / aquantity b + _ -> Nothing + where + costedAmounts = case conversionop_ of + Just ToCost -> amounts . mixedAmountCost + _ -> amounts + -- | Like percentage, but accept multicommodity actual and budget amounts, + -- and extract the specified commodity from both. + percentage' :: Change -> BudgetGoal -> CommoditySymbol -> Maybe Percentage + percentage' am bm c = case ((,) `on` find ((==) c . acommodity) . amounts) am bm of + (Just a, Just b) -> percentage (mixedAmount a) (mixedAmount b) + _ -> Nothing + -- XXX generalise this with multiBalanceReportAsCsv ? -- | Render a budget report as CSV. Like multiBalanceReportAsCsv, -- but includes alternating actual and budget amount columns. budgetReportAsCsv :: ReportOpts -> BudgetReport -> [[Text]] budgetReportAsCsv ReportOpts{..} - (PeriodicReport colspans items tr) + (PeriodicReport colspans items totrow) = (if transpose_ then transpose else id) $ -- heading row - - - -- heading row ("Account" : ["Commodity" | layout_ == LayoutBare ] ++ concatMap (\spn -> [showDateSpan spn, "budget"]) colspans @@ -456,36 +525,33 @@ ) : -- account rows - - - -- account rows concatMap (rowAsTexts prrFullName) items -- totals row - ++ concat [ rowAsTexts (const "Total:") tr | not no_total_ ] + ++ concat [ rowAsTexts (const "Total:") totrow | not no_total_ ] where flattentuples tups = concat [[a,b] | (a,b) <- tups] - showNorm = maybe "" (wbToText . showMixedAmountB oneLine) + showNorm = maybe "" (wbToText . showMixedAmountB oneLineNoCostFmt) rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text) -> PeriodicReportRow a BudgetCell -> [[Text]] rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg)) - | layout_ /= LayoutBare = [render row : fmap showNorm vals] + | layout_ /= LayoutBare = [render row : map showNorm vals] | otherwise = joinNames . zipWith (:) cs -- add symbols and names . transpose -- each row becomes a list of Text quantities - . fmap (fmap wbToText . showMixedAmountLinesB dopts . fromMaybe nullmixedamt) + . map (map wbToText . showMixedAmountLinesB dopts . fromMaybe nullmixedamt) $ vals where - cs = S.toList . foldl' S.union mempty . fmap maCommodities $ catMaybes vals - dopts = oneLine{displayCommodity=layout_ /= LayoutBare, displayCommodityOrder=Just cs, displayMinWidth=Nothing} + cs = S.toList . foldl' S.union mempty . map maCommodities $ catMaybes vals + dopts = oneLineNoCostFmt{displayCommodity=layout_ /= LayoutBare, displayCommodityOrder=Just cs, displayMinWidth=Nothing} vals = flattentuples as ++ concat [[rowtot, budgettot] | row_total_] ++ concat [[rowavg, budgetavg] | average_] - joinNames = fmap (render row :) + joinNames = map (render row :) -- tests diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -374,7 +374,7 @@ $ buildReportRows ropts displaynames matrix -- Calculate column totals - totalsrow = dbg5 "totalsrow" $ calculateTotalsRow ropts rows + totalsrow = dbg5 "totalsrow" $ calculateTotalsRow ropts rows $ length colps -- Sorted report rows. sortedrows = dbg5 "sortedrows" $ sortRows ropts j rows @@ -449,7 +449,7 @@ balance = maybeStripPrices . case accountlistmode_ ropts of ALTree | d == qdepth -> aibalance _ -> aebalance - where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripPrices + where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripCosts -- Accounts interesting because they are a fork for interesting subaccounts interestingParents = dbg5 "interestingParents" $ case accountlistmode_ ropts of @@ -490,7 +490,7 @@ sortFlatMBRByAmount = case fromMaybe NormallyPositive $ normalbalance_ ropts of NormallyPositive -> sortOn (\r -> (Down $ amt r, prrFullName r)) NormallyNegative -> sortOn (\r -> (amt r, prrFullName r)) - where amt = mixedAmountStripPrices . prrTotal + where amt = mixedAmountStripCosts . prrTotal -- Sort the report rows by account declaration order then account name. sortMBRByAccountDeclaration :: [MultiBalanceReportRow] -> [MultiBalanceReportRow] @@ -501,8 +501,8 @@ -- | Build the report totals row. -- -- Calculate the column totals. These are always the sum of column amounts. -calculateTotalsRow :: ReportOpts -> [MultiBalanceReportRow] -> PeriodicReportRow () MixedAmount -calculateTotalsRow ropts rows = +calculateTotalsRow :: ReportOpts -> [MultiBalanceReportRow] -> Int -> PeriodicReportRow () MixedAmount +calculateTotalsRow ropts rows colcount = PeriodicReportRow () coltotals grandtotal grandaverage where isTopRow row = flat_ ropts || not (any (`HM.member` rowMap) parents) @@ -511,7 +511,9 @@ colamts = transpose . map prrAmounts $ filter isTopRow rows - coltotals :: [MixedAmount] = dbg5 "coltotals" $ map maSum colamts + coltotals :: [MixedAmount] = dbg5 "coltotals" $ case colamts of + [] -> replicate colcount nullmixedamt + _ -> map maSum colamts -- Calculate the grand total and average. These are always the sum/average -- of the column totals. @@ -617,7 +619,7 @@ tests_MultiBalanceReport = testGroup "MultiBalanceReport" [ let - amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, + amt0 = Amount {acommodity="$", aquantity=0, acost=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing, asdecimalmark = Just '.', asprecision = Precision 2, asrounding = NoRounding}} (rspec,journal) `gives` r = do diff --git a/Hledger/Reports/PostingsReport.hs b/Hledger/Reports/PostingsReport.hs --- a/Hledger/Reports/PostingsReport.hs +++ b/Hledger/Reports/PostingsReport.hs @@ -127,7 +127,7 @@ -- speed improvement by stripping them early. In some cases, such as in hledger-ui, we still -- want to keep prices around, so we can toggle between cost and no cost quickly. We can use -- the show_costs_ flag to be efficient when we can, and detailed when we have to. - . (if show_costs_ ropts then id else journalMapPostingAmounts mixedAmountStripPrices) + . (if show_costs_ ropts then id else journalMapPostingAmounts mixedAmountStripCosts) $ journalValueAndFilterPostings rspec{_rsQuery=beforeandduringq} j -- filter postings by the query, with no start date or depth limit @@ -139,7 +139,7 @@ dateqtype = if queryIsDate2 dateq || (queryIsDate dateq && date2_ ropts) then Date2 else Date where - dateq = dbg4 "dateq" $ filterQuery queryIsDateOrDate2 $ dbg4 "q" q -- XXX confused by multiple date:/date2: ? + dateq = dbg4 "matchedPostingsBeforeAndDuring dateq" $ filterQuery queryIsDateOrDate2 $ dbg4 "matchedPostingsBeforeAndDuring q" q -- XXX confused by multiple date:/date2: ? -- | Generate postings report line items from a list of postings or (with -- non-Nothing periods attached) summary postings. diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -696,7 +696,7 @@ _ -> Nothing -- If the requested span is open-ended, close it using the journal's start and end dates. -- This can still be the null (open) span if the journal is empty. - requestedspan' = dbg3 "requestedspan'" $ requestedspan `spanDefaultsFrom` (journalspan `spanUnion` pricespan) + requestedspan' = dbg3 "requestedspan'" $ requestedspan `spanDefaultsFrom` (journalspan `spanExtend` pricespan) -- The list of interval spans enclosing the requested span. -- This list can be empty if the journal was empty, -- or if hledger-ui has added its special date:-tomorrow to the query diff --git a/Hledger/Reports/ReportTypes.hs b/Hledger/Reports/ReportTypes.hs --- a/Hledger/Reports/ReportTypes.hs +++ b/Hledger/Reports/ReportTypes.hs @@ -28,6 +28,7 @@ , flatDisplayName , treeDisplayName +, prrShowDebug , prrFullName , prrDisplayName , prrDepth @@ -44,6 +45,8 @@ import Hledger.Data import Hledger.Query (Query) import Hledger.Reports.ReportOptions (ReportOpts) +import qualified Data.Text as T +import Data.List (intercalate) type Percentage = Decimal @@ -119,6 +122,14 @@ ,prrAverage=styleAmounts styles $ prrAverage r } +prrShowDebug :: PeriodicReportRow DisplayName MixedAmount -> String +prrShowDebug (PeriodicReportRow dname amts _tot _avg) = + unwords [ + T.unpack $ displayFull dname, + "", + intercalate " | " $ map showMixedAmount amts + ] + -- | 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) = @@ -132,8 +143,10 @@ -- | Figure out the overall date span of a PeriodicReport periodicReportSpan :: PeriodicReport a b -> DateSpan -periodicReportSpan (PeriodicReport [] _ _) = DateSpan Nothing Nothing -periodicReportSpan (PeriodicReport colspans _ _) = DateSpan (fmap Exact . spanStart $ head colspans) (fmap Exact . spanEnd $ last colspans) +periodicReportSpan (PeriodicReport colspans _ _) = + case colspans of + [] -> DateSpan Nothing Nothing + s:_ -> DateSpan (Exact <$> spanStart s) (Exact <$> spanEnd (last colspans)) -- | Map a function over the row names. prMapName :: (a -> b) -> PeriodicReport a c -> PeriodicReport b c diff --git a/Hledger/Utils/IO.hs b/Hledger/Utils/IO.hs --- a/Hledger/Utils/IO.hs +++ b/Hledger/Utils/IO.hs @@ -450,12 +450,13 @@ -- ~username is not supported. Leaves "-" unchanged. Can raise an error. expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers expandPath _ "-" = return "-" -expandPath curdir p = (if isRelative p then (curdir ) else id) <$> expandHomePath p +expandPath curdir p = (if isRelative p then (curdir ) else id) <$> expandHomePath p -- PARTIAL: -- | Like expandPath, but treats the expanded path as a glob, and returns -- zero or more matched absolute file paths, alphabetically sorted. +-- Can raise an error. expandGlob :: FilePath -> FilePath -> IO [FilePath] -expandGlob curdir p = expandPath curdir p >>= glob <&> sort +expandGlob curdir p = expandPath curdir p >>= glob <&> sort -- PARTIAL: -- | Given a list of existing file paths, sort them by modification time, most recent first. sortByModTime :: [FilePath] -> IO [FilePath] diff --git a/Hledger/Utils/Parse.hs b/Hledger/Utils/Parse.hs --- a/Hledger/Utils/Parse.hs +++ b/Hledger/Utils/Parse.hs @@ -51,6 +51,7 @@ import Control.Monad (when) import qualified Data.Text as T +import Safe (tailErr) import Text.Megaparsec import Text.Printf import Control.Monad.State.Strict (StateT, evalStateT) @@ -163,7 +164,7 @@ showDateParseError :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String -showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) +showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tailErr $ lines $ show e) -- PARTIAL tailError won't be null because showing a parse error isNewline :: Char -> Bool isNewline '\n' = True diff --git a/Hledger/Utils/String.hs b/Hledger/Utils/String.hs --- a/Hledger/Utils/String.hs +++ b/Hledger/Utils/String.hs @@ -41,6 +41,7 @@ import Data.Char (isSpace, toLower, toUpper) import Data.List (intercalate, dropWhileEnd) import qualified Data.Text as T +import Safe (headErr, tailErr) import Text.Megaparsec ((<|>), between, many, noneOf, sepBy) import Text.Megaparsec.Char (char) import Text.Printf (printf) @@ -203,12 +204,12 @@ -- | Strip one matching pair of single or double quotes on the ends of a string. stripquotes :: String -> String -stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s +stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tailErr s else s -- PARTIAL tailErr won't fail because isDoubleQuoted -isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\'' +isSingleQuoted s@(_:_:_) = headErr s == '\'' && last s == '\'' -- PARTIAL headErr, last will succeed because of pattern isSingleQuoted _ = False -isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"' +isDoubleQuoted s@(_:_:_) = headErr s == '"' && last s == '"' -- PARTIAL headErr, last will succeed because of pattern isDoubleQuoted _ = False -- Functions below treat wide (eg CJK) characters as double-width. 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.32.3 +version: 1.33 synopsis: A library providing the core functionality of hledger description: This library contains hledger's core functionality. It is used by most hledger* packages so that they support the same @@ -113,7 +113,7 @@ , aeson-pretty , ansi-terminal >=0.9 , array - , base >=4.14 && <4.19 + , base >=4.14 && <4.20 , base-compat , blaze-markup >=0.5.1 , bytestring @@ -138,7 +138,7 @@ , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa - , safe >=0.3.19 + , safe >=0.3.20 , tabular >=0.2 , tasty >=1.2.3 , tasty-hunit >=0.10.0.2 @@ -157,67 +157,6 @@ build-depends: pager >=0.1.1.0 -test-suite doctest - type: exitcode-stdio-1.0 - main-is: doctests.hs - hs-source-dirs: - ./ - test - ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind - build-depends: - Decimal >=0.5.1 - , Glob >=0.7 - , aeson >=1 && <2.3 - , aeson-pretty - , ansi-terminal >=0.9 - , array - , base >=4.14 && <4.19 - , base-compat - , blaze-markup >=0.5.1 - , bytestring - , call-stack - , cassava - , cassava-megaparsec - , cmdargs >=0.10 - , colour >=2.3.6 - , containers >=0.5.9 - , data-default >=0.5 - , deepseq - , directory - , doclayout >=0.3 && <0.5 - , doctest >=0.18.1 - , extra >=1.6.3 - , file-embed >=0.0.10 - , filepath - , hashtables >=1.2.3.1 - , megaparsec >=7.0.0 && <9.7 - , microlens >=0.4 - , microlens-th >=0.4 - , mtl >=2.2.1 - , parser-combinators >=0.4.0 - , pretty-simple >4 && <5 - , regex-tdfa - , safe >=0.3.19 - , tabular >=0.2 - , tasty >=1.2.3 - , tasty-hunit >=0.10.0.2 - , template-haskell - , terminal-size >=0.3.3 - , text >=1.2.4.1 - , text-ansi >=0.2.1 - , time >=1.5 - , timeit - , transformers >=0.2 - , uglymemo - , unordered-containers >=0.2 - , utf8-string >=0.3.5 - default-language: Haskell2010 - if (!(os(windows))) - build-depends: - pager >=0.1.1.0 - if impl(ghc >= 9.0) && impl(ghc < 9.2) - buildable: False - test-suite unittest type: exitcode-stdio-1.0 main-is: unittest.hs @@ -232,7 +171,7 @@ , aeson-pretty , ansi-terminal >=0.9 , array - , base >=4.14 && <4.19 + , base >=4.14 && <4.20 , base-compat , blaze-markup >=0.5.1 , bytestring @@ -258,7 +197,7 @@ , parser-combinators >=0.4.0 , pretty-simple >4 && <5 , regex-tdfa - , safe >=0.3.19 + , safe >=0.3.20 , tabular >=0.2 , tasty >=1.2.3 , tasty-hunit >=0.10.0.2