lib: -X/--exchange now supports indirect price chains (#131)

Adds fgl as a dependency.

hledger-lib/Hledger/Data/Posting.hs

@@ -354,12 +354,12 @@ postingApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -
 postingApplyValuation prices styles periodend today ismultiperiod p v =
   case v of
     AtCost    Nothing            -> postingToCost styles p
-    AtCost    mc                 -> postingValueAtDate prices mc periodend $ postingToCost styles p
+    AtCost    mc                 -> postingValueAtDate prices styles mc periodend $ postingToCost styles p
-    AtEnd     mc                 -> postingValueAtDate prices mc periodend p
+    AtEnd     mc                 -> postingValueAtDate prices styles mc periodend p
-    AtNow     mc                 -> postingValueAtDate prices mc today     p
+    AtNow     mc                 -> postingValueAtDate prices styles mc today     p
-    AtDefault mc | ismultiperiod -> postingValueAtDate prices mc periodend p
+    AtDefault mc | ismultiperiod -> postingValueAtDate prices styles mc periodend p
-    AtDefault mc                 -> postingValueAtDate prices mc today     p
+    AtDefault mc                 -> postingValueAtDate prices styles mc today     p
-    AtDate d  mc                 -> postingValueAtDate prices mc d         p
+    AtDate d  mc                 -> postingValueAtDate prices styles mc d         p
 
 -- | Convert this posting's amount to cost, and apply the appropriate amount styles.
 postingToCost :: M.Map CommoditySymbol AmountStyle -> Posting -> Posting
@@ -370,8 +370,8 @@ postingToCost styles p@Posting{pamount=a} = p{pamount=mixedAmountToCost styles a
 -- using the given market prices.
 -- When market prices available on that date are not sufficient to
 -- calculate the value, amounts are left unchanged.
-postingValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> Posting -> Posting
+postingValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Posting -> Posting
-postingValueAtDate prices mc d p = postingTransformAmount (mixedAmountValueAtDate prices mc d) p
+postingValueAtDate prices styles mc d p = postingTransformAmount (mixedAmountValueAtDate prices styles mc d) p
 
 -- | Apply a transform function to this posting's amount.
 postingTransformAmount :: (MixedAmount -> MixedAmount) -> Posting -> Posting

hledger-lib/Hledger/Data/Prices.hs

@@ -1,7 +1,7 @@
 {-|
 
-Find historical market prices (exchange rates) between commodities,
+Convert amounts to some related value in various ways. This involves
-convert amounts to value in various ways.
+looking up historical market prices (exchange rates) between commodities.
 
 -}
 
@@ -11,8 +11,7 @@ convert amounts to value in various ways.
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Hledger.Data.Prices (
-   Prices
+   amountValueAtDate
-  ,amountValueAtDate
   ,amountApplyValuation
   ,mixedAmountValueAtDate
   ,mixedAmountApplyValuation
@@ -22,8 +21,13 @@ module Hledger.Data.Prices (
 where
 
 import Control.Applicative ((<|>))
+import Data.Decimal (roundTo)
+import Data.Function (on)
+import Data.Graph.Inductive  (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, suc, sp)
 import Data.List
+import Data.List.Extra
 import qualified Data.Map as M
+import Data.Maybe
 import qualified Data.Text as T
 import Data.Time.Calendar (Day)
 import Safe (headMay)
@@ -34,9 +38,6 @@ import Hledger.Data.Amount
 import Hledger.Data.Dates (parsedate)
 
 
-d = parsedate
--- amt c q = nullamt{acommodity=c, aquantity=q}
-
 tests_Prices = tests "Prices" [
    tests_priceLookup
   ]
@@ -58,8 +59,8 @@ mixedAmountApplyValuation prices styles periodend today ismultiperiod v (Mixed a
 -- valuation date, using the given market prices.
 -- When market prices available on that date are not sufficient to
 -- calculate the value, amounts are left unchanged.
-mixedAmountValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
+mixedAmountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
-mixedAmountValueAtDate prices mc d (Mixed as) = Mixed $ map (amountValueAtDate prices mc d) as
+mixedAmountValueAtDate prices styles mc d (Mixed as) = Mixed $ map (amountValueAtDate prices styles mc d) as
 
 -- | Apply a specified valuation to this amount, using the provided
 -- prices db, commodity styles, period-end/current dates, 
@@ -68,12 +69,12 @@ amountApplyValuation :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle ->
 amountApplyValuation prices styles periodend today ismultiperiod v a =
   case v of
     AtCost    Nothing            -> amountToCost styles a
-    AtCost    mc                 -> amountValueAtDate prices mc periodend $ amountToCost styles a
+    AtCost    mc                 -> amountValueAtDate prices styles mc periodend $ amountToCost styles a
-    AtEnd     mc                 -> amountValueAtDate prices mc periodend a
+    AtEnd     mc                 -> amountValueAtDate prices styles mc periodend a
-    AtNow     mc                 -> amountValueAtDate prices mc today     a
+    AtNow     mc                 -> amountValueAtDate prices styles mc today     a
-    AtDefault mc | ismultiperiod -> amountValueAtDate prices mc periodend a
+    AtDefault mc | ismultiperiod -> amountValueAtDate prices styles mc periodend a
-    AtDefault mc                 -> amountValueAtDate prices mc today     a
+    AtDefault mc                 -> amountValueAtDate prices styles mc today     a
-    AtDate d  mc                 -> amountValueAtDate prices mc d         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
@@ -82,85 +83,183 @@ amountApplyValuation prices styles periodend today ismultiperiod v a =
 -- valuation date.)
 -- If the market prices available on that date are not sufficient to
 -- calculate this value, the amount is left unchanged.
-amountValueAtDate :: [PriceDirective] -> Maybe CommoditySymbol -> Day -> Amount -> Amount
+amountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount
-amountValueAtDate pricedirectives mc d a =
+amountValueAtDate pricedirectives styles mto d a =
-  case priceLookup pricedirectives d mc (acommodity a) of
+  case priceLookup pricedirectives d (acommodity a) mto of
-    Just v  -> v{aquantity=aquantity v * aquantity a}
     Nothing           -> a
+    Just (comm, rate) -> styleAmount styles $ amount{acommodity=comm, aquantity=rate * aquantity a}
 
 ------------------------------------------------------------------------------
--- Market price lookup, naive version
+-- Market price lookup
+                     
+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"
+      ]
+  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 commodity, in a
+-- value at the given date of one unit of a given source commodity, in
--- different specified valuation commodity, defaulting to the
+-- a different specified valuation commodity, or a default valuation
--- commodity of the most recent applicable price.
+-- commodity.
--- This might be slow if there are many price declarations.
 --
 -- When the valuation commodity is specified, this looks for, in order:
 --
--- - a direct price, giving the exchange rate from source commodity to
+-- - a price declaration giving the exchange rate from source
---   valuation commodity.
+--   commodity to valuation commodity ("declared price").
 --
--- - a reverse direct price, giving the exchange rate from valuation
+-- - a price declaration from valuation to source commodity, which
---   commodity to source commodity, which is inverted.
+--   gets inverted ("reverse price").
 --
--- - (TODO: the shortest chain of prices leading from source commodity
+-- - the shortest chain of prices (declared or reverse) leading from
---   to valuation commodity, which is collapsed into a single
+--   source commodity to valuation commodity, which gets collapsed
---   synthetic exchange rate.)
+--   into a single synthetic exchange rate ("indirect price").
 --
 -- When the valuation commodity is not specified, this looks for the
 -- latest applicable market price, and converts to the commodity
--- mentioned in that price. Note when valuing amounts over multiple
+-- mentioned in that price (default valuation commodity).
--- periods, this default valuation commodity may vary, since it
--- depends on the presence and parse order of market price
--- declarations in each period.
 --
--- If no applicable market price or chain of prices can be found, or
+-- Note when calling this repeatedly for different periods, the
--- if the source commodity and the valuation commodity are the same,
+-- default valuation commodity can vary, since it depends on the
--- this returns Nothing.
+-- presence and parse order of market price declarations in each
+-- period.
 --
-priceLookup :: [PriceDirective] -> Day -> Maybe CommoditySymbol -> CommoditySymbol -> Maybe Amount
+-- This returns the valuation commodity that was specified or
-priceLookup pricedirectives d mto from
+-- inferred, and the quantity of it that one unit of the source
-  | mto == Just from = Nothing
+-- commodity is worth. Or if no applicable market price or chain of
-  | otherwise        = mdirectprice <|> mreverseprice
+-- prices can be found, or the source commodity and the valuation
+-- commodity are the same, returns Nothing.
+--
+-- A 'Prices' database (price graphs) is built each time this is
+-- called, which is probably wasteful when looking up multiple prices
+-- on the same day; it could be built at a higher level, or memoised.
+--
+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
+    Prices{prNodemap=m, prDeclaredPrices=g, prWithReversePrices=gr} = pricesAtDate pricedirectives d
+    fromnode = node m from
+    -- if to is unspecified, try to find a default valuation commodity based on available prices
+    mto' = mto <|> mdefaultto
       where
-    dbgprice lbl =
+        -- the default valuation commodity, if we could find one.
-      dbg4With ( ((lbl++" for "++T.unpack from++" at "++show d++": ") ++)
+        -- XXX how to choose ? Take lowest sorted ?
-                 . maybe "none" showAmount )
+        -- Take first, hoping current order is useful ?       <- 
+        -- Keep parse order in label and take latest parsed ?
+        mdefaultto = headMay (suc g fromnode) >>= lab g
+  in
+    case mto' of
+      Nothing            -> Nothing
+      Just to | to==from -> Nothing
+      Just to            ->
+        -- We have a commodity to convert to. Find the most direct price available,
+        -- and return it as an amount.
+        case
+          -- These seem unnecessary, and we can avoid building one of the graphs
+          -- mdeclaredprice <|> mreverseprice <|>
+          mindirectprice of
+            Nothing -> Nothing
+            Just q  -> Just (to, q)
+        where
+          tonode = node m to
+          -- mdeclaredprice :: Maybe Quantity =
+          --   dbg ("declared market price "++T.unpack from++"->"++T.unpack to) $
+          --   nodesEdgeLabel g (fromnode,tonode)
+          -- mreverseprice  :: Maybe Quantity =
+          --   dbg ("reverse  market price "++T.unpack from++"->"++T.unpack to) $
+          --   ((1 /) <$> nodesEdgeLabel g (tonode,fromnode))
+          mindirectprice :: Maybe Quantity =
+            -- Find the shortest path, if any, between from and to.
+            -- This time use gr which includes both declared and reverse prices.
+            case sp fromnode tonode gr :: Maybe [Node] of
+              Nothing    -> Nothing
+              Just nodes ->
+                dbg ("market price "++intercalate "->" (map T.unpack comms)) $
+                Just $ product $ pathEdgeLabels gr nodes  -- convert to a single exchange rate
+                where comms = catMaybes $ map (lab g) nodes
 
-    latestfirst = reverse $ sortOn pddate pricedirectives  -- sortOn will preserve parse order within the same date I think
+          -- log a message and a Maybe Quantity, hiding Just/Nothing and limiting decimal places
+          dbg msg = dbg4With (((msg++": ")++) . maybe "" (show . roundTo 3))
 
-    -- Key to commodity symbols:
+-- | Convert a list of market price directives in parse order to
-    -- from  - commodity we are converting from (looking up a price for)
+-- a database of market prices in effect on a given day,
-    -- mto   - commodity we want to convert to, or Nothing meaning use default
+-- allowing efficient lookup of exchange rates between commodity pairs.
-    -- pfrom - commodity that this market price converts from
+pricesAtDate :: [PriceDirective] -> Day -> Prices
-    -- pto   - commodity that this market price converts to
+pricesAtDate pricedirectives d = Prices{
+   prNodemap = m
+  ,prDeclaredPrices = g
+  ,prWithReversePrices = gr
+  }
+  where
+    -- get the latest (before d) declared price for each commodity pair
+    latestdeclaredprices :: [MarketPrice] =
+      dbg4 "latestdeclaredprices" $
+      nubSortBy (compare `on` (\(MarketPrice{..})->(mpfrom,mpto))) $  -- keep only the first (ie newest and latest parsed) price for each pair
+      map snd $  -- discard the parse order label
+      sortBy (flip compare `on` (\(parseorder,mp)->(mpdate mp,parseorder))) $  -- sort with newest dates and latest parse order first
+      zip [1..] $  -- label with parse order
+      map priceDirectiveToMarketPrice $
+      filter ((<=d).pddate) pricedirectives  -- consider only price declarations up to the valuation date
+    -- and the latest declared or reverse price for each commodity pair
+    latestdeclaredandreverseprices =
+      latestdeclaredprices `union` map marketPriceReverse latestdeclaredprices
+        -- XXX hopefully this prioritises the declared prices, test
+    allcomms = sort $ map mpfrom latestdeclaredandreverseprices
+    (g :: PriceGraph, m :: NodeMap CommoditySymbol) = mkMapGraph
+      (dbg5 "g nodelabels" allcomms) -- this must include all nodes mentioned in edges
+      (dbg5 "g edges"      [(mpfrom, mpto, mprate) | MarketPrice{..} <- latestdeclaredprices])
+    (gr, _) = mkMapGraph
+      (dbg5 "gr nodelabels" allcomms) -- this must include all nodes mentioned in edges
+      (dbg5 "gr edges"      [(mpfrom, mpto, mprate) | MarketPrice{..} <- latestdeclaredandreverseprices])
 
-    -- prPriceDirectives is sorted by date then parse order, reversed. So the
+priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
-    -- first price on or before the valuation date is the effective one.
+priceDirectiveToMarketPrice PriceDirective{..} =
+  MarketPrice{ mpdate = pddate
+             , mpfrom = pdcommodity
+             , mpto   = acommodity pdamount
+             , mprate = aquantity pdamount
+             }
 
-    mdirectprice =
+marketPriceReverse :: MarketPrice -> MarketPrice
-      dbgprice "direct  market price" $
+marketPriceReverse mp@MarketPrice{..} = mp{mpfrom=mpto, mpto=mpfrom, mprate=1/mprate}
-      headMay [pdamount | PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst
+
-                        , let pto = acommodity pdamount
+------------------------------------------------------------------------------
-                        , pddate <= d
+-- fgl helpers
-                        , pfrom == from
+
-                        , maybe True (== pto) mto
+-- | Look up an existing node by its label in the given NodeMap.
-                        ]
+-- (If the node does not exist, a new one will be generated, but not
-    mreverseprice =
+-- persisted in the nodemap.)
-      dbgprice "reverse market price" $
+node :: Ord a => NodeMap a -> a -> Node
-      headMay [ priceamt
+node m = fst . fst . mkNode m
-              | PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst
+
-              , let pto = acommodity pdamount
+-- | Convert a valid path from the given graph to the corresponding
-              , pddate <= d
+-- edge labels. When there are multiple edges between two nodes, the
-              , pto == from
+-- lowest-sorting label is used.
-              , maybe False (== pfrom) mto  -- use reverse prices only when target commodity is explicitly specified
+pathEdgeLabels :: (Show b, Ord b) => Gr a b -> [Node] -> [b]
-              , let PriceDirective{pdamount=priceamt} = undefined -- marketPriceInvert mp
+pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges
-              ]
+  where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here")
-
+  
-tests_priceLookup = tests "priceLookup" [
+-- | Convert a path to node pairs representing the path's edges.
-   priceLookup [] (d "2019-06-01") Nothing "" `is` Nothing
+pathEdges :: [Node] -> [(Node,Node)]
-  ]
+pathEdges p = [(f,t) | f:t:_ <- tails p]
+
+-- | Get the label of a graph edge from one node to another.
+-- When there are multiple such edges, the lowest-sorting label is used.
+nodesEdgeLabel :: Ord b => Gr a b -> (Node, Node) -> Maybe b
+nodesEdgeLabel g (from,to) = headMay $ sort [l | (_,t,l) <- out g from, t==to]
 
 ------------------------------------------------------------------------------

hledger-lib/Hledger/Data/Types.hs

@@ -27,6 +27,7 @@ import Data.Data
 import Data.Decimal
 import Data.Default
 import Data.Functor (($>))
+import Data.Graph.Inductive (Gr, NodeMap)
 import Data.List (intercalate)
 import Text.Blaze (ToMarkup(..))
 --XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html 
@@ -445,15 +446,17 @@ data MarketPrice = MarketPrice {
 
 instance NFData MarketPrice
 
--- | A database of the exchange rates between commodity pairs at a given date,
+-- | A graph whose node labels are commodities and edge labels are exchange rates.
--- organised as maps for efficient lookup.
+type PriceGraph = Gr CommoditySymbol Quantity
+
+-- | A snapshot of the known exchange rates between commodity pairs at a given date.
 data Prices = Prices {
-   prDeclaredPrices ::
+   prNodemap            :: NodeMap CommoditySymbol
-      M.Map CommoditySymbol         -- from commodity A
+  ,prDeclaredPrices     :: PriceGraph  -- ^ Explicitly declared market prices for commodity pairs.
-            (M.Map CommoditySymbol  -- to commodity B
+  ,prWithReversePrices  :: PriceGraph  -- ^ The above, plus derived reverse prices for any pairs which don't have a declared price.
-                   Quantity)        -- exchange rate from A to B (one A is worth this many B)
+  -- ,prWithIndirectPrices :: PriceGraph  -- ^ The above, plus indirect prices found for any pairs which don't have a declared or reverse price.
-            -- ^ Explicitly declared market prices, as { FROMCOMM : { TOCOMM : RATE } }.
   }
+  deriving (Show)
 
 -- | What kind of value conversion should be done on amounts ?
 -- UI: --value=cost|end|now|DATE[,COMM]

hledger-lib/hledger-lib.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ac2028674178919d87ff7e06ea16e97e245e92deeb60beb9689c083547cd1a44
+-- hash: 89c2a4dadadc88418d53e5b39a17bcc9831b58cf46dbf77c4a5598f6db326cbc
 
 name:           hledger-lib
 version:        1.14.99
@@ -121,6 +121,7 @@ library
     , directory
     , easytest >=0.2.1 && <0.3
     , extra
+    , fgl >=5.5.3.0
     , file-embed >=0.0.10
     , filepath
     , hashtables >=1.2.3.1
@@ -223,6 +224,7 @@ test-suite doctests
     , doctest >=0.16
     , easytest >=0.2.1 && <0.3
     , extra
+    , fgl >=5.5.3.0
     , file-embed >=0.0.10
     , filepath
     , hashtables >=1.2.3.1
@@ -324,6 +326,7 @@ test-suite easytests
     , directory
     , easytest >=0.2.1 && <0.3
     , extra
+    , fgl >=5.5.3.0
     , file-embed >=0.0.10
     , filepath
     , hashtables >=1.2.3.1

hledger-lib/package.yaml

@@ -55,6 +55,7 @@ dependencies:
 - deepseq
 - directory
 - easytest >= 0.2.1 && <0.3
+- fgl >=5.5.3.0
 - file-embed >=0.0.10
 - filepath
 - hashtables >=1.2.3.1

hledger/hledger_options.m4.md

@@ -550,9 +550,11 @@ you want.
 
 To select a different valuation commodity: write the commodity symbol
 after the valuation type, separated by a comma (eg: **`--value=now,EUR`**). 
-Currently this will only use market prices leading directly from A to
+This will use, in this preferred order:
-B, or (after inverting them) prices from B to A;
+
-it does not yet follow chains of market prices.
+- declared prices (from source commodity to valuation commodity)
+- reverse prices (declared prices from valuation to source commodity, inverted)
+- indirect prices (prices calculated from the shortest chain of declared or reverse prices from source to valuation commodity).
 
 #### --value examples