valuation: implement new --infer-value flag & semantics (#1239, #1253)

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
+-- The boolean argument is whether to infer market prices from
-journalPriceOracle Journal{jpricedirectives, jinferredmarketprices} =
+-- 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
+-- 1. The price commodity from the latest declared market price for A
---    date) declared market price for A.
+--    on or before valuation date.
 --
--- 2. If there are no P directives at all (any commodity, any date),
+-- 2. The price commodity from the latest declared market price for A
---    and the `--value-infer` flag is used, then the price commodity
+--    on any date. (Allows conversion to proceed if there are inferred
---    from the latest (on or before valuation date) transaction price
+--    prices before the valuation date.)
---    for A.
+--
+-- 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:
+    -- determine a default valuation commodity for each source commodity
-    -- the price commodity in the latest declared market price for S (on any date)
+    -- somewhat but not quite like effectiveMarketPrices
-    defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- alldeclaredprices]
+    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,
+-- | Given a list of P-declared market prices in parse order and a
--- and a list of transaction-inferred market prices in parse order,
+-- list of transaction-inferred market prices in parse order, select
--- get the effective price on the given date for each commodity pair.
+-- just the latest prices that are in effect for each commodity pair.
--- That is, the latest (by date then parse order) declared price or
+-- That is, for each commodity pair, the latest price by date then
--- inferred price, on or before that date, If there is both a declared
+-- parse order, with declared prices having precedence over inferred
--- and inferred price on the same day, declared takes precedence.
+-- prices on the same day.
-declaredOrInferredPricesOn :: [MarketPrice] -> [MarketPrice] -> Day -> [MarketPrice]
+effectiveMarketPrices :: [MarketPrice] -> [MarketPrice] -> [MarketPrice]
-declaredOrInferredPricesOn declaredprices inferredprices d =
+effectiveMarketPrices declaredprices inferredprices =
   let
-    -- keeping only prices on or before the valuation date, label each
+    -- label each item with its same-day precedence, then parse order
-    -- item with its same-day precedence (declared above inferred) and
+    declaredprices' = [(1, i, p) | (i,p) <- zip [1..] declaredprices]
-    -- then parse order
+    inferredprices' = [(0, i, p) | (i,p) <- zip [1..] inferredprices]
-    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]
   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

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

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 =
+                  applyvaluation = mixedAmountApplyValuation priceoracle styles periodlast mreportlast today multiperiod
-                    fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen
+                    where
-                    reportPeriodOrJournalLastDay ropts j
+                      priceoracle = journalPriceOracle infer_value_ j
-                  mreportlast = reportPeriodLastDay ropts
+                      styles = journalCommodityStyles j
-                  today = fromMaybe (error' "balanceReport: could not pick a valuation date, ReportOpts today_ is unset") today_
+                      periodlast = fromMaybe
-                  multiperiod = interval_ /= NoInterval
+                                   (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]

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

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

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_
 

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'

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"

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

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
+$ hledger -f- bal -N -V
-  (assets:stock)   1 TSLA @ $500
+                 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
+# 24. A P-declared market price on the same date as a transaction price has precedence.
-  (assets:stock)   1 TSLA @ $800
+<
+P 2020-01-01 A  1 B
 
-# 22. Market price is inferred from a transaction price,
+2020-01-01
-# -V works without a P directive.
+  (a)   1 A @ 2 B
-$ hledger -f- bal -N -V -e 2020-01-02
-                $500  assets:stock
 
-# 23. A P-declared market price has precedence over a transaction price 
+$ hledger -f- bal -N -V --infer-value
-# on the same date.
+                 1 B  a
-$ hledger -f- bal -N -V -e 2020-03-02
+
-               $1200  assets:stock
+# 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