96 lines
3.4 KiB
Haskell
96 lines
3.4 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
{- |
|
|
Module : Agora.SafeMoney.QQ
|
|
Maintainer : emi@haskell.fyi
|
|
Description: Quasiquoter for SafeMoney types.
|
|
|
|
Quasiquoter for SafeMoney types.
|
|
-}
|
|
module Agora.SafeMoney.QQ (discrete) where
|
|
|
|
import GHC.Real (Ratio ((:%)))
|
|
import Language.Haskell.TH qualified as TH (Type)
|
|
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
|
|
import Language.Haskell.TH.Syntax (
|
|
Dec (TySynD),
|
|
Exp (AppE, AppTypeE, LitE, VarE),
|
|
Info (TyConI),
|
|
Lit (IntegerL),
|
|
Pat,
|
|
Q,
|
|
TyLit (NumTyLit, StrTyLit),
|
|
Type (AppT, ConT, LitT, PromotedTupleT),
|
|
lookupTypeName,
|
|
reify,
|
|
)
|
|
import Text.ParserCombinators.ReadP (readP_to_S, skipSpaces)
|
|
import Text.Read (lexP, readPrec_to_P)
|
|
import Text.Read.Lex (Lexeme (Ident, Number), Number, numberToFixed, numberToRational)
|
|
import Prelude
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
import Plutarch.Internal (punsafeCoerce)
|
|
|
|
import Agora.SafeMoney (MoneyClass, PDiscrete)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
{- | Generate 'PDiscrete' values tagged by a particular MoneyClass
|
|
|
|
@
|
|
[discrete| 123.456 ADA |] :: 'Term' s ('PDiscrete' 'ADA')
|
|
@
|
|
-}
|
|
discrete :: QuasiQuoter
|
|
discrete = QuasiQuoter discreteExp errorDiscretePat errorDiscreteType errorDiscreteDiscretelaration
|
|
|
|
discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (PDiscrete moneyClass)
|
|
discreteConstant n = punsafeCoerce (pconstant n :: Term s PInteger)
|
|
|
|
fixedToInteger :: Integer -> (Integer, Integer) -> Integer
|
|
fixedToInteger places (i, f) = i * 10 ^ places + f
|
|
|
|
safeIntegerUpcast :: Integer -> Number -> Either String Integer
|
|
safeIntegerUpcast places num =
|
|
case (numberToFixed places num, numberToRational num * 10 ^ places) of
|
|
(Just (i, f), _n :% 1) ->
|
|
Right $ fixedToInteger places (i, f)
|
|
(Just (i, f), _n :% _d) ->
|
|
Left $ "Using more than the available decimal places (" <> show places <> "). Would round to " <> show i <> "." <> show f
|
|
_ -> Left "Some error occurred while getting number"
|
|
|
|
discreteExp :: String -> Q Exp
|
|
discreteExp s = case parseDiscreteRatioExp s of
|
|
Nothing ->
|
|
fail $ "Input malformed. Got: " <> s
|
|
Just (num, mc) -> do
|
|
mcName <-
|
|
lookupTypeName mc >>= \case
|
|
Nothing -> fail $ "MoneyClass with the name " <> show mc <> " is not in scope."
|
|
Just v -> pure v
|
|
reified <- reify mcName
|
|
case reified of
|
|
TyConI (TySynD tyName [] (AppT (AppT (AppT (PromotedTupleT 3) (LitT (StrTyLit _))) (LitT _)) (LitT (NumTyLit n)))) ->
|
|
case safeIntegerUpcast n num of
|
|
Right i ->
|
|
pure $ AppE (AppTypeE (VarE 'discreteConstant) (ConT tyName)) (LitE (IntegerL i))
|
|
Left e -> fail e
|
|
ty' -> fail $ "Could not reify type, got: " <> show ty'
|
|
|
|
parseDiscreteRatioExp :: String -> Maybe (Number, String)
|
|
parseDiscreteRatioExp s =
|
|
let p = skipSpaces *> ((,) <$> readPrec_to_P lexP 0 <* skipSpaces <*> readPrec_to_P lexP 0) <* skipSpaces
|
|
in case readP_to_S p s of
|
|
[((Number n, Ident i), "")] -> Just (n, i)
|
|
_ -> Nothing
|
|
|
|
errorDiscretePat :: String -> Q Pat
|
|
errorDiscretePat _ = fail "Cannot use 'discrete' in a pattern context."
|
|
|
|
errorDiscreteType :: String -> Q TH.Type
|
|
errorDiscreteType _ = fail "Cannot use 'discrete' in a type context."
|
|
|
|
errorDiscreteDiscretelaration :: String -> Q [Dec]
|
|
errorDiscreteDiscretelaration _ = fail "Cannot use 'discrete' in a declaration context."
|