diff --git a/hledger-lib/Hledger/Data/Posting.hs b/hledger-lib/Hledger/Data/Posting.hs index 373c261a2..911a35e4e 100644 --- a/hledger-lib/Hledger/Data/Posting.hs +++ b/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 - AtEnd mc -> postingValueAtDate prices mc periodend p - AtNow mc -> postingValueAtDate prices mc today p - AtDefault mc | ismultiperiod -> postingValueAtDate prices mc periodend p - AtDefault mc -> postingValueAtDate prices mc today p - AtDate d mc -> postingValueAtDate prices mc d p + AtCost mc -> postingValueAtDate prices styles mc periodend $ postingToCost styles p + AtEnd mc -> postingValueAtDate prices styles mc periodend p + AtNow mc -> postingValueAtDate prices styles mc today p + AtDefault mc | ismultiperiod -> postingValueAtDate prices styles mc periodend p + AtDefault mc -> postingValueAtDate prices styles mc today 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 prices mc d p = postingTransformAmount (mixedAmountValueAtDate prices mc d) p +postingValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Posting -> Posting +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 diff --git a/hledger-lib/Hledger/Data/Prices.hs b/hledger-lib/Hledger/Data/Prices.hs index 8010a25e3..1e318515e 100644 --- a/hledger-lib/Hledger/Data/Prices.hs +++ b/hledger-lib/Hledger/Data/Prices.hs @@ -1,7 +1,7 @@ {-| -Find historical market prices (exchange rates) between commodities, -convert amounts to value in various ways. +Convert amounts to some related value in various ways. This involves +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 prices mc d (Mixed as) = Mixed $ map (amountValueAtDate prices mc d) as +mixedAmountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount +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 - AtEnd mc -> amountValueAtDate prices mc periodend a - AtNow mc -> amountValueAtDate prices mc today a - AtDefault mc | ismultiperiod -> amountValueAtDate prices mc periodend a - AtDefault mc -> amountValueAtDate prices mc today a - AtDate d mc -> amountValueAtDate prices mc d 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 @@ -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 pricedirectives mc d a = - case priceLookup pricedirectives d mc (acommodity a) of - Just v -> v{aquantity=aquantity v * aquantity a} - Nothing -> a +amountValueAtDate :: [PriceDirective] -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount +amountValueAtDate pricedirectives styles mto d a = + case priceLookup pricedirectives d (acommodity a) mto of + 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 --- different specified valuation commodity, defaulting to the --- commodity of the most recent applicable price. --- This might be slow if there are many price declarations. +-- value at the given date of one unit of a given source commodity, in +-- a different specified valuation commodity, or a default valuation +-- commodity. -- -- When the valuation commodity is specified, this looks for, in order: -- --- - a direct price, giving the exchange rate from source commodity to --- valuation commodity. +-- - a price declaration giving the exchange rate from source +-- commodity to valuation commodity ("declared price"). -- --- - a reverse direct price, giving the exchange rate from valuation --- commodity to source commodity, which is inverted. +-- - a price declaration from valuation to source commodity, which +-- gets inverted ("reverse price"). -- --- - (TODO: the shortest chain of prices leading from source commodity --- to valuation commodity, which is collapsed into a single --- synthetic exchange rate.) +-- - the shortest chain of prices (declared or reverse) leading from +-- source commodity to valuation commodity, which gets collapsed +-- 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 --- 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 --- if the source commodity and the valuation commodity are the same, --- this returns Nothing. +-- mentioned in that price (default valuation commodity). -- -priceLookup :: [PriceDirective] -> Day -> Maybe CommoditySymbol -> CommoditySymbol -> Maybe Amount -priceLookup pricedirectives d mto from - | mto == Just from = Nothing - | otherwise = mdirectprice <|> mreverseprice +-- 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. +-- +-- This returns the valuation commodity that was specified or +-- inferred, and the quantity of it that one unit of the source +-- commodity is worth. Or if no applicable market price or chain of +-- 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 + -- the default valuation commodity, if we could find one. + -- 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 + 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 + + -- log a message and a Maybe Quantity, hiding Just/Nothing and limiting decimal places + dbg msg = dbg4With (((msg++": ")++) . maybe "" (show . roundTo 3)) + +-- | 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 + } where - dbgprice lbl = - dbg4With ( ((lbl++" for "++T.unpack from++" at "++show d++": ") ++) - . maybe "none" showAmount ) + -- 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]) - latestfirst = reverse $ sortOn pddate pricedirectives -- sortOn will preserve parse order within the same date I think +priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice +priceDirectiveToMarketPrice PriceDirective{..} = + MarketPrice{ mpdate = pddate + , mpfrom = pdcommodity + , mpto = acommodity pdamount + , mprate = aquantity pdamount + } - -- Key to commodity symbols: - -- from - commodity we are converting from (looking up a price for) - -- mto - commodity we want to convert to, or Nothing meaning use default - -- pfrom - commodity that this market price converts from - -- pto - commodity that this market price converts to - - -- prPriceDirectives is sorted by date then parse order, reversed. So the - -- first price on or before the valuation date is the effective one. - - mdirectprice = - dbgprice "direct market price" $ - headMay [pdamount | PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst - , let pto = acommodity pdamount - , pddate <= d - , pfrom == from - , maybe True (== pto) mto - ] - mreverseprice = - dbgprice "reverse market price" $ - headMay [ priceamt - | PriceDirective{pddate, pdcommodity=pfrom, pdamount} <- latestfirst - , let pto = acommodity pdamount - , pddate <= d - , pto == from - , maybe False (== pfrom) mto -- use reverse prices only when target commodity is explicitly specified - , let PriceDirective{pdamount=priceamt} = undefined -- marketPriceInvert mp - ] - -tests_priceLookup = tests "priceLookup" [ - priceLookup [] (d "2019-06-01") Nothing "" `is` Nothing - ] +marketPriceReverse :: MarketPrice -> MarketPrice +marketPriceReverse mp@MarketPrice{..} = mp{mpfrom=mpto, mpto=mpfrom, mprate=1/mprate} + +------------------------------------------------------------------------------ +-- fgl helpers + +-- | 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 +-- persisted in the nodemap.) +node :: Ord a => NodeMap a -> a -> Node +node m = fst . fst . mkNode m + +-- | Convert a valid path from the given graph to the corresponding +-- edge labels. When there are multiple edges between two nodes, the +-- lowest-sorting label is used. +pathEdgeLabels :: (Show b, Ord b) => Gr a b -> [Node] -> [b] +pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges + where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here") + +-- | Convert a path to node pairs representing the path's edges. +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] ------------------------------------------------------------------------------ diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index 41be0a59d..c2abd0a24 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/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, --- organised as maps for efficient lookup. +-- | 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 { - prDeclaredPrices :: - M.Map CommoditySymbol -- from commodity A - (M.Map CommoditySymbol -- to commodity B - Quantity) -- exchange rate from A to B (one A is worth this many B) - -- ^ Explicitly declared market prices, as { FROMCOMM : { TOCOMM : RATE } }. + 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. } + deriving (Show) -- | What kind of value conversion should be done on amounts ? -- UI: --value=cost|end|now|DATE[,COMM] diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index d0317172e..1edefef50 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/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 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index d2b32058e..805d3979d 100644 --- a/hledger-lib/package.yaml +++ b/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 diff --git a/hledger/hledger_options.m4.md b/hledger/hledger_options.m4.md index 735d662f3..778129ddd 100644 --- a/hledger/hledger_options.m4.md +++ b/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 -B, or (after inverting them) prices from B to A; -it does not yet follow chains of market prices. +This will use, in this preferred order: + +- 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