{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module PlutusTx.Lift.THUtils where
import PlutusIR
import PlutusIR.Compiler.Names
import PlutusCore.Quote
import Control.Monad
import Data.Text qualified as T
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Datatype qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Prelude as Haskell
showName :: TH.Name -> T.Text
showName :: Name -> Text
showName Name
n = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ case Name
n of
TH.Name OccName
occ NameFlavour
TH.NameS -> OccName -> String
TH.occString OccName
occ
TH.Name OccName
occ (TH.NameQ ModName
m) -> ModName -> String
TH.modString ModName
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
TH.occString OccName
occ
TH.Name OccName
occ (TH.NameG NameSpace
_ PkgName
_ ModName
m) -> ModName -> String
TH.modString ModName
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
TH.occString OccName
occ
TH.Name OccName
occ (TH.NameU Uniq
_) -> OccName -> String
TH.occString OccName
occ
TH.Name OccName
occ (TH.NameL Uniq
_) -> OccName -> String
TH.occString OccName
occ
normalizeType :: TH.Type -> TH.Type
normalizeType :: Type -> Type
normalizeType = \case
TH.ForallT [TyVarBndr Specificity]
b Cxt
c Type
t -> [TyVarBndr Specificity] -> Cxt -> Type -> Type
TH.ForallT [TyVarBndr Specificity]
b Cxt
c (Type -> Type
normalizeType Type
t)
TH.AppT Type
t1 Type
t2 -> Type -> Type -> Type
TH.AppT (Type -> Type
normalizeType Type
t1) (Type -> Type
normalizeType Type
t2)
TH.SigT Type
t Type
_ -> Type -> Type
normalizeType Type
t
TH.InfixT Type
t1 Name
n Type
t2 -> Name -> Type
TH.ConT Name
n Type -> Type -> Type
`TH.AppT` Type -> Type
normalizeType Type
t1 Type -> Type -> Type
`TH.AppT` Type -> Type
normalizeType Type
t2
TH.UInfixT Type
t1 Name
n Type
t2 -> Name -> Type
TH.ConT Name
n Type -> Type -> Type
`TH.AppT` Type -> Type
normalizeType Type
t1 Type -> Type -> Type
`TH.AppT` Type -> Type
normalizeType Type
t2
TH.ParensT Type
t -> Type -> Type
normalizeType Type
t
Type
TH.ListT -> Name -> Type
TH.ConT ''[]
TH.TupleT Int
arity -> Name -> Type
TH.ConT (Int -> Name
TH.tupleTypeName Int
arity)
TH.UnboxedTupleT Int
arity -> Name -> Type
TH.ConT (Int -> Name
TH.unboxedTupleTypeName Int
arity)
TH.UnboxedSumT Int
arity -> Name -> Type
TH.ConT (Int -> Name
TH.unboxedSumTypeName Int
arity)
Type
t -> Type
t
requireExtension :: TH.Extension -> TH.Q ()
requireExtension :: Extension -> Q ()
requireExtension Extension
ext = do
Bool
enabled <- Extension -> Q Bool
TH.isExtEnabled Extension
ext
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
enabled (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Extension must be enabled: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Extension -> String
forall a. Show a => a -> String
show Extension
ext
mkTyVarDecl :: (MonadQuote m) => TH.Name -> Kind () -> m (TH.Name, TyVarDecl TyName ())
mkTyVarDecl :: forall (m :: * -> *).
MonadQuote m =>
Name -> Kind () -> m (Name, TyVarDecl TyName ())
mkTyVarDecl Name
name Kind ()
kind = do
TyName
tyName <- Text -> m TyName
forall (m :: * -> *). MonadQuote m => Text -> m TyName
safeFreshTyName (Text -> m TyName) -> Text -> m TyName
forall a b. (a -> b) -> a -> b
$ Name -> Text
showName Name
name
(Name, TyVarDecl TyName ()) -> m (Name, TyVarDecl TyName ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, () -> TyName -> Kind () -> TyVarDecl TyName ()
forall tyname ann.
ann -> tyname -> Kind ann -> TyVarDecl tyname ann
TyVarDecl () TyName
tyName Kind ()
kind)
isNewtype :: TH.DatatypeInfo -> Bool
isNewtype :: DatatypeInfo -> Bool
isNewtype TH.DatatypeInfo{datatypeVariant :: DatatypeInfo -> DatatypeVariant
TH.datatypeVariant=DatatypeVariant
variant} = case DatatypeVariant
variant of
DatatypeVariant
TH.Newtype -> Bool
True
DatatypeVariant
_ -> Bool
False
tyListE :: [TH.TExpQ a] -> TH.TExpQ [a]
tyListE :: forall a. [TExpQ a] -> TExpQ [a]
tyListE [TExpQ a]
texps = Q Exp -> Q (TExp [a])
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
TH.unsafeTExpCoerce [| $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.listE ((TExpQ a -> Q Exp) -> [TExpQ a] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TExpQ a -> Q Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
TH.unTypeQ [TExpQ a]
texps)) |]