lib: try to simplify, use just one price graph (#131)

hledger-lib/Hledger/Data/Prices.hs

@@ -15,8 +15,9 @@ module Hledger.Data.Prices (
   ,amountApplyValuation
   ,mixedAmountValueAtDate
   ,mixedAmountApplyValuation
-  ,priceLookup
+  ,marketPriceReverse
   ,priceDirectiveToMarketPrice
+  ,priceLookup
   ,tests_Prices
 )
 where
@@ -24,7 +25,7 @@ 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.Graph.Inductive  (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, sp)
 import Data.List
 import Data.List.Extra
 import qualified Data.Map as M
@@ -128,13 +129,12 @@ tests_priceLookup =
 --   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
+-- latest applicable declared price, and converts to the commodity
--- mentioned in that price (default valuation commodity).
+-- mentioned in that price (the default valuation commodity).
 --
--- Note when calling this repeatedly for different periods, the
+-- Note this default valuation commodity can vary across successive
--- default valuation commodity can vary, since it depends on the
+-- calls for different dates, since it depends on the price
--- presence and parse order of market price declarations in each
+-- declarations in each period.
--- period.
 --
 -- This returns the valuation commodity that was specified or
 -- inferred, and the quantity of it that one unit of the source
@@ -142,88 +142,81 @@ tests_priceLookup =
 -- 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
+-- A 'PriceGraph' is built each time this is called, which is probably
--- called, which is probably wasteful when looking up multiple prices
+-- wasteful when looking up multiple prices on the same day; it could
--- on the same day; it could be built at a higher level, or memoised.
+-- 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
     -- XXX should hide these fgl details better
-    Prices{prNodemap=m, prDeclaredPrices=g, prWithReversePrices=gr} = pricesAtDate pricedirectives d
+    PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps} = 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
-        -- the default valuation commodity, if we could find one.
+        -- If to is unspecified, try to pick a default valuation commodity from declared prices (only).
         -- XXX how to choose ? Take lowest sorted ?
         -- Take first, hoping current order is useful ?       <- 
         -- Keep parse order in label and take latest parsed ?
-        mdefaultto = headMay (suc g fromnode) >>= lab g
+        mdefaultto =
+          dbg4 ("default valuation commodity for "++T.unpack from) $
+          headMay [t | (f,t,_) <- out g fromnode, (f,t) `elem` dps] >>= 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.
-        case
+        case mindirectprice of
-          -- These seem unnecessary, and we can avoid building one of the graphs
+          Nothing -> Nothing
-          -- mdeclaredprice <|> mreverseprice <|>
+          Just q  -> Just (to, q)
-          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 g :: Maybe [Node] of
-            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
+                Just $ product $ pathEdgeLabels g nodes  -- convert to a single exchange rate
                 where comms = catMaybes $ map (lab g) nodes
 
           -- log a message and a Maybe Quantity, hiding Just/Nothing and limiting decimal places
           dbg msg = dbg4With (((msg++": ")++) . maybe "" (show . roundTo 8))
 
--- | Convert a list of market price directives in parse order to
+-- | Convert a list of market price directives in parse order to a
--- a database of market prices in effect on a given day,
+-- graph of all prices in effect on a given day, allowing efficient
--- allowing efficient lookup of exchange rates between commodity pairs.
+-- lookup of exchange rates between commodity pairs.
-pricesAtDate :: [PriceDirective] -> Day -> Prices
+pricesAtDate :: [PriceDirective] -> Day -> PriceGraph
-pricesAtDate pricedirectives d = Prices{
+pricesAtDate pricedirectives d = PriceGraph{prGraph=g, prNodemap=m, prDeclaredPairs=dps}
-   prNodemap = m
-  ,prDeclaredPrices = g
-  ,prWithReversePrices = gr
-  }
   where
-    -- get the latest (before d) declared price for each commodity pair
+    -- build the graph and associated node map
-    latestdeclaredprices :: [MarketPrice] =
+    (g :: Gr CommoditySymbol Quantity, m :: NodeMap CommoditySymbol) =
-      dbg5 "latestdeclaredprices" $
+      mkMapGraph
+      (dbg5 "g nodelabels" $ sort allcomms) -- this must include all nodes mentioned in edges
+      (dbg5 "g edges"      $ [(mpfrom, mpto, mprate) | MarketPrice{..} <- prices])
+      where
+        prices   = declaredprices ++ reverseprices
+        allcomms = map mpfrom prices
+
+    -- get the latest (on or before date d) declared price for each commodity pair
+    declaredprices :: [MarketPrice] =
+      dbg5 "declaredprices" $
       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 =
+    -- infer additional reverse prices where not already declared
-      latestdeclaredprices `union` map marketPriceReverse latestdeclaredprices
+    reverseprices =
-        -- XXX hopefully this prioritises the declared prices, test
+      dbg5 "reverseprices" $
-    allcomms = sort $ map mpfrom latestdeclaredandreverseprices
+      map marketPriceReverse declaredprices \\ declaredprices
-    (g :: PriceGraph, m :: NodeMap CommoditySymbol) = mkMapGraph
+
-      (dbg5 "g nodelabels" allcomms) -- this must include all nodes mentioned in edges
+    -- remember which edges correspond to declared prices
-      (dbg5 "g edges"      [(mpfrom, mpto, mprate) | MarketPrice{..} <- latestdeclaredprices])
+    dps = [(node m mpfrom, node m mpto) | MarketPrice{..} <- declaredprices ]
-    (gr, _) = mkMapGraph
-      (dbg5 "gr nodelabels" allcomms) -- this must include all nodes mentioned in edges
-      (dbg5 "gr edges"      [(mpfrom, mpto, mprate) | MarketPrice{..} <- latestdeclaredandreverseprices])
 
 priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
 priceDirectiveToMarketPrice PriceDirective{..} =

hledger-lib/Hledger/Data/Types.hs

@@ -27,7 +27,7 @@ import Data.Data
 import Data.Decimal
 import Data.Default
 import Data.Functor (($>))
-import Data.Graph.Inductive (Gr, NodeMap)
+import Data.Graph.Inductive (Gr,Node,NodeMap)
 import Data.List (intercalate)
 import Text.Blaze (ToMarkup(..))
 --XXX https://hackage.haskell.org/package/containers/docs/Data-Map.html 
@@ -446,15 +446,23 @@ data MarketPrice = MarketPrice {
 
 instance NFData MarketPrice
 
--- | A graph whose node labels are commodities and edge labels are exchange rates.
+-- | A snapshot of the known exchange rates between commodity pairs at a given date,
-type PriceGraph = Gr CommoditySymbol Quantity
+-- as a graph allowing fast lookup and path finding, along with some helper data.
-
+data PriceGraph = PriceGraph {
--- | A snapshot of the known exchange rates between commodity pairs at a given date.
+   prGraph   :: Gr CommoditySymbol Quantity
-data Prices = Prices {
+    -- ^ A directed graph of exchange rates between commodity pairs.
-   prNodemap            :: NodeMap CommoditySymbol
+    -- Node labels are commodities and edge labels are exchange rates,
-  ,prDeclaredPrices     :: PriceGraph  -- ^ Explicitly declared market prices for commodity pairs.
+    -- either explicitly declared (preferred) or inferred by reversing a declared rate.
-  ,prWithReversePrices  :: PriceGraph  -- ^ The above, plus derived reverse prices for any pairs which don't have a declared price.
+    -- There will be at most one edge between each directed pair of commodities,
-  -- ,prWithIndirectPrices :: PriceGraph  -- ^ The above, plus indirect prices found for any pairs which don't have a declared or reverse price.
+    -- eg there can be one USD->EUR and one EUR->USD.
+  ,prNodemap :: NodeMap CommoditySymbol
+    -- ^ Mapping of graph node ids to commodity symbols.
+  ,prDeclaredPairs :: [(Node,Node)]
+    -- ^ Which of the edges in this graph are declared rates,
+    --   rather than inferred reverse rates.
+    --   A bit ugly. We could encode this in the edges,
+    --   but those have to be Real for shortest path finding,
+    --   so we'd have to transform them all first.
   }
   deriving (Show)