684cb45e1a
Beginnings of a project-wide policy for what output to show at each debug level, for now. Later we'll want more flexibility, eg filtering by topic.
406 lines
19 KiB
Haskell
406 lines
19 KiB
Haskell
{-|
|
|
|
|
Convert amounts to some related value in various ways. This involves
|
|
looking up historical market prices (exchange rates) between commodities.
|
|
|
|
-}
|
|
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
|
|
module Hledger.Data.Valuation (
|
|
ValuationType(..)
|
|
,PriceOracle
|
|
,journalPriceOracle
|
|
,unsupportedValueThenError
|
|
-- ,amountApplyValuation
|
|
-- ,amountValueAtDate
|
|
,mixedAmountApplyValuation
|
|
,mixedAmountValueAtDate
|
|
,marketPriceReverse
|
|
,priceDirectiveToMarketPrice
|
|
-- ,priceLookup
|
|
,tests_Valuation
|
|
)
|
|
where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.DeepSeq (NFData)
|
|
import Data.Data
|
|
import Data.Decimal (roundTo)
|
|
import Data.Function ((&), on)
|
|
import Data.Graph.Inductive (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, sp)
|
|
import Data.List
|
|
import Data.List.Extra (nubSortBy)
|
|
import qualified Data.Map as M
|
|
import Data.Maybe
|
|
import qualified Data.Text as T
|
|
import Data.Time.Calendar (Day)
|
|
import Data.MemoUgly (memo)
|
|
import GHC.Generics (Generic)
|
|
import Safe (headMay)
|
|
|
|
import Hledger.Utils
|
|
import Hledger.Data.Types
|
|
import Hledger.Data.Amount
|
|
import Hledger.Data.Dates (parsedate)
|
|
|
|
|
|
------------------------------------------------------------------------------
|
|
-- Types
|
|
|
|
-- | 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,
|
|
-- which were either:
|
|
-- declared by P directives,
|
|
-- implied by transaction prices,
|
|
-- inferred by reversing a declared rate,
|
|
-- or inferred by reversing a transaction-implied 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.
|
|
,prDefaultValuationCommodities :: M.Map CommoditySymbol CommoditySymbol
|
|
-- ^ The default valuation commodity for each source commodity.
|
|
-- These are used when a valuation commodity is not specified
|
|
-- (-V). They are the destination commodity of the latest
|
|
-- (declared or transaction-implied, but not reverse) each
|
|
-- source commodity's latest market price (on the date of this
|
|
-- graph).
|
|
}
|
|
deriving (Show,Generic)
|
|
|
|
instance NFData PriceGraph
|
|
|
|
-- | A price oracle is a magic function that looks up market prices
|
|
-- (exchange rates) from one commodity to another (or if unspecified,
|
|
-- to a default valuation commodity) on a given date, somewhat efficiently.
|
|
type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (CommoditySymbol, Quantity)
|
|
|
|
-- | What kind of value conversion should be done on amounts ?
|
|
-- CLI: --value=cost|then|end|now|DATE[,COMM]
|
|
data ValuationType =
|
|
AtCost (Maybe CommoditySymbol) -- ^ convert to cost commodity using transaction prices, then optionally to given commodity using market prices at posting date
|
|
| AtThen (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using market prices at each posting's date
|
|
| AtEnd (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using market prices at period end(s)
|
|
| AtNow (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using current market prices
|
|
| AtDate Day (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using market prices on some date
|
|
| AtDefault (Maybe CommoditySymbol) -- ^ works like AtNow in single period reports, like AtEnd in multiperiod reports
|
|
deriving (Show,Data,Eq) -- Typeable
|
|
|
|
|
|
------------------------------------------------------------------------------
|
|
-- Valuation
|
|
|
|
-- | Apply a specified valuation to this mixed amount, using the
|
|
-- provided price oracle, commodity styles, reference dates, and
|
|
-- whether this is for a multiperiod report or not.
|
|
-- See amountApplyValuation.
|
|
mixedAmountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Maybe Day -> Day -> Bool -> ValuationType -> MixedAmount -> MixedAmount
|
|
mixedAmountApplyValuation priceoracle styles periodlast mreportlast today ismultiperiod v (Mixed as) =
|
|
Mixed $ map (amountApplyValuation priceoracle styles periodlast mreportlast today ismultiperiod v) as
|
|
|
|
-- | Apply a specified valuation to this amount, using the provided
|
|
-- price oracle, reference dates, and whether this is for a
|
|
-- multiperiod report or not. Also fix up its display style using the
|
|
-- provided commodity styles.
|
|
--
|
|
-- When the valuation requires converting to another commodity, a
|
|
-- valuation (conversion) date is chosen based on the valuation type,
|
|
-- the provided reference dates, and whether this is for a
|
|
-- single-period or multi-period report. It will be one of:
|
|
--
|
|
-- - a fixed date specified by the ValuationType itself
|
|
-- (--value=DATE).
|
|
--
|
|
-- - the provided "period end" date - this is typically the last day
|
|
-- of a subperiod (--value=end with a multi-period report), or of
|
|
-- the specified report period or the journal (--value=end with a
|
|
-- single-period report).
|
|
--
|
|
-- - the provided "report end" date - the last day of the specified
|
|
-- report period, if any (-V/-X with a report end date).
|
|
--
|
|
-- - the provided "today" date - (--value=now, or -V/X with no report
|
|
-- end date).
|
|
--
|
|
-- Note --value=then is not supported by this function, and will cause an error;
|
|
-- use postingApplyValuation for that.
|
|
--
|
|
-- This is all a bit complicated. See the reference doc at
|
|
-- https://hledger.org/hledger.html#effect-of-valuation-on-reports
|
|
-- (hledger_options.m4.md "Effect of valuation on reports"), and #1083.
|
|
--
|
|
amountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Maybe Day -> Day -> Bool -> ValuationType -> Amount -> Amount
|
|
amountApplyValuation priceoracle styles periodlast mreportlast today ismultiperiod v a =
|
|
case v of
|
|
AtCost Nothing -> styleAmount styles $ amountCost a
|
|
AtCost mc -> amountValueAtDate priceoracle styles mc periodlast $ styleAmount styles $ amountCost a
|
|
AtThen _mc -> error' unsupportedValueThenError -- TODO
|
|
-- amountValueAtDate priceoracle styles mc periodlast a -- posting date unknown, handle like AtEnd
|
|
AtEnd mc -> amountValueAtDate priceoracle styles mc periodlast a
|
|
AtNow mc -> amountValueAtDate priceoracle styles mc today a
|
|
AtDefault mc | ismultiperiod -> amountValueAtDate priceoracle styles mc periodlast a
|
|
AtDefault mc -> amountValueAtDate priceoracle styles mc (fromMaybe today mreportlast) a
|
|
AtDate d mc -> amountValueAtDate priceoracle styles mc d a
|
|
|
|
-- | Standard error message for a report not supporting --value=then.
|
|
unsupportedValueThenError :: String
|
|
unsupportedValueThenError = "Sorry, --value=then is not yet implemented for this kind of report."
|
|
|
|
-- | Find the market value of each component amount in the given
|
|
-- commodity, or its default valuation commodity, at the given
|
|
-- valuation date, using the given market price oracle.
|
|
-- When market prices available on that date are not sufficient to
|
|
-- calculate the value, amounts are left unchanged.
|
|
mixedAmountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
|
|
mixedAmountValueAtDate priceoracle styles mc d (Mixed as) = Mixed $ map (amountValueAtDate priceoracle styles mc d) as
|
|
|
|
-- | Find the market value of this amount in the given valuation
|
|
-- commodity if any, otherwise the default valuation commodity, at the
|
|
-- given valuation date. (The default valuation commodity is the
|
|
-- commodity of the latest applicable market price before the
|
|
-- valuation date.)
|
|
--
|
|
-- The returned amount will have its commodity's canonical style applied,
|
|
-- but with the precision adjusted to show all significant decimal digits
|
|
-- up to a maximum of 8. (experimental)
|
|
--
|
|
-- If the market prices available on that date are not sufficient to
|
|
-- calculate this value, the amount is left unchanged.
|
|
amountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount
|
|
amountValueAtDate priceoracle styles mto d a =
|
|
case priceoracle (d, acommodity a, mto) of
|
|
Nothing -> a
|
|
Just (comm, rate) ->
|
|
-- setNaturalPrecisionUpTo 8 $ -- XXX force higher precision in case amount appears to be zero ?
|
|
-- Make default display style use precision 2 instead of 0 ?
|
|
-- Leave as is for now; mentioned in manual.
|
|
styleAmount styles
|
|
amount{acommodity=comm, aquantity=rate * aquantity a}
|
|
|
|
------------------------------------------------------------------------------
|
|
-- Market price lookup
|
|
|
|
-- From a journal's directive-declared and transaction-implied market
|
|
-- prices, generate a memoising function that efficiently looks up
|
|
-- exchange rates between commodities on any date. For best performance,
|
|
-- you should generate this only once per journal, reusing it across
|
|
-- reports if there are more than one (as in compoundBalanceCommand).
|
|
journalPriceOracle :: Journal -> PriceOracle
|
|
journalPriceOracle Journal{jpricedirectives, jimpliedmarketprices} =
|
|
-- traceStack "journalPriceOracle" $
|
|
let
|
|
pricesatdate =
|
|
memo $
|
|
pricesAtDate jpricedirectives jimpliedmarketprices
|
|
in
|
|
memo $
|
|
uncurry3 $
|
|
priceLookup pricesatdate
|
|
|
|
-- | Given a list of price directives in parse order, find the market
|
|
-- 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 an
|
|
-- exchange rate (market price) calculated in any of the following
|
|
-- ways, in order of preference:
|
|
--
|
|
-- 1. a declared market price (DMP) - a P directive giving the
|
|
-- exchange rate from source commodity to valuation commodity
|
|
--
|
|
-- 2. a transaction-implied market price (TMP) - a market price
|
|
-- equivalent to the transaction price used in the latest
|
|
-- transaction from source commodity to valuation commodity
|
|
-- (on or before the valuation date)
|
|
--
|
|
-- 3. a reverse declared market price (RDMP) - calculated by inverting
|
|
-- a DMP
|
|
--
|
|
-- 4. a reverse transaction-implied market price (RTMP) - calculated
|
|
-- by inverting a TMP
|
|
--
|
|
-- 5. an indirect market price (IMP) - calculated by combining the
|
|
-- shortest chain of market prices (any of the above types) leading
|
|
-- from source commodity to valuation commodity.
|
|
--
|
|
-- When the valuation commodity is not specified, this looks for the
|
|
-- latest applicable declared or transaction-implied price, and
|
|
-- converts to the commodity mentioned in that price (the default
|
|
-- valuation commodity).
|
|
--
|
|
-- 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
|
|
-- 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.
|
|
--
|
|
priceLookup :: (Day -> PriceGraph) -> Day -> CommoditySymbol -> Maybe CommoditySymbol -> Maybe (CommoditySymbol, Quantity)
|
|
priceLookup pricesatdate d from mto =
|
|
-- trace ("priceLookup ("++show d++", "++show from++", "++show mto++")") $
|
|
let
|
|
-- build a graph of the commodity exchange rates in effect on this day
|
|
-- XXX should hide these fgl details better
|
|
PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests} = pricesatdate d
|
|
fromnode = node m from
|
|
mto' = mto <|> mdefaultto
|
|
where
|
|
mdefaultto = dbg1 ("default valuation commodity for "++T.unpack from) $
|
|
M.lookup from defaultdests
|
|
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 mindirectprice of
|
|
Nothing -> Nothing
|
|
Just q -> Just (to, q)
|
|
where
|
|
tonode = node m to
|
|
mindirectprice :: Maybe Quantity =
|
|
-- Find the shortest path, if any, between from and to.
|
|
case sp fromnode tonode g :: Maybe [Node] of
|
|
Nothing -> Nothing
|
|
Just nodes ->
|
|
dbg ("market price for "++intercalate " -> " (map T.unpack comms)) $
|
|
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 = dbg1With (((msg++": ")++) . maybe "" (show . roundTo 8))
|
|
|
|
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"
|
|
]
|
|
pricesatdate = pricesAtDate ps1 []
|
|
in test "priceLookup" $ do
|
|
priceLookup pricesatdate (d "1999/01/01") "A" Nothing @?= Nothing
|
|
priceLookup pricesatdate (d "2000/01/01") "A" Nothing @?= Just ("B",10)
|
|
priceLookup pricesatdate (d "2000/01/01") "B" (Just "A") @?= Just ("A",0.1)
|
|
priceLookup pricesatdate (d "2000/01/01") "A" (Just "E") @?= Just ("E",500)
|
|
|
|
------------------------------------------------------------------------------
|
|
-- Building the price graph (network of commodity conversions) on a given day.
|
|
|
|
-- | Convert a list of market price directives in parse order, and a
|
|
-- list of transaction-implied market prices in parse order, to a
|
|
-- graph of the effective exchange rates between commodity pairs on
|
|
-- the given day.
|
|
pricesAtDate :: [PriceDirective] -> [MarketPrice] -> Day -> PriceGraph
|
|
pricesAtDate pricedirectives impliedmarketprices d =
|
|
dbg9 ("pricesAtDate "++show d) $
|
|
PriceGraph{prGraph=g, prNodemap=m, prDefaultValuationCommodities=defaultdests}
|
|
where
|
|
-- prices in effect on date d, either declared or implied
|
|
currentdeclaredandimpliedprices = dbg2 "currentdeclaredandimpliedprices" $
|
|
latestPriceForEachPairOn pricedirectives impliedmarketprices d
|
|
|
|
-- infer any additional reverse prices not already declared or implied
|
|
reverseprices = dbg2 "reverseprices" $
|
|
map marketPriceReverse currentdeclaredandimpliedprices \\ currentdeclaredandimpliedprices
|
|
|
|
-- build the graph and associated node map
|
|
(g, m) =
|
|
mkMapGraph
|
|
(dbg9 "price graph labels" $ sort allcomms) -- this must include all nodes mentioned in edges
|
|
(dbg9 "price graph edges" $ [(mpfrom, mpto, mprate) | MarketPrice{..} <- prices])
|
|
:: (Gr CommoditySymbol Quantity, NodeMap CommoditySymbol)
|
|
where
|
|
prices = currentdeclaredandimpliedprices ++ reverseprices
|
|
allcomms = map mpfrom prices
|
|
|
|
-- determine a default valuation commodity D for each source commodity S:
|
|
-- the price commodity in the latest declared market price for S (on any date)
|
|
defaultdests = M.fromList [(mpfrom,mpto) | MarketPrice{..} <- alldeclaredprices]
|
|
where
|
|
alldeclaredprices = dbg2 "alldeclaredprices" $ map priceDirectiveToMarketPrice pricedirectives
|
|
|
|
-- From a list of price directives in parse order, and a list of
|
|
-- transaction-implied market prices in parse order, get the effective
|
|
-- price on the given date for each commodity pair. That is, the
|
|
-- latest declared or transaction-implied price dated on or before
|
|
-- that day, with declared prices taking precedence.
|
|
latestPriceForEachPairOn :: [PriceDirective] -> [MarketPrice] -> Day -> [MarketPrice]
|
|
latestPriceForEachPairOn pricedirectives impliedmarketprices d =
|
|
let
|
|
-- consider only declarations/transactions before the valuation date
|
|
declaredprices = map priceDirectiveToMarketPrice $ filter ((<=d).pddate) pricedirectives
|
|
impliedmarketprices' = filter ((<=d).mpdate) impliedmarketprices
|
|
-- label the items with their precedence and then their parse order
|
|
declaredprices' = [(1, i, p) | (i,p) <- zip [1..] declaredprices]
|
|
impliedmarketprices'' = [(0, i, p) | (i,p) <- zip [1..] impliedmarketprices']
|
|
in
|
|
-- combine
|
|
declaredprices' ++ impliedmarketprices''
|
|
-- sort by newest date then highest precedence then latest parse order
|
|
& sortBy (flip compare `on` (\(precedence,parseorder,mp)->(mpdate mp,precedence,parseorder)))
|
|
-- discard the sorting labels
|
|
& map third3
|
|
-- keep only the first (ie the newest, highest precedence and latest parsed) price for each pair
|
|
& nubSortBy (compare `on` (\(MarketPrice{..})->(mpfrom,mpto)))
|
|
|
|
priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
|
|
priceDirectiveToMarketPrice PriceDirective{..} =
|
|
MarketPrice{ mpdate = pddate
|
|
, mpfrom = pdcommodity
|
|
, mpto = acommodity pdamount
|
|
, mprate = aquantity pdamount
|
|
}
|
|
|
|
marketPriceReverse :: MarketPrice -> MarketPrice
|
|
marketPriceReverse mp@MarketPrice{..} = mp{mpfrom=mpto, mpto=mpfrom, mprate=1/mprate}
|
|
|
|
------------------------------------------------------------------------------
|
|
-- fgl helpers
|
|
|
|
-- | Look up an existing graph node by its label.
|
|
-- (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 within 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]
|
|
|
|
------------------------------------------------------------------------------
|
|
|
|
tests_Valuation = tests "Valuation" [
|
|
tests_priceLookup
|
|
]
|