{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
module Haspara.FxQuote where
import Control.Monad.Except (MonadError (throwError))
import qualified Data.Aeson as Aeson
import Data.Foldable (foldl')
import qualified Data.Map.Strict as SM
import Data.Scientific (Scientific)
import qualified Data.Text as T
import Data.Time (Day, addDays)
import GHC.Generics (Generic)
import GHC.TypeLits (KnownNat, Nat)
import Haspara.Currency (Currency, CurrencyPair (CurrencyPair))
import Haspara.Internal.Aeson (commonAesonOptions)
import Haspara.Quantity (Quantity (..), mkQuantity)
import Refined (Positive, Refined, refineError)
data FxQuote (s :: Nat) = MkFxQuote
{ forall (s :: Nat). FxQuote s -> CurrencyPair
fxQuotePair :: !CurrencyPair
, forall (s :: Nat). FxQuote s -> Day
fxQuoteDate :: !Day
, forall (s :: Nat). FxQuote s -> Refined Positive (Quantity s)
fxQuoteRate :: !(Refined Positive (Quantity s))
}
deriving (FxQuote s -> FxQuote s -> Bool
forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FxQuote s -> FxQuote s -> Bool
$c/= :: forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
== :: FxQuote s -> FxQuote s -> Bool
$c== :: forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
Eq, forall (s :: Nat) x. Rep (FxQuote s) x -> FxQuote s
forall (s :: Nat) x. FxQuote s -> Rep (FxQuote s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (s :: Nat) x. Rep (FxQuote s) x -> FxQuote s
$cfrom :: forall (s :: Nat) x. FxQuote s -> Rep (FxQuote s) x
Generic, FxQuote s -> FxQuote s -> Bool
FxQuote s -> FxQuote s -> Ordering
forall (s :: Nat). Eq (FxQuote s)
forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
forall (s :: Nat). FxQuote s -> FxQuote s -> Ordering
forall (s :: Nat). FxQuote s -> FxQuote s -> FxQuote s
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FxQuote s -> FxQuote s -> FxQuote s
$cmin :: forall (s :: Nat). FxQuote s -> FxQuote s -> FxQuote s
max :: FxQuote s -> FxQuote s -> FxQuote s
$cmax :: forall (s :: Nat). FxQuote s -> FxQuote s -> FxQuote s
>= :: FxQuote s -> FxQuote s -> Bool
$c>= :: forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
> :: FxQuote s -> FxQuote s -> Bool
$c> :: forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
<= :: FxQuote s -> FxQuote s -> Bool
$c<= :: forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
< :: FxQuote s -> FxQuote s -> Bool
$c< :: forall (s :: Nat). FxQuote s -> FxQuote s -> Bool
compare :: FxQuote s -> FxQuote s -> Ordering
$ccompare :: forall (s :: Nat). FxQuote s -> FxQuote s -> Ordering
Ord, Int -> FxQuote s -> ShowS
forall (s :: Nat). KnownNat s => Int -> FxQuote s -> ShowS
forall (s :: Nat). KnownNat s => [FxQuote s] -> ShowS
forall (s :: Nat). KnownNat s => FxQuote s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FxQuote s] -> ShowS
$cshowList :: forall (s :: Nat). KnownNat s => [FxQuote s] -> ShowS
show :: FxQuote s -> String
$cshow :: forall (s :: Nat). KnownNat s => FxQuote s -> String
showsPrec :: Int -> FxQuote s -> ShowS
$cshowsPrec :: forall (s :: Nat). KnownNat s => Int -> FxQuote s -> ShowS
Show)
instance KnownNat s => Aeson.FromJSON (FxQuote s) where
parseJSON :: Value -> Parser (FxQuote s)
parseJSON = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON forall a b. (a -> b) -> a -> b
$ String -> Options
commonAesonOptions String
"fxQuote"
instance KnownNat s => Aeson.ToJSON (FxQuote s) where
toJSON :: FxQuote s -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Aeson.genericToJSON forall a b. (a -> b) -> a -> b
$ String -> Options
commonAesonOptions String
"fxQuote"
toEncoding :: FxQuote s -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Aeson.genericToEncoding forall a b. (a -> b) -> a -> b
$ String -> Options
commonAesonOptions String
"fxQuote"
mkFxQuoteError
:: MonadError T.Text m
=> KnownNat s
=> Currency
-> Currency
-> Day
-> Scientific
-> m (FxQuote s)
mkFxQuoteError :: forall (m :: * -> *) (s :: Nat).
(MonadError Text m, KnownNat s) =>
Currency -> Currency -> Day -> Scientific -> m (FxQuote s)
mkFxQuoteError Currency
ccy1 Currency
ccy2 Day
date Scientific
rate =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Semigroup a => a -> a -> a
(<>) Text
"Can not create FX Rate. Error was: ") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
Refined Positive (Quantity s)
pval <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p x (m :: * -> *).
(Predicate p x, MonadError RefineException m) =>
x -> m (Refined p x)
refineError (forall (s :: Nat). KnownNat s => Scientific -> Quantity s
mkQuantity Scientific
rate)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (s :: Nat).
CurrencyPair -> Day -> Refined Positive (Quantity s) -> FxQuote s
MkFxQuote (Currency -> Currency -> CurrencyPair
CurrencyPair Currency
ccy1 Currency
ccy2) Day
date Refined Positive (Quantity s)
pval
mkFxQuoteFail
:: MonadFail m
=> KnownNat s
=> Currency
-> Currency
-> Day
-> Scientific
-> m (FxQuote s)
mkFxQuoteFail :: forall (m :: * -> *) (s :: Nat).
(MonadFail m, KnownNat s) =>
Currency -> Currency -> Day -> Scientific -> m (FxQuote s)
mkFxQuoteFail Currency
ccy1 Currency
ccy2 Day
date =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (s :: Nat).
(MonadError Text m, KnownNat s) =>
Currency -> Currency -> Day -> Scientific -> m (FxQuote s)
mkFxQuoteError Currency
ccy1 Currency
ccy2 Day
date
mkFxQuoteUnsafe
:: KnownNat s
=> Currency
-> Currency
-> Day
-> Scientific
-> FxQuote s
mkFxQuoteUnsafe :: forall (s :: Nat).
KnownNat s =>
Currency -> Currency -> Day -> Scientific -> FxQuote s
mkFxQuoteUnsafe Currency
ccy1 Currency
ccy2 Day
date =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (s :: Nat).
(MonadError Text m, KnownNat s) =>
Currency -> Currency -> Day -> Scientific -> m (FxQuote s)
mkFxQuoteError Currency
ccy1 Currency
ccy2 Day
date
type FxQuoteDatabase (n :: Nat) = SM.Map CurrencyPair (FxQuotePairDatabase n)
data FxQuotePairDatabase (n :: Nat) = FxQuotePairDatabase
{ forall (n :: Nat). FxQuotePairDatabase n -> CurrencyPair
fxQuotePairDatabasePair :: !CurrencyPair
, forall (n :: Nat). FxQuotePairDatabase n -> Map Day (FxQuote n)
fxQuotePairDatabaseTable :: !(SM.Map Day (FxQuote n))
, forall (n :: Nat). FxQuotePairDatabase n -> Day
fxQuotePairDatabaseSince :: !Day
, forall (n :: Nat). FxQuotePairDatabase n -> Day
fxQuotePairDatabaseUntil :: !Day
}
deriving (Int -> FxQuotePairDatabase n -> ShowS
forall (n :: Nat).
KnownNat n =>
Int -> FxQuotePairDatabase n -> ShowS
forall (n :: Nat). KnownNat n => [FxQuotePairDatabase n] -> ShowS
forall (n :: Nat). KnownNat n => FxQuotePairDatabase n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FxQuotePairDatabase n] -> ShowS
$cshowList :: forall (n :: Nat). KnownNat n => [FxQuotePairDatabase n] -> ShowS
show :: FxQuotePairDatabase n -> String
$cshow :: forall (n :: Nat). KnownNat n => FxQuotePairDatabase n -> String
showsPrec :: Int -> FxQuotePairDatabase n -> ShowS
$cshowsPrec :: forall (n :: Nat).
KnownNat n =>
Int -> FxQuotePairDatabase n -> ShowS
Show)
findFxQuote
:: KnownNat n
=> FxQuoteDatabase n
-> CurrencyPair
-> Day
-> Maybe (FxQuote n)
findFxQuote :: forall (n :: Nat).
KnownNat n =>
FxQuoteDatabase n -> CurrencyPair -> Day -> Maybe (FxQuote n)
findFxQuote FxQuoteDatabase n
db CurrencyPair
pair Day
date = forall k a. Ord k => k -> Map k a -> Maybe a
SM.lookup CurrencyPair
pair FxQuoteDatabase n
db forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (n :: Nat).
KnownNat n =>
Day -> FxQuotePairDatabase n -> Maybe (FxQuote n)
findFxQuoteAux Day
date
findFxQuoteAux :: KnownNat n => Day -> FxQuotePairDatabase n -> Maybe (FxQuote n)
findFxQuoteAux :: forall (n :: Nat).
KnownNat n =>
Day -> FxQuotePairDatabase n -> Maybe (FxQuote n)
findFxQuoteAux Day
date FxQuotePairDatabase n
db
| Day
date forall a. Ord a => a -> a -> Bool
< forall (n :: Nat). FxQuotePairDatabase n -> Day
fxQuotePairDatabaseSince FxQuotePairDatabase n
db = forall a. Maybe a
Nothing
| Bool
otherwise = case forall k a. Ord k => k -> Map k a -> Maybe a
SM.lookup Day
date (forall (n :: Nat). FxQuotePairDatabase n -> Map Day (FxQuote n)
fxQuotePairDatabaseTable FxQuotePairDatabase n
db) of
Maybe (FxQuote n)
Nothing -> forall (n :: Nat).
KnownNat n =>
Day -> FxQuotePairDatabase n -> Maybe (FxQuote n)
findFxQuoteAux (Integer -> Day -> Day
addDays (-Integer
1) Day
date) FxQuotePairDatabase n
db
Just FxQuote n
fx -> forall a. a -> Maybe a
Just FxQuote n
fx
emptyFxQuoteDatabase
:: KnownNat n
=> FxQuoteDatabase n
emptyFxQuoteDatabase :: forall (n :: Nat). KnownNat n => FxQuoteDatabase n
emptyFxQuoteDatabase = forall k a. Map k a
SM.empty
addFxQuotes
:: KnownNat n
=> [FxQuote n]
-> FxQuoteDatabase n
-> FxQuoteDatabase n
addFxQuotes :: forall (n :: Nat).
KnownNat n =>
[FxQuote n] -> FxQuoteDatabase n -> FxQuoteDatabase n
addFxQuotes [FxQuote n]
quotes FxQuoteDatabase n
database = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (n :: Nat).
KnownNat n =>
FxQuote n -> FxQuoteDatabase n -> FxQuoteDatabase n
addFxQuote) FxQuoteDatabase n
database [FxQuote n]
quotes
addFxQuote
:: KnownNat n
=> FxQuote n
-> FxQuoteDatabase n
-> FxQuoteDatabase n
addFxQuote :: forall (n :: Nat).
KnownNat n =>
FxQuote n -> FxQuoteDatabase n -> FxQuoteDatabase n
addFxQuote quote :: FxQuote n
quote@(MkFxQuote CurrencyPair
pair Day
_ Refined Positive (Quantity n)
_) FxQuoteDatabase n
database = case forall k a. Ord k => k -> Map k a -> Maybe a
SM.lookup CurrencyPair
pair FxQuoteDatabase n
database of
Maybe (FxQuotePairDatabase n)
Nothing -> forall k a. Ord k => k -> a -> Map k a -> Map k a
SM.insert CurrencyPair
pair (forall (n :: Nat). KnownNat n => FxQuote n -> FxQuotePairDatabase n
initFxQuotePairDatabase FxQuote n
quote) FxQuoteDatabase n
database
Just FxQuotePairDatabase n
fpd -> forall k a. Ord k => k -> a -> Map k a -> Map k a
SM.insert CurrencyPair
pair (forall (n :: Nat).
KnownNat n =>
FxQuote n -> FxQuotePairDatabase n -> FxQuotePairDatabase n
updateFxQuotePairDatabase FxQuote n
quote FxQuotePairDatabase n
fpd) FxQuoteDatabase n
database
initFxQuotePairDatabase
:: KnownNat n
=> FxQuote n
-> FxQuotePairDatabase n
initFxQuotePairDatabase :: forall (n :: Nat). KnownNat n => FxQuote n -> FxQuotePairDatabase n
initFxQuotePairDatabase quote :: FxQuote n
quote@(MkFxQuote CurrencyPair
pair Day
date Refined Positive (Quantity n)
_) =
FxQuotePairDatabase
{ fxQuotePairDatabasePair :: CurrencyPair
fxQuotePairDatabasePair = CurrencyPair
pair
, fxQuotePairDatabaseTable :: Map Day (FxQuote n)
fxQuotePairDatabaseTable = forall k a. k -> a -> Map k a
SM.singleton Day
date FxQuote n
quote
, fxQuotePairDatabaseSince :: Day
fxQuotePairDatabaseSince = Day
date
, fxQuotePairDatabaseUntil :: Day
fxQuotePairDatabaseUntil = Day
date
}
updateFxQuotePairDatabase
:: KnownNat n
=> FxQuote n
-> FxQuotePairDatabase n
-> FxQuotePairDatabase n
updateFxQuotePairDatabase :: forall (n :: Nat).
KnownNat n =>
FxQuote n -> FxQuotePairDatabase n -> FxQuotePairDatabase n
updateFxQuotePairDatabase quote :: FxQuote n
quote@(MkFxQuote CurrencyPair
_ Day
date Refined Positive (Quantity n)
_) FxQuotePairDatabase n
before =
FxQuotePairDatabase n
before
{ fxQuotePairDatabaseTable :: Map Day (FxQuote n)
fxQuotePairDatabaseTable = forall k a. Ord k => k -> a -> Map k a -> Map k a
SM.insert Day
date FxQuote n
quote (forall (n :: Nat). FxQuotePairDatabase n -> Map Day (FxQuote n)
fxQuotePairDatabaseTable FxQuotePairDatabase n
before)
, fxQuotePairDatabaseSince :: Day
fxQuotePairDatabaseSince = forall a. Ord a => a -> a -> a
min (forall (n :: Nat). FxQuotePairDatabase n -> Day
fxQuotePairDatabaseSince FxQuotePairDatabase n
before) Day
date
, fxQuotePairDatabaseUntil :: Day
fxQuotePairDatabaseUntil = forall a. Ord a => a -> a -> a
max (forall (n :: Nat). FxQuotePairDatabase n -> Day
fxQuotePairDatabaseUntil FxQuotePairDatabase n
before) Day
date
}