-- | This module provides template-haskell functions for various "Haspara"
-- definitions.
module Haspara.TH where

import Data.Function (fix)
import Data.Scientific (Scientific)
import qualified Data.Text as T
import GHC.TypeLits (KnownNat)
import Haspara.Currency (Currency, CurrencyPair (CurrencyPair), mkCurrencyError)
import Haspara.Quantity (Quantity, mkQuantityLossless)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH.Syntax


-- | Constructs a 'Quantity' value at compile-time using @-XTemplateHaskell@.
--
-- >>> :set -XDataKinds
-- >>> :set -XOverloadedStrings
-- >>> :set -XTemplateHaskell
-- >>> $$(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.Code TH.Q (Quantity s)
quantityTH :: forall (s :: Nat). KnownNat s => Scientific -> Code Q (Quantity s)
quantityTH = ((Scientific -> Code Q (Quantity s))
 -> Scientific -> Code Q (Quantity s))
-> Scientific -> Code Q (Quantity s)
forall a. (a -> a) -> a
fix (((Scientific -> Code Q (Quantity s))
  -> Scientific -> Code Q (Quantity s))
 -> Scientific -> Code Q (Quantity s))
-> ((Scientific -> Code Q (Quantity s))
    -> Scientific -> Code Q (Quantity s))
-> Scientific
-> Code Q (Quantity s)
forall a b. (a -> b) -> a -> b
$ \Scientific -> Code Q (Quantity s)
loop -> (String -> Code Q (Quantity s))
-> (Quantity s -> Code Q (Quantity s))
-> Either String (Quantity s)
-> Code Q (Quantity s)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Q (TExp (Quantity s)) -> Code Q (Quantity s)
forall a (m :: * -> *). m (TExp a) -> Code m a
TH.Syntax.liftCode (Q (TExp (Quantity s)) -> Code Q (Quantity s))
-> (String -> Q (TExp (Quantity s)))
-> String
-> Code Q (Quantity s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q (TExp (Quantity s))
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (TExp (Quantity s)))
-> (String -> String) -> String -> Q (TExp (Quantity s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) Quantity s -> Code Q (Quantity s)
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
forall (m :: * -> *). Quote m => Quantity s -> Code m (Quantity s)
TH.Syntax.liftTyped (Either String (Quantity s) -> Code Q (Quantity s))
-> (Scientific -> Either String (Quantity s))
-> Scientific
-> Code Q (Quantity s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code Q (Quantity s) -> Scientific -> Either String (Quantity s)
forall (s :: Nat).
KnownNat s =>
Code Q (Quantity s) -> Scientific -> Either String (Quantity s)
quantityWE (Scientific -> Code Q (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.Code TH.Q (Quantity s) -> Scientific -> Either String (Quantity s)
    quantityWE :: forall (s :: Nat).
KnownNat s =>
Code Q (Quantity s) -> Scientific -> Either String (Quantity s)
quantityWE = (Scientific -> Either String (Quantity s))
-> Code Q (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)
mkQuantityLossless


-- | Constructs a 'Currency' value at compile-time using @-XTemplateHaskell@.
--
-- >>> :set -XOverloadedStrings
-- >>> :set -XTemplateHaskell
-- >>> $$(currencyTH "USD")
-- USD
-- >>> $$(currencyTH "usd")
-- ...
-- ...Currency code error! Expecting at least 3 uppercase ASCII letters, but received: usd
-- ...
currencyTH :: T.Text -> TH.Code TH.Q Currency
currencyTH :: Text -> Code Q Currency
currencyTH = (Text -> Code Q Currency)
-> (Currency -> Code Q Currency)
-> Either Text Currency
-> Code Q Currency
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Q (TExp Currency) -> Code Q Currency
forall a (m :: * -> *). m (TExp a) -> Code m a
TH.Syntax.liftCode (Q (TExp Currency) -> Code Q Currency)
-> (Text -> Q (TExp Currency)) -> Text -> Code Q Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q (TExp Currency)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (TExp Currency))
-> (Text -> String) -> Text -> Q (TExp Currency)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Currency -> Code Q Currency
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
forall (m :: * -> *). Quote m => Currency -> Code m Currency
TH.Syntax.liftTyped (Either Text Currency -> Code Q Currency)
-> (Text -> Either Text Currency) -> Text -> Code Q Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Currency
forall (m :: * -> *). MonadError Text m => Text -> m Currency
mkCurrencyError


-- | Constructs a 'CurrencyPair' value at compile-time using @-XTemplateHaskell@.
--
-- >>> :set -XOverloadedStrings
-- >>> :set -XTemplateHaskell
-- >>> $$(currencyPairTH "EUR" "USD")
-- EUR/USD
-- >>> $$(currencyPairTH "USD" "USD")
-- USD/USD
-- >>> $$(currencyPairTH "USD" "eur")
-- ...
-- ... Currency code error! Expecting at least 3 uppercase ASCII letters, but received: eur
-- ...
currencyPairTH :: T.Text -> T.Text -> TH.Code TH.Q CurrencyPair
currencyPairTH :: Text -> Text -> Code Q CurrencyPair
currencyPairTH Text
cf Text
ct = (Text -> Code Q CurrencyPair)
-> (CurrencyPair -> Code Q CurrencyPair)
-> Either Text CurrencyPair
-> Code Q CurrencyPair
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Q (TExp CurrencyPair) -> Code Q CurrencyPair
forall a (m :: * -> *). m (TExp a) -> Code m a
TH.Syntax.liftCode (Q (TExp CurrencyPair) -> Code Q CurrencyPair)
-> (Text -> Q (TExp CurrencyPair)) -> Text -> Code Q CurrencyPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q (TExp CurrencyPair)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (TExp CurrencyPair))
-> (Text -> String) -> Text -> Q (TExp CurrencyPair)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) CurrencyPair -> Code Q CurrencyPair
forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
forall (m :: * -> *).
Quote m =>
CurrencyPair -> Code m CurrencyPair
TH.Syntax.liftTyped (Text -> Text -> Either Text CurrencyPair
mkPair Text
cf Text
ct)
  where
    mkPair :: T.Text -> T.Text -> Either T.Text CurrencyPair
    mkPair :: Text -> Text -> Either Text CurrencyPair
mkPair Text
x Text
y = Currency -> Currency -> CurrencyPair
CurrencyPair (Currency -> Currency -> CurrencyPair)
-> Either Text Currency -> Either Text (Currency -> CurrencyPair)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Currency
forall (m :: * -> *). MonadError Text m => Text -> m Currency
mkCurrencyError Text
x Either Text (Currency -> CurrencyPair)
-> Either Text Currency -> Either Text CurrencyPair
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Either Text Currency
forall (m :: * -> *). MonadError Text m => Text -> m Currency
mkCurrencyError Text
y