{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
module Hledger.Data.Valuation (
ConversionOp(..)
,ValuationType(..)
,PriceOracle
,journalPriceOracle
,mixedAmountToCost
,mixedAmountApplyValuation
,mixedAmountValueAtDate
,mixedAmountApplyGain
,mixedAmountGainAtDate
,marketPriceReverse
,priceDirectiveToMarketPrice
,amountPriceDirectiveFromCost
,tests_Valuation
)
where
import Control.Applicative ((<|>))
import Data.Function ((&), on)
import Data.List (partition, intercalate, sortBy)
import Data.List.Extra (nubSortBy)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Time.Calendar (Day, fromGregorian)
import Data.MemoUgly (memo)
import GHC.Generics (Generic)
import Safe (headMay, lastMay)
import Hledger.Utils
import Hledger.Data.Types
import Hledger.Data.Amount
import Hledger.Data.Dates (nulldate)
import Text.Printf (printf)
data ConversionOp = NoConversionOp | ToCost
deriving (Int -> ConversionOp -> ShowS
[ConversionOp] -> ShowS
ConversionOp -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConversionOp] -> ShowS
$cshowList :: [ConversionOp] -> ShowS
show :: ConversionOp -> [Char]
$cshow :: ConversionOp -> [Char]
showsPrec :: Int -> ConversionOp -> ShowS
$cshowsPrec :: Int -> ConversionOp -> ShowS
Show,ConversionOp -> ConversionOp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConversionOp -> ConversionOp -> Bool
$c/= :: ConversionOp -> ConversionOp -> Bool
== :: ConversionOp -> ConversionOp -> Bool
$c== :: ConversionOp -> ConversionOp -> Bool
Eq)
data ValuationType =
AtThen (Maybe CommoditySymbol)
| AtEnd (Maybe CommoditySymbol)
| AtNow (Maybe CommoditySymbol)
| AtDate Day (Maybe CommoditySymbol)
deriving (Int -> ValuationType -> ShowS
[ValuationType] -> ShowS
ValuationType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ValuationType] -> ShowS
$cshowList :: [ValuationType] -> ShowS
show :: ValuationType -> [Char]
$cshow :: ValuationType -> [Char]
showsPrec :: Int -> ValuationType -> ShowS
$cshowsPrec :: Int -> ValuationType -> ShowS
Show,ValuationType -> ValuationType -> Bool
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)
type PriceOracle = (Day, CommoditySymbol, Maybe CommoditySymbol) -> Maybe (CommoditySymbol, Quantity)
journalPriceOracle :: Bool -> Journal -> PriceOracle
journalPriceOracle :: Bool -> Journal -> PriceOracle
journalPriceOracle Bool
infer Journal{[PriceDirective]
jpricedirectives :: Journal -> [PriceDirective]
jpricedirectives :: [PriceDirective]
jpricedirectives, [MarketPrice]
jinferredmarketprices :: Journal -> [MarketPrice]
jinferredmarketprices :: [MarketPrice]
jinferredmarketprices} =
let
declaredprices :: [MarketPrice]
declaredprices = forall a b. (a -> b) -> [a] -> [b]
map PriceDirective -> MarketPrice
priceDirectiveToMarketPrice [PriceDirective]
jpricedirectives
inferredprices :: [MarketPrice]
inferredprices = if Bool
infer then [MarketPrice]
jinferredmarketprices else []
makepricegraph :: Day -> PriceGraph
makepricegraph = forall a b. Ord a => (a -> b) -> a -> b
memo forall a b. (a -> b) -> a -> b
$ [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph
makePriceGraph [MarketPrice]
declaredprices [MarketPrice]
inferredprices
in
forall a b. Ord a => (a -> b) -> a -> b
memo forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 forall a b. (a -> b) -> a -> b
$ (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
makepricegraph
priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
priceDirectiveToMarketPrice :: PriceDirective -> MarketPrice
priceDirectiveToMarketPrice PriceDirective{CommoditySymbol
Day
Amount
pdamount :: PriceDirective -> Amount
pdcommodity :: PriceDirective -> CommoditySymbol
pddate :: PriceDirective -> Day
pdamount :: Amount
pdcommodity :: CommoditySymbol
pddate :: Day
..} =
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
}
amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective
amountPriceDirectiveFromCost :: Day -> Amount -> Maybe PriceDirective
amountPriceDirectiveFromCost Day
d amt :: Amount
amt@Amount{acommodity :: Amount -> CommoditySymbol
acommodity=CommoditySymbol
fromcomm, aquantity :: Amount -> Quantity
aquantity=Quantity
fromq} = case Amount -> Maybe AmountPrice
aprice Amount
amt of
Just (UnitPrice Amount
pa) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PriceDirective
pd{pdamount :: Amount
pdamount=Amount
pa}
Just (TotalPrice Amount
pa) | Quantity
fromq forall a. Eq a => a -> a -> Bool
/= Quantity
0 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PriceDirective
pd{pdamount :: Amount
pdamount=Quantity
fromq Quantity -> Amount -> Amount
`divideAmountExtraPrecision` Amount
pa}
Maybe AmountPrice
_ -> forall a. Maybe a
Nothing
where
pd :: PriceDirective
pd = PriceDirective{pddate :: Day
pddate = Day
d, pdcommodity :: CommoditySymbol
pdcommodity = CommoditySymbol
fromcomm, pdamount :: Amount
pdamount = Amount
nullamt}
divideAmountExtraPrecision :: Quantity -> Amount -> Amount
divideAmountExtraPrecision Quantity
n Amount
a = (Quantity
n Quantity -> Amount -> Amount
`divideAmount` Amount
a) { astyle :: AmountStyle
astyle = AmountStyle
style' }
where
style' :: AmountStyle
style' = (Amount -> AmountStyle
astyle Amount
a) { asprecision :: AmountPrecision
asprecision = AmountPrecision
precision' }
precision' :: AmountPrecision
precision' = case AmountStyle -> AmountPrecision
asprecision (Amount -> AmountStyle
astyle Amount
a) of
AmountPrecision
NaturalPrecision -> AmountPrecision
NaturalPrecision
Precision Word8
p -> Word8 -> AmountPrecision
Precision forall a b. (a -> b) -> a -> b
$ (forall a. Integral a => Int -> a
numDigitsInt forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
truncate Quantity
n) forall a. Num a => a -> a -> a
+ Word8
p
mixedAmountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> MixedAmount -> MixedAmount
mixedAmountToCost :: Map CommoditySymbol AmountStyle
-> ConversionOp -> MixedAmount -> MixedAmount
mixedAmountToCost Map CommoditySymbol AmountStyle
styles ConversionOp
cost = (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount (Map CommoditySymbol AmountStyle -> ConversionOp -> Amount -> Amount
amountToCost Map CommoditySymbol AmountStyle
styles ConversionOp
cost)
mixedAmountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> ValuationType -> MixedAmount -> MixedAmount
mixedAmountApplyValuation :: PriceOracle
-> Map CommoditySymbol AmountStyle
-> Day
-> Day
-> Day
-> ValuationType
-> MixedAmount
-> MixedAmount
mixedAmountApplyValuation PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Day
periodlast Day
today Day
postingdate ValuationType
v =
(Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount (PriceOracle
-> Map CommoditySymbol AmountStyle
-> Day
-> Day
-> Day
-> ValuationType
-> Amount
-> Amount
amountApplyValuation PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Day
periodlast Day
today Day
postingdate ValuationType
v)
amountToCost :: M.Map CommoditySymbol AmountStyle -> ConversionOp -> Amount -> Amount
amountToCost :: Map CommoditySymbol AmountStyle -> ConversionOp -> Amount -> Amount
amountToCost Map CommoditySymbol AmountStyle
styles ConversionOp
ToCost = Map CommoditySymbol AmountStyle -> Amount -> Amount
styleAmount Map CommoditySymbol AmountStyle
styles forall b c a. (b -> c) -> (a -> b) -> a -> c
. Amount -> Amount
amountCost
amountToCost Map CommoditySymbol AmountStyle
_ ConversionOp
NoConversionOp = forall a. a -> a
id
amountApplyValuation :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> ValuationType -> Amount -> Amount
amountApplyValuation :: PriceOracle
-> Map CommoditySymbol AmountStyle
-> Day
-> Day
-> Day
-> ValuationType
-> Amount
-> Amount
amountApplyValuation PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Day
periodlast Day
today Day
postingdate ValuationType
v Amount
a =
case ValuationType
v of
AtThen Maybe CommoditySymbol
mc -> PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
postingdate Amount
a
AtEnd 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 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
AtDate Day
d 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
mixedAmountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
mixedAmountValueAtDate :: PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> MixedAmount
-> MixedAmount
mixedAmountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
d = (Amount -> Amount) -> MixedAmount -> MixedAmount
mapMixedAmount (PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mc Day
d)
amountValueAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> Amount -> Amount
amountValueAtDate :: PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> Amount
-> Amount
amountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mto Day
d Amount
a =
case PriceOracle
priceoracle (Day
d, Amount -> CommoditySymbol
acommodity Amount
a, Maybe CommoditySymbol
mto) of
Maybe (CommoditySymbol, Quantity)
Nothing -> Amount
a
Just (CommoditySymbol
comm, Quantity
rate) ->
Map CommoditySymbol AmountStyle -> Amount -> Amount
styleAmount Map CommoditySymbol AmountStyle
styles
Amount
nullamt{acommodity :: CommoditySymbol
acommodity=CommoditySymbol
comm, aquantity :: Quantity
aquantity=Quantity
rate forall a. Num a => a -> a -> a
* Amount -> Quantity
aquantity Amount
a}
mixedAmountApplyGain :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Day -> Day -> Day -> ValuationType -> MixedAmount -> MixedAmount
mixedAmountApplyGain :: PriceOracle
-> Map CommoditySymbol AmountStyle
-> Day
-> Day
-> Day
-> ValuationType
-> MixedAmount
-> MixedAmount
mixedAmountApplyGain PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Day
periodlast Day
today Day
postingdate ValuationType
v MixedAmount
ma =
PriceOracle
-> Map CommoditySymbol AmountStyle
-> Day
-> Day
-> Day
-> ValuationType
-> MixedAmount
-> MixedAmount
mixedAmountApplyValuation PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Day
periodlast Day
today Day
postingdate ValuationType
v forall a b. (a -> b) -> a -> b
$ MixedAmount
ma MixedAmount -> MixedAmount -> MixedAmount
`maMinus` MixedAmount -> MixedAmount
mixedAmountCost MixedAmount
ma
mixedAmountGainAtDate :: PriceOracle -> M.Map CommoditySymbol AmountStyle -> Maybe CommoditySymbol -> Day -> MixedAmount -> MixedAmount
mixedAmountGainAtDate :: PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> MixedAmount
-> MixedAmount
mixedAmountGainAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mto Day
d MixedAmount
ma =
PriceOracle
-> Map CommoditySymbol AmountStyle
-> Maybe CommoditySymbol
-> Day
-> MixedAmount
-> MixedAmount
mixedAmountValueAtDate PriceOracle
priceoracle Map CommoditySymbol AmountStyle
styles Maybe CommoditySymbol
mto Day
d forall a b. (a -> b) -> a -> b
$ MixedAmount
ma MixedAmount -> MixedAmount -> MixedAmount
`maMinus` MixedAmount -> MixedAmount
mixedAmountCost MixedAmount
ma
priceLookup :: (Day -> PriceGraph) -> Day -> CommoditySymbol -> Maybe CommoditySymbol -> Maybe (CommoditySymbol, Quantity)
priceLookup :: (Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
makepricegraph Day
d CommoditySymbol
from Maybe CommoditySymbol
mto =
let
PriceGraph{pgEdges :: PriceGraph -> [MarketPrice]
pgEdges=[MarketPrice]
forwardprices
,pgEdgesRev :: PriceGraph -> [MarketPrice]
pgEdgesRev=[MarketPrice]
allprices
,pgDefaultValuationCommodities :: PriceGraph -> Map CommoditySymbol CommoditySymbol
pgDefaultValuationCommodities=Map CommoditySymbol CommoditySymbol
defaultdests
} =
forall a. Int -> [Char] -> a -> a
traceOrLogAt Int
1 ([Char]
"valuation date: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Day
d) forall a b. (a -> b) -> a -> b
$ Day -> PriceGraph
makepricegraph Day
d
mto' :: Maybe CommoditySymbol
mto' = Maybe CommoditySymbol
mto forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CommoditySymbol
mdefaultto
where
mdefaultto :: Maybe CommoditySymbol
mdefaultto = forall a. Show a => [Char] -> a -> a
dbg1 ([Char]
"default valuation commodity for "forall a. [a] -> [a] -> [a]
++CommoditySymbol -> [Char]
T.unpack CommoditySymbol
from) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CommoditySymbol
from Map CommoditySymbol CommoditySymbol
defaultdests
in
case Maybe CommoditySymbol
mto' of
Maybe CommoditySymbol
Nothing -> forall a. Maybe a
Nothing
Just CommoditySymbol
to | CommoditySymbol
toforall a. Eq a => a -> a -> Bool
==CommoditySymbol
from -> forall a. Maybe a
Nothing
Just CommoditySymbol
to ->
let msg :: [Char]
msg = forall r. PrintfType r => [Char] -> r
printf [Char]
"seeking %s to %s price" (CommoditySymbol -> CommoditySymbol
showCommoditySymbol CommoditySymbol
from) (CommoditySymbol -> CommoditySymbol
showCommoditySymbol CommoditySymbol
to)
in case
(forall a. Int -> [Char] -> a -> a
traceOrLogAt Int
2 ([Char]
msgforall a. [a] -> [a] -> [a]
++[Char]
" using forward prices") forall a b. (a -> b) -> a -> b
$
CommoditySymbol
-> CommoditySymbol -> [MarketPrice] -> Maybe [MarketPrice]
pricesShortestPath CommoditySymbol
from CommoditySymbol
to [MarketPrice]
forwardprices)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(forall a. Int -> [Char] -> a -> a
traceOrLogAt Int
2 ([Char]
msgforall a. [a] -> [a] -> [a]
++[Char]
" using forward and reverse prices") forall a b. (a -> b) -> a -> b
$
CommoditySymbol
-> CommoditySymbol -> [MarketPrice] -> Maybe [MarketPrice]
pricesShortestPath CommoditySymbol
from CommoditySymbol
to [MarketPrice]
allprices)
of
Maybe [MarketPrice]
Nothing -> forall a. Maybe a
Nothing
Just [] -> forall a. Maybe a
Nothing
Just [MarketPrice]
ps -> forall a. a -> Maybe a
Just (MarketPrice -> CommoditySymbol
mpto forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [MarketPrice]
ps, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map MarketPrice -> Quantity
mprate [MarketPrice]
ps)
tests_priceLookup :: TestTree
tests_priceLookup =
let
p :: Integer
-> Int
-> Int
-> CommoditySymbol
-> Quantity
-> CommoditySymbol
-> MarketPrice
p Integer
y Int
m Int
d CommoditySymbol
from Quantity
q CommoditySymbol
to = MarketPrice{mpdate :: Day
mpdate=Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d, mpfrom :: CommoditySymbol
mpfrom=CommoditySymbol
from, mpto :: CommoditySymbol
mpto=CommoditySymbol
to, mprate :: Quantity
mprate=Quantity
q}
ps1 :: [MarketPrice]
ps1 = [
Integer
-> Int
-> Int
-> CommoditySymbol
-> Quantity
-> CommoditySymbol
-> MarketPrice
p Integer
2000 Int
01 Int
01 CommoditySymbol
"A" Quantity
10 CommoditySymbol
"B"
,Integer
-> Int
-> Int
-> CommoditySymbol
-> Quantity
-> CommoditySymbol
-> MarketPrice
p Integer
2000 Int
01 Int
01 CommoditySymbol
"B" Quantity
10 CommoditySymbol
"C"
,Integer
-> Int
-> Int
-> CommoditySymbol
-> Quantity
-> CommoditySymbol
-> MarketPrice
p Integer
2000 Int
01 Int
01 CommoditySymbol
"C" Quantity
10 CommoditySymbol
"D"
,Integer
-> Int
-> Int
-> CommoditySymbol
-> Quantity
-> CommoditySymbol
-> MarketPrice
p Integer
2000 Int
01 Int
01 CommoditySymbol
"E" Quantity
2 CommoditySymbol
"D"
,Integer
-> Int
-> Int
-> CommoditySymbol
-> Quantity
-> CommoditySymbol
-> MarketPrice
p Integer
2001 Int
01 Int
01 CommoditySymbol
"A" Quantity
11 CommoditySymbol
"B"
]
makepricegraph :: Day -> PriceGraph
makepricegraph = [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph
makePriceGraph [MarketPrice]
ps1 []
in [Char] -> Assertion -> TestTree
testCase [Char]
"priceLookup" forall a b. (a -> b) -> a -> b
$ do
(Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
makepricegraph (Integer -> Int -> Int -> Day
fromGregorian Integer
1999 Int
01 Int
01) CommoditySymbol
"A" forall a. Maybe a
Nothing forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. Maybe a
Nothing
(Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
makepricegraph (Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
01 Int
01) CommoditySymbol
"A" forall a. Maybe a
Nothing forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. a -> Maybe a
Just (CommoditySymbol
"B",Quantity
10)
(Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
makepricegraph (Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
01 Int
01) CommoditySymbol
"B" (forall a. a -> Maybe a
Just CommoditySymbol
"A") forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. a -> Maybe a
Just (CommoditySymbol
"A",Quantity
0.1)
(Day -> PriceGraph)
-> Day
-> CommoditySymbol
-> Maybe CommoditySymbol
-> Maybe (CommoditySymbol, Quantity)
priceLookup Day -> PriceGraph
makepricegraph (Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
01 Int
01) CommoditySymbol
"A" (forall a. a -> Maybe a
Just CommoditySymbol
"E") forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. a -> Maybe a
Just (CommoditySymbol
"E",Quantity
500)
type Edge = MarketPrice
type Path = [Edge]
data PriceGraph = PriceGraph {
PriceGraph -> Day
pgDate :: Day
,PriceGraph -> [MarketPrice]
pgEdges :: [Edge]
,PriceGraph -> [MarketPrice]
pgEdgesRev :: [Edge]
,PriceGraph -> Map CommoditySymbol CommoditySymbol
pgDefaultValuationCommodities :: M.Map CommoditySymbol CommoditySymbol
}
deriving (Int -> PriceGraph -> ShowS
[PriceGraph] -> ShowS
PriceGraph -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PriceGraph] -> ShowS
$cshowList :: [PriceGraph] -> ShowS
show :: PriceGraph -> [Char]
$cshow :: PriceGraph -> [Char]
showsPrec :: Int -> PriceGraph -> ShowS
$cshowsPrec :: Int -> PriceGraph -> ShowS
Show,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)
pricesShortestPath :: CommoditySymbol -> CommoditySymbol -> [Edge] -> Maybe Path
pricesShortestPath :: CommoditySymbol
-> CommoditySymbol -> [MarketPrice] -> Maybe [MarketPrice]
pricesShortestPath CommoditySymbol
start CommoditySymbol
end [MarketPrice]
edges =
let label :: [Char]
label = forall r. PrintfType r => [Char] -> r
printf [Char]
"shortest path from %s to %s: " (CommoditySymbol -> CommoditySymbol
showCommoditySymbol CommoditySymbol
start) (CommoditySymbol -> CommoditySymbol
showCommoditySymbol CommoditySymbol
end) in
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Show a => (a -> [Char]) -> a -> a
dbg2With (([Char]
"price chain:\n"forall a. [a] -> [a] -> [a]
++)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> [Char]
pshow)) forall a b. (a -> b) -> a -> b
$
forall a. Show a => (a -> [Char]) -> a -> a
dbg2With (([Char]
labelforall a. [a] -> [a] -> [a]
++)forall b c a. (b -> c) -> (a -> b) -> a -> c
.(forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"none found" ([Char] -> [MarketPrice] -> [Char]
pshowpath [Char]
""))) forall a b. (a -> b) -> a -> b
$
[([MarketPrice], [MarketPrice])] -> Maybe [MarketPrice]
find [([],[MarketPrice]
edges)]
where
find :: [(Path,[Edge])] -> Maybe Path
find :: [([MarketPrice], [MarketPrice])] -> Maybe [MarketPrice]
find [([MarketPrice], [MarketPrice])]
paths =
case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([MarketPrice], [MarketPrice]) -> [([MarketPrice], [MarketPrice])]
extend [([MarketPrice], [MarketPrice])]
paths of
[] -> forall a. Maybe a
Nothing
[([MarketPrice], [MarketPrice])]
_ | Int
pathlength forall a. Ord a => a -> a -> Bool
> Int
maxpathlength ->
forall a. [Char] -> a -> a
traceOrLog ([Char]
"gave up searching for a price chain at length "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Int
maxpathlengthforall a. [a] -> [a] -> [a]
++[Char]
", please report a bug")
forall a. Maybe a
Nothing
where
pathlength :: Int
pathlength = Int
2 forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall a. [a] -> Maybe a
headMay [([MarketPrice], [MarketPrice])]
paths)
maxpathlength :: Int
maxpathlength = Int
1000
[([MarketPrice], [MarketPrice])]
paths' ->
case [[MarketPrice]]
completepaths of
[MarketPrice]
p:[[MarketPrice]]
_ -> forall a. a -> Maybe a
Just [MarketPrice]
p
[] -> [([MarketPrice], [MarketPrice])] -> Maybe [MarketPrice]
find [([MarketPrice], [MarketPrice])]
paths'
where completepaths :: [[MarketPrice]]
completepaths = [[MarketPrice]
p | ([MarketPrice]
p,[MarketPrice]
_) <- [([MarketPrice], [MarketPrice])]
paths', (MarketPrice -> CommoditySymbol
mpto forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
lastMay [MarketPrice]
p) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just CommoditySymbol
end]
extend :: (Path,[Edge]) -> [(Path,[Edge])]
extend :: ([MarketPrice], [MarketPrice]) -> [([MarketPrice], [MarketPrice])]
extend ([MarketPrice]
path,[MarketPrice]
unusededges) =
let
pathnodes :: [CommoditySymbol]
pathnodes = CommoditySymbol
start forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map MarketPrice -> CommoditySymbol
mpto [MarketPrice]
path
pathend :: CommoditySymbol
pathend = forall b a. b -> (a -> b) -> Maybe a -> b
maybe CommoditySymbol
start MarketPrice -> CommoditySymbol
mpto forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
lastMay [MarketPrice]
path
([MarketPrice]
nextedges,[MarketPrice]
remainingedges) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
==CommoditySymbol
pathend)forall b c a. (b -> c) -> (a -> b) -> a -> c
.MarketPrice -> CommoditySymbol
mpfrom) [MarketPrice]
unusededges
in
[ ([MarketPrice]
path', [MarketPrice]
remainingedges')
| MarketPrice
e <- [MarketPrice]
nextedges
, let path' :: [MarketPrice]
path' = [Char] -> [MarketPrice] -> [MarketPrice]
dbgpath [Char]
"trying" forall a b. (a -> b) -> a -> b
$ [MarketPrice]
path forall a. [a] -> [a] -> [a]
++ [MarketPrice
e]
, let pathnodes' :: [CommoditySymbol]
pathnodes' = MarketPrice -> CommoditySymbol
mpto MarketPrice
e forall a. a -> [a] -> [a]
: [CommoditySymbol]
pathnodes
, let remainingedges' :: [MarketPrice]
remainingedges' = [MarketPrice
r | MarketPrice
r <- [MarketPrice]
remainingedges, MarketPrice -> CommoditySymbol
mpto MarketPrice
r forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CommoditySymbol]
pathnodes' ]
]
dbgpath :: [Char] -> [MarketPrice] -> [MarketPrice]
dbgpath [Char]
label = forall a. Show a => (a -> [Char]) -> a -> a
dbg2With ([Char] -> [MarketPrice] -> [Char]
pshowpath [Char]
label)
pshowpath :: [Char] -> [MarketPrice] -> [Char]
pshowpath [Char]
label = \case
[] -> [Char] -> ShowS
prefix [Char]
label [Char]
""
p :: [MarketPrice]
p@(MarketPrice
e:[MarketPrice]
_) -> [Char] -> ShowS
prefix [Char]
label forall a b. (a -> b) -> a -> b
$ CommoditySymbol -> [Char]
pshownode (MarketPrice -> CommoditySymbol
mpfrom MarketPrice
e) forall a. [a] -> [a] -> [a]
++ [Char]
">" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
">" (forall a b. (a -> b) -> [a] -> [b]
map (CommoditySymbol -> [Char]
pshownode forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarketPrice -> CommoditySymbol
mpto) [MarketPrice]
p)
pshownode :: CommoditySymbol -> [Char]
pshownode = CommoditySymbol -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommoditySymbol -> CommoditySymbol
showCommoditySymbol
prefix :: [Char] -> ShowS
prefix [Char]
l = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
l then ([Char]
""forall a. [a] -> [a] -> [a]
++) else (([Char]
lforall a. [a] -> [a] -> [a]
++[Char]
": ")forall a. [a] -> [a] -> [a]
++)
makePriceGraph :: [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph
makePriceGraph :: [MarketPrice] -> [MarketPrice] -> Day -> PriceGraph
makePriceGraph [MarketPrice]
alldeclaredprices [MarketPrice]
allinferredprices Day
d =
forall a. Show a => [Char] -> a -> a
dbg9 ([Char]
"makePriceGraph "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show Day
d) forall a b. (a -> b) -> a -> b
$
PriceGraph{
pgDate :: Day
pgDate = Day
d
,pgEdges :: [MarketPrice]
pgEdges=[MarketPrice]
forwardprices
,pgEdgesRev :: [MarketPrice]
pgEdgesRev=[MarketPrice]
allprices
,pgDefaultValuationCommodities :: Map CommoditySymbol CommoditySymbol
pgDefaultValuationCommodities=Map CommoditySymbol CommoditySymbol
defaultdests
}
where
visibledeclaredprices :: [MarketPrice]
visibledeclaredprices = forall a. Show a => [Char] -> a -> a
dbg9 [Char]
"visibledeclaredprices" forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<=Day
d)forall b c a. (b -> c) -> (a -> b) -> a -> c
.MarketPrice -> Day
mpdate) [MarketPrice]
alldeclaredprices
visibleinferredprices :: [MarketPrice]
visibleinferredprices = forall a. Show a => [Char] -> a -> a
dbg9 [Char]
"visibleinferredprices" forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<=Day
d)forall b c a. (b -> c) -> (a -> b) -> a -> c
.MarketPrice -> Day
mpdate) [MarketPrice]
allinferredprices
forwardprices :: [MarketPrice]
forwardprices = [MarketPrice] -> [MarketPrice] -> [MarketPrice]
effectiveMarketPrices [MarketPrice]
visibledeclaredprices [MarketPrice]
visibleinferredprices
reverseprices :: [MarketPrice]
reverseprices = forall a. Show a => [Char] -> a -> a
dbg9 [Char]
"additional reverse prices" forall a b. (a -> b) -> a -> b
$
[MarketPrice
p | p :: MarketPrice
p@MarketPrice{Quantity
CommoditySymbol
Day
mprate :: Quantity
mpto :: CommoditySymbol
mpfrom :: CommoditySymbol
mpdate :: Day
mprate :: MarketPrice -> Quantity
mpto :: MarketPrice -> CommoditySymbol
mpfrom :: MarketPrice -> CommoditySymbol
mpdate :: MarketPrice -> Day
..} <- forall a b. (a -> b) -> [a] -> [b]
map MarketPrice -> MarketPrice
marketPriceReverse [MarketPrice]
forwardprices
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (CommoditySymbol
mpfrom,CommoditySymbol
mpto) forall a. Ord a => a -> Set a -> Bool
`S.member` Set (CommoditySymbol, CommoditySymbol)
forwardpairs
]
where
forwardpairs :: Set (CommoditySymbol, CommoditySymbol)
forwardpairs = forall a. Ord a => [a] -> Set a
S.fromList [(CommoditySymbol
mpfrom,CommoditySymbol
mpto) | MarketPrice{Quantity
CommoditySymbol
Day
mprate :: Quantity
mpdate :: Day
mpto :: CommoditySymbol
mpfrom :: CommoditySymbol
mprate :: MarketPrice -> Quantity
mpto :: MarketPrice -> CommoditySymbol
mpfrom :: MarketPrice -> CommoditySymbol
mpdate :: MarketPrice -> Day
..} <- [MarketPrice]
forwardprices]
allprices :: [MarketPrice]
allprices = [MarketPrice]
forwardprices forall a. [a] -> [a] -> [a]
++ [MarketPrice]
reverseprices
defaultdests :: Map CommoditySymbol CommoditySymbol
defaultdests = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(CommoditySymbol
mpfrom,CommoditySymbol
mpto) | MarketPrice{Quantity
CommoditySymbol
Day
mprate :: Quantity
mpdate :: Day
mpto :: CommoditySymbol
mpfrom :: CommoditySymbol
mprate :: MarketPrice -> Quantity
mpto :: MarketPrice -> CommoditySymbol
mpfrom :: MarketPrice -> CommoditySymbol
mpdate :: MarketPrice -> Day
..} <- [MarketPrice]
pricesfordefaultcomms]
where
pricesfordefaultcomms :: [MarketPrice]
pricesfordefaultcomms = forall a. Show a => [Char] -> a -> a
dbg9 [Char]
"prices for choosing default valuation commodities, by date then parse order" forall a b. (a -> b) -> a -> b
$
[MarketPrice]
ps
forall a b. a -> (a -> b) -> b
& forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..]
forall a b. a -> (a -> b) -> b
& forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Integer
parseorder,MarketPrice{Quantity
CommoditySymbol
Day
mprate :: Quantity
mpto :: CommoditySymbol
mpfrom :: CommoditySymbol
mpdate :: Day
mprate :: MarketPrice -> Quantity
mpto :: MarketPrice -> CommoditySymbol
mpfrom :: MarketPrice -> CommoditySymbol
mpdate :: MarketPrice -> Day
..})->(Day
mpdate,Integer
parseorder)))
forall a b. a -> (a -> b) -> b
& forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd
where
ps :: [MarketPrice]
ps | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MarketPrice]
visibledeclaredprices = [MarketPrice]
visibledeclaredprices
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MarketPrice]
alldeclaredprices = [MarketPrice]
alldeclaredprices
| Bool
otherwise = [MarketPrice]
visibleinferredprices
effectiveMarketPrices :: [MarketPrice] -> [MarketPrice] -> [MarketPrice]
effectiveMarketPrices :: [MarketPrice] -> [MarketPrice] -> [MarketPrice]
effectiveMarketPrices [MarketPrice]
declaredprices [MarketPrice]
inferredprices =
let
declaredprices' :: [(Integer, Integer, MarketPrice)]
declaredprices' = [(Integer
1, Integer
i, MarketPrice
p) | (Integer
i,MarketPrice
p) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [MarketPrice]
declaredprices]
inferredprices' :: [(Integer, Integer, MarketPrice)]
inferredprices' = [(Integer
0, Integer
i, MarketPrice
p) | (Integer
i,MarketPrice
p) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [MarketPrice]
inferredprices]
in
forall a. Show a => [Char] -> a -> a
dbg9 [Char]
"effective forward prices" forall a b. (a -> b) -> a -> b
$
[(Integer, Integer, MarketPrice)]
declaredprices' forall a. [a] -> [a] -> [a]
++ [(Integer, Integer, MarketPrice)]
inferredprices'
forall a b. a -> (a -> b) -> b
& forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(Integer
precedence,Integer
parseorder,MarketPrice
mp)->(MarketPrice -> Day
mpdate MarketPrice
mp,Integer
precedence,Integer
parseorder)))
forall a b. a -> (a -> b) -> b
& forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> c
third3
forall a b. a -> (a -> b) -> b
& forall a. (a -> a -> Ordering) -> [a] -> [a]
nubSortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\(MarketPrice{Quantity
CommoditySymbol
Day
mprate :: Quantity
mpto :: CommoditySymbol
mpfrom :: CommoditySymbol
mpdate :: Day
mprate :: MarketPrice -> Quantity
mpto :: MarketPrice -> CommoditySymbol
mpfrom :: MarketPrice -> CommoditySymbol
mpdate :: MarketPrice -> Day
..})->(CommoditySymbol
mpfrom,CommoditySymbol
mpto)))
marketPriceReverse :: MarketPrice -> MarketPrice
marketPriceReverse :: MarketPrice -> MarketPrice
marketPriceReverse mp :: MarketPrice
mp@MarketPrice{Quantity
CommoditySymbol
Day
mprate :: Quantity
mpto :: CommoditySymbol
mpfrom :: CommoditySymbol
mpdate :: Day
mprate :: MarketPrice -> Quantity
mpto :: MarketPrice -> CommoditySymbol
mpfrom :: MarketPrice -> CommoditySymbol
mpdate :: MarketPrice -> Day
..} =
MarketPrice
mp{mpfrom :: CommoditySymbol
mpfrom=CommoditySymbol
mpto, mpto :: CommoditySymbol
mpto=CommoditySymbol
mpfrom, mprate :: Quantity
mprate=if Quantity
mprateforall a. Eq a => a -> a -> Bool
==Quantity
0 then Quantity
0 else Quantity
1forall a. Fractional a => a -> a -> a
/Quantity
mprate}
nullmarketprice :: MarketPrice
nullmarketprice :: MarketPrice
nullmarketprice = MarketPrice {
mpdate :: Day
mpdate=Day
nulldate
,mpfrom :: CommoditySymbol
mpfrom=CommoditySymbol
""
,mpto :: CommoditySymbol
mpto=CommoditySymbol
""
,mprate :: Quantity
mprate=Quantity
0
}
tests_Valuation :: TestTree
tests_Valuation = [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Valuation" [
TestTree
tests_priceLookup
,[Char] -> Assertion -> TestTree
testCase [Char]
"marketPriceReverse" forall a b. (a -> b) -> a -> b
$ do
MarketPrice -> MarketPrice
marketPriceReverse MarketPrice
nullmarketprice{mprate :: Quantity
mprate=Quantity
2} forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= MarketPrice
nullmarketprice{mprate :: Quantity
mprate=Quantity
0.5}
MarketPrice -> MarketPrice
marketPriceReverse MarketPrice
nullmarketprice forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= MarketPrice
nullmarketprice
]