From e3cae4aadc260a42d55144d494f5cde4e208be82 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Fri, 19 Jun 2020 14:33:34 -0700 Subject: [PATCH] valuation: implement new --infer-value flag & semantics (#1239, #1253) --- hledger-lib/Hledger/Data/Valuation.hs | 78 +++++++++++-------- .../Reports/AccountTransactionsReport.hs | 2 +- hledger-lib/Hledger/Reports/BalanceReport.hs | 20 +++-- hledger-lib/Hledger/Reports/EntriesReport.hs | 2 +- .../Hledger/Reports/MultiBalanceReport.hs | 9 ++- hledger-lib/Hledger/Reports/PostingsReport.hs | 2 +- hledger-lib/Hledger/Reports/ReportOptions.hs | 3 + hledger/Hledger/Cli/CliOptions.hs | 3 +- hledger/Hledger/Cli/CompoundBalanceCommand.hs | 2 +- tests/journal/valuation2.test | 66 +++++++++++----- 10 files changed, 122 insertions(+), 65 deletions(-) diff --git a/hledger-lib/Hledger/Data/Valuation.hs b/hledger-lib/Hledger/Data/Valuation.hs index 2fd2f4641..3c4d701a6 100644 --- a/hledger-lib/Hledger/Data/Valuation.hs +++ b/hledger-lib/Hledger/Data/Valuation.hs @@ -101,11 +101,14 @@ type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (Commo -- prices. For best performance, generate this only once per journal, -- reusing it across reports if there are more than one, as -- compoundBalanceCommand does. -journalPriceOracle :: Journal -> PriceOracle -journalPriceOracle Journal{jpricedirectives, jinferredmarketprices} = +-- The boolean argument is whether to infer market prices from +-- transactions or not. +journalPriceOracle :: Bool -> Journal -> PriceOracle +journalPriceOracle infer Journal{jpricedirectives, jinferredmarketprices} = let declaredprices = map priceDirectiveToMarketPrice jpricedirectives - makepricegraph = memo $ makePriceGraph declaredprices jinferredmarketprices + inferredprices = if infer then jinferredmarketprices else [] + makepricegraph = memo $ makePriceGraph declaredprices inferredprices in memo $ uncurry3 $ priceLookup makepricegraph @@ -231,7 +234,8 @@ priceLookup makepricegraph d from mto = let -- build a graph of the commodity exchange rates in effect on this day -- XXX should hide these fgl details better - PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests} = makepricegraph d + PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests} = + traceAt 1 ("valuation date: "++show d) $ makepricegraph d fromnode = node m from mto' = mto <|> mdefaultto where @@ -290,7 +294,7 @@ tests_priceLookup = -- -- 1. A *declared market price* or *inferred market price*: -- A's latest market price in B on or before the valuation date --- as declared by a P directive, or (with the `--value-infer` flag) +-- as declared by a P directive, or (with the `--infer-value` flag) -- inferred from transaction prices. -- -- 2. A *reverse market price*: @@ -305,15 +309,18 @@ tests_priceLookup = -- -- We also identify each commodity's default valuation commodity, if -- any. For each commodity A, hledger picks a default valuation --- commodity as follows: +-- commodity as follows, in this order of preference: -- --- 1. The price commodity from the latest (on or before valuation --- date) declared market price for A. +-- 1. The price commodity from the latest declared market price for A +-- on or before valuation date. -- --- 2. If there are no P directives at all (any commodity, any date), --- and the `--value-infer` flag is used, then the price commodity --- from the latest (on or before valuation date) transaction price --- for A. +-- 2. The price commodity from the latest declared market price for A +-- on any date. (Allows conversion to proceed if there are inferred +-- prices before the valuation date.) +-- +-- 3. If there are no P directives at all (any commodity or date), and +-- the `--infer-value` flag is used, then the price commodity from +-- the latest transaction price for A on or before valuation date. -- makePriceGraph :: [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph makePriceGraph alldeclaredprices allinferredprices d = @@ -321,8 +328,10 @@ makePriceGraph alldeclaredprices allinferredprices d = PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests} where -- prices in effect on date d, either declared or inferred + visibledeclaredprices = filter ((<=d).mpdate) alldeclaredprices + visibleinferredprices = filter ((<=d).mpdate) allinferredprices declaredandinferredprices = dbg2 "declaredandinferredprices" $ - declaredOrInferredPricesOn alldeclaredprices allinferredprices d + effectiveMarketPrices visibledeclaredprices visibleinferredprices -- infer any additional reverse prices not already declared or inferred reverseprices = dbg2 "reverseprices" $ @@ -338,33 +347,40 @@ makePriceGraph alldeclaredprices allinferredprices d = prices = declaredandinferredprices ++ reverseprices allcomms = map mpfrom prices - -- determine a default valuation commodity D for each source commodity S: - -- the price commodity in the latest declared market price for S (on any date) - defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- alldeclaredprices] + -- determine a default valuation commodity for each source commodity + -- somewhat but not quite like effectiveMarketPrices + defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- pricesfordefaultcomms] + where + pricesfordefaultcomms = dbg2 "prices for choosing default valuation commodities, by date then parse order" $ + ps + & zip [1..] -- label items with their parse order + & sortBy (compare `on` (\(parseorder,MarketPrice{..})->(mpdate,parseorder))) -- sort by increasing date then increasing parse order + & map snd -- discard labels + where + ps | not $ null visibledeclaredprices = visibledeclaredprices + | not $ null alldeclaredprices = alldeclaredprices + | otherwise = visibleinferredprices -- will be null without --infer-value --- | From a list of directive-declared market prices in parse order, --- and a list of transaction-inferred market prices in parse order, --- get the effective price on the given date for each commodity pair. --- That is, the latest (by date then parse order) declared price or --- inferred price, on or before that date, If there is both a declared --- and inferred price on the same day, declared takes precedence. -declaredOrInferredPricesOn :: [MarketPrice] -> [MarketPrice] -> Day -> [MarketPrice] -declaredOrInferredPricesOn declaredprices inferredprices d = +-- | Given a list of P-declared market prices in parse order and a +-- list of transaction-inferred market prices in parse order, select +-- just the latest prices that are in effect for each commodity pair. +-- That is, for each commodity pair, the latest price by date then +-- parse order, with declared prices having precedence over inferred +-- prices on the same day. +effectiveMarketPrices :: [MarketPrice] -> [MarketPrice] -> [MarketPrice] +effectiveMarketPrices declaredprices inferredprices = let - -- keeping only prices on or before the valuation date, label each - -- item with its same-day precedence (declared above inferred) and - -- then parse order - declaredprices' = [(1, i, p) | (i,p@MarketPrice{mpdate}) <- zip [1..] declaredprices, mpdate<=d] - inferredprices' = [(0, i, p) | (i,p@MarketPrice{mpdate}) <- zip [1..] inferredprices, mpdate<=d] + -- label each item with its same-day precedence, then parse order + declaredprices' = [(1, i, p) | (i,p) <- zip [1..] declaredprices] + inferredprices' = [(0, i, p) | (i,p) <- zip [1..] inferredprices] in -- combine declaredprices' ++ inferredprices' - -- sort by newest date then highest precedence then latest parse order + -- sort by decreasing date then decreasing precedence then decreasing parse order & sortBy (flip compare `on` (\(precedence,parseorder,mp)->(mpdate mp,precedence,parseorder))) -- discard the sorting labels & map third3 -- keep only the first (ie the newest, highest precedence, latest parsed) price for each pair - -- XXX or use a Map ? & nubSortBy (compare `on` (\(MarketPrice{..})->(mpfrom,mpto))) marketPriceReverse :: MarketPrice -> MarketPrice diff --git a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs index f02ff07f6..d263d0481 100644 --- a/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs +++ b/hledger-lib/Hledger/Reports/AccountTransactionsReport.hs @@ -102,7 +102,7 @@ accountTransactionsReport ropts j reportq thisacctq = (label, items) ts3 = filter (matchesTransaction thisacctq . filterTransactionPostings (And [realq, statusq])) ts2 -- maybe convert these transactions to cost or value - prices = journalPriceOracle j + prices = journalPriceOracle (infer_value_ ropts) j styles = journalCommodityStyles j periodlast = fromMaybe (error' "journalApplyValuation: expected a non-empty journal") $ -- XXX shouldn't happen diff --git a/hledger-lib/Hledger/Reports/BalanceReport.hs b/hledger-lib/Hledger/Reports/BalanceReport.hs index c2967c58e..a1027969d 100644 --- a/hledger-lib/Hledger/Reports/BalanceReport.hs +++ b/hledger-lib/Hledger/Reports/BalanceReport.hs @@ -82,16 +82,20 @@ balanceReport ropts@ReportOpts{..} q j = -- per hledger_options.m4.md "Effect of --value on reports". valuedaccttree = mapAccounts avalue accttree where - avalue a@Account{..} = a{aebalance=bvalue aebalance, aibalance=bvalue aibalance} + avalue a@Account{..} = a{aebalance=maybevalue aebalance, aibalance=maybevalue aibalance} where - bvalue = maybe id (mixedAmountApplyValuation (journalPriceOracle j) (journalCommodityStyles j) periodlast mreportlast today multiperiod) value_ + maybevalue = maybe id applyvaluation value_ where - periodlast = - fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen - reportPeriodOrJournalLastDay ropts j - mreportlast = reportPeriodLastDay ropts - today = fromMaybe (error' "balanceReport: could not pick a valuation date, ReportOpts today_ is unset") today_ - multiperiod = interval_ /= NoInterval + applyvaluation = mixedAmountApplyValuation priceoracle styles periodlast mreportlast today multiperiod + where + priceoracle = journalPriceOracle infer_value_ j + styles = journalCommodityStyles j + periodlast = fromMaybe + (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen + reportPeriodOrJournalLastDay ropts j + mreportlast = reportPeriodLastDay ropts + today = fromMaybe (error' "balanceReport: could not pick a valuation date, ReportOpts today_ is unset") today_ + multiperiod = interval_ /= NoInterval -- Modify this tree for display - depth limit, boring parents, zeroes - and convert to a list. displayaccts :: [Account] diff --git a/hledger-lib/Hledger/Reports/EntriesReport.hs b/hledger-lib/Hledger/Reports/EntriesReport.hs index 60e502fe9..4872dab01 100644 --- a/hledger-lib/Hledger/Reports/EntriesReport.hs +++ b/hledger-lib/Hledger/Reports/EntriesReport.hs @@ -40,7 +40,7 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} = tvalue t@Transaction{..} = t{tpostings=map pvalue tpostings} where pvalue p = maybe p - (postingApplyValuation (journalPriceOracle j) (journalCommodityStyles j) periodlast mreportlast today False p) + (postingApplyValuation (journalPriceOracle infer_value_ j) (journalCommodityStyles j) periodlast mreportlast today False p) value_ where periodlast = fromMaybe today $ reportPeriodOrJournalLastDay ropts j diff --git a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs index 69b6b1851..a2883a319 100644 --- a/hledger-lib/Hledger/Reports/MultiBalanceReport.hs +++ b/hledger-lib/Hledger/Reports/MultiBalanceReport.hs @@ -72,7 +72,11 @@ type ClippedAccountName = AccountName -- hledger's most powerful and useful report, used by the balance -- command (in multiperiod mode) and (via multiBalanceReport') by the bs/cf/is commands. multiBalanceReport :: Day -> ReportOpts -> Journal -> MultiBalanceReport -multiBalanceReport today ropts j = multiBalanceReportWith ropts (queryFromOpts today ropts) j (journalPriceOracle j) +multiBalanceReport today ropts j = + multiBalanceReportWith ropts q j (journalPriceOracle infer j) + where + q = queryFromOpts today ropts + infer = infer_value_ ropts -- | A helper for multiBalanceReport. This one takes an explicit Query -- instead of deriving one from ReportOpts, and an extra argument, a @@ -363,7 +367,8 @@ multiBalanceReportWith ropts@ReportOpts{..} q j priceoracle = balanceReportFromMultiBalanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReportFromMultiBalanceReport opts q j = (rows', total) where - PeriodicReport _ rows (PeriodicReportRow _ _ totals _ _) = multiBalanceReportWith opts q j (journalPriceOracle j) + PeriodicReport _ rows (PeriodicReportRow _ _ totals _ _) = + multiBalanceReportWith opts q j (journalPriceOracle (infer_value_ opts) j) rows' = [( a , if flat_ opts then a else accountLeafName a -- BalanceReport expects full account name here with --flat , if tree_ opts then d-1 else 0 -- BalanceReport uses 0-based account depths diff --git a/hledger-lib/Hledger/Reports/PostingsReport.hs b/hledger-lib/Hledger/Reports/PostingsReport.hs index eabe00a7c..473e9bd5a 100644 --- a/hledger-lib/Hledger/Reports/PostingsReport.hs +++ b/hledger-lib/Hledger/Reports/PostingsReport.hs @@ -74,7 +74,7 @@ postingsReport ropts@ReportOpts{..} q j = whichdate = whichDateFromOpts ropts depth = queryDepth q styles = journalCommodityStyles j - priceoracle = journalPriceOracle j + priceoracle = journalPriceOracle infer_value_ j multiperiod = interval_ /= NoInterval today = fromMaybe (error' "postingsReport: could not pick a valuation date, ReportOpts today_ is unset") today_ diff --git a/hledger-lib/Hledger/Reports/ReportOptions.hs b/hledger-lib/Hledger/Reports/ReportOptions.hs index 680b52ade..d85622962 100644 --- a/hledger-lib/Hledger/Reports/ReportOptions.hs +++ b/hledger-lib/Hledger/Reports/ReportOptions.hs @@ -93,6 +93,7 @@ data ReportOpts = ReportOpts { ,interval_ :: Interval ,statuses_ :: [Status] -- ^ Zero, one, or two statuses to be matched ,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ? + ,infer_value_ :: Bool -- ^ Infer market prices from transactions ? ,depth_ :: Maybe Int ,display_ :: Maybe DisplayExp -- XXX unused ? ,date2_ :: Bool @@ -161,6 +162,7 @@ defreportopts = ReportOpts def def def + def rawOptsToReportOpts :: RawOpts -> IO ReportOpts rawOptsToReportOpts rawopts = checkReportOpts <$> do @@ -173,6 +175,7 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do ,interval_ = intervalFromRawOpts rawopts' ,statuses_ = statusesFromRawOpts rawopts' ,value_ = valuationTypeFromRawOpts rawopts' + ,infer_value_ = boolopt "infer-value" rawopts' ,depth_ = maybeintopt "depth" rawopts' ,display_ = maybedisplayopt d rawopts' ,date2_ = boolopt "date2" rawopts' diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 6037eb69c..9426228d5 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -155,7 +155,7 @@ reportflags = [ -- valuation ,flagNone ["B","cost"] (setboolopt "B") - "show amounts converted to their cost, using the transaction price. Equivalent to --value=cost." + "show amounts converted to their cost/selling amount, using the transaction price. Equivalent to --value=cost." ,flagNone ["V","market"] (setboolopt "V") (unwords ["show amounts converted to current market value (single period reports)" @@ -178,6 +178,7 @@ reportflags = [ ,"- current market value, in default valuation commodity or COMM" ,"- market value on the given date, in default valuation commodity or COMM" ]) + ,flagNone ["infer-value"] (setboolopt "infer-value") "with -V/-X/--value, also infer market prices from transactions" -- generated postings/transactions ,flagNone ["auto"] (setboolopt "auto") "apply automated posting rules to modify transactions" diff --git a/hledger/Hledger/Cli/CompoundBalanceCommand.hs b/hledger/Hledger/Cli/CompoundBalanceCommand.hs index 2f3819eb6..a92e9c3bc 100644 --- a/hledger/Hledger/Cli/CompoundBalanceCommand.hs +++ b/hledger/Hledger/Cli/CompoundBalanceCommand.hs @@ -146,7 +146,7 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=r -- make a CompoundBalanceReport. -- For efficiency, generate a price oracle here and reuse it with each subreport. - priceoracle = journalPriceOracle j + priceoracle = journalPriceOracle infer_value_ j subreports = map (\CBCSubreportSpec{..} -> (cbcsubreporttitle diff --git a/tests/journal/valuation2.test b/tests/journal/valuation2.test index a30493c71..345bc54b5 100644 --- a/tests/journal/valuation2.test +++ b/tests/journal/valuation2.test @@ -222,31 +222,59 @@ P 2002/01/01 A 2 B $ hledger -f- bal -N -V -e 2002-01-01 1 B a -# Test market prices inferred from transactions, as in Ledger. +# Test market prices inferred from transactions. +# 22. Market price is not inferred from transactions by default. < 2020-01-01 - (assets:stock) 1 TSLA @ $500 + (a) 1 A @ 2 B -2020-03-01 - (assets:stock) 1 TSLA @ $500 +$ hledger -f- bal -N -V + 1 A a -P 2020-03-01 TSLA $600 +# 23. Market price is inferred from transactions with --infer-value, +# and -V can work with no P directives. +$ hledger -f- bal -N -V --infer-value + B2 a -2020-05-01 - (assets:stock) 1 TSLA @ $800 +# 24. A P-declared market price on the same date as a transaction price has precedence. +< +P 2020-01-01 A 1 B -# 22. Market price is inferred from a transaction price, -# -V works without a P directive. -$ hledger -f- bal -N -V -e 2020-01-02 - $500 assets:stock +2020-01-01 + (a) 1 A @ 2 B -# 23. A P-declared market price has precedence over a transaction price -# on the same date. -$ hledger -f- bal -N -V -e 2020-03-02 - $1200 assets:stock +$ hledger -f- bal -N -V --infer-value + 1 B a + +# 25. A transaction-inferred price newer than a P-declared price has precedence. +< +P 2020-01-01 A 1 B + +2020-01-02 + (a) 1 A @ 2 B + +$ hledger -f- bal -N -V --infer-value + 2 B a + +# 26. A later-dated P directive sets the valuation commodity even if parsed out of order. +< +P 2020-02-01 A 1 C +P 2020-01-01 A 1 B + +2020-02-01 + (a) 1 A @ 2 B + +$ hledger -f- bal -N -V + 1 C a + +# 27. A later-dated transaction price sets the valuation commodity even if parsed out of order. +< +2020-01-01 + (a) 1 A @ 1 C ; date: 2020-01-02 + (a) 1 A @ 1 D ; date: 2020-01-02 + (a) 1 A @ 1 B + +$ hledger -f- bal -N -V --infer-value + D3 a -# 24. A transaction-implied market price has precedence -# over an older P-declared market price. -$ hledger -f- bal -N -V -e 2020-05-02 - $2400 assets:stock