{-|

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
  -- ,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 {
   PriceGraph -> Gr CommoditySymbol Quantity
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.
  ,PriceGraph -> NodeMap CommoditySymbol
prNodemap :: NodeMap CommoditySymbol
    -- ^ Mapping of graph node ids to commodity symbols.
  ,PriceGraph -> [(Node, Node)]
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 (Node -> PriceGraph -> ShowS
[PriceGraph] -> ShowS
PriceGraph -> String
(Node -> PriceGraph -> ShowS)
-> (PriceGraph -> String)
-> ([PriceGraph] -> ShowS)
-> Show PriceGraph
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PriceGraph] -> ShowS
$cshowList :: [PriceGraph] -> ShowS
show :: PriceGraph -> String
$cshow :: PriceGraph -> String
showsPrec :: Node -> PriceGraph -> ShowS
$cshowsPrec :: Node -> PriceGraph -> ShowS
Show,(forall x. PriceGraph -> Rep PriceGraph x)
-> (forall x. Rep PriceGraph x -> PriceGraph) -> Generic PriceGraph
forall x. Rep PriceGraph x -> PriceGraph
forall x. PriceGraph -> Rep PriceGraph x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PriceGraph x -> PriceGraph
$cfrom :: forall x. PriceGraph -> Rep PriceGraph x
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 ?
-- UI: --value=cost|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
  | AtEnd      (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using market prices at period end(s)
  | AtNow      (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using current market prices
  | AtDate Day (Maybe CommoditySymbol)  -- ^ convert to default valuation commodity or given commodity, using market prices on some date
  | AtDefault  (Maybe CommoditySymbol)  -- ^ works like AtNow in single period reports, like AtEnd in multiperiod reports
  deriving (Node -> ValuationType -> ShowS
[ValuationType] -> ShowS
ValuationType -> String
(Node -> ValuationType -> ShowS)
-> (ValuationType -> String)
-> ([ValuationType] -> ShowS)
-> Show ValuationType
forall a.
(Node -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValuationType] -> ShowS
$cshowList :: [ValuationType] -> ShowS
show :: ValuationType -> String
$cshow :: ValuationType -> String
showsPrec :: Node -> ValuationType -> ShowS
$cshowsPrec :: Node -> ValuationType -> ShowS
Show,Typeable ValuationType
Constr
DataType
Typeable ValuationType =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> ValuationType -> c ValuationType)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ValuationType)
-> (ValuationType -> Constr)
-> (ValuationType -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ValuationType))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ValuationType))
-> ((forall b. Data b => b -> b) -> ValuationType -> ValuationType)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ValuationType -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ValuationType -> r)
-> (forall u. (forall d. Data d => d -> u) -> ValuationType -> [u])
-> (forall u.
    Node -> (forall d. Data d => d -> u) -> ValuationType -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ValuationType -> m ValuationType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ValuationType -> m ValuationType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ValuationType -> m ValuationType)
-> Data ValuationType
ValuationType -> Constr
ValuationType -> DataType
(forall b. Data b => b -> b) -> ValuationType -> ValuationType
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValuationType -> c ValuationType
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValuationType
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Node -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Node -> (forall d. Data d => d -> u) -> ValuationType -> u
forall u. (forall d. Data d => d -> u) -> ValuationType -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ValuationType -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ValuationType -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValuationType
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValuationType -> c ValuationType
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ValuationType)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ValuationType)
$cAtDefault :: Constr
$cAtDate :: Constr
$cAtNow :: Constr
$cAtEnd :: Constr
$cAtCost :: Constr
$tValuationType :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
gmapMp :: (forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
gmapM :: (forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ValuationType -> m ValuationType
gmapQi :: Node -> (forall d. Data d => d -> u) -> ValuationType -> u
$cgmapQi :: forall u.
Node -> (forall d. Data d => d -> u) -> ValuationType -> u
gmapQ :: (forall d. Data d => d -> u) -> ValuationType -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ValuationType -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ValuationType -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ValuationType -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ValuationType -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ValuationType -> r
gmapT :: (forall b. Data b => b -> b) -> ValuationType -> ValuationType
$cgmapT :: (forall b. Data b => b -> b) -> ValuationType -> ValuationType
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ValuationType)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ValuationType)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c ValuationType)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ValuationType)
dataTypeOf :: ValuationType -> DataType
$cdataTypeOf :: ValuationType -> DataType
toConstr :: ValuationType -> Constr
$ctoConstr :: ValuationType -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValuationType
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ValuationType
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValuationType -> c ValuationType
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ValuationType -> c ValuationType
$cp1Data :: Typeable ValuationType
Data,ValuationType -> ValuationType -> Bool
(ValuationType -> ValuationType -> Bool)
-> (ValuationType -> ValuationType -> Bool) -> Eq ValuationType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValuationType -> ValuationType -> Bool
$c/= :: ValuationType -> ValuationType -> Bool
== :: ValuationType -> ValuationType -> Bool
$c== :: ValuationType -> ValuationType -> Bool
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
-> Map CommoditySymbol AmountStyle
-> Day
-> Maybe Day
-> Day
-> Bool
-> ValuationType
-> MixedAmount
-> MixedAmount
mixedAmountApplyValuation priceoracle :: PriceOracle
priceoracle styles :: Map CommoditySymbol AmountStyle
styles periodlast :: Day
periodlast mreportlast :: Maybe Day
mreportlast today :: Day
today ismultiperiod :: Bool
ismultiperiod v :: ValuationType
v (Mixed as :: [Amount]
as) =
  [Amount] -> MixedAmount
Mixed ([Amount] -> MixedAmount) -> [Amount] -> MixedAmount
forall a b. (a -> b) -> a -> b
$ (Amount -> Amount) -> [Amount] -> [Amount]
forall a b. (a -> b) -> [a] -> [b]
map (PriceOracle
-> Map CommoditySymbol AmountStyle
-> Day
-> Maybe Day
-> Day
-> Bool
-> ValuationType
-> Amount
-> Amount
amountApplyValuation PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Day
periodlast Maybe Day
mreportlast Day
today Bool
ismultiperiod ValuationType
v) [Amount]
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).
-- 
-- This is all a bit complicated. See the reference doc at
-- https://hledger.org/hledger.html#effect-of-value-on-reports
-- (hledger_options.m4.md "Effect of --value on reports"), and #1083.
--
amountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Maybe Day -> Day -> Bool -> ValuationType -> Amount -> Amount
amountApplyValuation :: PriceOracle
-> Map CommoditySymbol AmountStyle
-> Day
-> Maybe Day
-> Day
-> Bool
-> ValuationType
-> Amount
-> Amount
amountApplyValuation priceoracle :: PriceOracle
priceoracle styles :: Map CommoditySymbol AmountStyle
styles periodlast :: Day
periodlast mreportlast :: Maybe Day
mreportlast today :: Day
today ismultiperiod :: Bool
ismultiperiod v :: ValuationType
v a :: Amount
a =
  case ValuationType
v of
    AtCost    Nothing            -> Map CommoditySymbol AmountStyle -> Amount -> Amount
amountToCost Map CommoditySymbol AmountStyle
styles Amount
a
    AtCost    mc :: Maybe CommoditySymbol
mc                 -> PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
periodlast (Amount -> Amount) -> Amount -> Amount
forall a b. (a -> b) -> a -> b
$ Map CommoditySymbol AmountStyle -> Amount -> Amount
amountToCost Map CommoditySymbol AmountStyle
styles Amount
a
    AtEnd     mc :: Maybe CommoditySymbol
mc                 -> PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
periodlast Amount
a
    AtNow     mc :: Maybe CommoditySymbol
mc                 -> PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
today Amount
a
    AtDefault mc :: Maybe CommoditySymbol
mc | Bool
ismultiperiod -> PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
periodlast Amount
a
    AtDefault mc :: Maybe CommoditySymbol
mc                 -> PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc (Day -> Maybe Day -> Day
forall a. a -> Maybe a -> a
fromMaybe Day
today Maybe Day
mreportlast) Amount
a
    AtDate d :: Day
d  mc :: Maybe CommoditySymbol
mc                 -> PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
d Amount
a

-- | 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
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> MixedAmount
-> MixedAmount
mixedAmountValueAtDate priceoracle :: PriceOracle
priceoracle styles :: Map CommoditySymbol AmountStyle
styles mc :: Maybe CommoditySymbol
mc d :: Day
d (Mixed as :: [Amount]
as) = [Amount] -> MixedAmount
Mixed ([Amount] -> MixedAmount) -> [Amount] -> MixedAmount
forall a b. (a -> b) -> a -> b
$ (Amount -> Amount) -> [Amount] -> [Amount]
forall a b. (a -> b) -> [a] -> [b]
map (PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
d) [Amount]
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
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate priceoracle :: PriceOracle
priceoracle styles :: Map CommoditySymbol AmountStyle
styles mto :: Maybe CommoditySymbol
mto d :: Day
d a :: Amount
a =
  case PriceOracle
priceoracle (Day
d, Amount -> CommoditySymbol
acommodity Amount
a, Maybe CommoditySymbol
mto) of
    Nothing           -> Amount
a
    Just (comm :: CommoditySymbol
comm, rate :: Quantity
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.
      Map CommoditySymbol AmountStyle -> Amount -> Amount
styleAmount Map CommoditySymbol AmountStyle
styles
      Amount
amount{acommodity :: CommoditySymbol
acommodity=CommoditySymbol
comm, aquantity :: Quantity
aquantity=Quantity
rate Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
* Amount -> Quantity
aquantity Amount
a}

------------------------------------------------------------------------------
-- Market price lookup

-- From a journal's market price directives, generate a memoising function
-- that efficiently looks up exchange rates between commodities on any date.
-- For best results, 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 -> PriceOracle
journalPriceOracle Journal{[PriceDirective]
jpricedirectives :: Journal -> [PriceDirective]
jpricedirectives :: [PriceDirective]
jpricedirectives} =
  -- traceStack "journalPriceOracle" $
  let
    pricesatdate :: Day -> PriceGraph
pricesatdate =
      (Day -> PriceGraph) -> Day -> PriceGraph
forall a b. Ord a => (a -> b) -> a -> b
memo ((Day -> PriceGraph) -> Day -> PriceGraph)
-> (Day -> PriceGraph) -> Day -> PriceGraph
forall a b. (a -> b) -> a -> b
$
      [PriceDirective] -> Day -> PriceGraph
pricesAtDate [PriceDirective]
jpricedirectives
  in
    PriceOracle -> PriceOracle
forall a b. Ord a => (a -> b) -> a -> b
memo (PriceOracle -> PriceOracle) -> PriceOracle -> PriceOracle
forall a b. (a -> b) -> a -> b
$
    (Day
 -> CommoditySymbol
 -> Maybe CommoditySymbol
 -> Maybe (CommoditySymbol, Quantity))
-> PriceOracle
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 ((Day
  -> CommoditySymbol
  -> Maybe CommoditySymbol
  -> Maybe (CommoditySymbol, Quantity))
 -> PriceOracle)
-> (Day
    -> CommoditySymbol
    -> Maybe CommoditySymbol
    -> Maybe (CommoditySymbol, Quantity))
-> PriceOracle
forall a b. (a -> b) -> a -> b
$
    (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
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, in order:
--
-- - a price declaration giving the exchange rate from source
--   commodity to valuation commodity ("declared price").
--
-- - a price declaration from valuation to source commodity, which
--   gets inverted ("reverse price").
--
-- - 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 declared 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 :: (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup pricesatdate :: Day -> PriceGraph
pricesatdate d :: Day
d from :: CommoditySymbol
from mto :: Maybe CommoditySymbol
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 :: PriceGraph -> Gr CommoditySymbol Quantity
prGraph=Gr CommoditySymbol Quantity
g, prNodemap :: PriceGraph -> NodeMap CommoditySymbol
prNodemap=NodeMap CommoditySymbol
m, prDeclaredPairs :: PriceGraph -> [(Node, Node)]
prDeclaredPairs=[(Node, Node)]
dps} = Day -> PriceGraph
pricesatdate Day
d
    fromnode :: Node
fromnode = NodeMap CommoditySymbol -> CommoditySymbol -> Node
forall a. Ord a => NodeMap a -> a -> Node
node NodeMap CommoditySymbol
m CommoditySymbol
from
    mto' :: Maybe CommoditySymbol
mto' = Maybe CommoditySymbol
mto Maybe CommoditySymbol
-> Maybe CommoditySymbol -> Maybe CommoditySymbol
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CommoditySymbol
mdefaultto
      where
        -- 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 :: Maybe CommoditySymbol
mdefaultto =
          String -> Maybe CommoditySymbol -> Maybe CommoditySymbol
forall a. Show a => String -> a -> a
dbg4 ("default valuation commodity for "String -> ShowS
forall a. [a] -> [a] -> [a]
++CommoditySymbol -> String
T.unpack CommoditySymbol
from) (Maybe CommoditySymbol -> Maybe CommoditySymbol)
-> Maybe CommoditySymbol -> Maybe CommoditySymbol
forall a b. (a -> b) -> a -> b
$
          [Node] -> Maybe Node
forall a. [a] -> Maybe a
headMay [Node
t | (f :: Node
f,t :: Node
t,_) <- Gr CommoditySymbol Quantity -> Node -> [(Node, Node, Quantity)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [LEdge b]
out Gr CommoditySymbol Quantity
g Node
fromnode, (Node
f,Node
t) (Node, Node) -> [(Node, Node)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Node, Node)]
dps] Maybe Node
-> (Node -> Maybe CommoditySymbol) -> Maybe CommoditySymbol
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Gr CommoditySymbol Quantity -> Node -> Maybe CommoditySymbol
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab Gr CommoditySymbol Quantity
g
  in
    case Maybe CommoditySymbol
mto' of
      Nothing            -> Maybe (CommoditySymbol, Quantity)
forall a. Maybe a
Nothing
      Just to :: CommoditySymbol
to | CommoditySymbol
toCommoditySymbol -> CommoditySymbol -> Bool
forall a. Eq a => a -> a -> Bool
==CommoditySymbol
from -> Maybe (CommoditySymbol, Quantity)
forall a. Maybe a
Nothing
      Just to :: CommoditySymbol
to            ->
        -- We have a commodity to convert to. Find the most direct price available.
        case Maybe Quantity
mindirectprice of
          Nothing -> Maybe (CommoditySymbol, Quantity)
forall a. Maybe a
Nothing
          Just q :: Quantity
q  -> (CommoditySymbol, Quantity) -> Maybe (CommoditySymbol, Quantity)
forall a. a -> Maybe a
Just (CommoditySymbol
to, Quantity
q)
        where
          tonode :: Node
tonode = NodeMap CommoditySymbol -> CommoditySymbol -> Node
forall a. Ord a => NodeMap a -> a -> Node
node NodeMap CommoditySymbol
m CommoditySymbol
to
          Maybe Quantity
mindirectprice :: Maybe Quantity =
            -- Find the shortest path, if any, between from and to.
            case Node -> Node -> Gr CommoditySymbol Quantity -> Maybe [Node]
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Node -> Node -> gr a b -> Maybe [Node]
sp Node
fromnode Node
tonode Gr CommoditySymbol Quantity
g :: Maybe [Node] of
              Nothing    -> Maybe Quantity
forall a. Maybe a
Nothing
              Just nodes :: [Node]
nodes ->
                String -> Maybe Quantity -> Maybe Quantity
forall i.
(Integral i, Show i) =>
String -> Maybe (DecimalRaw i) -> Maybe (DecimalRaw i)
dbg ("market price "String -> ShowS
forall a. [a] -> [a] -> [a]
++String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "->" ((CommoditySymbol -> String) -> [CommoditySymbol] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CommoditySymbol -> String
T.unpack [CommoditySymbol]
comms)) (Maybe Quantity -> Maybe Quantity)
-> Maybe Quantity -> Maybe Quantity
forall a b. (a -> b) -> a -> b
$
                Quantity -> Maybe Quantity
forall a. a -> Maybe a
Just (Quantity -> Maybe Quantity) -> Quantity -> Maybe Quantity
forall a b. (a -> b) -> a -> b
$ [Quantity] -> Quantity
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Quantity] -> Quantity) -> [Quantity] -> Quantity
forall a b. (a -> b) -> a -> b
$ Gr CommoditySymbol Quantity -> [Node] -> [Quantity]
forall b a. (Show b, Ord b) => Gr a b -> [Node] -> [b]
pathEdgeLabels Gr CommoditySymbol Quantity
g [Node]
nodes  -- convert to a single exchange rate
                where comms :: [CommoditySymbol]
comms = [Maybe CommoditySymbol] -> [CommoditySymbol]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CommoditySymbol] -> [CommoditySymbol])
-> [Maybe CommoditySymbol] -> [CommoditySymbol]
forall a b. (a -> b) -> a -> b
$ (Node -> Maybe CommoditySymbol)
-> [Node] -> [Maybe CommoditySymbol]
forall a b. (a -> b) -> [a] -> [b]
map (Gr CommoditySymbol Quantity -> Node -> Maybe CommoditySymbol
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab Gr CommoditySymbol Quantity
g) [Node]
nodes

          -- log a message and a Maybe Quantity, hiding Just/Nothing and limiting decimal places
          dbg :: String -> Maybe (DecimalRaw i) -> Maybe (DecimalRaw i)
dbg msg :: String
msg = (Maybe (DecimalRaw i) -> String)
-> Maybe (DecimalRaw i) -> Maybe (DecimalRaw i)
forall a. Show a => (a -> String) -> a -> a
dbg4With (((String
msgString -> ShowS
forall a. [a] -> [a] -> [a]
++": ")String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (Maybe (DecimalRaw i) -> String)
-> Maybe (DecimalRaw i)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (DecimalRaw i -> String) -> Maybe (DecimalRaw i) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (DecimalRaw i -> String
forall a. Show a => a -> String
show (DecimalRaw i -> String)
-> (DecimalRaw i -> DecimalRaw i) -> DecimalRaw i -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> DecimalRaw i -> DecimalRaw i
forall i. Integral i => Word8 -> DecimalRaw i -> DecimalRaw i
roundTo 8))

tests_priceLookup :: TestTree
tests_priceLookup =
  let
    d :: String -> Day
d = String -> Day
parsedate
    a :: Quantity -> CommoditySymbol -> Amount
a q :: Quantity
q c :: CommoditySymbol
c = Amount
amount{acommodity :: CommoditySymbol
acommodity=CommoditySymbol
c, aquantity :: Quantity
aquantity=Quantity
q}
    p :: String
-> CommoditySymbol -> Quantity -> CommoditySymbol -> PriceDirective
p date :: String
date from :: CommoditySymbol
from q :: Quantity
q to :: CommoditySymbol
to = PriceDirective :: Day -> CommoditySymbol -> Amount -> PriceDirective
PriceDirective{pddate :: Day
pddate=String -> Day
d String
date, pdcommodity :: CommoditySymbol
pdcommodity=CommoditySymbol
from, pdamount :: Amount
pdamount=Quantity -> CommoditySymbol -> Amount
a Quantity
q CommoditySymbol
to}
    ps1 :: [PriceDirective]
ps1 = [
       String
-> CommoditySymbol -> Quantity -> CommoditySymbol -> PriceDirective
p "2000/01/01" "A" 10 "B"
      ,String
-> CommoditySymbol -> Quantity -> CommoditySymbol -> PriceDirective
p "2000/01/01" "B" 10 "C"
      ,String
-> CommoditySymbol -> Quantity -> CommoditySymbol -> PriceDirective
p "2000/01/01" "C" 10 "D"
      ,String
-> CommoditySymbol -> Quantity -> CommoditySymbol -> PriceDirective
p "2000/01/01" "E"  2 "D"
      ,String
-> CommoditySymbol -> Quantity -> CommoditySymbol -> PriceDirective
p "2001/01/01" "A" 11 "B"
      ]
    pricesatdate :: Day -> PriceGraph
pricesatdate = [PriceDirective] -> Day -> PriceGraph
pricesAtDate [PriceDirective]
ps1
  in String -> Assertion -> TestTree
test "priceLookup" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
    (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
pricesatdate (String -> Day
d "1999/01/01") "A" Maybe CommoditySymbol
forall a. Maybe a
Nothing    Maybe (CommoditySymbol, Quantity)
-> Maybe (CommoditySymbol, Quantity) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe (CommoditySymbol, Quantity)
forall a. Maybe a
Nothing
    (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
pricesatdate (String -> Day
d "2000/01/01") "A" Maybe CommoditySymbol
forall a. Maybe a
Nothing    Maybe (CommoditySymbol, Quantity)
-> Maybe (CommoditySymbol, Quantity) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (CommoditySymbol, Quantity) -> Maybe (CommoditySymbol, Quantity)
forall a. a -> Maybe a
Just ("B",10)
    (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
pricesatdate (String -> Day
d "2000/01/01") "B" (CommoditySymbol -> Maybe CommoditySymbol
forall a. a -> Maybe a
Just "A") Maybe (CommoditySymbol, Quantity)
-> Maybe (CommoditySymbol, Quantity) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (CommoditySymbol, Quantity) -> Maybe (CommoditySymbol, Quantity)
forall a. a -> Maybe a
Just ("A",0.1)
    (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
pricesatdate (String -> Day
d "2000/01/01") "A" (CommoditySymbol -> Maybe CommoditySymbol
forall a. a -> Maybe a
Just "E") Maybe (CommoditySymbol, Quantity)
-> Maybe (CommoditySymbol, Quantity) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (CommoditySymbol, Quantity) -> Maybe (CommoditySymbol, Quantity)
forall a. a -> Maybe a
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 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 :: [PriceDirective] -> Day -> PriceGraph
pricesAtDate pricedirectives :: [PriceDirective]
pricedirectives d :: Day
d =
  -- trace ("pricesAtDate ("++show d++")") $
  PriceGraph :: Gr CommoditySymbol Quantity
-> NodeMap CommoditySymbol -> [(Node, Node)] -> PriceGraph
PriceGraph{prGraph :: Gr CommoditySymbol Quantity
prGraph=Gr CommoditySymbol Quantity
g, prNodemap :: NodeMap CommoditySymbol
prNodemap=NodeMap CommoditySymbol
m, prDeclaredPairs :: [(Node, Node)]
prDeclaredPairs=[(Node, Node)]
dps}
  where
    declaredprices :: [MarketPrice]
declaredprices = [PriceDirective] -> Day -> [MarketPrice]
latestPriceForEachPairOn [PriceDirective]
pricedirectives Day
d

    -- infer additional reverse prices where not already declared
    reverseprices :: [MarketPrice]
reverseprices =
      String -> [MarketPrice] -> [MarketPrice]
forall a. Show a => String -> a -> a
dbg5 "reverseprices" ([MarketPrice] -> [MarketPrice]) -> [MarketPrice] -> [MarketPrice]
forall a b. (a -> b) -> a -> b
$
      (MarketPrice -> MarketPrice) -> [MarketPrice] -> [MarketPrice]
forall a b. (a -> b) -> [a] -> [b]
map MarketPrice -> MarketPrice
marketPriceReverse [MarketPrice]
declaredprices [MarketPrice] -> [MarketPrice] -> [MarketPrice]
forall a. Eq a => [a] -> [a] -> [a]
\\ [MarketPrice]
declaredprices

    -- build the graph and associated node map
    (g :: Gr CommoditySymbol Quantity
g, m :: NodeMap CommoditySymbol
m) =
      [CommoditySymbol]
-> [(CommoditySymbol, CommoditySymbol, Quantity)]
-> (Gr CommoditySymbol Quantity, NodeMap CommoditySymbol)
forall a (g :: * -> * -> *) b.
(Ord a, DynGraph g) =>
[a] -> [(a, a, b)] -> (g a b, NodeMap a)
mkMapGraph
      (String -> [CommoditySymbol] -> [CommoditySymbol]
forall a. Show a => String -> a -> a
dbg5 "g nodelabels" ([CommoditySymbol] -> [CommoditySymbol])
-> [CommoditySymbol] -> [CommoditySymbol]
forall a b. (a -> b) -> a -> b
$ [CommoditySymbol] -> [CommoditySymbol]
forall a. Ord a => [a] -> [a]
sort [CommoditySymbol]
allcomms) -- this must include all nodes mentioned in edges
      (String
-> [(CommoditySymbol, CommoditySymbol, Quantity)]
-> [(CommoditySymbol, CommoditySymbol, Quantity)]
forall a. Show a => String -> a -> a
dbg5 "g edges"      ([(CommoditySymbol, CommoditySymbol, Quantity)]
 -> [(CommoditySymbol, CommoditySymbol, Quantity)])
-> [(CommoditySymbol, CommoditySymbol, Quantity)]
-> [(CommoditySymbol, CommoditySymbol, Quantity)]
forall a b. (a -> b) -> a -> b
$ [(CommoditySymbol
mpfrom, CommoditySymbol
mpto, Quantity
mprate) | MarketPrice{..} <- [MarketPrice]
prices])
      :: (Gr CommoditySymbol Quantity, NodeMap CommoditySymbol)
      where
        prices :: [MarketPrice]
prices   = [MarketPrice]
declaredprices [MarketPrice] -> [MarketPrice] -> [MarketPrice]
forall a. [a] -> [a] -> [a]
++ [MarketPrice]
reverseprices
        allcomms :: [CommoditySymbol]
allcomms = (MarketPrice -> CommoditySymbol)
-> [MarketPrice] -> [CommoditySymbol]
forall a b. (a -> b) -> [a] -> [b]
map MarketPrice -> CommoditySymbol
mpfrom [MarketPrice]
prices

    -- remember which edges correspond to declared prices
    dps :: [(Node, Node)]
dps = [(NodeMap CommoditySymbol -> CommoditySymbol -> Node
forall a. Ord a => NodeMap a -> a -> Node
node NodeMap CommoditySymbol
m CommoditySymbol
mpfrom, NodeMap CommoditySymbol -> CommoditySymbol -> Node
forall a. Ord a => NodeMap a -> a -> Node
node NodeMap CommoditySymbol
m CommoditySymbol
mpto) | MarketPrice{..} <- [MarketPrice]
declaredprices ]

-- From a list of price directives in parse order, get the latest
-- price declared on or before date d for each commodity pair.
latestPriceForEachPairOn :: [PriceDirective] -> Day -> [MarketPrice]
latestPriceForEachPairOn :: [PriceDirective] -> Day -> [MarketPrice]
latestPriceForEachPairOn pricedirectives :: [PriceDirective]
pricedirectives d :: Day
d =
  String -> [MarketPrice] -> [MarketPrice]
forall a. Show a => String -> a -> a
dbg5 "latestPriceForEachPairOn" ([MarketPrice] -> [MarketPrice]) -> [MarketPrice] -> [MarketPrice]
forall a b. (a -> b) -> a -> b
$
  (MarketPrice -> MarketPrice -> Ordering)
-> [MarketPrice] -> [MarketPrice]
forall a. (a -> a -> Ordering) -> [a] -> [a]
nubSortBy ((CommoditySymbol, CommoditySymbol)
-> (CommoditySymbol, CommoditySymbol) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((CommoditySymbol, CommoditySymbol)
 -> (CommoditySymbol, CommoditySymbol) -> Ordering)
-> (MarketPrice -> (CommoditySymbol, CommoditySymbol))
-> MarketPrice
-> MarketPrice
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(MarketPrice{..})->(CommoditySymbol
mpfrom,CommoditySymbol
mpto))) ([MarketPrice] -> [MarketPrice]) -> [MarketPrice] -> [MarketPrice]
forall a b. (a -> b) -> a -> b
$  -- keep only the first (ie newest and latest parsed) price for each pair
  ((Integer, MarketPrice) -> MarketPrice)
-> [(Integer, MarketPrice)] -> [MarketPrice]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, MarketPrice) -> MarketPrice
forall a b. (a, b) -> b
snd ([(Integer, MarketPrice)] -> [MarketPrice])
-> [(Integer, MarketPrice)] -> [MarketPrice]
forall a b. (a -> b) -> a -> b
$  -- discard the parse order label
  ((Integer, MarketPrice) -> (Integer, MarketPrice) -> Ordering)
-> [(Integer, MarketPrice)] -> [(Integer, MarketPrice)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Day, Integer) -> (Day, Integer) -> Ordering)
-> (Day, Integer) -> (Day, Integer) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Day, Integer) -> (Day, Integer) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Day, Integer) -> (Day, Integer) -> Ordering)
-> ((Integer, MarketPrice) -> (Day, Integer))
-> (Integer, MarketPrice)
-> (Integer, MarketPrice)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(parseorder :: Integer
parseorder,mp :: MarketPrice
mp)->(MarketPrice -> Day
mpdate MarketPrice
mp,Integer
parseorder))) ([(Integer, MarketPrice)] -> [(Integer, MarketPrice)])
-> [(Integer, MarketPrice)] -> [(Integer, MarketPrice)]
forall a b. (a -> b) -> a -> b
$  -- sort with newest dates and latest parse order first
  [Integer] -> [MarketPrice] -> [(Integer, MarketPrice)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] ([MarketPrice] -> [(Integer, MarketPrice)])
-> [MarketPrice] -> [(Integer, MarketPrice)]
forall a b. (a -> b) -> a -> b
$  -- label with parse order
  (PriceDirective -> MarketPrice)
-> [PriceDirective] -> [MarketPrice]
forall a b. (a -> b) -> [a] -> [b]
map PriceDirective -> MarketPrice
priceDirectiveToMarketPrice ([PriceDirective] -> [MarketPrice])
-> [PriceDirective] -> [MarketPrice]
forall a b. (a -> b) -> a -> b
$
  (PriceDirective -> Bool) -> [PriceDirective] -> [PriceDirective]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<=Day
d)(Day -> Bool) -> (PriceDirective -> Day) -> PriceDirective -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.PriceDirective -> Day
pddate) [PriceDirective]
pricedirectives  -- consider only price declarations up to the valuation date

priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
priceDirectiveToMarketPrice PriceDirective{..} =
  MarketPrice :: Day
-> CommoditySymbol -> CommoditySymbol -> Quantity -> MarketPrice
MarketPrice{ mpdate :: Day
mpdate = Day
pddate
             , mpfrom :: CommoditySymbol
mpfrom = CommoditySymbol
pdcommodity
             , mpto :: CommoditySymbol
mpto   = Amount -> CommoditySymbol
acommodity Amount
pdamount
             , mprate :: Quantity
mprate = Amount -> Quantity
aquantity Amount
pdamount
             }

marketPriceReverse :: MarketPrice -> MarketPrice
marketPriceReverse :: MarketPrice -> MarketPrice
marketPriceReverse mp :: MarketPrice
mp@MarketPrice{..} = MarketPrice
mp{mpfrom :: CommoditySymbol
mpfrom=CommoditySymbol
mpto, mpto :: CommoditySymbol
mpto=CommoditySymbol
mpfrom, mprate :: Quantity
mprate=1Quantity -> Quantity -> Quantity
forall a. Fractional a => a -> a -> a
/Quantity
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 :: NodeMap a -> a -> Node
node m :: NodeMap a
m = (Node, a) -> Node
forall a b. (a, b) -> a
fst ((Node, a) -> Node) -> (a -> (Node, a)) -> a -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, a), NodeMap a) -> (Node, a)
forall a b. (a, b) -> a
fst (((Node, a), NodeMap a) -> (Node, a))
-> (a -> ((Node, a), NodeMap a)) -> a -> (Node, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeMap a -> a -> ((Node, a), NodeMap a)
forall a. Ord a => NodeMap a -> a -> (LNode a, NodeMap a)
mkNode NodeMap a
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 :: Gr a b -> [Node] -> [b]
pathEdgeLabels g :: Gr a b
g = (Maybe b -> b) -> [Maybe b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map Maybe b -> b
forall a. Maybe a -> a
frommaybe ([Maybe b] -> [b]) -> ([Node] -> [Maybe b]) -> [Node] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, Node) -> Maybe b) -> [(Node, Node)] -> [Maybe b]
forall a b. (a -> b) -> [a] -> [b]
map (Gr a b -> (Node, Node) -> Maybe b
forall b a. Ord b => Gr a b -> (Node, Node) -> Maybe b
nodesEdgeLabel Gr a b
g) ([(Node, Node)] -> [Maybe b])
-> ([Node] -> [(Node, Node)]) -> [Node] -> [Maybe b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [(Node, Node)]
pathEdges
  where frommaybe :: Maybe a -> a
frommaybe = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. String -> a
error' "pathEdgeLabels: expected no Nothings here")

-- | Convert a path to node pairs representing the path's edges.
pathEdges :: [Node] -> [(Node,Node)]
pathEdges :: [Node] -> [(Node, Node)]
pathEdges p :: [Node]
p = [(Node
f,Node
t) | f :: Node
f:t :: Node
t:_ <- [Node] -> [[Node]]
forall a. [a] -> [[a]]
tails [Node]
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 :: Gr a b -> (Node, Node) -> Maybe b
nodesEdgeLabel g :: Gr a b
g (from :: Node
from,to :: Node
to) = [b] -> Maybe b
forall a. [a] -> Maybe a
headMay ([b] -> Maybe b) -> [b] -> Maybe b
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
forall a. Ord a => [a] -> [a]
sort [b
l | (_,t :: Node
t,l :: b
l) <- Gr a b -> Node -> [(Node, Node, b)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [LEdge b]
out Gr a b
g Node
from, Node
tNode -> Node -> Bool
forall a. Eq a => a -> a -> Bool
==Node
to]

------------------------------------------------------------------------------

tests_Valuation :: TestTree
tests_Valuation = String -> [TestTree] -> TestTree
tests "Valuation" [
   TestTree
tests_priceLookup
  ]