memoise market valuation, making it fast (#999)

hledger-lib/Hledger/Data/Posting.hs

@@ -319,6 +319,7 @@ accountNameApplyAliases aliases a = accountNameWithPostingType atype aname'
 -- | Memoising version of accountNameApplyAliases, maybe overkill.
 accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> AccountName
 accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases)
+  -- XXX re-test this memoisation
 
 -- aliasMatches :: AccountAlias -> AccountName -> Bool
 -- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a
@@ -331,18 +332,18 @@ aliasReplace (BasicAlias old new) a
 aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.unpack a -- XXX
 
 -- Apply a specified valuation to this posting's amount, using the provided
--- prices db, commodity styles, period-end/current dates, and whether
+-- price oracle, commodity styles, period-end/current dates, and whether
 -- this is for a multiperiod report or not.
-postingApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> Posting -> ValuationType -> Posting
+postingApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> Posting -> ValuationType -> Posting
-postingApplyValuation prices styles periodend today ismultiperiod p v =
+postingApplyValuation priceoracle styles periodend today ismultiperiod p v =
   case v of
     AtCost    Nothing            -> postingToCost styles p
-    AtCost    mc                 -> postingValueAtDate prices styles mc periodend $ postingToCost styles p
+    AtCost    mc                 -> postingValueAtDate priceoracle styles mc periodend $ postingToCost styles p
-    AtEnd     mc                 -> postingValueAtDate prices styles mc periodend p
+    AtEnd     mc                 -> postingValueAtDate priceoracle styles mc periodend p
-    AtNow     mc                 -> postingValueAtDate prices styles mc today     p
+    AtNow     mc                 -> postingValueAtDate priceoracle styles mc today     p
-    AtDefault mc | ismultiperiod -> postingValueAtDate prices styles mc periodend p
+    AtDefault mc | ismultiperiod -> postingValueAtDate priceoracle styles mc periodend p
-    AtDefault mc                 -> postingValueAtDate prices styles mc today     p
+    AtDefault mc                 -> postingValueAtDate priceoracle styles mc today     p
-    AtDate d  mc                 -> postingValueAtDate prices styles mc d         p
+    AtDate d  mc                 -> postingValueAtDate priceoracle styles mc d         p
 
 -- | Convert this posting's amount to cost, and apply the appropriate amount styles.
 postingToCost :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting
@@ -350,11 +351,11 @@ postingToCost styles p@Posting{pamount=a} = p{pamount=mixedAmountToCost styles a
 
 -- | Convert this posting's amount to market value in the given commodity,
 -- or the default valuation commodity, at the given valuation date,
--- using the given market prices.
+-- using the given market price oracle.
 -- When market prices available on that date are not sufficient to
 -- calculate the value, amounts are left unchanged.
-postingValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Posting -> Posting
+postingValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Posting -> Posting
-postingValueAtDate prices styles mc d p = postingTransformAmount (mixedAmountValueAtDate prices styles mc d) p
+postingValueAtDate priceoracle styles mc d p = postingTransformAmount (mixedAmountValueAtDate priceoracle styles mc d) p
 
 -- | Apply a transform function to this posting's amount.
 postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting

hledger-lib/Hledger/Data/Types.hs

@@ -468,6 +468,11 @@ data PriceGraph = PriceGraph {
 
 instance NFData PriceGraph
 
+-- | A price oracle is a magic function that looks up market prices
+-- (exchange rates) from one commodity to another (or if unspecified,
+-- to a default valuation commodity) on a given date, somewhat efficiently.
+type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (CommoditySymbol, Quantity)
+
 -- | What kind of value conversion should be done on amounts ?
 -- UI: --value=cost|end|now|DATE[,COMM]
 data ValuationType =

hledger-lib/Hledger/Data/Valuation.hs

@@ -11,8 +11,9 @@ looking up historical market prices (exchange rates) between commodities.
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Hledger.Data.Valuation (
-   amountValueAtDate
+   journalPriceOracle
-  ,amountApplyValuation
+  -- ,amountValueAtDate
+  -- ,amountApplyValuation
   ,mixedAmountValueAtDate
   ,mixedAmountApplyValuation
   ,marketPriceReverse
@@ -32,6 +33,7 @@ import qualified Data.Map as M
 import Data.Maybe
 import qualified Data.Text as T
 import Data.Time.Calendar (Day)
+import Data.MemoUgly (memo)
 import Safe (headMay)
 
 import Hledger.Utils
@@ -44,37 +46,39 @@ tests_Valuation = tests "Valuation" [
    tests_priceLookup
   ]
 
+
+
 ------------------------------------------------------------------------------
 -- Valuation
 
--- Apply a specified valuation to this mixed amount, using the provided
+-- | Apply a specified valuation to this mixed amount, using the provided
--- prices db, commodity styles, period-end/current dates,
+-- price oracle, commodity styles, period-end/current dates,
 -- and whether this is for a multiperiod report or not.
-mixedAmountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
+mixedAmountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
-mixedAmountApplyValuation prices styles periodend today ismultiperiod v (Mixed as) =
+mixedAmountApplyValuation priceoracle styles periodend today ismultiperiod v (Mixed as) =
-  Mixed $ map (amountApplyValuation prices styles periodend today ismultiperiod v) as
+  Mixed $ map (amountApplyValuation priceoracle styles periodend today ismultiperiod v) as
+
+-- | Apply a specified valuation to this amount, using the provided
+-- price oracle, commodity styles, period-end/current dates,
+-- and whether this is for a multiperiod report or not.
+amountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
+amountApplyValuation priceoracle styles periodend today ismultiperiod v a =
+  case v of
+    AtCost    Nothing            -> amountToCost styles a
+    AtCost    mc                 -> amountValueAtDate priceoracle styles mc periodend $ amountToCost styles a
+    AtEnd     mc                 -> amountValueAtDate priceoracle styles mc periodend a
+    AtNow     mc                 -> amountValueAtDate priceoracle styles mc today     a
+    AtDefault mc | ismultiperiod -> amountValueAtDate priceoracle styles mc periodend a
+    AtDefault mc                 -> amountValueAtDate priceoracle styles mc today     a
+    AtDate d  mc                 -> amountValueAtDate priceoracle styles mc d         a
 
 -- | Find the market value of each component amount in the given
 -- commodity, or its default valuation commodity, at the given
--- valuation date, using the given market prices.
+-- valuation date, using the given market price oracle.
 -- When market prices available on that date are not sufficient to
 -- calculate the value, amounts are left unchanged.
-mixedAmountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
+mixedAmountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
-mixedAmountValueAtDate prices styles mc d (Mixed as) = Mixed $ map (amountValueAtDate prices styles mc d) as
+mixedAmountValueAtDate priceoracle styles mc d (Mixed as) = Mixed $ map (amountValueAtDate priceoracle styles mc d) as
-
--- | Apply a specified valuation to this amount, using the provided
--- prices db, commodity styles, period-end/current dates,
--- and whether this is for a multiperiod report or not.
-amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Bool -> ValuationType -> Amount -> Amount
-amountApplyValuation prices styles periodend today ismultiperiod v a =
-  case v of
-    AtCost    Nothing            -> amountToCost styles a
-    AtCost    mc                 -> amountValueAtDate prices styles mc periodend $ amountToCost styles a
-    AtEnd     mc                 -> amountValueAtDate prices styles mc periodend a
-    AtNow     mc                 -> amountValueAtDate prices styles mc today     a
-    AtDefault mc | ismultiperiod -> amountValueAtDate prices styles mc periodend a
-    AtDefault mc                 -> amountValueAtDate prices styles mc today     a
-    AtDate d  mc                 -> amountValueAtDate prices styles mc d         a
 
 -- | Find the market value of this amount in the given valuation
 -- commodity if any, otherwise the default valuation commodity, at the
@@ -88,9 +92,9 @@ amountApplyValuation prices styles periodend today ismultiperiod v a =
 --
 -- If the market prices available on that date are not sufficient to
 -- calculate this value, the amount is left unchanged.
-amountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount
+amountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount
-amountValueAtDate pricedirectives styles mto d a =
+amountValueAtDate priceoracle styles mto d a =
-  case priceLookup pricedirectives d (acommodity a) mto of
+  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 ?
@@ -102,24 +106,21 @@ amountValueAtDate pricedirectives styles mto d a =
 ------------------------------------------------------------------------------
 -- Market price lookup
 
-tests_priceLookup =
+-- From a journal's market price directives, generate a memoising function
+-- that efficiently looks up exchange rates between commodities on any date.
+-- For best results, you should generate this only once per journal, reusing it
+-- across reports if there are more than one (as in compoundBalanceCommand).
+journalPriceOracle :: Journal -> PriceOracle
+journalPriceOracle Journal{jpricedirectives} =
+  -- traceStack "journalPriceOracle" $
   let
-    d = parsedate
+    pricesatdate =
-    a q c = amount{acommodity=c, aquantity=q}
+      memo $
-    p date from q to = PriceDirective{pddate=d date, pdcommodity=from, pdamount=a q to}
+      pricesAtDate jpricedirectives
-    ps1 = [
+  in
-       p "2000/01/01" "A" 10 "B"
+    memo $
-      ,p "2000/01/01" "B" 10 "C"
+    uncurry3 $
-      ,p "2000/01/01" "C" 10 "D"
+    priceLookup pricesatdate
-      ,p "2000/01/01" "E"  2 "D"
-      ,p "2001/01/01" "A" 11 "B"
-      ]
-  in tests "priceLookup" [
-     priceLookup ps1 (d "1999/01/01") "A" Nothing    `is` Nothing
-    ,priceLookup ps1 (d "2000/01/01") "A" Nothing    `is` Just ("B",10)
-    ,priceLookup ps1 (d "2000/01/01") "B" (Just "A") `is` Just ("A",0.1)
-    ,priceLookup ps1 (d "2000/01/01") "A" (Just "E") `is` Just ("E",500)
-    ]
 
 -- | Given a list of price directives in parse order, find the market
 -- value at the given date of one unit of a given source commodity, in
@@ -152,16 +153,13 @@ tests_priceLookup =
 -- prices can be found, or the source commodity and the valuation
 -- commodity are the same, returns Nothing.
 --
--- A 'PriceGraph' is built each time this is called, which is probably
+priceLookup :: (Day -> PriceGraph) -> Day -> CommoditySymbol -> Maybe CommoditySymbol -> Maybe (CommoditySymbol, Quantity)
--- wasteful when looking up multiple prices on the same day; it could
+priceLookup pricesatdate d from mto =
--- be built at a higher level, or memoised.
+  -- trace ("priceLookup ("++show d++", "++show from++", "++show mto++")") $
---
-priceLookup :: [PriceDirective] -> Day -> CommoditySymbol -> Maybe CommoditySymbol -> Maybe (CommoditySymbol, Quantity)
-priceLookup pricedirectives 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, prDeclaredPairs=dps} = pricesAtDate pricedirectives d
+    PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps} = pricesatdate d
     fromnode = node m from
     mto' = mto <|> mdefaultto
       where
@@ -195,6 +193,26 @@ priceLookup pricedirectives d from mto =
           -- log a message and a Maybe Quantity, hiding Just/Nothing and limiting decimal places
           dbg msg = dbg4With (((msg++": ")++) . maybe "" (show . roundTo 8))
 
+tests_priceLookup =
+  let
+    d = parsedate
+    a q c = amount{acommodity=c, aquantity=q}
+    p date from q to = PriceDirective{pddate=d date, pdcommodity=from, pdamount=a q to}
+    ps1 = [
+       p "2000/01/01" "A" 10 "B"
+      ,p "2000/01/01" "B" 10 "C"
+      ,p "2000/01/01" "C" 10 "D"
+      ,p "2000/01/01" "E"  2 "D"
+      ,p "2001/01/01" "A" 11 "B"
+      ]
+    pricesatdate = pricesAtDate ps1
+  in tests "priceLookup" [
+     priceLookup pricesatdate (d "1999/01/01") "A" Nothing    `is` Nothing
+    ,priceLookup pricesatdate (d "2000/01/01") "A" Nothing    `is` Just ("B",10)
+    ,priceLookup pricesatdate (d "2000/01/01") "B" (Just "A") `is` Just ("A",0.1)
+    ,priceLookup pricesatdate (d "2000/01/01") "A" (Just "E") `is` Just ("E",500)
+    ]
+
 ------------------------------------------------------------------------------
 -- Building the price graph (network of commodity conversions) on a given day.
 
@@ -202,7 +220,9 @@ priceLookup pricedirectives d from mto =
 -- graph of all prices in effect on a given day, allowing efficient
 -- lookup of exchange rates between commodity pairs.
 pricesAtDate :: [PriceDirective] -> Day -> PriceGraph
-pricesAtDate pricedirectives d = PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps}
+pricesAtDate pricedirectives d =
+  -- trace ("pricesAtDate ("++show d++")") $
+  PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps}
   where
     declaredprices = latestPriceForEachPairOn pricedirectives d
 
@@ -212,7 +232,6 @@ pricesAtDate pricedirectives d = PriceGraph{prGraph=g, prNodemap=m, prDeclaredPa
       map marketPriceReverse declaredprices \\ declaredprices
 
     -- build the graph and associated node map
-    -- (g :: Gr CommoditySymbol Quantity, m :: NodeMap CommoditySymbol) =
     (g, m) =
       mkMapGraph
       (dbg5 "g nodelabels" $ sort allcomms) -- this must include all nodes mentioned in edges
@@ -237,7 +256,6 @@ latestPriceForEachPairOn pricedirectives d =
   map priceDirectiveToMarketPrice $
   filter ((<=d).pddate) pricedirectives  -- consider only price declarations up to the valuation date
 
-
 priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
 priceDirectiveToMarketPrice PriceDirective{..} =
   MarketPrice{ mpdate = pddate

hledger-lib/Hledger/Read/Common.hs

@@ -552,7 +552,7 @@ modifiedaccountnamep = do
   a <- lift accountnamep
   return $!
     accountNameApplyAliases aliases $
-     -- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference
+     -- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function)
     joinAccountNames parent
     a
 

hledger-lib/Hledger/Reports/BalanceReport.hs

@@ -80,11 +80,12 @@ balanceReport ropts@ReportOpts{..} q j@Journal{..} =
       accttree = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts ropts j
 
       -- For other kinds of valuation, convert the summed amounts to value.
+      priceoracle = journalPriceOracle j
       valuedaccttree = mapAccounts valueaccount accttree
         where
           valueaccount a@Account{..} = a{aebalance=val aebalance, aibalance=val aibalance}
             where
-              val = maybe id (mixedAmountApplyValuation jpricedirectives styles periodlastday today multiperiod) value_
+              val = maybe id (mixedAmountApplyValuation priceoracle styles periodlastday today multiperiod) value_
                 where
                   periodlastday =
                     fromMaybe (error' "balanceReport: expected a non-empty journal") $ -- XXX shouldn't happen

hledger-lib/Hledger/Reports/EntriesReport.hs

@@ -40,7 +40,8 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
     datefn = transactionDateFn ropts
     styles = journalCommodityStyles j
     tvalue t@Transaction{..} = t{tpostings=map pvalue tpostings}
-    pvalue p = maybe p (postingApplyValuation jpricedirectives styles end today False p) value_
+    priceoracle = journalPriceOracle j
+    pvalue p = maybe p (postingApplyValuation priceoracle styles end today False p) value_
       where
         today  = fromMaybe (error' "erValue: ReportOpts today_ is unset so could not satisfy --value=now") today_
         end    = fromMaybe (postingDate p) mperiodorjournallastday

hledger-lib/Hledger/Reports/MultiBalanceReport.hs

@@ -9,6 +9,7 @@ module Hledger.Reports.MultiBalanceReport (
   MultiBalanceReport(..),
   MultiBalanceReportRow,
   multiBalanceReport,
+  multiBalanceReportWith,
   balanceReportFromMultiBalanceReport,
   mbrNegate,
   mbrNormaliseSign,
@@ -94,9 +95,16 @@ type ClippedAccountName = AccountName
 -- If the normalbalance_ option is set, it adjusts the sorting and sign of amounts
 -- (see ReportOpts and CompoundBalanceCommand).
 -- hledger's most powerful and useful report, used by the balance
--- command (in multiperiod mode) and by the bs/cf/is commands.
+-- command (in multiperiod mode) and (via multiBalanceReport') by the bs/cf/is commands.
 multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport
-multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
+multiBalanceReport ropts q j = multiBalanceReportWith ropts q j (journalPriceOracle j)
+
+-- | A helper for multiBalanceReport. This one takes an extra argument, a
+-- PriceOracle to be used for looking up market prices. Commands which
+-- run multiple reports (bs etc.) can generate the price oracle just once
+-- for efficiency, passing it to each report by calling this function directly.
+multiBalanceReportWith :: ReportOpts -> Query -> Journal -> PriceOracle -> MultiBalanceReport
+multiBalanceReportWith ropts@ReportOpts{..} q j@Journal{..} priceoracle =
   (if invert_ then mbrNegate else id) $
   MultiBalanceReport (colspans, sortedrows, totalsrow)
     where
@@ -252,7 +260,7 @@ multiBalanceReport ropts@ReportOpts{..} q j@Journal{..} =
                    CumulativeChange  -> drop 1 $ scanl (+) 0                      changes
                    HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes
              -- The row amounts valued according to --value if needed.
-           , let val end = maybe id (mixedAmountApplyValuation jpricedirectives styles end today multiperiod) value_
+           , let val end = maybe id (mixedAmountApplyValuation priceoracle styles end today multiperiod) value_
            , let valuedrowbals = dbg1 "valuedrowbals" $ [val periodlastday amt | (amt,periodlastday) <- zip rowbals lastdays]
              -- The total and average for the row, and their values.
              -- Total for a cumulative/historical report is always zero.

hledger-lib/Hledger/Reports/PostingsReport.hs

@@ -99,7 +99,8 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
         reportPeriodOrJournalLastDay ropts j
       multiperiod = interval_ /= NoInterval
       showempty = empty_ || average_
-      pvalue p end = maybe p (postingApplyValuation jpricedirectives styles end today multiperiod p) value_
+      priceoracle = journalPriceOracle j
+      pvalue p end = maybe p (postingApplyValuation priceoracle styles end today multiperiod p) value_
 
       -- Postings, or summary postings with their subperiod's end date, to be displayed.
       displayps :: [(Posting, Maybe Day)]
@@ -121,7 +122,7 @@ postingsReport ropts@ReportOpts{..} q j@Journal{..} =
           -- For --value=end/now/DATE, convert the initial running total/average to value.
           startbalvalued = val startbal
             where
-              val = maybe id (mixedAmountApplyValuation jpricedirectives styles daybeforereportstart today multiperiod) value_
+              val = maybe id (mixedAmountApplyValuation priceoracle styles daybeforereportstart today multiperiod) value_
                 where
                   daybeforereportstart = maybe
                                          (error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen

hledger/Hledger/Cli/CompoundBalanceCommand.hs

@@ -145,12 +145,14 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=r
       userq = queryFromOpts d ropts'
       format = outputFormatFromOpts opts
 
-      -- make a CompoundBalanceReport
+      -- make a CompoundBalanceReport.
+      -- For efficiency, generate a price oracle here and reuse it with each subreport.
+      priceoracle = journalPriceOracle j
       subreports =
         map (\CBCSubreportSpec{..} ->
                 (cbcsubreporttitle
                 ,mbrNormaliseSign cbcsubreportnormalsign $ -- <- convert normal-negative to normal-positive
-                  compoundBalanceSubreport ropts' userq j cbcsubreportquery cbcsubreportnormalsign
+                  compoundBalanceSubreport ropts' userq j priceoracle cbcsubreportquery cbcsubreportnormalsign
                 ,cbcsubreportincreasestotal
                 ))
             cbcqueries
@@ -252,14 +254,14 @@ showEndDates es = case es of
 
 -- | Run one subreport for a compound balance command in multi-column mode.
 -- This returns a MultiBalanceReport.
-compoundBalanceSubreport :: ReportOpts -> Query -> Journal -> (Journal -> Query) -> NormalSign -> MultiBalanceReport
+compoundBalanceSubreport :: ReportOpts -> Query -> Journal -> PriceOracle -> (Journal -> Query) -> NormalSign -> MultiBalanceReport
-compoundBalanceSubreport ropts@ReportOpts{..} userq j subreportqfn subreportnormalsign = r'
+compoundBalanceSubreport ropts@ReportOpts{..} userq j priceoracle subreportqfn subreportnormalsign = r'
   where
     -- force --empty to ensure same columns in all sections
     ropts' = ropts { empty_=True, normalbalance_=Just subreportnormalsign }
     -- run the report
     q = And [subreportqfn j, userq]
-    r@(MultiBalanceReport (dates, rows, totals)) = multiBalanceReport ropts' q j
+    r@(MultiBalanceReport (dates, rows, totals)) = multiBalanceReportWith ropts' q j priceoracle
     -- if user didn't specify --empty, now remove the all-zero rows, unless they have non-zero subaccounts
     -- in this report
     r' | empty_    = r