diff --git a/hledger-lib/Hledger/Data/Prices.hs b/hledger-lib/Hledger/Data/Prices.hs index c5f70d36f..1ee26583e 100644 --- a/hledger-lib/Hledger/Data/Prices.hs +++ b/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 --- mentioned in that price (default valuation commodity). +-- latest applicable declared price, and converts to the commodity +-- mentioned in that price (the default valuation commodity). -- --- Note when calling this repeatedly for different periods, the --- default valuation commodity can vary, since it depends on the --- presence and parse order of market price declarations in each --- period. +-- Note this default valuation commodity can vary across successive +-- calls for different dates, since it depends on the price +-- declarations in each 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 --- called, which is probably wasteful when looking up multiple prices --- on the same day; it could be built at a higher level, or memoised. +-- A 'PriceGraph' 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 -- 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 - -- These seem unnecessary, and we can avoid building one of the graphs - -- mdeclaredprice <|> mreverseprice <|> - mindirectprice of - Nothing -> Nothing - Just q -> Just (to, q) + case 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 + case sp fromnode tonode g :: 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 --- a database of market prices in effect on a given day, --- allowing efficient lookup of exchange rates between commodity pairs. -pricesAtDate :: [PriceDirective] -> Day -> Prices -pricesAtDate pricedirectives d = Prices{ - prNodemap = m - ,prDeclaredPrices = g - ,prWithReversePrices = gr - } +-- | Convert a list of market price directives in parse order to a +-- 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} where - -- get the latest (before d) declared price for each commodity pair - latestdeclaredprices :: [MarketPrice] = - dbg5 "latestdeclaredprices" $ + -- build the graph and associated node map + (g :: Gr CommoditySymbol Quantity, m :: NodeMap CommoditySymbol) = + 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 = - 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]) + + -- infer additional reverse prices where not already declared + reverseprices = + dbg5 "reverseprices" $ + map marketPriceReverse declaredprices \\ declaredprices + + -- remember which edges correspond to declared prices + dps = [(node m mpfrom, node m mpto) | MarketPrice{..} <- declaredprices ] priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice priceDirectiveToMarketPrice PriceDirective{..} = diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index c2abd0a24..00e9f98dd 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/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. -type PriceGraph = Gr CommoditySymbol Quantity - --- | A snapshot of the known exchange rates between commodity pairs at a given date. -data Prices = Prices { - prNodemap :: NodeMap CommoditySymbol - ,prDeclaredPrices :: PriceGraph -- ^ Explicitly declared market prices for commodity pairs. - ,prWithReversePrices :: PriceGraph -- ^ The above, plus derived reverse prices for any pairs which don't have a declared price. - -- ,prWithIndirectPrices :: PriceGraph -- ^ The above, plus indirect prices found for any pairs which don't have a declared or reverse price. +-- | A snapshot of the known exchange rates between commodity pairs at a given date, +-- as a graph allowing fast lookup and path finding, along with some helper data. +data PriceGraph = PriceGraph { + prGraph :: Gr CommoditySymbol Quantity + -- ^ A directed graph of exchange rates between commodity pairs. + -- Node labels are commodities and edge labels are exchange rates, + -- either explicitly declared (preferred) or inferred by reversing a declared rate. + -- There will be at most one edge between each directed pair of commodities, + -- 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)