simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-09-20 02:37:12 +03:00
Code Issues Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Simon Michael 2019-06-11 15:08:09 -07:00
parent dd5afbb6fe
commit e664fab956
2 changed files with 64 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

99
hledger-lib/Hledger/Data/Prices.hs
View File

@ -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{..} =

28
hledger-lib/Hledger/Data/Types.hs
View File

@ -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)