diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -13,6 +13,21 @@ Internal/api/developer-ish changes in the hledger-lib (and hledger) packages. For user-visible changes, see the hledger package changelog. +# 1.32 2023-12-01 + +Misc. changes + +- styleAmounts is used in more places + +- journalApplyCommodityStyles renamed to journalStyleAmounts + +- "hard" and "all" rounding strategies have been added + +- debug output improvements, eg for precision handling + +- Table is now Showable, for debugging + + # 1.31 2023-09-03 Breaking changes diff --git a/Hledger.hs b/Hledger.hs --- a/Hledger.hs +++ b/Hledger.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-| +This is the root of the @hledger-lib@ package and the @Hledger.*@ module hierarchy. +hledger-lib is the core engine used by various hledger UIs and tools, +providing the main data types, file format parsers, reporting logic, and utilities. +-} module Hledger ( + -- $DOCS module X ,tests_Hledger ) @@ -19,3 +24,350 @@ ,tests_Reports ,tests_Utils ] + + +{- $DOCS + +This is also the starting point for hledger's code docs, +aimed at hledger developers and PTA implementors (and curious users). +These are embedded in hledger's source code as Haddock comments and can be viewed +in your code editor, +or in a web browser (eg with @make haddock@), +or (for released versions) on Hackage, eg [hledger-lib:Hledger](https://hackage.haskell.org/package/hledger-lib/docs/Hledger.html). +See also: + +- hledger:Hledger.Cli +- hledger-ui:Hledger.UI +- hledger-web:Hledger.Web +- [The README files](https://github.com/search?q=repo%3Asimonmichael%2Fhledger+path%3A**%2FREADME*&type=code&ref=advsearch) +- [The high-level developer docs](https://hledger.org/dev.html) + +The rest of this page discusses some general topics. +Together with the hledger manual it describes and provides a functional specification +for hledger and hledger-like apps. +The current code and tests generally conform to this, hopefully. + +== Jargon + +In addition to the terminology defined in the hledger manual, +eg at [Journal](https://hledger.org/dev/hledger.html#journal): + +Here are some words with particular meanings in the context of hledger: + +- __/Decimal/__ is a decimal number representation provided by + the Decimal package, used by hledger for storing numeric quantities. + +- __/Normalised decimal/__ A Decimal which has no trailing decimal zeros. + This can be ensured by the @normaliseDecimal@ function. + +- __/Amount/__ ('Amount') is hledger's representation of numeric amounts + which have a decimal quantity, + a commodity symbol ('CommoditySymbol'), + and a display style ('AmountStyle') and display precision ('Precision'). + and optionally a cost in another commodity. + +- __/Style/__, __/Amount style/__ An amount's display style, such its decimal mark and symbol placement. + Represented by "CommodityStyle". (That also stores display precision, + though it is sometimes convenient to speak of style and precision separately.) + +- __/Commodity style/__ The standard display style inferred or specified for a particular commodity. + Normally all amounts in that commodity are displayed with that style. + +- __/Precision/__ In hledger docs, "precision" means the number of decimal digits, + ie digits to the right of the decimal mark. + +- __/Journal precision/__ The number of decimal digits written for an amount + in the journal file (or in other input data). + +- __/Decimal precision/__ The number of decimal digits stored in an Amount's internal Decimal number. + After parsing, this will be the same as the journal precision; it can increase during amount calculations. + +- __/Display precision/__ The preferred number of decimal digits to show in output + (except by @print@-like reports, which show journal precision by default). + +- __/MixedAmount/__ ('MixedAmount') is hledger's representation of a + multi-commodity amount; it is a set of zero or more Amounts in + different commodities and costs (stored as a map for efficiency). + +- __/amount/__ means either a single-commodity Amount or a multi-commodity MixedAmount, + depending on context. There are various sources and kinds of amount: + +- __/Posting amount/__ An amount being posted (moved from or to) an account. + +- __/Cost amount/__ The (cost in a different commodity) associated with a posting amount. + Eg the purchase cost when buying, or the sale price when selling. + Cost is recorded in the journal immediately following the posting amount, expressed as a unit or total cost. + +- __/Unit cost/__ The cost per unit of the posting amount. Written as @\@ UNITCOST@. + +- __/Total cost/__ The total cost the posting amount. Written as @\@\@ TOTALCOST@. + +- __/Amount cost/__ A posting amount converted to its cost's commodity. Shown by @hledger print -B@. + + > 2023-01-01 + > (a) 2 A @ 2 B ; <- the amount cost is 4 B + + > 2023-01-01 + > (a) 2 A @@ 2 B ; <- the amount cost is 2 B + +- __/Cost/__ can mean any of the four above depending on context. + +- __/Balance assertion \/ assignment amount/__ + An amount written after the posting amount and cost, + following @=@ or @==@ or @=*@ or @==*@, + representing a balance assertion + (or when the posting amount is omitted, a balance assignment). + +- __/Balance assertion \/ assignment cost/__ + The unit or total cost of the balance assertion\/assignment amount, if any. + Written after it in the usual way. + +- __/Price/__, __/Market price/__ + A conversion rate\/exchange rate from a particular commodity to another as of a particular date. + These usually fluctuate over time, and are recorded by @P@ price directives. + Shown by @hledger prices@. + +- __/Price amount/__ The amount written in a @P@ price directive, + which specifies the destination commodity and the per-unit conversion rate. + +- __/Cost vs price/__ + Both of these words are quite slippery in english. + To simplify, we always say + "cost" for a conversion rate used in a particular transaction (posting), and + "price" for conversion rates prevailing in the environment. + +- __/Value/__ + Any amount converted to some other commodity using a market price on a certain date. + Shown by any hledger report when the @-V@, @-X@ or @--value@ option is used. + +- __/Real postings/__ Normal account postings, required to balance to zero. + +- __/Virtual postings/__ Account postings which are exempt from the normal balance-to-zero requirement. + Written with parentheses around the account name. + Can be excluded from reports with the @--real@ flag. + +- __/Balanced virtual postings/__ Account postings which are required to balance to zero, + but separately from the real postings. + Written with square brackets around the account name. + Can be excluded from reports with the @--real@ flag. + +- __/Transaction balancing/__ The process of inferring amounts and/or costs to balance a transaction, + both in its real and its balanced virtual postings. + +- __/Balancing amount/__ An amount that is inferred to balance a transaction with a missing amount. Shown by @hledger print -x@. + + > 2023-01-01 + > a 1 + > b ; <- a balancing amount of -1 is inferred + +- __/Balancing cost/__ A cost that is inferred to balance a transaction involving two commodities. Shown by @hledger print -x@. + + > 2023-01-01 + > a 1 A ; <- a balancing cost of @@ 2 B is inferred + > b -2 B + +== Precision + +As mentioned in Jargon: +"precision" in hledger means the number of digits to the right of the decimal mark. +And, amounts have several precisions we can talk about: + +__/Journal precision/__ is the number of decimal digits recorded in the +journal file \/ input data. We accept up to 255 decimal digits there. + +__/Decimal precision/__ is the number of decimal digits stored internally in each Decimal value. Decimal supports up to 255 decimal digits. +In amounts just parsed from the journal, this will be the same as their journal precision. +During calculations, amounts' decimal precision may increase, and will not decrease. + +__/Display precision/__ is the preferred number of decimal digits to show in report output. +It is represented by 'AmountPrecision', which is currently part of the 'AmountStyle' stored within each Amount. +In amounts just parsed from the journal, this will be the same as the journal and decimal precisions; +later it gets standardised for each commodity's amounts. +When display precision is less than the decimal precision, fewer, rounded decimal digits are displayed ("rounding"). +When display precision is greater than the decimal precision, additional decimal zeros are displayed ("padding"). + +Basically, hledger amounts have two main precisions we care about at runtime: +their internal decimal precision, used for calculation, and their display precision, used for rendering. + +== Rounding + +__/Internal rounding/__ means rounding (or padding) internal Decimal numbers, +using @amountSetInternalPrecision@ (which uses @Data.Decimal.roundTo@). +Internal rounding loses information so we don't do this much. + +__/Display rounding/__ means applying a target display precision to an existing amount. +This can be done more or less forcefully, determined by a "display rounding strategy" ('Rounding'). +Currently this too is stored within each Amount's AmountStyle, for convenience, +(though semantically speaking it is not part of the amount). + +The rounding strategies are: + +- none - leave the amount's display precision unchanged +- soft - add or remove trailing decimal zeros to approximate the target precision, but don't remove significant digits +- hard - use the exact target precision, possibly rounding and hiding significant digits +- all - do hard rounding of both the main amount and its cost amount (costs are normally not display-rounded). + +Broadly, here is when display rounding happens: + +1. After reading a journal, when standard commodity styles are applied, + display precisions are kept unchanged; no rounding is done at this stage (since 1.31). + +2. While balancing each transaction, + its amounts are temporarily hard-rounded to the standard commodity display precisions, + to provide some configurable tolerance in the balancing calculations. + (We plan to change this to use transaction-local standard precisions, + inferred from the transaction's journal precisions only, like Ledger.) + +3. Just before output, reports do display rounding according to their needs (since 1.31). + Most reports do hard display rounding. + @print@ and other print-like commands do no rounding by default, + or optionally one of the other rounding strategies. + +=== Precision and style handling + +hledger supports user-specified precisions from 0 to 255 for each +commodity, and tries to propagate these consistently and intuitively +through all the various processing steps. + +This gets rather complicated, so we keep a summary of the current +precision and style behaviours here. +This doc should always be kept synced with code. + +In Decimal number calculations: + +- the result is normalised, meaning any trailing decimal zeros are trimmed. + So the result 's precision can be larger + (1 / 2, both with precision 0, is 0.5, with precision 1) + or smaller + (2.0 / 1.0, both with precision 1, is normalised to 2, with precision 0). + +In amount calculations: + +- When amounts are summed (or subtracted), the result has the maximum + of their decimal precisions, the maximum of their display precisions, + and the display style of the second amount. + +- When an amount is multiplied (or divided) by a pure number, + the result's decimal precision is that of the decimal result, normalised. + The display precision and style is kept unchanged. + +- When an amount is converted to cost, the new amount's decimal precision + is that of the cost amount (if it's a total cost), + or of the cost amount multiplied by the quantity and normalised (if it's a unit cost). + Its display precision is kept unchanged. + Its display style is that of the cost amount. + +- When an amount is converted to value, the new amount's decimal precision + is that of the price amount multiplied by the quantity and normalised. + Its display precision is set to match the decimal precision, + or to a fallback precision (8) if the decimal appears to be infinite. + Its display style is its commodity's standard display style. + If no standard style is known for the commodity (eg because it does not appear in the journal), + it is given the fallback display style (symbol on the left unspaced, period as decimal mark, + precision limited to a maximum of 8 digits). + +In a run of hledger: + +__1. Input__ + +__1.1. Parsing__ + +- Each parsed amount initially has decimal precision, display precision, + and display style set according to how it was written in the journal. + +__1.2. Standard styling__ + +- After all amounts are parsed, + standard display styles and display precisions are inferred for each commodity + from its amounts, directives like @commodity@ and @D@, and -c\/--commodity options + (in 'journalInferCommodityStyles'), + and these are applied to all amounts and their costs for consistent display + (in 'journalStyleAmounts'). + No amount display precisions are changed at this stage. + +__1.3. Transaction balancing__ + +- When amounts are summed, the result has the maximum of their + decimal precisions and the maximum of their display precisions. + +- A balancing amount without a cost will have the same precisions as + the amount (or sum) it is balancing. + +- A balancing amount which has a cost will be converted to cost; see + "When an amount is converted to cost" above. + +- When inferring a balancing cost: + + - The "from amount" is the sum of postings in the first-appearing commodity. + + - The "to amount" is the sum of postings in the second-appearing commodity. See "When amounts are summed" above. + + - If the from amount comes from a single posting, it is given a total cost. + The cost's decimal precision will be that of the to amount divided by the from quantity, normalised. + Its display precision and style will be that of the to amount. + + - If the from amount comes from multiple postings, they all are given a unit cost. + The cost's decimal precision will be that of the to amount divided by the from quantity, normalised. + Its display precision will be the sum of the from and to amounts' display precisions, or 2, whichever is greater. + Its display style will be that of the to amount. + +- An amount inferred from a balance assignment will have the same precisions as the balance assignment amount. + +__1.4. Determining market prices__ + +If needed, for a value report: + +- Any @P@ price directives form the __/declared prices/__. + Like posting amounts, their price amounts have been standard-styled + but their precisions have not yet been changed. + +- If the @--infer-market-prices@ flag is used, additional price + directives are generated from any journal postings with costs + (in 'amountPriceDirectiveFromCost'). + When the cost was a unit cost, the price amount will have the same precisions. + When the cost was a total cost, + + - The total cost is divided by the amount quantity to get a unit cost. + - Its decimal precision becomes that of the decimal result, normalised. + - Its display precision is set to match the new decimal precision; + unless the decimal appears to be infinite (because it uses all the 255 digits allowed), + in which case it is given a smaller fallback display precision (8 decimal digits). + + These plus the declared prices are the __/forward prices/__. + +- Additional market prices are generated (as 'MarketPrice' this time, not 'PriceDirective') + by reversing the forward prices (in 'marketPriceReverse'). + Any new prices generated in this way are the __/reverse prices/__. + Their decimal precision will be that of (1 \/ the decimal quantity), normalised. + (They don't have a display precision.) + These plus the forward prices are the __/direct prices/__ + (giving direct conversion rates from one commodity to another). + +And later, if needed: + +- For each requested value conversion from commodity A to commodity B, + if an appropriate price is not found in the direct prices, we try to calculate a __/chained price/__, + combining two or more direct prices that form a path from A to B. + The resulting price's decimal precision will be the product of the chained prices, normalised, + then padded back up to the maximum of their decimal precisions + (undoing the normalising, because later we will choose the value amount's display precision + based on the value's decimal precision). + +__2. Calculating reports__ + +- Amounts may be converted to cost (-B), summed, averaged, converted + to velue (-V\/-X\/--value), etc. Precisions and styles are affected + as described in "In amount calculations" above. + +__3. Output__ + +- print-like reports: amounts are displayed with their current display precisions. + Or with --round, they can be soft- or hard-rounded/padded to the standard commodity precisions. + +- All other reports: amounts are displayed hard rounded/padded to the standard commodity precisions. + +- In the roi report: if there is no standard display precision for the valuation commodity, + it is limited to a maximum of 8 digits. + +== Exports of this module: +-} diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -52,6 +52,8 @@ ,concatAccountNames ,accountNameApplyAliases ,accountNameApplyAliasesMemo + ,accountNameToBeancount + ,beancountTopLevelAccounts ,tests_AccountName ) where @@ -71,6 +73,7 @@ import Hledger.Data.Types import Hledger.Utils +import Data.Char (isDigit, isLetter) -- $setup -- >>> :set -XOverloadedStrings @@ -345,6 +348,50 @@ -- -- | Does this string look like an exact account-matching regular expression ? --isAccountRegex :: String -> Bool --isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:(" + +type BeancountAccountName = AccountName +type BeancountAccountNameComponent = AccountName + +-- Convert a hledger account name to a valid Beancount account name. +-- It replaces non-supported characters with @-@ (warning: in extreme cases +-- separate accounts could end up with the same name), and it capitalises +-- each account name part. It also checks that the first part is one of +-- Assets, Liabilities, Equity, Income, or Expenses, and if not it raises an error. +-- Account aliases (eg --alias) should be used to set these required +-- top-level account names if needed. +accountNameToBeancount :: AccountName -> BeancountAccountName +accountNameToBeancount a = + -- https://beancount.github.io/docs/beancount_language_syntax.html#accounts + accountNameFromComponents $ + case map (accountNameComponentToBeancount a) $ accountNameComponents a of + c:_ | c `notElem` beancountTopLevelAccounts -> error' e + where + e = T.unpack $ T.unlines [ + beancountAccountErrorMessage a, + "For Beancount output, all top-level accounts must be (or be aliased to) one of", + T.intercalate ", " beancountTopLevelAccounts <> "." + ] + cs -> cs + +accountNameComponentToBeancount :: AccountName -> AccountName -> BeancountAccountNameComponent +accountNameComponentToBeancount acct part = + case T.uncons part of + Just (c,_) | not $ isLetter c -> error' e + where + e = unlines [ + T.unpack $ beancountAccountErrorMessage acct, + "For Beancount output, each account name part must begin with a letter." + ] + _ -> textCapitalise part' + where part' = T.map (\c -> if isBeancountAccountChar c then c else '-') part + +beancountAccountErrorMessage :: AccountName -> Text +beancountAccountErrorMessage a = "Could not convert \"" <> a <> "\" to a Beancount account name." + +isBeancountAccountChar :: Char -> Bool +isBeancountAccountChar c = c `elem` ("-:"::[Char]) || isLetter c || isDigit c + +beancountTopLevelAccounts = ["Assets", "Liabilities", "Equity", "Income", "Expenses"] tests_AccountName = testGroup "AccountName" [ testCase "accountNameTreeFrom" $ do diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -42,13 +42,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module Hledger.Data.Amount ( -- * Commodity showCommoditySymbol, isNonsimpleCommodityChar, quoteCommoditySymbolIfNeeded, + -- * Amount + -- ** arithmetic nullamt, missingamt, num, @@ -60,27 +63,26 @@ at, (@@), amountWithCommodity, - -- ** arithmetic amountCost, amountIsZero, amountLooksZero, divideAmount, multiplyAmount, + invertAmount, + -- ** styles + amountstyle, + canonicaliseAmount, + styleAmount, + amountSetStyles, + amountStyleSetRounding, + amountStylesSetRounding, + amountUnstyled, -- ** rendering AmountDisplayOpts(..), noColour, noPrice, oneLine, csvDisplay, - amountstyle, - canonicaliseAmount, - styleAmount, - amountSetStyles, - amountSetStylesExceptPrecision, - amountSetMainStyle, - amountSetCostStyle, - amountStyleUnsetPrecision, - amountUnstyled, showAmountB, showAmount, showAmountPrice, @@ -89,13 +91,20 @@ showAmountDebug, showAmountWithoutPrice, amountSetPrecision, + amountSetPrecisionMin, + amountSetPrecisionMax, withPrecision, amountSetFullPrecision, + amountSetFullPrecisionOr, + amountInternalPrecision, + amountDisplayPrecision, + defaultMaxPrecision, setAmountInternalPrecision, withInternalPrecision, setAmountDecimalPoint, withDecimalPoint, amountStripPrices, + -- * MixedAmount nullmixedamt, missingmixedamt, @@ -128,12 +137,12 @@ maIsZero, maIsNonZero, mixedAmountLooksZero, - -- ** rendering + -- ** styles canonicaliseMixedAmount, styleMixedAmount, mixedAmountSetStyles, - mixedAmountSetStylesExceptPrecision, mixedAmountUnstyled, + -- ** rendering showMixedAmount, showMixedAmountOneLine, showMixedAmountDebug, @@ -147,6 +156,9 @@ wbUnpack, mixedAmountSetPrecision, mixedAmountSetFullPrecision, + mixedAmountSetPrecisionMin, + mixedAmountSetPrecisionMax, + -- * misc. tests_Amount ) where @@ -174,10 +186,12 @@ import Test.Tasty.HUnit ((@?=), assertBool, testCase) import Hledger.Data.Types -import Hledger.Utils (colorB, numDigitsInt) +import Hledger.Utils (colorB, numDigitsInt, numDigitsInteger) import Hledger.Utils.Text (textQuoteIfNeeded) import Text.WideString (WideBuilder(..), wbFromText, wbToText, wbUnpack) import Data.Functor ((<&>)) +-- import Data.Function ((&)) +-- import Hledger.Utils.Debug (dbg0) -- A 'Commodity' is a symbol representing a currency or some other kind of @@ -203,11 +217,13 @@ -- | Options for the display of Amount and MixedAmount. --- (See also Types.AmountStyle) +-- (ee also Types.AmountStyle. data AmountDisplayOpts = AmountDisplayOpts { displayPrice :: Bool -- ^ Whether to display the Price of an Amount. , displayZeroCommodity :: Bool -- ^ If the Amount rounds to 0, whether to display its commodity string. - , displayThousandsSep :: Bool -- ^ Whether to display thousands separators. + , displayThousandsSep :: Bool -- ^ Whether to display digit group marks (eg thousands separators) + , displayAddDecimalMark :: Bool -- ^ Whether to add a trailing decimal mark when there are no decimal digits + -- and there are digit group marks, to disambiguate , displayColour :: Bool -- ^ Whether to colourise negative Amounts. , displayOneLine :: Bool -- ^ Whether to display on one line. , displayMinWidth :: Maybe Int -- ^ Minimum width to pad to @@ -226,6 +242,7 @@ , displayColour = False , displayZeroCommodity = False , displayThousandsSep = True + , displayAddDecimalMark = False , displayOneLine = False , displayMinWidth = Just 0 , displayMaxWidth = Nothing @@ -245,15 +262,7 @@ csvDisplay = oneLine{displayThousandsSep=False} ------------------------------------------------------------------------------- --- Amount styles - --- | Default amount style -amountstyle = AmountStyle L False Nothing (Just '.') (Just $ Precision 0) - -------------------------------------------------------------------------------- --- Amount - -instance HasAmounts Amount where styleAmounts = amountSetStyles +-- Amount arithmetic instance Num Amount where abs a@Amount{aquantity=q} = a{aquantity=abs q} @@ -279,11 +288,11 @@ -- usd/eur/gbp round their argument to a whole number of pennies/cents. -- XXX these are a bit clashy num n = nullamt{acommodity="", aquantity=n} -hrs n = nullamt{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=Just $ Precision 2, ascommodityside=R}} -usd n = nullamt{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Just $ Precision 2}} -eur n = nullamt{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Just $ Precision 2}} -gbp n = nullamt{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Just $ Precision 2}} -per n = nullamt{acommodity="%", aquantity=n, astyle=amountstyle{asprecision=Just $ Precision 1, ascommodityside=R, ascommodityspaced=True}} +hrs n = nullamt{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=Precision 2, ascommodityside=R}} +usd n = nullamt{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}} +eur n = nullamt{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}} +gbp n = nullamt{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=Precision 2}} +per n = nullamt{acommodity="%", aquantity=n, astyle=amountstyle{asprecision=Precision 1, ascommodityside=R, ascommodityspaced=True}} amt `at` priceamt = amt{aprice=Just $ UnitPrice priceamt} amt @@ priceamt = amt{aprice=Just $ TotalPrice priceamt} @@ -329,7 +338,7 @@ f' (TotalPrice a1@Amount{aquantity=pq}) = TotalPrice a1{aquantity = f pq} f' p' = p' --- | Divide an amount's quantity (and its total price, if it has one) by a constant. +-- | Divide an amount's quantity (and total cost, if any) by some number. divideAmount :: Quantity -> Amount -> Amount divideAmount n = transformAmount (/n) @@ -337,6 +346,11 @@ multiplyAmount :: Quantity -> Amount -> Amount multiplyAmount n = transformAmount (*n) +-- | Invert an amount (replace its quantity q with 1/q). +-- (Its cost if any is not changed, currently.) +invertAmount :: Amount -> Amount +invertAmount a@Amount{aquantity=q} = a{aquantity=1/q} + -- | Is this amount negative ? The price is ignored. isNegativeAmount :: Amount -> Bool isNegativeAmount Amount{aquantity=q} = q < 0 @@ -345,9 +359,8 @@ -- If that is unset or NaturalPrecision, this does nothing. amountRoundedQuantity :: Amount -> Quantity amountRoundedQuantity Amount{aquantity=q, astyle=AmountStyle{asprecision=mp}} = case mp of - Nothing -> q - Just NaturalPrecision -> q - Just (Precision p) -> roundTo p q + 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 @@ -363,49 +376,229 @@ amountLooksZero = testAmountAndTotalPrice looksZero where looksZero Amount{aquantity=Decimal e q, astyle=AmountStyle{asprecision=p}} = case p of - Just (Precision d) -> if e > d then abs q <= 5*10^(e-d-1) else q == 0 - Just NaturalPrecision -> q == 0 - Nothing -> q == 0 + 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 ? amountIsZero :: Amount -> Bool amountIsZero = testAmountAndTotalPrice (\Amount{aquantity=Decimal _ q} -> q == 0) +-- | Does this amount's internal Decimal representation have the +-- maximum number of digits, suggesting that it probably is +-- representing an infinite decimal ? +amountHasMaxDigits :: Amount -> Bool +amountHasMaxDigits = (>= 255) . numDigitsInteger . decimalMantissa . aquantity +-- XXX this seems not always right. Eg: +-- ghci> let n = 100 / (3.0 :: Decimal) +-- decimalPlaces n +-- 255 +-- numDigitsInteger $ decimalMantissa n +-- 257 + + -- | Set an amount's display precision, flipped. withPrecision :: Amount -> AmountPrecision -> Amount withPrecision = flip amountSetPrecision -- | Set an amount's display precision. amountSetPrecision :: AmountPrecision -> Amount -> Amount -amountSetPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=Just p}} +amountSetPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=p}} +-- | Ensure an amount's display precision is at least the given minimum precision. +-- Always sets an explicit Precision. +amountSetPrecisionMin :: Word8 -> Amount -> Amount +amountSetPrecisionMin minp a = amountSetPrecision p a + where p = Precision $ max minp (amountDisplayPrecision a) + +-- | Ensure an amount's display precision is at most the given maximum precision. +-- Always sets an explicit Precision. +amountSetPrecisionMax :: Word8 -> Amount -> Amount +amountSetPrecisionMax maxp a = amountSetPrecision p a + where p = Precision $ min maxp (amountDisplayPrecision a) + -- | Increase an amount's display precision, if needed, to enough decimal places -- to show it exactly (showing all significant decimal digits, without trailing zeros). --- If the amount's display precision is unset, it is will be treated as precision 0. +-- If the amount's display precision is unset, it will be treated as precision 0. amountSetFullPrecision :: Amount -> Amount amountSetFullPrecision a = amountSetPrecision p a where p = max displayprecision naturalprecision - displayprecision = fromMaybe (Precision 0) $ asprecision $ astyle a - naturalprecision = Precision . decimalPlaces . normalizeDecimal $ aquantity a + displayprecision = asprecision $ astyle a + naturalprecision = Precision $ amountInternalPrecision a +-- XXX Is that last sentence correct ? +-- max (Precision n) NaturalPrecision is NaturalPrecision. +-- Would this work instead ? +-- amountSetFullPrecision a = amountSetPrecision (Precision p) a +-- where p = max (amountDisplayPrecision a) (amountInternalPrecision a) --- | Set an amount's internal precision, ie rounds the Decimal representing --- the amount's quantity to some number of decimal places. + +-- | 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. +-- 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. +-- This function always sets an explicit display precision (ie, Precision n). +amountSetFullPrecisionOr :: Maybe Word8 -> Amount -> Amount +amountSetFullPrecisionOr mmaxp a = amountSetPrecision (Precision p2) a + where + p1 = if -- dbg0 "maxdigits" $ + amountHasMaxDigits a then defaultMaxPrecision else max disp intp + -- & dbg0 "p1" + where + intp = amountInternalPrecision a + disp = amountDisplayPrecision a + p2 = maybe p1 (min p1) mmaxp + -- & dbg0 "p2" + +-- | The fallback display precision used when showing amounts +-- representing an infinite decimal. +defaultMaxPrecision :: Word8 +defaultMaxPrecision = 8 + +-- | How many internal decimal digits are stored for this amount ? +amountInternalPrecision :: Amount -> Word8 +amountInternalPrecision = decimalPlaces . normalizeDecimal . aquantity + +-- | How many decimal digits will be displayed for this amount ? +amountDisplayPrecision :: Amount -> Word8 +amountDisplayPrecision a = + case asprecision $ astyle a of + Precision n -> n + NaturalPrecision -> amountInternalPrecision a + +-- | Set an amount's internal decimal precision as well as its display precision. +-- This rounds or pads its Decimal quantity to the specified number of decimal places. -- Rounding is done with Data.Decimal's default roundTo function: -- "If the value ends in 5 then it is rounded to the nearest even value (Banker's Rounding)". --- Does not change the amount's display precision. --- Intended mainly for internal use, eg when comparing amounts in tests. setAmountInternalPrecision :: Word8 -> Amount -> Amount setAmountInternalPrecision p a@Amount{ aquantity=q, astyle=s } = a{ - astyle=s{asprecision=Just $ Precision p} - ,aquantity=roundTo p q + aquantity=roundTo p q + ,astyle=s{asprecision=Precision p} } --- | Set an amount's internal precision, flipped. --- Intended mainly for internal use, eg when comparing amounts in tests. +-- | setAmountInternalPrecision with arguments flipped. withInternalPrecision :: Amount -> Word8 -> Amount withInternalPrecision = flip setAmountInternalPrecision +-- Amount display styles + +-- v1 +{-# DEPRECATED canonicaliseAmount "please use styleAmounts instead" #-} +canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +canonicaliseAmount = styleAmounts + +-- v2 +{-# DEPRECATED styleAmount "please use styleAmounts instead" #-} +styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +styleAmount = styleAmounts + +-- v3 +{-# DEPRECATED amountSetStyles "please use styleAmounts instead" #-} +amountSetStyles :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount +amountSetStyles = styleAmounts + +-- v4 +instance HasAmounts Amount where + -- | Given some commodity display styles, find and apply the appropriate one to this amount, + -- and its cost amount if any (and stop; we assume costs don't have costs). + -- Display precision will be applied (or not) as specified by the style's rounding strategy, + -- 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} + 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} + + mknewstyle :: Bool -> Quantity -> AmountStyle -> CommoditySymbol -> AmountStyle + mknewstyle iscost oldq olds com = + case M.lookup com styles of + Just s -> + -- dbg0 "new style" $ + amountStyleApplyWithRounding iscost oldq + ( + -- dbg0 "applying style" + s) + ( + -- dbg0 "old style" + olds) + Nothing -> olds + +-- AmountStyle helpers + +-- | Replace one AmountStyle with another, but don't just replace the display precision; +-- update that in one of several ways as selected by the new style's "rounding strategy": +-- +-- NoRounding - keep the precision unchanged +-- +-- SoftRounding - +-- +-- if either precision is NaturalPrecision, use NaturalPrecision; +-- +-- if the new precision is greater than the old, use the new (adds decimal zeros); +-- +-- if the new precision is less than the old, use as close to the new as we can get +-- without dropping (more) non-zero digits (drops decimal zeros). +-- +-- for a cost amount, keep the precision unchanged +-- +-- HardRounding - +-- +-- for a posting amount, use the new precision (may truncate significant digits); +-- +-- for a cost amount, keep the precision unchanged +-- +-- AllRounding - +-- +-- for both posting and cost amounts, do hard rounding. +-- +-- Arguments: +-- +-- whether this style is for a posting amount or a cost amount, +-- +-- the amount's decimal quantity (for inspecting its internal representation), +-- +-- the new style, +-- +-- the old style. +-- +amountStyleApplyWithRounding :: Bool -> Quantity -> AmountStyle -> AmountStyle -> AmountStyle +amountStyleApplyWithRounding iscost q news@AmountStyle{asprecision=newp, asrounding=newr} AmountStyle{asprecision=oldp} = + case newr of + NoRounding -> news{asprecision=oldp} + SoftRounding -> news{asprecision=if iscost then oldp else newp'} + where + newp' = case (newp, oldp) of + (Precision new, Precision old) -> + if new >= old + then Precision new + else Precision $ max (min old internal) new + where internal = decimalPlaces $ normalizeDecimal q + _ -> NaturalPrecision + HardRounding -> news{asprecision=if iscost then oldp else newp} + AllRounding -> news + +-- | Set this amount style's rounding strategy when being applied to amounts. +amountStyleSetRounding :: Rounding -> AmountStyle -> AmountStyle +amountStyleSetRounding r as = as{asrounding=r} + +amountStylesSetRounding :: Rounding -> M.Map CommoditySymbol AmountStyle -> M.Map CommoditySymbol AmountStyle +amountStylesSetRounding r = M.map (amountStyleSetRounding r) + +-- | Default amount style +amountstyle = AmountStyle L False Nothing (Just '.') (Precision 0) NoRounding + +-- | Reset this amount's display style to the default. +amountUnstyled :: Amount -> Amount +amountUnstyled a = a{astyle=amountstyle} + -- | Set (or clear) an amount's display decimal point. setAmountDecimalPoint :: Maybe Char -> Amount -> Amount setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalmark=mc} } @@ -414,6 +607,8 @@ withDecimalPoint :: Amount -> Maybe Char -> Amount withDecimalPoint = flip setAmountDecimalPoint +-- Amount rendering + -- | Strip all prices from an Amount amountStripPrices :: Amount -> Amount amountStripPrices a = a{aprice=Nothing} @@ -430,76 +625,6 @@ showAmountPriceDebug (Just (UnitPrice pa)) = " @ " ++ showAmountDebug pa showAmountPriceDebug (Just (TotalPrice pa)) = " @@ " ++ showAmountDebug pa --- Amount styling --- v1 - --- like journalCanonicaliseAmounts --- | Canonicalise an amount's display style using the provided commodity style map. --- Its cost amount, if any, is not affected. -canonicaliseAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -canonicaliseAmount = amountSetMainStyle -{-# DEPRECATED canonicaliseAmount "please use amountSetMainStyle (or amountSetStyles) instead" #-} - --- v2 - --- | Given a map of standard commodity display styles, apply the --- appropriate one to this amount. If there's no standard style for --- this amount's commodity, return the amount unchanged. --- Also do the same for the cost amount if any, but leave its precision unchanged. -styleAmount :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -styleAmount = amountSetStyles -{-# DEPRECATED styleAmount "please use amountSetStyles instead" #-} - --- v3 - --- | Given some commodity display styles, find and apply the appropriate --- display style to this amount, and do the same for its cost amount if any --- (and then stop; we assume costs don't have costs). --- The main amount's display precision is set or not, according to its style; --- the cost amount's display precision is left unchanged, regardless of its style. --- If no style is found for an amount, it is left unchanged. -amountSetStyles :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -amountSetStyles styles = amountSetMainStyle styles <&> amountSetCostStyle styles - --- | Like amountSetStyles, but leave the display precision unchanged --- in both main and cost amounts. -amountSetStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -amountSetStylesExceptPrecision styles a@Amount{astyle=AmountStyle{asprecision=origp}} = - case M.lookup (acommodity a) styles' of - Just s -> a{astyle=s{asprecision=origp}} - Nothing -> a - where styles' = M.map amountStyleUnsetPrecision styles - -amountStyleUnsetPrecision :: AmountStyle -> AmountStyle -amountStyleUnsetPrecision as = as{asprecision=Nothing} - --- | Find and apply the appropriate display style, if any, to this amount. --- The display precision is set or not, according to the style. -amountSetMainStyle :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -amountSetMainStyle styles a@Amount{acommodity=comm, astyle=AmountStyle{asprecision=morigp}} = - case M.lookup comm styles of - Nothing -> a - Just s@AmountStyle{asprecision=mp} -> a{astyle=s'} - where - s' = case mp of - Nothing -> s{asprecision=morigp} - _ -> s - --- | Find and apply the appropriate display style, if any, to this amount's cost, if any. --- The display precision is left unchanged, regardless of the style. -amountSetCostStyle :: M.Map CommoditySymbol AmountStyle -> Amount -> Amount -amountSetCostStyle styles a@Amount{aprice=mcost} = - case mcost of - Nothing -> a - Just (UnitPrice a2) -> a{aprice=Just $ UnitPrice $ amountSetStylesExceptPrecision styles a2} - Just (TotalPrice a2) -> a{aprice=Just $ TotalPrice $ amountSetStylesExceptPrecision styles a2} - - --- | Reset this amount's display style to the default. -amountUnstyled :: Amount -> Amount -amountUnstyled a = a{astyle=amountstyle} - - -- | Get the string representation of an amount, based on its -- commodity's display settings. String representations equivalent to -- zero are converted to just \"0\". The special "missing" amount is @@ -523,22 +648,25 @@ -- showAmountB :: AmountDisplayOpts -> Amount -> WideBuilder showAmountB _ Amount{acommodity="AUTO"} = mempty -showAmountB opts a@Amount{astyle=style} = +showAmountB + AmountDisplayOpts{displayPrice, displayColour, displayZeroCommodity, + displayThousandsSep, displayAddDecimalMark, displayOrder} + a@Amount{astyle=style} = color $ case ascommodityside style of L -> showC (wbFromText comm) space <> quantity' <> price R -> quantity' <> showC space (wbFromText comm) <> price where - color = if displayColour opts && isNegativeAmount a then colorB Dull Red else id - quantity = showamountquantity $ - if displayThousandsSep opts then a else a{astyle=(astyle a){asdigitgroups=Nothing}} + color = if displayColour && isNegativeAmount a then colorB Dull Red else id + quantity = showAmountQuantity displayAddDecimalMark $ + if displayThousandsSep then a else a{astyle=(astyle a){asdigitgroups=Nothing}} (quantity', comm) - | amountLooksZero a && not (displayZeroCommodity opts) = (WideBuilder (TB.singleton '0') 1, "") + | 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 -- concatenate these texts, -- or return the empty text if there's a commodity display order. XXX why ? - showC l r = if isJust (displayOrder opts) then mempty else l <> r - price = if displayPrice opts then showAmountPrice a else mempty + showC l r = if isJust displayOrder then mempty else l <> r + price = if displayPrice then showAmountPrice a else mempty -- | Colour version. For a negative amount, adds ANSI codes to change the colour, -- currently to hard-coded red. @@ -569,10 +697,10 @@ -- | 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. --- A special case: if it is showing digit group separators but no decimal places, --- show a decimal mark (with nothing after it) to make it easier to parse correctly. -showamountquantity :: Amount -> WideBuilder -showamountquantity amt@Amount{astyle=AmountStyle{asdecimalmark=mdec, asdigitgroups=mgrps}} = +-- With a true first argument, if there are no decimal digits but there are digit group separators, +-- it shows the amount with a trailing decimal mark to help disambiguate it for parsing. +showAmountQuantity :: Bool -> Amount -> WideBuilder +showAmountQuantity disambiguate amt@Amount{astyle=AmountStyle{asdecimalmark=mdec, asdigitgroups=mgrps}} = signB <> intB <> fracB where Decimal decplaces mantissa = amountRoundedQuantity amt @@ -584,13 +712,13 @@ (intPart, fracPart) = T.splitAt intLen numtxtwithzero intB = applyDigitGroupStyle mgrps intLen $ if decplaces == 0 then numtxt else intPart signB = if mantissa < 0 then WideBuilder (TB.singleton '-') 1 else mempty - fracB = if decplaces > 0 || isshowingdigitgroupseparator + fracB = if decplaces > 0 || (isshowingdigitgroupseparator && disambiguate) then WideBuilder (TB.singleton dec <> TB.fromText fracPart) (1 + fromIntegral decplaces) else mempty - - isshowingdigitgroupseparator = case mgrps of - Just (DigitGroups _ (rightmostgrplen:_)) -> intLen > fromIntegral rightmostgrplen - _ -> False + where + isshowingdigitgroupseparator = case mgrps of + Just (DigitGroups _ (rightmostgrplen:_)) -> intLen > fromIntegral rightmostgrplen + _ -> False -- | Given an integer as text, and its length, apply the given DigitGroupStyle, -- inserting digit group separators between digit groups where appropriate. @@ -611,8 +739,6 @@ ------------------------------------------------------------------------------- -- MixedAmount -instance HasAmounts MixedAmount where styleAmounts = mixedAmountSetStyles - instance Semigroup MixedAmount where (<>) = maPlus sconcat = maSum @@ -718,14 +844,12 @@ _ -> Nothing -- multiple amounts with different signs -- | Does this mixed amount appear to be zero when rendered with its display precision? --- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero), --- and zero quantity for each unit price? +-- See amountLooksZero. mixedAmountLooksZero :: MixedAmount -> Bool mixedAmountLooksZero (Mixed ma) = all amountLooksZero ma -- | Is this mixed amount exactly zero, ignoring its display precision? --- i.e. does it have zero quantity with no price, zero quantity with a total price (which is also zero), --- and zero quantity for each unit price? +-- See amountIsZero. mixedAmountIsZero :: MixedAmount -> Bool mixedAmountIsZero (Mixed ma) = all amountIsZero ma @@ -871,35 +995,38 @@ -- where a' = mixedAmountStripPrices a -- b' = mixedAmountStripPrices b --- Mixed amount styling --- v1 +-- Mixed amount styles --- | Canonicalise a mixed amount's display styles using the provided commodity style map. --- Cost amounts, if any, are not affected. +-- v1 +{-# DEPRECATED canonicaliseMixedAmount "please use mixedAmountSetStyle False (or styleAmounts) instead" #-} canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount -canonicaliseMixedAmount styles = mapMixedAmountUnsafe (canonicaliseAmount styles) -{-# DEPRECATED canonicaliseMixedAmount "please use mixedAmountSetMainStyle (or mixedAmountSetStyles) instead" #-} +canonicaliseMixedAmount = styleAmounts -- v2 - +{-# DEPRECATED styleMixedAmount "please use styleAmounts instead" #-} -- | Given a map of standard commodity display styles, find and apply -- the appropriate style to each individual amount. styleMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount -styleMixedAmount = mixedAmountSetStyles -{-# DEPRECATED styleMixedAmount "please use mixedAmountSetStyles instead" #-} +styleMixedAmount = styleAmounts -- v3 - +{-# DEPRECATED mixedAmountSetStyles "please use styleAmounts instead" #-} mixedAmountSetStyles :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount -mixedAmountSetStyles styles = mapMixedAmountUnsafe (amountSetStyles styles) +mixedAmountSetStyles = styleAmounts -mixedAmountSetStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount -mixedAmountSetStylesExceptPrecision styles = mapMixedAmountUnsafe (amountSetStylesExceptPrecision styles) +-- v4 +instance HasAmounts MixedAmount where + styleAmounts styles = mapMixedAmountUnsafe (styleAmounts styles) +instance HasAmounts Account where + styleAmounts styles acct@Account{aebalance,aibalance} = + acct{aebalance=styleAmounts styles aebalance, aibalance=styleAmounts styles aibalance} + -- | Reset each individual amount's display style to the default. mixedAmountUnstyled :: MixedAmount -> MixedAmount mixedAmountUnstyled = mapMixedAmountUnsafe amountUnstyled +-- Mixed amount rendering -- | Get the string representation of a mixed amount, after -- normalising it to one amount per commodity. Assumes amounts have @@ -1087,6 +1214,16 @@ mixedAmountSetFullPrecision :: MixedAmount -> MixedAmount mixedAmountSetFullPrecision = mapMixedAmountUnsafe amountSetFullPrecision +-- | 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 +mixedAmountSetPrecisionMin p = mapMixedAmountUnsafe (amountSetPrecisionMin p) + +-- | In each component amount, ensure the display precision is at most the given value. +-- Makes all amounts have an explicit Precision. +mixedAmountSetPrecisionMax :: Word8 -> MixedAmount -> MixedAmount +mixedAmountSetPrecisionMax p = mapMixedAmountUnsafe (amountSetPrecisionMax p) + -- | Remove all prices from a MixedAmount. mixedAmountStripPrices :: MixedAmount -> MixedAmount mixedAmountStripPrices (Mixed ma) = @@ -1120,8 +1257,8 @@ (usd (-1.23) + usd (-1.23)) @?= usd (-2.46) sum [usd 1.23,usd (-1.23),usd (-1.23),-(usd (-1.23))] @?= usd 0 -- highest precision is preserved - asprecision (astyle $ sum [usd 1 `withPrecision` Precision 1, usd 1 `withPrecision` Precision 3]) @?= Just (Precision 3) - asprecision (astyle $ sum [usd 1 `withPrecision` Precision 3, usd 1 `withPrecision` Precision 1]) @?= Just (Precision 3) + asprecision (astyle $ sum [usd 1 `withPrecision` Precision 1, usd 1 `withPrecision` Precision 3]) @?= Precision 3 + asprecision (astyle $ sum [usd 1 `withPrecision` Precision 3, usd 1 `withPrecision` Precision 1]) @?= Precision 3 -- adding different commodities assumes conversion rate 1 assertBool "" $ amountLooksZero (usd 1.23 - eur 1.23) diff --git a/Hledger/Data/Balancing.hs b/Hledger/Data/Balancing.hs --- a/Hledger/Data/Balancing.hs +++ b/Hledger/Data/Balancing.hs @@ -57,6 +57,7 @@ import Hledger.Data.Posting import Hledger.Data.Transaction import Hledger.Data.Errors +import Data.Bifunctor (second) data BalancingOpts = BalancingOpts @@ -93,6 +94,7 @@ transactionCheckBalanced :: BalancingOpts -> Transaction -> [String] transactionCheckBalanced BalancingOpts{commodity_styles_} t = errs where + -- get real and balanced virtual postings, to be checked separately (rps, bvps) = foldr partitionPosting ([], []) $ tpostings t where partitionPosting p ~(l, r) = case ptype p of @@ -100,24 +102,30 @@ BalancedVirtualPosting -> (l, p:r) VirtualPosting -> (l, r) - -- check for mixed signs, detecting nonzeros at display precision - setstyles = maybe id mixedAmountSetStyles commodity_styles_ + -- 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 | otherwise = mixedAmountCost $ pamount p - signsOk ps = - case filter (not.mixedAmountLooksZero) $ map (setstyles.postingBalancingAmount) ps of - nonzeros | length nonzeros >= 2 - -> length (nubSort $ mapMaybe isNegativeMixedAmount nonzeros) > 1 - _ -> True - (rsignsok, bvsignsok) = (signsOk rps, signsOk bvps) - -- check for zero sum, at display precision - (rsumcost, bvsumcost) = (foldMap postingBalancingAmount rps, foldMap postingBalancingAmount bvps) - (rsumdisplay, bvsumdisplay) = (setstyles rsumcost, setstyles bvsumcost) - (rsumok, bvsumok) = (mixedAmountLooksZero rsumdisplay, mixedAmountLooksZero bvsumdisplay) + -- transaction balancedness is checked at each commodity's display precision + lookszero = mixedAmountLooksZero . atdisplayprecision + where + atdisplayprecision = maybe id styleAmounts $ commodity_styles_ - -- generate error messages, showing amounts with their original precision + -- when there's multiple non-zeros, check they do not all have the same sign + (rsignsok, bvsignsok) = (signsOk rps, signsOk bvps) + where + signsOk ps = length nonzeros < 2 || length nonzerosigns > 1 + where + nonzeros = filter (not.lookszero) $ map postingBalancingAmount ps + nonzerosigns = nubSort $ mapMaybe isNegativeMixedAmount nonzeros + + -- check that the sum looks like zero + (rsumcost, bvsumcost) = (foldMap postingBalancingAmount rps, foldMap postingBalancingAmount bvps) + (rsumok, bvsumok) = (lookszero rsumcost, lookszero bvsumcost) + + -- Generate error messages if any. Show amounts with their original precisions. errs = filter (not.null) [rmsg, bvmsg] where rmsg @@ -160,10 +168,12 @@ -> Transaction -> Either String (Transaction, [(AccountName, MixedAmount)]) balanceTransactionHelper bopts t = do - (t', inferredamtsandaccts) <- - transactionInferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) $ - (if infer_balancing_costs_ bopts then transactionInferBalancingCosts else id) - t + let lbl = lbl_ "balanceTransactionHelper" + (t', inferredamtsandaccts) <- t + & (if infer_balancing_costs_ bopts then transactionInferBalancingCosts else id) + & dbg9With (lbl "amounts after balancing-cost-inferring".show.map showMixedAmountOneLine.transactionAmounts) + & transactionInferBalancingAmount (fromMaybe M.empty $ commodity_styles_ bopts) + <&> dbg9With (lbl "balancing amounts inferred".show.map (second showMixedAmountOneLine).snd) case transactionCheckBalanced bopts t' of [] -> Right (txnTieKnot t', inferredamtsandaccts) errs -> Left $ transactionBalanceError t' errs' @@ -227,10 +237,16 @@ | otherwise = let psandinferredamts = map inferamount ps inferredacctsandamts = [(paccount p, amt) | (p, Just amt) <- psandinferredamts] - in Right (t{tpostings=map fst psandinferredamts}, inferredacctsandamts) + in Right ( + t{tpostings=map fst psandinferredamts} + ,inferredacctsandamts + -- & dbg9With (lbl "inferred".show.map (showMixedAmountOneLine.snd)) + ) where + lbl = lbl_ "transactionInferBalancingAmount" (amountfulrealps, amountlessrealps) = partition hasAmount (realPostings t) realsum = sumPostings amountfulrealps + -- & dbg9With (lbl "real balancing amount".showMixedAmountOneLine) (amountfulbvps, amountlessbvps) = partition hasAmount (balancedVirtualPostings t) bvsum = sumPostings amountfulbvps @@ -250,7 +266,17 @@ -- Inferred amounts are converted to cost. -- Also ensure the new amount has the standard style for its commodity -- (since the main amount styling pass happened before this balancing pass); - a' = mixedAmountSetStyles styles . mixedAmountCost $ maNegate a + a' = maNegate a + -- & dbg9With (lbl "balancing amount".showMixedAmountOneLine) + & mixedAmountCost + -- & dbg9With (lbl "balancing amount converted to cost".showMixedAmountOneLine) + & styleAmounts (styles + -- Needed until we switch to locally-inferred balancing precisions: + -- these had hard rounding set to help with balanced-checking; + -- set no rounding now to avoid excessive display precision in output + & amountStylesSetRounding NoRounding + & dbg9With (lbl "balancing amount styles".show)) + & dbg9With (lbl "balancing amount styled".showMixedAmountOneLine) -- | Infer costs for this transaction's posting amounts, if needed to make -- the postings balance, and if permitted. This is done once for the real @@ -302,6 +328,7 @@ costInferrerFor :: Transaction -> PostingType -> (Posting -> Posting) costInferrerFor t pt = maybe id infercost inferFromAndTo where + lbl = lbl_ "costInferrerFor" postings = filter ((==pt).ptype) $ tpostings t pcommodities = map acommodity $ concatMap (amounts . pamount) postings sumamounts = amounts $ sumPostings postings -- amounts normalises to one amount per commodity & price @@ -326,7 +353,8 @@ infercost (fromamount, toamount) p | [a] <- amounts (pamount p), ptype p == pt, acommodity a == acommodity fromamount = p{ pamount = mixedAmount a{aprice=Just conversionprice} - , poriginal = Just $ originalPosting p } + & 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. @@ -337,8 +365,8 @@ unitprice = aquantity fromamount `divideAmount` toamount unitprecision = case (asprecision $ astyle fromamount, asprecision $ astyle toamount) of - (Just (Precision a), Just (Precision b)) -> Precision . max 2 $ saturatedAdd a b - _ -> NaturalPrecision + (Precision a, Precision b) -> Precision . max 2 $ saturatedAdd a b + _ -> NaturalPrecision saturatedAdd a b = if maxBound - a < b then maxBound else a + b @@ -441,18 +469,24 @@ -- and (optional) check that all balance assertions pass. -- Or, return an error message (just the first error encountered). -- --- Assumes journalInferCommodityStyles has been called, since those +-- Assumes journalStyleAmounts has been called, since amount styles -- affect transaction balancing. -- -- This does multiple things at once because amount inferring, balance -- assignments, balance assertions and posting dates are interdependent. +-- journalBalanceTransactions :: BalancingOpts -> Journal -> Either String Journal journalBalanceTransactions bopts' j' = let -- ensure transactions are numbered, so we can store them by number j@Journal{jtxns=ts} = journalNumberTransactions j' -- display precisions used in balanced checking - styles = Just $ journalCommodityStyles j + styles = Just $ + -- Use all the specified commodity display precisions, with hard rounding, when checking txn balancedness. + -- XXX Problem, those precisions will also be used when inferring balancing amounts; + -- it would be better to give those the precision of the amount they are balancing. + journalCommodityStylesWith HardRounding + j bopts = bopts'{commodity_styles_=styles} -- XXX ^ The commodity directive styles and default style and inferred styles -- are merged into the command line styles in commodity_styles_ - why ? @@ -504,7 +538,8 @@ -- This stores the balanced transactions in case 2 but not in case 1. balanceTransactionAndCheckAssertionsB :: Either Posting Transaction -> Balancing s () balanceTransactionAndCheckAssertionsB (Left p@Posting{}) = - -- update the account's running balance and check the balance assertion if any + -- 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 balanceTransactionAndCheckAssertionsB (Right t@Transaction{tpostings=ps}) = do -- make sure we can handle the balance assignments @@ -1008,26 +1043,26 @@ -- testCase "1091a" $ do commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Just $ Precision 3)} - ,nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 2)} + nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Precision 3) NoRounding} + ,nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 2) NoRounding} ] @?= -- The commodity style should have period as decimal mark -- and comma as digit group mark. Right (M.fromList [ - ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 3)) + ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 3) NoRounding) ]) -- same journal, entries in reverse order ,testCase "1091b" $ do commodityStylesFromAmounts [ - nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 2)} - ,nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Just $ Precision 3)} + nullamt{aquantity=1000, astyle=AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 2) NoRounding} + ,nullamt{aquantity=1000, astyle=AmountStyle L False Nothing (Just ',') (Precision 3) NoRounding} ] @?= -- The commodity style should have period as decimal mark -- and comma as digit group mark. Right (M.fromList [ - ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Just $ Precision 3)) + ("", AmountStyle L False (Just (DigitGroups ',' [3])) (Just '.') (Precision 3) NoRounding) ]) ] diff --git a/Hledger/Data/Errors.hs b/Hledger/Data/Errors.hs --- a/Hledger/Data/Errors.hs +++ b/Hledger/Data/Errors.hs @@ -21,6 +21,7 @@ import qualified Data.Text as T import Hledger.Data.Transaction (showTransaction) +import Hledger.Data.Posting (postingStripPrices) import Hledger.Data.Types import Hledger.Utils import Data.Maybe @@ -118,7 +119,9 @@ Just t -> (f, errabsline, merrcols, ex) where (SourcePos f tl _) = fst $ tsourcepos t - mpindex = transactionFindPostingIndex (==p) t + -- p had cost removed in balanceTransactionAndCheckAssertionsB, + -- must remove them from t's postings too (#2083) + mpindex = transactionFindPostingIndex ((==p).postingStripPrices) 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 @@ -22,9 +22,11 @@ addPeriodicTransaction, addTransaction, journalInferMarketPricesFromTransactions, - journalApplyCommodityStyles, + journalInferCommodityStyles, + journalStyleAmounts, commodityStylesFromAmounts, journalCommodityStyles, + journalCommodityStylesWith, journalToCost, journalInferEquityFromCosts, journalInferCostsFromEquity, @@ -84,6 +86,8 @@ journalNextTransaction, journalPrevTransaction, journalPostings, + journalPostingAmounts, + showJournalAmountsDebug, journalTransactionsSimilarTo, -- * Account types journalAccountType, @@ -144,6 +148,7 @@ import Data.Ord (comparing) import Hledger.Data.Dates (nulldate) import Data.List (sort) +-- import Data.Function ((&)) -- | A parser of text that runs in some monad, keeping a Journal as state. @@ -340,6 +345,14 @@ journalPostings :: Journal -> [Posting] journalPostings = concatMap tpostings . jtxns +-- | All posting amounts from this journal, in order. +journalPostingAmounts :: Journal -> [MixedAmount] +journalPostingAmounts = map pamount . journalPostings + +-- | Show the journal amounts rendered, suitable for debug logging. +showJournalAmountsDebug :: Journal -> String +showJournalAmountsDebug = show.map showMixedAmountOneLine.journalPostingAmounts + -- | Sorted unique commodity symbols declared by commodity directives in this journal. journalCommoditiesDeclared :: Journal -> [CommoditySymbol] journalCommoditiesDeclared = M.keys . jcommodities @@ -792,18 +805,19 @@ Right ts -> Right j{jtxns=ts} Left err -> Left err --- | Choose and apply a consistent display style to the posting --- amounts in each commodity (see journalCommodityStyles), --- keeping all display precisions unchanged. --- Can return an error message eg if inconsistent number formats are found. -journalApplyCommodityStyles :: Journal -> Either String Journal -journalApplyCommodityStyles = fmap fixjournal . journalInferCommodityStyles +-- | Apply this journal's commodity display styles to all of its amounts. +-- This does no display rounding, keeping decimal digits as they were; +-- it is suitable for an early cleanup pass before calculations. +-- Reports may want to do additional rounding/styling at render time. +-- This can return an error message eg if inconsistent number formats are found. +journalStyleAmounts :: Journal -> Either String Journal +journalStyleAmounts = fmap journalapplystyles . journalInferCommodityStyles where - fixjournal j@Journal{jpricedirectives=pds} = - journalMapPostings (postingApplyCommodityStylesExceptPrecision styles) j{jpricedirectives=map fixpricedirective pds} + journalapplystyles j@Journal{jpricedirectives=pds} = + journalMapPostings (styleAmounts styles) j{jpricedirectives=map fixpricedirective pds} where - styles = journalCommodityStyles j - fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=amountSetStylesExceptPrecision styles a} + styles = journalCommodityStylesWith NoRounding j -- defer rounding, in case of print --round=none + fixpricedirective pd@PriceDirective{pdamount=a} = pd{pdamount=styleAmounts styles a} -- | Get the canonical amount styles for this journal, whether (in order of precedence): -- set globally in InputOpts, @@ -821,6 +835,11 @@ declaredstyles = M.mapMaybe cformat $ jcommodities j defaultcommoditystyle = M.fromList $ catMaybes [jparsedefaultcommodity j] inferredstyles = jinferredcommodities j + +-- | Like journalCommodityStyles, but attach a particular rounding strategy to the styles, +-- affecting how they will affect display precisions when applied. +journalCommodityStylesWith :: Rounding -> Journal -> M.Map CommoditySymbol AmountStyle +journalCommodityStylesWith r = amountStylesSetRounding r . journalCommodityStyles -- | Collect and save inferred amount styles for each commodity based on -- the posting amounts in that commodity (excluding price amounts), ie: diff --git a/Hledger/Data/Json.hs b/Hledger/Data/Json.hs --- a/Hledger/Data/Json.hs +++ b/Hledger/Data/Json.hs @@ -82,6 +82,7 @@ ] instance ToJSON Amount +instance ToJSON Rounding instance ToJSON AmountStyle -- Use the same JSON serialisation as Maybe Word8 @@ -165,20 +166,21 @@ #endif => Account -> [kv] accountKV a = - [ "aname" .= aname a - , "aebalance" .= aebalance a - , "aibalance" .= aibalance a - , "anumpostings" .= anumpostings a - , "aboring" .= aboring a + [ "aname" .= aname a + , "adeclarationinfo" .= adeclarationinfo a + , "aebalance" .= aebalance a + , "aibalance" .= aibalance a + , "anumpostings" .= anumpostings a + , "aboring" .= aboring a -- To avoid a cycle, show just the parent account's name -- in a dummy field. When re-parsed, there will be no parent. - , "aparent_" .= maybe "" aname (aparent a) + , "aparent_" .= maybe "" aname (aparent a) -- Just the names of subaccounts, as a dummy field, ignored when parsed. - , "asubs_" .= map aname (asubs a) + , "asubs_" .= map aname (asubs a) -- The actual subaccounts (and their subs..), making a (probably highly redundant) tree -- ,"asubs" .= asubs a -- Omit the actual subaccounts - , "asubs" .= ([]::[Account]) + , "asubs" .= ([]::[Account]) ] instance ToJSON Ledger @@ -192,6 +194,7 @@ parseJSON = fmap mkPos . parseJSON instance FromJSON Amount +instance FromJSON Rounding instance FromJSON AmountStyle -- Use the same JSON serialisation as Maybe Word8 diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -39,7 +39,7 @@ postingStripPrices, postingApplyAliases, postingApplyCommodityStyles, - postingApplyCommodityStylesExceptPrecision, + postingStyleAmounts, postingAddTags, -- * date operations postingDate, @@ -52,6 +52,7 @@ -- * comment/tag operations commentJoin, commentAddTag, + commentAddTagUnspaced, commentAddTagNextLine, -- * arithmetic sumPostings, @@ -60,7 +61,10 @@ showPostingLines, postingAsLines, postingsAsLines, + postingsAsLinesBeancount, + postingAsLinesBeancount, showAccountName, + showAccountNameBeancount, renderCommentLines, showBalanceAssertion, -- * misc. @@ -107,6 +111,19 @@ ,pbalanceassertion=styleAmounts styles pbalanceassertion } +{-# DEPRECATED postingApplyCommodityStyles "please use styleAmounts instead" #-} +-- | Find and apply the appropriate display style to the posting amounts +-- in each commodity (see journalCommodityStyles). +-- Main amount precisions may be set or not according to the styles, but cost precisions are not set. +postingApplyCommodityStyles :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting +postingApplyCommodityStyles = styleAmounts + +{-# DEPRECATED postingStyleAmounts "please use styleAmounts instead" #-} +-- | Like postingApplyCommodityStyles, but neither +-- main amount precisions or cost precisions are set. +postingStyleAmounts :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting +postingStyleAmounts = styleAmounts + nullposting, posting :: Posting nullposting = Posting {pdate=Nothing @@ -274,7 +291,10 @@ -- amtwidth at all. shownAmounts | elideamount = [mempty] - | otherwise = showMixedAmountLinesB noColour{displayZeroCommodity=True, displayOneLine=onelineamounts} $ pamount p + | otherwise = showMixedAmountLinesB displayopts $ pamount p + where displayopts = noColour{ + displayZeroCommodity=True, displayAddDecimalMark=True, displayOneLine=onelineamounts + } thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts -- when there is a balance assertion, show it only on the last posting line @@ -301,6 +321,91 @@ fmt VirtualPosting = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w +-- | Like postingsAsLines but generates Beancount journal format. +postingsAsLinesBeancount :: [Posting] -> [Text] +postingsAsLinesBeancount ps = concatMap first3 linesWithWidths + where + linesWithWidths = map (postingAsLinesBeancount False maxacctwidth maxamtwidth) ps + maxacctwidth = maximumBound 0 $ map second3 linesWithWidths + maxamtwidth = maximumBound 0 $ map third3 linesWithWidths + +-- | Like postingAsLines but generates Beancount journal format. +postingAsLinesBeancount :: Bool -> Int -> Int -> Posting -> ([Text], Int, Int) +postingAsLinesBeancount elideamount acctwidth amtwidth p = + (concatMap (++ newlinecomments) postingblocks, thisacctwidth, thisamtwidth) + where + -- This needs to be converted to strict Text in order to strip trailing + -- spaces. This adds a small amount of inefficiency, and the only difference + -- is whether there are trailing spaces in print (and related) reports. This + -- could be removed and we could just keep everything as a Text Builder, but + -- would require adding trailing spaces to 42 failing tests. + postingblocks = [map T.stripEnd . T.lines . TL.toStrict $ + render [ textCell BottomLeft statusandaccount + , textCell BottomLeft " " + , Cell BottomLeft [pad amt] + , textCell BottomLeft samelinecomment + ] + | (amt,_assertion) <- shownAmountsAssertions] + render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header + pad amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt + where w = max 12 amtwidth - wbWidth amt -- min. 12 for backwards compatibility + + pacct = showAccountNameBeancount Nothing $ paccount p + pstatusandacct p' = if pstatus p' == Pending then "! " else "" <> pacct + + -- currently prices are considered part of the amount string when right-aligning amounts + -- Since we will usually be calling this function with the knot tied between + -- amtwidth and thisamtwidth, make sure thisamtwidth does not depend on + -- amtwidth at all. + shownAmounts + | elideamount = [mempty] + | otherwise = showMixedAmountLinesB displayopts a' + where + displayopts = noColour{ displayZeroCommodity=True, displayAddDecimalMark=True } + a' = mapMixedAmount amountToBeancount $ pamount p + thisamtwidth = maximumBound 0 $ map wbWidth shownAmounts + + -- when there is a balance assertion, show it only on the last posting line + shownAmountsAssertions = zip shownAmounts shownAssertions + where + shownAssertions = replicate (length shownAmounts - 1) mempty ++ [assertion] + where + assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p + + -- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned + statusandaccount = lineIndent . fitText (Just $ 2 + acctwidth) Nothing False True $ pstatusandacct p + thisacctwidth = realLength pacct + + (samelinecomment, newlinecomments) = + case renderCommentLines (pcomment p) of [] -> ("",[]) + c:cs -> (c,cs) + +type BeancountAmount = Amount + +-- | Do some best effort adjustments to make an amount that renders +-- 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'} + -- https://beancount.github.io/docs/beancount_language_syntax.html#commodities-currencies + where + c' = T.toUpper $ + T.replace "$" "USD" $ + T.replace "€" "EUR" $ + T.replace "¥" "JPY" $ + T.replace "£" "GBP" $ + c + s' = s{ascommodityside=R, ascommodityspaced=True} + mp' = costToBeancount <$> mp + where + costToBeancount (TotalPrice amt) = TotalPrice $ amountToBeancount amt + costToBeancount (UnitPrice amt) = UnitPrice $ amountToBeancount amt + +-- | Like showAccountName for Beancount journal format. +-- Calls accountNameToBeancount first. +showAccountNameBeancount :: Maybe Int -> AccountName -> Text +showAccountNameBeancount w = maybe id T.take w . accountNameToBeancount + -- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. -- The first line (unless empty) will have leading space, subsequent lines will have a larger indent. renderCommentLines :: Text -> [Text] @@ -419,23 +524,6 @@ err = "problem while applying account aliases:\n" ++ pshow aliases ++ "\n to account name: "++T.unpack paccount++"\n "++e --- | Find and apply the appropriate display style to the posting amounts --- in each commodity (see journalCommodityStyles). --- Main amount precisions may be set or not according to the styles, but cost precisions are not set. -postingApplyCommodityStyles :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting -postingApplyCommodityStyles styles p = p{pamount=mixedAmountSetStyles styles $ pamount p - ,pbalanceassertion=balanceassertionsetstyles <$> pbalanceassertion p} - where - balanceassertionsetstyles ba = ba{baamount=amountSetStyles styles $ baamount ba} - --- | Like postingApplyCommodityStyles, but neither --- main amount precisions or cost precisions are set. -postingApplyCommodityStylesExceptPrecision :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting -postingApplyCommodityStylesExceptPrecision styles p = p{pamount=mixedAmountSetStylesExceptPrecision styles $ pamount p - ,pbalanceassertion=balanceassertionsetstyles <$> pbalanceassertion p} - where - balanceassertionsetstyles ba = ba{baamount=amountSetStylesExceptPrecision styles $ baamount ba} - -- | Add tags to a posting, discarding any for which the posting already has a value. postingAddTags :: Posting -> [Tag] -> Posting postingAddTags p@Posting{ptags} tags = p{ptags=ptags `union` tags} @@ -523,6 +611,15 @@ where c' = T.stripEnd c tag = t <> ": " <> v + +-- | Like commentAddTag, but omits the space after the colon. +commentAddTagUnspaced :: Text -> Tag -> Text +commentAddTagUnspaced c (t,v) + | T.null c' = tag + | otherwise = c' `commentJoin` tag + where + c' = T.stripEnd c + tag = t <> ":" <> v -- | Add a tag on its own line to a comment, preserving any prior content. -- A space is inserted following the colon, before the value. diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -32,6 +32,7 @@ , transactionApplyAliases , transactionMapPostings , transactionMapPostingAmounts +, transactionAmounts , partitionAndCheckConversionPostings -- nonzerobalanceerror -- * date operations @@ -45,6 +46,7 @@ , showTransaction , showTransactionOneLineAmounts , showTransactionLineFirstPart +, showTransactionBeancount , transactionFile -- * transaction errors , annotateErrorWithTransaction @@ -113,6 +115,12 @@ where (p, n) = T.span (/= '|') t +-- | Like payeeAndNoteFromDescription, but if there's no | then payee is empty. +payeeAndNoteFromDescription' :: Text -> (Text,Text) +payeeAndNoteFromDescription' t = + if isJust $ T.find (=='|') t then payeeAndNoteFromDescription t else ("",t) + + {-| Render a journal transaction as text similar to the style of Ledger's print command. @@ -168,6 +176,33 @@ | otherwise = "" code = if T.null (tcode t) then "" else wrap " (" ")" $ tcode t +-- | Like showTransaction, but generates Beancount journal format. +showTransactionBeancount :: Transaction -> Text +showTransactionBeancount t = + -- https://beancount.github.io/docs/beancount_language_syntax.html + -- similar to showTransactionHelper, but I haven't bothered with Builder + firstline <> nl + <> foldMap ((<> nl)) newlinecomments + <> foldMap ((<> nl)) (postingsAsLinesBeancount $ tpostings t) + <> nl + where + nl = "\n" + firstline = T.concat [date, status, payee, note, tags, samelinecomment] + date = showDate $ tdate t + status = if tstatus t == Pending then " !" else " *" + (payee,note) = + case payeeAndNoteFromDescription' $ tdescription t of + ("","") -> ("", "" ) + ("",n ) -> ("" , wrapq n ) + (p ,"") -> (wrapq p, wrapq "") + (p ,n ) -> (wrapq p, wrapq n ) + where + wrapq = wrap " \"" "\"" . escapeDoubleQuotes . escapeBackslash + tags = T.concat $ map ((" #"<>).fst) $ ttags t + (samelinecomment, newlinecomments) = + case renderCommentLines (tcomment t) of [] -> ("",[]) + c:cs -> (c,cs) + hasRealPostings :: Transaction -> Bool hasRealPostings = not . null . realPostings @@ -378,11 +413,7 @@ 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 ? - -- (Or if that's unset, compare as-is) - amountsMatch a b = - case asprecision $ astyle a of - Just p -> amountLooksZero $ amountSetPrecision p $ a - b - Nothing -> amountLooksZero $ a - b + amountsMatch a b = amountLooksZero $ amountSetPrecision (asprecision $ astyle a) $ a - b -- Delete a posting from the indexed list of postings based on either its -- index or its posting amount. @@ -400,9 +431,8 @@ dbgShowAmountPrecision a = case asprecision $ astyle a of - Just (Precision n) -> show n - Just NaturalPrecision -> show $ decimalPlaces $ normalizeDecimal $ aquantity a - Nothing -> "unset" + Precision n -> show n + NaturalPrecision -> show $ decimalPlaces $ normalizeDecimal $ aquantity a -- Using the provided account types map, sort the given indexed postings -- into three lists of posting numbers (stored in two pairs), like so: @@ -449,6 +479,10 @@ -- | Apply a transformation to a transaction's posting amounts. transactionMapPostingAmounts :: (MixedAmount -> MixedAmount) -> Transaction -> Transaction transactionMapPostingAmounts f = transactionMapPostings (postingTransformAmount f) + +-- | All posting amounts from this transactin, in order. +transactionAmounts :: Transaction -> [MixedAmount] +transactionAmounts = map pamount . tpostings -- | The file path from which this transaction was parsed. transactionFile :: Transaction -> FilePath diff --git a/Hledger/Data/TransactionModifier.hs b/Hledger/Data/TransactionModifier.hs --- a/Hledger/Data/TransactionModifier.hs +++ b/Hledger/Data/TransactionModifier.hs @@ -25,7 +25,7 @@ import Hledger.Data.Transaction (txnTieKnot) import Hledger.Query (Query, filterQuery, matchesAmount, matchesPostingExtra, parseQuery, queryIsAmt, queryIsSym, simplifyQuery) -import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags, postingApplyCommodityStyles) +import Hledger.Data.Posting (commentJoin, commentAddTag, postingAddTags) import Hledger.Utils (dbg6, wrap) -- $setup @@ -109,7 +109,7 @@ -- The provided TransactionModifier's query text is saved as the tags' value. tmPostingRuleToFunction :: Bool -> M.Map CommoditySymbol AmountStyle -> Query -> T.Text -> TMPostingRule -> (Posting -> Posting) tmPostingRuleToFunction verbosetags styles query querytxt tmpr = - \p -> postingApplyCommodityStyles styles . renderPostingCommentDates $ pr + \p -> styleAmounts styles . renderPostingCommentDates $ pr { pdate = pdate pr <|> pdate p , pdate2 = pdate2 pr <|> pdate2 p , pamount = amount' p diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -249,16 +249,19 @@ data AmountPrice = UnitPrice !Amount | TotalPrice !Amount deriving (Eq,Ord,Generic,Show) --- | The display style for an amount. --- (See also Amount.AmountDisplayOpts). +-- | 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. data AmountStyle = AmountStyle { ascommodityside :: !Side, -- ^ show the symbol on the left or the right ? ascommodityspaced :: !Bool, -- ^ show a space between symbol and quantity ? asdigitgroups :: !(Maybe DigitGroupStyle), -- ^ show the integer part with these digit group marks, or not asdecimalmark :: !(Maybe Char), -- ^ show this character (should be . or ,) as decimal mark, or use the default (.) - asprecision :: !(Maybe AmountPrecision) -- ^ show this number of digits after the decimal point, or show as-is (leave precision unchanged) - -- XXX Making asprecision a maybe simplifies code for styling with or without precision, - -- but complicates the semantics (Nothing is useful only when setting style). + asprecision :: !AmountPrecision, -- ^ "display precision" - show this number of digits after the decimal point + 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. } deriving (Eq,Ord,Read,Generic) instance Show AmountStyle where @@ -269,6 +272,7 @@ , show asdigitgroups , show asdecimalmark , show asprecision + , show asrounding ] -- | The "display precision" for a hledger amount, by which we mean @@ -276,6 +280,16 @@ data AmountPrecision = Precision !Word8 -- ^ show this many decimal digits (0..255) | NaturalPrecision -- ^ show all significant decimal digits stored internally + deriving (Eq,Ord,Read,Show,Generic) + +-- | "Rounding strategy" - how to apply an AmountStyle's display precision +-- to a posting amount (and its cost, if any). +-- Mainly used to customise print's output, with --round=none|soft|hard|all. +data Rounding = + NoRounding -- ^ keep display precisions unchanged in amt and cost + | SoftRounding -- ^ do soft rounding of amt and cost amounts (show more or fewer decimal zeros to approximate the target precision, but don't hide significant digits) + | HardRounding -- ^ do hard rounding of amt (use the exact target precision, possibly hiding significant digits), and soft rounding of cost + | AllRounding -- ^ do hard rounding of amt and cost deriving (Eq,Ord,Read,Show,Generic) -- | A style for displaying digit groups in the integer part of a diff --git a/Hledger/Data/Valuation.hs b/Hledger/Data/Valuation.hs --- a/Hledger/Data/Valuation.hs +++ b/Hledger/Data/Valuation.hs @@ -25,6 +25,7 @@ ,marketPriceReverse ,priceDirectiveToMarketPrice ,amountPriceDirectiveFromCost + ,valuationTypeValuationCommodity -- ,priceLookup ,tests_Valuation ) @@ -47,6 +48,7 @@ import Hledger.Data.Amount import Hledger.Data.Dates (nulldate) import Text.Printf (printf) +import Data.Decimal (decimalPlaces, roundTo) ------------------------------------------------------------------------------ @@ -67,6 +69,14 @@ | AtDate Day (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using market prices on some date deriving (Show,Eq) +valuationTypeValuationCommodity :: ValuationType -> Maybe CommoditySymbol +valuationTypeValuationCommodity = \case + AtThen (Just c) -> Just c + AtEnd (Just c) -> Just c + AtNow (Just c) -> Just c + AtDate _ (Just c) -> Just c + _ -> Nothing + -- | A price oracle is a magic memoising function that efficiently -- looks up market prices (exchange rates) from one commodity to -- another (or if unspecified, to a default valuation commodity) on a @@ -97,22 +107,19 @@ , mprate = aquantity pdamount } --- | Make one or more `MarketPrice` from an 'Amount' and its price directives. +-- | Infer a market price from the given amount and its cost (if any), +-- and make a corresponding price directive on the given date. +-- 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=fromq} = case aprice amt of - Just (UnitPrice pa) -> Just $ pd{pdamount=pa} - Just (TotalPrice pa) | fromq /= 0 -> Just $ pd{pdamount=fromq `divideAmountExtraPrecision` pa} - _ -> Nothing +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 + _ -> Nothing where pd = PriceDirective{pddate = d, pdcommodity = fromcomm, pdamount = nullamt} - divideAmountExtraPrecision n a = (n `divideAmount` a) { astyle = style' } - where - style' = (astyle a) { asprecision = precision' } - precision' = case asprecision (astyle a) of - Just (Precision p) -> Just $ Precision $ (numDigitsInt $ truncate n) + p - mp -> mp - ------------------------------------------------------------------------------ -- Converting things to value @@ -129,7 +136,7 @@ -- | Convert an Amount to its cost if requested, and style it appropriately. amountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Amount -> Amount -amountToCost styles ToCost = amountSetStyles styles . amountCost +amountToCost styles ToCost = styleAmounts styles . amountCost amountToCost _ NoConversionOp = id -- | Apply a specified valuation to this amount, using the provided @@ -179,22 +186,32 @@ -- valuation date.) -- -- The returned amount will have its commodity's canonical style applied, --- but with the precision adjusted to show all significant decimal digits --- up to a maximum of 8. (experimental) +-- (with soft display rounding). -- -- If the market prices available on that date are not sufficient to -- calculate this value, the amount is left unchanged. +-- amountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount amountValueAtDate priceoracle styles mto d a = + let lbl = lbl_ "amountValueAtDate" in case priceoracle (d, acommodity a, mto) of Nothing -> a Just (comm, rate) -> - -- setNaturalPrecisionUpTo 8 $ -- XXX force higher precision in case amount appears to be zero ? - -- Make default display style use precision 2 instead of 0 ? - -- Leave as is for now; mentioned in manual. - amountSetStyles styles nullamt{acommodity=comm, aquantity=rate * aquantity a} + -- Manage style and precision of the new amount. Initially: + -- rate is a Decimal with the internal precision of the original market price declaration. + -- aquantity is a Decimal with a's internal precision. + -- The calculated value's internal precision may be different from these. + -- Its display precision will be that of nullamt (0). + -- Now apply the standard display style for comm (if there is one) + & styleAmounts styles + -- 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 + & dbg9With (lbl "calculated value".showAmount) + -- | Calculate the gain of each component amount, that is the difference -- between the valued amount and the value of the cost basis (see -- mixedAmountApplyValuation). @@ -266,7 +283,19 @@ of Nothing -> Nothing Just [] -> Nothing - Just ps -> Just (mpto $ last ps, product $ map mprate ps) + Just ps -> Just (mpto $ last ps, rate) + where + rates = map mprate ps + rate = + -- aggregate all the prices into one + product rates + -- product (Decimal's Num instance) normalises, stripping trailing zeros. + -- Here we undo that (by restoring the old max precision with roundTo), + -- so that amountValueAtDate can see the original internal precision, + -- to use as the display precision of calculated value amounts. + -- (This can add more than the original number of trailing zeros to some prices, + -- making them seem more precise than they were, but it seems harmless here.) + & roundTo (maximum $ map decimalPlaces rates) tests_priceLookup = let @@ -435,6 +464,8 @@ ,pgDefaultValuationCommodities=defaultdests } where + -- XXX logic duplicated in Hledger.Cli.Commands.Prices.prices, keep synced + -- prices in effect on date d, either declared or inferred visibledeclaredprices = dbg9 "visibledeclaredprices" $ filter ((<=d).mpdate) alldeclaredprices visibleinferredprices = dbg9 "visibleinferredprices" $ filter ((<=d).mpdate) allinferredprices diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -8,12 +8,80 @@ journal data or read journal files. Generally it should not be necessary to import modules below this one. +== Journal reading + +Reading an input file (in journal, csv, timedot, or timeclock format..) +involves these steps: + +- select an appropriate file format "reader" + based on filename extension/file path prefix/function parameter. + A reader contains a parser and a finaliser (usually @journalFinalise@). + +- run the parser to get a ParsedJournal + (this may run additional sub-parsers to parse included files) + +- run the finaliser to get a complete Journal, which passes standard checks + +- if reading multiple files: merge the per-file Journals into one + overall Journal + +- if using -s/--strict: run additional strict checks + +- if running print --new: save .latest files for each input file. + (import also does this, as its final step.) + +== Journal merging + +Journal implements the Semigroup class, so two Journals can be merged +into one Journal with @j1 <> j2@. This is implemented by the +@journalConcat@ function, whose documentation explains what merging +Journals means exactly. + +== Journal finalising + +This is post-processing done after parsing an input file, such as +inferring missing information, normalising amount styles, +checking for errors and so on - a delicate and influential stage +of data processing. +In hledger it is done by @journalFinalise@, which converts a +preliminary ParsedJournal to a validated, ready-to-use Journal. +This is called immediately after the parsing of each input file. +It is not called when Journals are merged. + +== Journal reading API + +There are three main Journal-reading functions: + +- readJournal to read from a Text value. + Selects a reader and calls its parser and finaliser, + then does strict checking if needed. + +- readJournalFile to read one file, or stdin if the file path is @-@. + Uses the file path/file name to help select the reader, + calls readJournal, + then writes .latest files if needed. + +- readJournalFiles to read multiple files. + Calls readJournalFile for each file (without strict checking or .latest file writing) + then merges the Journals into one, + then does strict checking and .latest file writing at the end if needed. + +Each of these also has an easier variant with ' suffix, +which uses default options and has a simpler type signature. + +One more variant, @readJournalFilesAndLatestDates@, is like +readJournalFiles but exposing the latest transaction date +(and how many on the same day) seen for each file. +This is used by the import command. + -} --- ** language {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} --- ** exports module Hledger.Read ( @@ -26,10 +94,11 @@ ensureJournalFileExists, -- * Journal parsing + runExceptT, readJournal, readJournalFile, readJournalFiles, - runExceptT, + readJournalFilesAndLatestDates, -- * Easy journal parsing readJournal', @@ -37,6 +106,10 @@ readJournalFiles', orDieTrying, + -- * Misc + journalStrictChecks, + saveLatestDates, + -- * Re-exported JournalReader.tmpostingrulep, findReader, @@ -53,7 +126,7 @@ --- ** imports import qualified Control.Exception as C import Control.Monad (unless, when) -import "mtl" Control.Monad.Except (ExceptT(..), runExceptT) +import "mtl" Control.Monad.Except (ExceptT(..), runExceptT, liftEither) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Default (def) import Data.Foldable (asum) @@ -85,6 +158,7 @@ -- import Hledger.Read.TimeclockReader (tests_TimeclockReader) import Hledger.Utils import Prelude hiding (getContents, writeFile) +import Hledger.Data.JournalChecks (journalCheckAccounts, journalCheckCommodities) --- ** doctest setup -- $setup @@ -126,7 +200,8 @@ -- | @readJournal iopts mfile txt@ -- --- Read a Journal from some text, or return an error message. +-- Read a Journal from some text, with strict checks if enabled, +-- or return an error message. -- -- The reader (data format) is chosen based on, in this order: -- @@ -137,16 +212,19 @@ -- - a file extension in @mfile@ -- -- If none of these is available, or if the reader name is unrecognised, --- we use the journal reader. (We used to try all readers in this case; --- since hledger 1.17, we prefer predictability.) +-- we use the journal reader (for predictability). +-- readJournal :: InputOpts -> Maybe FilePath -> Text -> ExceptT String IO Journal -readJournal iopts mpath txt = do +readJournal iopts@InputOpts{strict_} mpath txt = do let r :: Reader IO = fromMaybe JournalReader.reader $ findReader (mformat_ iopts) mpath dbg6IO "readJournal: trying reader" (rFormat r) - rReadFn r iopts (fromMaybe "(string)" mpath) txt + j <- rReadFn r iopts (fromMaybe "(string)" mpath) txt + when strict_ $ liftEither $ journalStrictChecks j + return j -- | Read a Journal from this file, or from stdin if the file path is -, --- or return an error message. The file path can have a READER: prefix. +-- with strict checks if enabled, or return an error message. +-- The file path can have a READER: prefix. -- -- The reader (data format) to use is determined from (in priority order): -- the @mformat_@ specified in the input options, if any; @@ -156,8 +234,25 @@ -- -- The input options can also configure balance assertion checking, automated posting -- generation, a rules file for converting CSV data, etc. +-- +-- If using --new, and if latest-file writing is enabled in input options, +-- and after passing strict checks if enabled, a .latest.FILE file will be created/updated +-- (for the main file only, not for included files), +-- to remember the latest transaction date (and how many transactions on this date) +-- successfully read. +-- readJournalFile :: InputOpts -> PrefixedFilePath -> ExceptT String IO Journal -readJournalFile iopts prefixedfile = do +readJournalFile iopts@InputOpts{new_, new_save_} prefixedfile = do + (j,latestdates) <- readJournalFileAndLatestDates iopts prefixedfile + when (new_ && new_save_) $ liftIO $ + saveLatestDates latestdates (snd $ splitReaderPrefix prefixedfile) + return j + +-- The implementation of readJournalFile, but with --new, +-- also returns the latest transaction date(s) read. +-- Used by readJournalFiles, to save those at the end. +readJournalFileAndLatestDates :: InputOpts -> PrefixedFilePath -> ExceptT String IO (Journal,LatestDates) +readJournalFileAndLatestDates iopts prefixedfile = do let (mfmt, f) = splitReaderPrefix prefixedfile iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]} @@ -168,25 +263,50 @@ -- <- T.readFile f -- or without line ending translation, for testing j <- readJournal iopts' (Just f) t if new_ iopts - then do - ds <- liftIO $ previousLatestDates f - let (newj, newds) = journalFilterSinceLatestDates ds j - when (new_save_ iopts && not (null newds)) . liftIO $ saveLatestDates newds f - return newj - else return j + then do + ds <- liftIO $ previousLatestDates f + let (newj, newds) = journalFilterSinceLatestDates ds j + return (newj, newds) + else + return (j, []) --- | Read a Journal from each specified file path and combine them into one. --- Or, return the first error message. +-- | Read a Journal from each specified file path (using @readJournalFile@) +-- and combine them into one; or return the first error message. +-- Strict checks, if enabled, are deferred till the end. +-- Writing .latest files, if enabled, is also deferred till the end, +-- and happens only if strict checks pass. -- -- Combining Journals means concatenating them, basically. -- The parse state resets at the start of each file, which means that -- directives & aliases do not affect subsequent sibling or parent files. -- They do affect included child files though. -- Also the final parse state saved in the Journal does span all files. +-- readJournalFiles :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO Journal -readJournalFiles iopts = - fmap (maybe def sconcat . nonEmpty) . mapM (readJournalFile iopts) +readJournalFiles iopts@InputOpts{strict_,new_,new_save_} prefixedfiles = do + let iopts' = iopts{strict_=False, new_save_=False} + (j,latestdates) <- + traceOrLogAt 6 ("readJournalFiles: "++show prefixedfiles) $ + readJournalFilesAndLatestDates iopts' prefixedfiles + when strict_ $ liftEither $ journalStrictChecks j + when (new_ && new_save_) $ liftIO $ + mapM_ (saveLatestDates latestdates . snd . splitReaderPrefix) prefixedfiles + return j +-- The implementation of readJournalFiles, but with --new, +-- also returns the latest transaction date(s) read in each file. +-- Used by the import command, to save those at the end. +readJournalFilesAndLatestDates :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO (Journal,LatestDates) +readJournalFilesAndLatestDates iopts = + fmap (maybe def sconcat . nonEmpty) . mapM (readJournalFileAndLatestDates iopts) + +-- | Run the extra -s/--strict checks on a journal, +-- returning the first error message if any of them fail. +journalStrictChecks :: Journal -> Either String () +journalStrictChecks j = do + journalCheckAccounts j + journalCheckCommodities j + -- | An easy version of 'readJournal' which assumes default options, and fails -- in the IO monad. readJournal' :: Text -> IO Journal @@ -255,10 +375,11 @@ -- Ie, if the latest date appears once, return it in a one-element list, -- if it appears three times (anywhere), return three of it. latestDates :: [Day] -> LatestDates -latestDates = headDef [] . take 1 . group . reverse . sort +latestDates = {-# HLINT ignore "Avoid reverse" #-} + headDef [] . take 1 . group . reverse . sort --- | Remember that these transaction dates were the latest seen when --- reading this journal file. +-- | Save the given latest date(s) seen in the given data FILE, +-- in a hidden file named .latest.FILE, creating it if needed. saveLatestDates :: LatestDates -> FilePath -> IO () saveLatestDates dates f = T.writeFile (latestDatesFileFor f) $ T.unlines $ map showDate dates diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -24,6 +24,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Functor law" #-} --- ** exports module Hledger.Read.Common ( @@ -96,6 +98,7 @@ emptyorcommentlinep, followingcommentp, transactioncommentp, + commenttagsp, postingcommentp, -- ** bracketed dates @@ -316,37 +319,39 @@ journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal journalFinalise iopts@InputOpts{..} f txt pj = do t <- liftIO getPOSIXTime - liftEither $ do - j <- pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_} + let + fname = "journalFinalise " <> takeFileName f + lbl = lbl_ fname + liftEither $ + pj{jglobalcommoditystyles=fromMaybe mempty $ commodity_styles_ balancingopts_} & journalSetLastReadTime t -- save the last read time & journalAddFile (f, txt) -- save the main file's info & journalReverse -- convert all lists to the order they were parsed & journalAddAccountTypes -- build a map of all known account types - & journalApplyCommodityStyles -- Infer and apply commodity styles - should be done early + & journalStyleAmounts -- Infer and apply commodity styles (but don't round) - should be done early <&> journalAddForecast (verbose_tags_) (forecastPeriod iopts pj) -- Add forecast transactions if enabled <&> journalPostingsAddAccountTags -- Add account tags to postings, so they can be matched by auto postings. + >>= journalMarkRedundantCosts -- Mark redundant costs, to help journalBalanceTransactions ignore them >>= (if auto_ && not (null $ jtxnmodifiers pj) - then journalAddAutoPostings verbose_tags_ _ioDay balancingopts_ -- Add auto postings if enabled, and account tags if needed + then journalAddAutoPostings verbose_tags_ _ioDay balancingopts_ -- Add auto postings if enabled, and account tags if needed. Does preliminary transaction balancing. else pure) -- XXX how to force debug output here ? -- >>= Right . dbg0With (concatMap (T.unpack.showTransaction).jtxns) -- >>= \j -> deepseq (concatMap (T.unpack.showTransaction).jtxns $ j) (return j) - >>= journalMarkRedundantCosts -- Mark redundant costs, to help journalBalanceTransactions ignore them - >>= journalBalanceTransactions balancingopts_ -- Balance all transactions and maybe check balance assertions. + <&> dbg9With (lbl "amounts after styling, forecasting, auto-posting".showJournalAmountsDebug) + >>= journalBalanceTransactions balancingopts_ -- infer balance assignments and missing amounts and maybe check balance assertions. + <&> dbg9With (lbl "amounts after transaction-balancing".showJournalAmountsDebug) + -- <&> dbg9With (("journalFinalise amounts after styling, forecasting, auto postings, transaction balancing"<>).showJournalAmountsDebug) + >>= journalInferCommodityStyles -- infer commodity styles once more now that all posting amounts are present + -- >>= Right . dbg0With (pshow.journalCommodityStyles) >>= (if infer_costs_ then journalInferCostsFromEquity else pure) -- Maybe infer costs from equity postings where possible <&> (if infer_equity_ then journalInferEquityFromCosts verbose_tags_ else id) -- Maybe infer equity postings from costs where possible + <&> dbg9With (lbl "amounts after equity-inferring".showJournalAmountsDebug) <&> journalInferMarketPricesFromTransactions -- infer market prices from commodity-exchanging transactions - <&> traceOrLogAt 6 ("journalFinalise: " <> takeFileName f) -- debug logging - <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> " acct decls : ") + -- <&> traceOrLogAt 6 fname -- debug logging + <&> dbgJournalAcctDeclOrder (fname <> ": acct decls : ") <&> journalRenumberAccountDeclarations - <&> dbgJournalAcctDeclOrder ("journalFinalise: " <> takeFileName f <> " acct decls renumbered: ") - when strict_ $ do - journalCheckAccounts j -- If in strict mode, check all postings are to declared accounts - journalCheckCommodities j -- and using declared commodities - -- journalCheckPairedConversionPostings j -- check conversion postings are in adjacent pairs - -- disabled for now, single conversion postings are sometimes needed eg with paypal - - return j + <&> dbgJournalAcctDeclOrder (fname <> ": acct decls renumbered: ") -- | Apply any auto posting rules to generate extra postings on this journal's transactions. -- With a true first argument, adds visible tags to generated postings and modified transactions. @@ -368,8 +373,9 @@ journalAddForecast _ Nothing j = j journalAddForecast verbosetags (Just forecastspan) j = j{jtxns = jtxns j ++ forecasttxns} where + {-# HLINT ignore "Move concatMap out" #-} forecasttxns = - map (txnTieKnot . transactionTransformPostings (postingApplyCommodityStyles $ journalCommodityStyles j)) + map (txnTieKnot . transactionTransformPostings (styleAmounts $ journalCommodityStyles j)) . filter (spanContainsDate forecastspan . tdate) . concatMap (\pt -> runPeriodicTransaction verbosetags pt forecastspan) $ jperiodictxns j @@ -802,7 +808,7 @@ offAfterNum <- getOffset let numRegion = (offBeforeNum, offAfterNum) (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent - let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=Just prec, asdecimalmark=mdec, asdigitgroups=mgrps} + 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} -- An amount with commodity symbol on the right or no commodity symbol. @@ -824,7 +830,7 @@ -- XXX amounts of this commodity in periodic transaction rules and auto posting rules ? #1461 let msuggestedStyle = mdecmarkStyle <|> mcommodityStyle (q,prec,mdec,mgrps) <- lift $ interpretNumber numRegion msuggestedStyle ambiguousRawNum mExponent - let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=Just prec, asdecimalmark=mdec, asdigitgroups=mgrps} + let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalmark=mdec, asdigitgroups=mgrps} return nullamt{acommodity=c, aquantity=sign q, astyle=s, aprice=Nothing} -- no symbol amount Nothing -> do @@ -840,8 +846,8 @@ -- (unless it's a multiplier in an automated posting) defcs <- getDefaultCommodityAndStyle let (c,s) = case (mult, defcs) of - (False, Just (defc,defs)) -> (defc, defs{asprecision=max (asprecision defs) (Just prec)}) - _ -> ("", amountstyle{asprecision=Just prec, asdecimalmark=mdec, asdigitgroups=mgrps}) + (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} -- For reducing code duplication. Doesn't parse anything. Has the type @@ -953,8 +959,9 @@ label "ledger-style lot cost" $ do char '{' doublebrace <- option False $ char '{' >> pure True - _fixed <- fmap isJust $ optional $ lift skipNonNewlineSpaces >> char '=' lift skipNonNewlineSpaces + _fixed <- fmap isJust $ optional $ char '=' + lift skipNonNewlineSpaces _a <- simpleamountp False lift skipNonNewlineSpaces char '}' @@ -1068,7 +1075,7 @@ isValidDecimalBy c = \case AmountStyle{asdecimalmark = Just d} -> d == c AmountStyle{asdigitgroups = Just (DigitGroups g _)} -> g /= c - AmountStyle{asprecision = Just (Precision 0)} -> False + AmountStyle{asprecision = Precision 0} -> False _ -> True -- | Parse and interpret the structure of a number without external hints. @@ -1572,24 +1579,24 @@ nullamt{ acommodity="$" ,aquantity=10 -- need to test internal precision with roundTo ? I think not - ,astyle=amountstyle{asprecision=Just $ Precision 0, asdecimalmark=Nothing} + ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing} ,aprice=Just $ UnitPrice $ nullamt{ acommodity="€" ,aquantity=0.5 - ,astyle=amountstyle{asprecision=Just $ Precision 1, asdecimalmark=Just '.'} + ,astyle=amountstyle{asprecision=Precision 1, asdecimalmark=Just '.'} } } ,testCase "total price" $ assertParseEq amountp "$10 @@ €5" nullamt{ acommodity="$" ,aquantity=10 - ,astyle=amountstyle{asprecision=Just $ Precision 0, asdecimalmark=Nothing} + ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing} ,aprice=Just $ TotalPrice $ nullamt{ acommodity="€" ,aquantity=5 - ,astyle=amountstyle{asprecision=Just $ Precision 0, asdecimalmark=Nothing} + ,astyle=amountstyle{asprecision=Precision 0, asdecimalmark=Nothing} } } ,testCase "unit price, parenthesised" $ assertParse amountp "$10 (@) €0.5" diff --git a/Hledger/Read/CsvUtils.hs b/Hledger/Read/CsvUtils.hs --- a/Hledger/Read/CsvUtils.hs +++ b/Hledger/Read/CsvUtils.hs @@ -13,6 +13,7 @@ module Hledger.Read.CsvUtils ( CSV, CsvRecord, CsvValue, printCSV, + printTSV, -- * Tests tests_CsvUtils, ) @@ -41,9 +42,15 @@ where printRecord = foldMap TB.fromText . intersperse "," . map printField printField = wrap "\"" "\"" . T.replace "\"" "\"\"" +printTSV :: [CsvRecord] -> TL.Text +printTSV = TB.toLazyText . unlinesB . map printRecord + where printRecord = foldMap TB.fromText . intersperse "\t" . map printField + printField = T.map replaceWhitespace + replaceWhitespace c | c `elem` ['\t', '\n', '\r'] = ' ' + replaceWhitespace c = c + --- ** tests tests_CsvUtils :: TestTree tests_CsvUtils = testGroup "CsvUtils" [ ] - diff --git a/Hledger/Read/RulesReader.hs b/Hledger/Read/RulesReader.hs --- a/Hledger/Read/RulesReader.hs +++ b/Hledger/Read/RulesReader.hs @@ -75,9 +75,10 @@ import Hledger.Data import Hledger.Utils -import Hledger.Read.Common (aliasesFromOpts, Reader(..), InputOpts(..), amountp, statusp, journalFinalise, accountnamep ) +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 @@ -258,7 +259,7 @@ type CsvRulesParsed = CsvRules' () -- | Type used after parsing is done. Directives, assignments and conditional blocks --- are in the same order as they were in the unput file and rblocksassigning is functional. +-- 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 @@ -300,7 +301,7 @@ type DateFormat = Text -- | A prefix for a matcher test, either & or none (implicit or). -data MatcherPrefix = And | None +data MatcherPrefix = And | Not | None deriving (Show, Eq) -- | A single test for matching a CSV record, in one way or another. @@ -372,10 +373,12 @@ ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? ) -FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs) +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+ @@ -660,7 +663,7 @@ matcherprefixp :: CsvRulesParser MatcherPrefix matcherprefixp = do lift $ dbgparse 8 "trying matcherprefixp" - (char '&' >> lift skipNonNewlineSpaces >> return And) <|> return None + (char '&' >> lift skipNonNewlineSpaces >> return And) <|> (char '!' >> lift skipNonNewlineSpaces >> return Not) <|> return None csvfieldreferencep :: CsvRulesParser CsvFieldReference csvfieldreferencep = do @@ -707,8 +710,12 @@ -- | Look up the final value assigned to a hledger field, with csv field -- references interpolated. hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text -hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record +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. @@ -721,60 +728,89 @@ 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 - -- 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 $ (rblocksassigning rules) f - where - -- does this conditional block match the current csv record ? - isBlockActive :: ConditionalBlock -> Bool - isBlockActive CB{..} = any (all matcherMatches) $ groupedMatchers cbMatchers - where - -- does this individual matcher match the current csv record ? - matcherMatches :: Matcher -> Bool - matcherMatches (RecordMatcher _ pat) = regexMatchText pat' wholecsvline - 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 - matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchText pat csvfieldvalue - where - -- the value of the referenced CSV field to match against. - csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref + 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 + -- | 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. Outer whitespace is removed from interpolated values. -renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> Text -renderTemplate rules record t = maybe t mconcat $ parseMaybe - (many $ takeWhile1P Nothing (/='%') +renderTemplate :: CsvRules -> CsvRecord -> HledgerFieldName -> FieldTemplate -> Text +renderTemplate rules record f t = maybe t mconcat $ parseMaybe + (many $ takeWhile1P Nothing isNotEscapeChar + <|> replaceRegexGroupReference rules record f <$> matchp <|> replaceCsvFieldReference rules record <$> referencep) t where + -- XXX: can we return a parsed Int here? + matchp = liftA2 T.cons (char '\\') (takeWhile1P (Just "matchref") isDigit) :: Parsec HledgerParseErrorData Text Text referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isFieldNameChar) :: Parsec HledgerParseErrorData Text Text isFieldNameChar c = isAlphaNum c || c == '_' || c == '-' + isNotEscapeChar 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 -> FieldTemplate -> 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. @@ -1032,6 +1068,7 @@ 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 @@ -1044,6 +1081,7 @@ 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 @@ -1056,6 +1094,7 @@ ,ptransaction = Just t ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance ,pcomment = cmt + ,ptags = ptags ,ptype = accountNamePostingType acct } ] @@ -1071,6 +1110,7 @@ ,tcode = code ,tdescription = description ,tcomment = comment + ,ttags = ttags ,tprecedingcomment = precomment ,tpostings = ps } @@ -1153,7 +1193,7 @@ -- assignments to any of these field names with non-empty values assignments = [(f,a') | f <- fieldnames - , Just v <- [T.strip . renderTemplate rules record <$> hledgerField rules record f] + , 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 @@ -2976,6 +3016,12 @@ ,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") diff --git a/Hledger/Read/TimedotReader.hs b/Hledger/Read/TimedotReader.hs --- a/Hledger/Read/TimedotReader.hs +++ b/Hledger/Read/TimedotReader.hs @@ -52,6 +52,11 @@ import Hledger.Data import Hledger.Read.Common hiding (emptyorcommentlinep) import Hledger.Utils +import Data.Decimal (roundTo) +import Data.Functor ((<&>)) +import Data.List (sort) +import Data.List (group) +-- import Text.Megaparsec.Debug (dbg) --- ** doctest setup -- $setup @@ -125,9 +130,8 @@ pos <- getSourcePos (date,desc,comment,tags) <- datelinep commentlinesp - ps <- many $ timedotentryp <* commentlinesp + ps <- (many $ timedotentryp <* commentlinesp) <&> concat endpos <- getSourcePos - -- lift $ traceparse' "dayp end" let t = txnTieKnot $ nulltransaction{ tsourcepos = (pos, endpos), tdate = date, @@ -146,7 +150,6 @@ date <- datep desc <- T.strip <$> lift descriptionp (comment, tags) <- lift transactioncommentp - -- lift $ traceparse' "datelinep end" return (date, desc, comment, tags) -- | Zero or more empty lines or hash/semicolon comment lines @@ -164,51 +167,52 @@ -- void $ lift restofline -- lift $ traceparse' "orgnondatelinep" -orgheadingprefixp = do - -- traceparse "orgheadingprefixp" - skipSome (char '*') >> skipNonNewlineSpaces1 +orgheadingprefixp = skipSome (char '*') >> skipNonNewlineSpaces1 -- | Parse a single timedot entry to one (dateless) transaction. -- @ -- fos.haskell .... .. -- @ -timedotentryp :: JournalParser m Posting +timedotentryp :: JournalParser m [Posting] timedotentryp = do lift $ traceparse "timedotentryp" notFollowedBy datelinep lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1] a <- modifiedaccountnamep lift skipNonNewlineSpaces - (hours, comment, tags) <- - try (do - (c,ts) <- lift transactioncommentp -- or postingp, but let's not bother supporting date:/date2: - return (0, c, ts) - ) - <|> (do - h <- lift durationp - (c,ts) <- try (lift transactioncommentp) <|> (newline >> return ("",[])) - return (h,c,ts) - ) + taggedhours <- lift durationsp + (comment0, tags0) <- + lift transactioncommentp -- not postingp, don't bother with date: tags here + <|> (newline >> return ("",[])) mcs <- getDefaultCommodityAndStyle let (c,s) = case mcs of - Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) (Just $ Precision 2)}) - _ -> ("", amountstyle{asprecision=Just $ Precision 2}) - -- lift $ traceparse' "timedotentryp end" - return $ nullposting{paccount=a - ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hours, astyle=s} - ,ptype=VirtualPosting - ,pcomment=comment - ,ptags=tags - } + Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) (Precision 2)}) + _ -> ("", amountstyle{asprecision=Precision 2}) + ps = [ + nullposting{paccount=a + ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hours, astyle=s} + ,ptype=VirtualPosting + ,pcomment=comment + ,ptags=tags + } + | (hours,tagval) <- taggedhours + , let tag = ("t",tagval) + , let tags = if T.null tagval then tags0 else tags0 ++ [tag] + , let comment = if T.null tagval then comment0 else comment0 `commentAddTagUnspaced` tag + ] + return ps type Hours = Quantity -durationp :: TextParser m Hours -durationp = do - traceparse "durationp" - try numericquantityp <|> dotquantityp - -- <* traceparse' "durationp" +-- | Parse one or more durations in hours, each with an optional tag value +-- (or empty string for none). +durationsp :: TextParser m [(Hours,TagValue)] +durationsp = + (dotquantityp <&> \h -> [(h,"")]) + <|> (numericquantityp <&> \h -> [(h,"")]) + <|> letterquantitiesp + <|> pure [(0,"")] -- | Parse a duration of seconds, minutes, hours, days, weeks, months or years, -- written as a decimal number followed by s, m, h, d, w, mo or y, assuming h @@ -228,7 +232,7 @@ let q' = case msymbol of Nothing -> q - Just sym -> + Just sym -> roundTo 2 $ case lookup sym timeUnits of Just mult -> q * mult Nothing -> q -- shouldn't happen.. ignore @@ -245,15 +249,33 @@ ,("y",61320) ] --- | Parse a quantity written as a line of dots, each representing 0.25. +-- | Parse a quantity written as a line of one or more dots, +-- each representing 0.25, ignoring any interspersed spaces +-- after the first dot. -- @ -- .... .. -- @ -dotquantityp :: TextParser m Quantity +dotquantityp :: TextParser m Hours dotquantityp = do -- lift $ traceparse "dotquantityp" - dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char])) - return $ fromIntegral (length dots) / 4 + char '.' + dots <- many (oneOf ['.', ' ']) <&> filter (not.isSpace) + return $ fromIntegral (1 + length dots) / 4 + +-- | Parse a quantity written as a line of one or more letters, +-- each representing 0.25 with a tag "t" whose value is the letter, +-- ignoring any interspersed spaces after the first letter. +letterquantitiesp :: TextParser m [(Hours, TagValue)] +letterquantitiesp = + -- dbg "letterquantitiesp" $ + do + letter1 <- letterChar + letters <- many (letterChar <|> spacenonewline) <&> filter (not.isSpace) + let groups = + [ (fromIntegral (length t) / 4, T.singleton c) + | t@(c:_) <- group $ sort $ letter1:letters + ] + return groups -- | XXX new comment line parser, move to Hledger.Read.Common.emptyorcommentlinep -- Parse empty lines, all-blank lines, and lines beginning with any of the provided diff --git a/Hledger/Reports/BudgetReport.hs b/Hledger/Reports/BudgetReport.hs --- a/Hledger/Reports/BudgetReport.hs +++ b/Hledger/Reports/BudgetReport.hs @@ -110,7 +110,7 @@ journalAddBudgetGoalTransactions :: BalancingOpts -> ReportOpts -> DateSpan -> Journal -> Journal journalAddBudgetGoalTransactions bopts ropts reportspan j = either error' id $ -- PARTIAL: - (journalApplyCommodityStyles >=> journalBalanceTransactions bopts) j{ jtxns = budgetts } + (journalStyleAmounts >=> journalBalanceTransactions bopts) j{ jtxns = budgetts } where budgetspan = dbg3 "budget span" $ DateSpan (Exact <$> mbudgetgoalsstartdate) (Exact <$> spanEnd reportspan) where diff --git a/Hledger/Reports/MultiBalanceReport.hs b/Hledger/Reports/MultiBalanceReport.hs --- a/Hledger/Reports/MultiBalanceReport.hs +++ b/Hledger/Reports/MultiBalanceReport.hs @@ -618,7 +618,8 @@ let amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, - astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing, asdecimalmark = Just '.', asprecision = Just $ Precision 2}} + astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asdigitgroups = Nothing, + asdecimalmark = Just '.', asprecision = Precision 2, asrounding = NoRounding}} (rspec,journal) `gives` r = do let rspec' = rspec{_rsQuery=And [queryFromFlags $ _rsReportOpts rspec, _rsQuery rspec]} (eitems, etotal) = r diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -83,6 +83,7 @@ import Hledger.Data import Hledger.Query import Hledger.Utils +import Data.Function ((&)) -- | What to calculate for each cell in a balance report. @@ -156,6 +157,7 @@ ,declared_ :: Bool -- ^ Include accounts declared but not yet posted to ? ,row_total_ :: Bool ,no_total_ :: Bool + ,summary_only_ :: Bool ,show_costs_ :: Bool -- ^ Show costs for reports which normally don't show them ? ,sort_amount_ :: Bool ,percent_ :: Bool @@ -206,6 +208,7 @@ , declared_ = False , row_total_ = False , no_total_ = False + , summary_only_ = False , show_costs_ = False , sort_amount_ = False , percent_ = False @@ -259,6 +262,7 @@ ,declared_ = boolopt "declared" rawopts ,row_total_ = boolopt "row-total" rawopts ,no_total_ = boolopt "no-total" rawopts + ,summary_only_ = boolopt "summary-only" rawopts ,show_costs_ = boolopt "show-costs" rawopts ,sort_amount_ = boolopt "sort-amount" rawopts ,percent_ = boolopt "percent" rawopts @@ -584,19 +588,28 @@ -- condition. journalApplyValuationFromOpts :: ReportSpec -> Journal -> Journal journalApplyValuationFromOpts rspec j = - journalApplyValuationFromOptsWith rspec j priceoracle + journalApplyValuationFromOptsWith rspec j priceoracle where priceoracle = journalPriceOracle (infer_prices_ $ _rsReportOpts rspec) j -- | Like journalApplyValuationFromOpts, but takes PriceOracle as an argument. journalApplyValuationFromOptsWith :: ReportSpec -> Journal -> PriceOracle -> Journal journalApplyValuationFromOptsWith rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle = - case balancecalc_ ropts of - CalcGain -> journalMapPostings (\p -> postingTransformAmount (gain p) p) j - _ -> journalMapPostings (\p -> postingTransformAmount (valuation p) p) $ costing j + costfn j + & journalMapPostings (\p -> p + & dbg9With (lbl "before calc".showMixedAmountOneLine.pamount) + & postingTransformAmount (calcfn p) + & dbg9With (lbl (show calc).showMixedAmountOneLine.pamount) + ) where - valuation p = maybe id (mixedAmountApplyValuation priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts) - gain p = maybe id (mixedAmountApplyGain priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts) - costing = journalToCost (fromMaybe NoConversionOp $ conversionop_ ropts) + lbl = lbl_ "journalApplyValuationFromOptsWith" + -- Which custom calculation to do for balance reports. For all other reports, it will be CalcChange. + calc = balancecalc_ ropts + calcfn = case calc of + CalcGain -> \p -> maybe id (mixedAmountApplyGain priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts) + _ -> \p -> maybe id (mixedAmountApplyValuation priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts) + costfn = case calc of + CalcGain -> id + _ -> journalToCost costop where costop = fromMaybe NoConversionOp $ conversionop_ ropts -- Find the end of the period containing this posting postingperiodend = addDays (-1) . fromMaybe err . mPeriodEnd . postingDateOrDate2 (whichDate ropts) @@ -623,7 +636,7 @@ gain mc spn = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn) costing = case fromMaybe NoConversionOp $ conversionop_ ropts of NoConversionOp -> id - ToCost -> mixedAmountSetStyles styles . mixedAmountCost + ToCost -> styleAmounts styles . mixedAmountCost styles = journalCommodityStyles j err = error "mixedAmountApplyValuationAfterSumFromOptsWith: expected all spans to have an end date" diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -49,6 +49,7 @@ -- * Misc multicol, numDigitsInt, + numDigitsInteger, makeHledgerClassyLenses, -- * Other @@ -232,6 +233,12 @@ | a >= 10000000000000000 = 16 + go (a `quot` 10000000000000000) | a >= 100000000 = 8 + go (a `quot` 100000000) | otherwise = 4 + go (a `quot` 10000) + +-- | Find the number of digits of an Integer. +-- The integer should not have more digits than an Int can count. +-- This is probably inefficient. +numDigitsInteger :: Integer -> Int +numDigitsInteger = length . dropWhile (=='-') . show -- | Make classy lenses for Hledger options fields. -- This is intended to be used with BalancingOpts, InputOpt, ReportOpts, diff --git a/Hledger/Utils/Debug.hs b/Hledger/Utils/Debug.hs --- a/Hledger/Utils/Debug.hs +++ b/Hledger/Utils/Debug.hs @@ -64,10 +64,27 @@ 9 any other rarely needed / more in-depth info @ +We don't yet have the ability to select debug output by topic. For now, here +are some standardish topic strings to search for in hledger debug messages: + +acct +arg +budget +calc +csv +journalFinalise +multiBalanceReport +opts +precision +price +q +style +val + -} --- Disabled until 0.1.2.0 is released with windows support --- This module also exports Debug.Trace and the breakpoint package's Debug.Breakpoint. +-- Disabled until 0.1.2.0 is released with windows support: +-- This module also exports Debug.Trace and the breakpoint package's Debug.Breakpoint. -- more: -- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html @@ -75,9 +92,10 @@ -- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html -- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html -- https://hackage.haskell.org/package/debug +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} module Hledger.Utils.Debug ( - + debugLevel -- * Tracing to stderr @@ -142,6 +160,9 @@ ,dbg8With ,dbg9With + -- * Utilities + ,lbl_ + -- * Re-exports -- ,module Debug.Breakpoint ,module Debug.Trace @@ -221,7 +242,7 @@ ptraceAt level | level > 0 && debugLevel < level = const id | otherwise = \lbl a -> trace (labelledPretty True lbl a) a - + -- Pretty-print a showable value with a label, with or without allowing ANSI color. labelledPretty :: Show a => Bool -> String -> a -> String labelledPretty allowcolour lbl a = lbl ++ ":" ++ nlorspace ++ intercalate "\n" ls' @@ -290,7 +311,7 @@ -- if the global debug level is at or above the specified level. -- At level 0, always logs. Otherwise, uses unsafePerformIO. traceLogAtWith :: Int -> (a -> String) -> a -> a -traceLogAtWith level f a = traceLogAt level (f a) a +traceLogAtWith level f a = traceLogAt level (f a) a -- | Pretty-log a label and showable value to the debug log, -- if the global debug level is at or above the specified level. @@ -433,3 +454,25 @@ dbg9With :: Show a => (a -> String) -> a -> a dbg9With = traceOrLogAtWith 9 +-- | Helper for producing debug messages: +-- concatenates a name (eg a function name), +-- short description of the value being logged, +-- and string representation of the value. +lbl_ :: String -> String -> String -> String +lbl_ name desc val = name <> ": " <> desc <> ":" <> " " <> val + +-- XXX the resulting function is constrained to only one value type +-- -- | A new helper for defining a local "dbg" function. +-- -- Given a debug level and a topic string (eg, a function name), +-- -- it generates a function which takes +-- -- - a description string, +-- -- - a value-to-string show function, +-- -- - and a value to be inspected, +-- -- debug-logs the topic, description and result of calling the show function on the value, +-- -- formatted nicely, at the specified debug level or above, +-- -- then returns the value. +-- dbg_ :: forall a. Show a => Int -> String -> (String -> (a -> String) -> a -> a) +-- dbg_ level topic = +-- \desc showfn val -> +-- traceOrLogAtWith level (lbl_ topic desc . showfn) val +-- {-# HLINT ignore "Redundant lambda" #-} diff --git a/Hledger/Utils/Parse.hs b/Hledger/Utils/Parse.hs --- a/Hledger/Utils/Parse.hs +++ b/Hledger/Utils/Parse.hs @@ -76,6 +76,7 @@ -- and current parser state (position and next input). -- See also: Hledger.Utils.Debug, megaparsec's dbg. -- Uses unsafePerformIO. +-- XXX Can be hard to make this evaluate. traceOrLogParse :: String -> TextParser m () traceOrLogParse msg = do pos <- getSourcePos diff --git a/Hledger/Utils/Regex.hs b/Hledger/Utils/Regex.hs --- a/Hledger/Utils/Regex.hs +++ b/Hledger/Utils/Regex.hs @@ -55,6 +55,7 @@ -- * total regex operations ,regexMatch ,regexMatchText + ,regexMatchTextGroups ,regexReplace ,regexReplaceUnmemo ,regexReplaceAllBy @@ -72,7 +73,8 @@ import Text.Regex.TDFA ( Regex, CompOption(..), defaultCompOpt, defaultExecOpt, makeRegexOptsM, AllMatches(getAllMatches), match, MatchText, - RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..) + RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..), + (=~) ) @@ -165,6 +167,14 @@ -- a performance bug in regex-tdfa (#9), which may or may not be relevant here. regexMatchText :: Regexp -> Text -> Bool regexMatchText r = matchTest r . T.unpack + +-- | Return a (possibly empty) list of match groups derived by applying the +-- Regex to a Text. +regexMatchTextGroups :: Regexp -> Text -> [Text] +regexMatchTextGroups r txt = let + pat = reString r + (_,_,_,matches) = txt =~ pat :: (Text,Text,Text,[Text]) + in matches -------------------------------------------------------------------------------- -- new total functions diff --git a/Hledger/Utils/String.hs b/Hledger/Utils/String.hs --- a/Hledger/Utils/String.hs +++ b/Hledger/Utils/String.hs @@ -3,6 +3,7 @@ module Hledger.Utils.String ( takeEnd, -- * misc + capitalise, lowercase, uppercase, underline, @@ -55,6 +56,10 @@ go (_:xs) (_:ys) = go xs ys go [] r = r go _ [] = [] + +capitalise :: String -> String +capitalise (c:cs) = toUpper c : cs +capitalise s = s lowercase, uppercase :: String -> String lowercase = map toLower diff --git a/Hledger/Utils/Text.hs b/Hledger/Utils/Text.hs --- a/Hledger/Utils/Text.hs +++ b/Hledger/Utils/Text.hs @@ -6,8 +6,7 @@ module Hledger.Utils.Text ( -- * misc - -- lowercase, - -- uppercase, + textCapitalise, -- underline, -- stripbrackets, textUnbracket, @@ -20,6 +19,7 @@ -- quotechars, -- whitespacechars, escapeDoubleQuotes, + escapeBackslash, -- escapeSingleQuotes, -- escapeQuotes, -- words', @@ -67,9 +67,8 @@ import Text.WideString (WideBuilder(..), wbToText, wbFromText, wbUnpack) --- lowercase, uppercase :: String -> String --- lowercase = map toLower --- uppercase = map toUpper +textCapitalise :: Text -> Text +textCapitalise t = T.toTitle c <> cs where (c,cs) = T.splitAt 1 t -- stripbrackets :: String -> String -- stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String @@ -140,6 +139,9 @@ escapeDoubleQuotes :: T.Text -> T.Text escapeDoubleQuotes = T.replace "\"" "\\\"" + +escapeBackslash :: T.Text -> T.Text +escapeBackslash = T.replace "\\" "\\\\" -- escapeSingleQuotes :: T.Text -> T.Text -- escapeSingleQuotes = T.replace "'" "\'" diff --git a/Text/Tabular/AsciiWide.hs b/Text/Tabular/AsciiWide.hs --- a/Text/Tabular/AsciiWide.hs +++ b/Text/Tabular/AsciiWide.hs @@ -75,12 +75,13 @@ -- | Render a table according to common options, for backwards compatibility -render :: Bool -> (rh -> Text) -> (ch -> Text) -> (a -> Text) -> Table rh ch a -> TL.Text +render :: Show a => Bool -> (rh -> Text) -> (ch -> Text) -> (a -> Text) -> Table rh ch a -> TL.Text render pretty fr fc f = renderTable def{prettyTable=pretty} (cell . fr) (cell . fc) (cell . f) where cell = textCell TopRight -- | Render a table according to various cell specifications> -renderTable :: TableOpts -- ^ Options controlling Table rendering +renderTable :: Show a => + TableOpts -- ^ Options controlling Table rendering -> (rh -> Cell) -- ^ Rendering function for row headers -> (ch -> Cell) -- ^ Rendering function for column headers -> (a -> Cell) -- ^ Function determining the string and width of a cell @@ -89,7 +90,8 @@ renderTable topts fr fc f = toLazyText . renderTableB topts fr fc f -- | A version of renderTable which returns the underlying Builder. -renderTableB :: TableOpts -- ^ Options controlling Table rendering +renderTableB :: Show a => + TableOpts -- ^ Options controlling Table rendering -> (rh -> Cell) -- ^ Rendering function for row headers -> (ch -> Cell) -- ^ Rendering function for column headers -> (a -> Cell) -- ^ Function determining the string and width of a cell @@ -99,7 +101,8 @@ -- | A version of renderTable that operates on rows (including the 'row' of -- column headers) and returns the underlying Builder. -renderTableByRowsB :: TableOpts -- ^ Options controlling Table rendering +renderTableByRowsB :: Show a => + TableOpts -- ^ Options controlling Table rendering -> ([ch] -> [Cell]) -- ^ Rendering function for column headers -> ((rh, [a]) -> (Cell, [Cell])) -- ^ Rendering function for row and row header -> Table rh ch a diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,22 +1,29 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: hledger-lib -version: 1.31 -synopsis: A reusable library providing the core functionality of hledger -description: A reusable library containing hledger's core functionality. - This is used by most hledger* packages so that they support the same - common file formats, command line options, reports etc. +version: 1.32 +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 + command line options, file formats, reports, etc. . hledger is a robust, cross-platform set of tools for tracking money, time, or any other commodity, using double-entry accounting and a simple, editable file format, with command-line, terminal and web interfaces. It is a Haskell rewrite of Ledger, and one of the leading - implementations of Plain Text Accounting. Read more at: - + implementations of Plain Text Accounting. + . + See also: + . + - https://hledger.org - hledger's home page + . + - https://hledger.org/dev.html - starting point for hledger's developer docs + . + - https://hackage.haskell.org/package/hledger-lib/docs/Hledger.html - starting point for hledger's haddock docs category: Finance stability: stable homepage: http://hledger.org @@ -137,7 +144,7 @@ , tasty-hunit >=0.10.0.2 , template-haskell , terminal-size >=0.3.3 - , text >=1.2 + , text >=1.2.4.1 , text-ansi >=0.2.1 , time >=1.5 , timeit @@ -196,7 +203,7 @@ , tasty-hunit >=0.10.0.2 , template-haskell , terminal-size >=0.3.3 - , text >=1.2 + , text >=1.2.4.1 , text-ansi >=0.2.1 , time >=1.5 , timeit @@ -257,7 +264,7 @@ , tasty-hunit >=0.10.0.2 , template-haskell , terminal-size >=0.3.3 - , text >=1.2 + , text >=1.2.4.1 , text-ansi >=0.2.1 , time >=1.5 , timeit