-- | This module provides template-haskell functions for various 'Haspara.Core.Base'
-- definitions.
--
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

module Haspara.TH where

import           Control.Monad              (join)
import           Data.Function              (fix)
import           Data.Scientific            (Scientific)
import qualified Data.Text                  as T
import           GHC.TypeLits               (KnownNat)
import           Haspara.Currency           (Currency, CurrencyPair, currency, currencyPair)
import           Haspara.Quantity           (Quantity, quantityLossless)
import qualified Language.Haskell.TH.Syntax as TH


-- | Constructs a 'Quantity' value at compile-time using @-XTemplateHaskell@.
--
-- >>> :set -XDataKinds
-- >>> $$(quantityTH 0.00) :: Quantity 2
-- 0.00
-- >>> $$(quantityTH 0.09) :: Quantity 2
-- 0.09
-- >>> $$(quantityTH 0.009) :: Quantity 2
-- ...
-- ..."Underflow while trying to create quantity: 9.0e-3"
-- ...
-- >>> $$(quantityTH 0.009) :: Quantity 3
-- 0.009
quantityTH :: KnownNat s => Scientific -> TH.Q (TH.TExp (Quantity s))
quantityTH :: Scientific -> Q (TExp (Quantity s))
quantityTH = ((Scientific -> Q (TExp (Quantity s)))
 -> Scientific -> Q (TExp (Quantity s)))
-> Scientific -> Q (TExp (Quantity s))
forall a. (a -> a) -> a
fix (((Scientific -> Q (TExp (Quantity s)))
  -> Scientific -> Q (TExp (Quantity s)))
 -> Scientific -> Q (TExp (Quantity s)))
-> ((Scientific -> Q (TExp (Quantity s)))
    -> Scientific -> Q (TExp (Quantity s)))
-> Scientific
-> Q (TExp (Quantity s))
forall a b. (a -> b) -> a -> b
$ \Scientific -> Q (TExp (Quantity s))
loop -> (Exp -> TExp (Quantity s)) -> Q Exp -> Q (TExp (Quantity s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> TExp (Quantity s)
forall a. Exp -> TExp a
TH.TExp (Q Exp -> Q (TExp (Quantity s)))
-> (Scientific -> Q Exp) -> Scientific -> Q (TExp (Quantity s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Q Exp)
-> (Quantity s -> Q Exp) -> Either String (Quantity s) -> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> (String -> String) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) Quantity s -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift (Either String (Quantity s) -> Q Exp)
-> (Scientific -> Either String (Quantity s))
-> Scientific
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q (TExp (Quantity s)) -> Scientific -> Either String (Quantity s)
forall (s :: Nat).
KnownNat s =>
Q (TExp (Quantity s)) -> Scientific -> Either String (Quantity s)
quantityWE (Scientific -> Q (TExp (Quantity s))
loop Scientific
forall a. HasCallStack => a
undefined)
  where
    -- This provides a work-around for the type-inference due the `s` type parameter.
    -- Trick is borrowed from the Haskell `refined` library.
    quantityWE :: KnownNat s => TH.Q (TH.TExp (Quantity s)) -> Scientific -> Either String (Quantity s)
    quantityWE :: Q (TExp (Quantity s)) -> Scientific -> Either String (Quantity s)
quantityWE = (Scientific -> Either String (Quantity s))
-> Q (TExp (Quantity s))
-> Scientific
-> Either String (Quantity s)
forall a b. a -> b -> a
const Scientific -> Either String (Quantity s)
forall (s :: Nat) (m :: * -> *).
(KnownNat s, MonadError String m) =>
Scientific -> m (Quantity s)
quantityLossless


-- | Constructs a 'Currency' value at compile-time using @-XTemplateHaskell@.
--
-- >>> $$(currencyTH "USD")
-- USD
-- >>> $$(currencyTH "usd")
-- ...
-- ...Currency code error! Expecting at least 3 uppercase characters, but received: "usd"
-- ...
currencyTH :: T.Text -> TH.Q (TH.TExp Currency)
currencyTH :: Text -> Q (TExp Currency)
currencyTH = (String -> Q (TExp Currency))
-> (Currency -> Q (TExp Currency))
-> Either String Currency
-> Q (TExp Currency)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q (TExp Currency)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ((Exp -> TExp Currency) -> Q Exp -> Q (TExp Currency)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> TExp Currency
forall a. Exp -> TExp a
TH.TExp (Q Exp -> Q (TExp Currency))
-> (Currency -> Q Exp) -> Currency -> Q (TExp Currency)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Currency -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift) (Either String Currency -> Q (TExp Currency))
-> (Text -> Either String Currency) -> Text -> Q (TExp Currency)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Currency
forall (m :: * -> *). MonadError String m => Text -> m Currency
currency


-- | Constructs a 'CurrencyPair' value at compile-time using @-XTemplateHaskell@.
--
-- >>> $$(currencyPairTH "EUR" "USD")
-- EUR/USD
-- >>> $$(currencyPairTH "USD" "USD")
-- ...
-- ...Can not create currency pair from same currencies: USD and USD
-- ...
-- >>> $$(currencyPairTH "USD" "eur")
-- ...
-- ...Currency code error! Expecting at least 3 uppercase characters, but received: "eur"
-- ...
currencyPairTH :: T.Text -> T.Text -> TH.Q (TH.TExp CurrencyPair)
currencyPairTH :: Text -> Text -> Q (TExp CurrencyPair)
currencyPairTH = ((String -> Q (TExp CurrencyPair))
-> (CurrencyPair -> Q (TExp CurrencyPair))
-> Either String CurrencyPair
-> Q (TExp CurrencyPair)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q (TExp CurrencyPair)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ((Exp -> TExp CurrencyPair) -> Q Exp -> Q (TExp CurrencyPair)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> TExp CurrencyPair
forall a. Exp -> TExp a
TH.TExp (Q Exp -> Q (TExp CurrencyPair))
-> (CurrencyPair -> Q Exp) -> CurrencyPair -> Q (TExp CurrencyPair)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencyPair -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift) (Either String CurrencyPair -> Q (TExp CurrencyPair))
-> (Text -> Either String CurrencyPair)
-> Text
-> Q (TExp CurrencyPair)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Text -> Either String CurrencyPair)
 -> Text -> Q (TExp CurrencyPair))
-> (Text -> Text -> Either String CurrencyPair)
-> Text
-> Text
-> Q (TExp CurrencyPair)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Either String CurrencyPair
mkPair
  where
    mkPair :: T.Text -> T.Text -> Either String CurrencyPair
    mkPair :: Text -> Text -> Either String CurrencyPair
mkPair Text
x Text
y = Either String (Either String CurrencyPair)
-> Either String CurrencyPair
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either String (Either String CurrencyPair)
 -> Either String CurrencyPair)
-> Either String (Either String CurrencyPair)
-> Either String CurrencyPair
forall a b. (a -> b) -> a -> b
$ Currency -> Currency -> Either String CurrencyPair
forall (m :: * -> *).
MonadError String m =>
Currency -> Currency -> m CurrencyPair
currencyPair (Currency -> Currency -> Either String CurrencyPair)
-> Either String Currency
-> Either String (Currency -> Either String CurrencyPair)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String Currency
forall (m :: * -> *). MonadError String m => Text -> m Currency
currency Text
x Either String (Currency -> Either String CurrencyPair)
-> Either String Currency
-> Either String (Either String CurrencyPair)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either String Currency
forall (m :: * -> *). MonadError String m => Text -> m Currency
currency Text
y


-- -- | Constructs an 'FXQuote' value at compile-time using @-XTemplateHaskell@.
-- --
-- -- >>> :set -XDataKinds
-- -- >>> $$(fxquoteTH (read "2021-01-01") "EUR" "USD" 10) :: FXQuote 2
-- -- ("EUR/USD","2021-01-01","10.00")
-- fxquoteTH :: KnownNat s => Date -> T.Text -> T.Text -> Scientific -> TH.Q (TH.TExp (FXQuote s))
-- fxquoteTH d c1 c2 = fix $ \loop -> fmap TH.TExp . either (fail . show) TH.lift . fxquoteWE (loop undefined)
--   where
--     -- This provides a work-around for the type-inference due the `s` type parameter.
--     -- Trick is borrowed from the Haskell `refined` library.
--     fxquoteWE :: KnownNat s => TH.Q (TH.TExp (FXQuote s)) -> Scientific -> Either String (FXQuote s)
--     fxquoteWE _ v = do
--       xc1 <- currency c1
--       xc2 <- currency c2
--       either (Left . show) Right $ fxquote d xc1 xc2 v