Language/Haskell/TH/Lib/Internal.hs

{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Language.Haskell.TH.Lib.Internal exposes some additional functionality that
-- is used internally in GHC's integration with Template Haskell. This is not a
-- part of the public API, and as such, there are no API guarantees for this
-- module from version to version.

-- Why do we have both Language.Haskell.TH.Lib.Internal and
-- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the
-- former (which are tailored for GHC's use) need different type signatures
-- than the ones in the latter. Syncing up the Internal type signatures would
-- involve a massive amount of breaking changes, so for the time being, we
-- relegate as many changes as we can to just the Internal module, where it
-- is safe to break things.

module Language.Haskell.TH.Lib.Internal where

import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
import qualified Language.Haskell.TH.Syntax as TH
import Control.Applicative(liftA, liftA2)
import qualified Data.Kind as Kind (Type)
import Data.Word( Word8 )
import GHC.Exts (TYPE)
import Prelude

----------------------------------------------------------
-- * Type synonyms
----------------------------------------------------------

-- Since GHC 8.8 is currently the minimum boot compiler version that we must
-- support, we must use inline kind signatures to make TExpQ and CodeQ
-- levity polymorphic. When we drop support for GHC 8.8, we can instead use
-- standalone kind signatures, which are provided as comments.

-- | Levity-polymorphic since /template-haskell-2.17.0.0/.
-- type TExpQ :: TYPE r -> Kind.Type
type TExpQ (a :: TYPE r) = Q (TExp a)

-- type CodeQ :: TYPE r -> Kind.Type
type CodeQ = Code Q :: (TYPE r -> Kind.Type)

type InfoQ = Q Info
type PatQ = Q Pat
type FieldPatQ = Q FieldPat
type ExpQ = Q Exp
type DecQ = Q Dec
type DecsQ = Q [Dec]
type Decs = [Dec] -- Defined as it is more convenient to wire-in
type ConQ = Q Con
type TypeQ = Q Type
type KindQ = Q Kind
type TyLitQ = Q TyLit
type CxtQ = Q Cxt
type PredQ = Q Pred
type DerivClauseQ = Q DerivClause
type MatchQ = Q Match
type ClauseQ = Q Clause
type BodyQ = Q Body
type GuardQ = Q Guard
type StmtQ = Q Stmt
type RangeQ = Q Range
type SourceStrictnessQ = Q SourceStrictness
type SourceUnpackednessQ = Q SourceUnpackedness
type BangQ = Q Bang
type BangTypeQ = Q BangType
type VarBangTypeQ = Q VarBangType
type StrictTypeQ = Q StrictType
type VarStrictTypeQ = Q VarStrictType
type FieldExpQ = Q FieldExp
type RuleBndrQ = Q RuleBndr
type TySynEqnQ = Q TySynEqn
type PatSynDirQ = Q PatSynDir
type PatSynArgsQ = Q PatSynArgs
type FamilyResultSigQ = Q FamilyResultSig
type DerivStrategyQ = Q DerivStrategy

-- must be defined here for DsMeta to find it
type Role = TH.Role
type InjectivityAnn = TH.InjectivityAnn

type TyVarBndrUnit = TyVarBndr ()
type TyVarBndrSpec = TyVarBndr Specificity

----------------------------------------------------------
-- * Lowercase pattern syntax functions
----------------------------------------------------------

intPrimL :: Integer -> Lit
intPrimL = IntPrimL
wordPrimL :: Integer -> Lit
wordPrimL = WordPrimL
floatPrimL :: Rational -> Lit
floatPrimL = FloatPrimL
doublePrimL :: Rational -> Lit
doublePrimL = DoublePrimL
integerL :: Integer -> Lit
integerL = IntegerL
charL :: Char -> Lit
charL = CharL
charPrimL :: Char -> Lit
charPrimL = CharPrimL
stringL :: String -> Lit
stringL = StringL
stringPrimL :: [Word8] -> Lit
stringPrimL = StringPrimL
bytesPrimL :: Bytes -> Lit
bytesPrimL = BytesPrimL
rationalL :: Rational -> Lit
rationalL = RationalL

litP :: Quote m => Lit -> m Pat
litP l = pure (LitP l)

varP :: Quote m => Name -> m Pat
varP v = pure (VarP v)

tupP :: Quote m => [m Pat] -> m Pat
tupP ps = do { ps1 <- sequenceA ps; pure (TupP ps1)}

unboxedTupP :: Quote m => [m Pat] -> m Pat
unboxedTupP ps = do { ps1 <- sequenceA ps; pure (UnboxedTupP ps1)}

unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat
unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) }

conP :: Quote m => Name -> [m Pat] -> m Pat
conP n ps = do ps' <- sequenceA ps
 pure (ConP n ps')
infixP :: Quote m => m Pat -> Name -> m Pat -> m Pat
infixP p1 n p2 = do p1' <- p1
 p2' <- p2
 pure (InfixP p1' n p2')
uInfixP :: Quote m => m Pat -> Name -> m Pat -> m Pat
uInfixP p1 n p2 = do p1' <- p1
 p2' <- p2
 pure (UInfixP p1' n p2')
parensP :: Quote m => m Pat -> m Pat
parensP p = do p' <- p
 pure (ParensP p')

tildeP :: Quote m => m Pat -> m Pat
tildeP p = do p' <- p
 pure (TildeP p')
bangP :: Quote m => m Pat -> m Pat
bangP p = do p' <- p
 pure (BangP p')
asP :: Quote m => Name -> m Pat -> m Pat
asP n p = do p' <- p
 pure (AsP n p')
wildP :: Quote m => m Pat
wildP = pure WildP
recP :: Quote m => Name -> [m FieldPat] -> m Pat
recP n fps = do fps' <- sequenceA fps
 pure (RecP n fps')
listP :: Quote m => [m Pat] -> m Pat
listP ps = do ps' <- sequenceA ps
 pure (ListP ps')
sigP :: Quote m => m Pat -> m Type -> m Pat
sigP p t = do p' <- p
 t' <- t
 pure (SigP p' t')
viewP :: Quote m => m Exp -> m Pat -> m Pat
viewP e p = do e' <- e
 p' <- p
 pure (ViewP e' p')

fieldPat :: Quote m => Name -> m Pat -> m FieldPat
fieldPat n p = do p' <- p
 pure (n, p')


-------------------------------------------------------------------------------
-- * Stmt

bindS :: Quote m => m Pat -> m Exp -> m Stmt
bindS p e = liftA2 BindS p e

letS :: Quote m => [m Dec] -> m Stmt
letS ds = do { ds1 <- sequenceA ds; pure (LetS ds1) }

noBindS :: Quote m => m Exp -> m Stmt
noBindS e = do { e1 <- e; pure (NoBindS e1) }

parS :: Quote m => [[m Stmt]] -> m Stmt
parS sss = do { sss1 <- traverse sequenceA sss; pure (ParS sss1) }

recS :: Quote m => [m Stmt] -> m Stmt
recS ss = do { ss1 <- sequenceA ss; pure (RecS ss1) }

-------------------------------------------------------------------------------
-- * Range

fromR :: Quote m => m Exp -> m Range
fromR x = do { a <- x; pure (FromR a) }

fromThenR :: Quote m => m Exp -> m Exp -> m Range
fromThenR x y = do { a <- x; b <- y; pure (FromThenR a b) }

fromToR :: Quote m => m Exp -> m Exp -> m Range
fromToR x y = do { a <- x; b <- y; pure (FromToR a b) }

fromThenToR :: Quote m => m Exp -> m Exp -> m Exp -> m Range
fromThenToR x y z = do { a <- x; b <- y; c <- z;
 pure (FromThenToR a b c) }
-------------------------------------------------------------------------------
-- * Body

normalB :: Quote m => m Exp -> m Body
normalB e = do { e1 <- e; pure (NormalB e1) }

guardedB :: Quote m => [m (Guard,Exp)] -> m Body
guardedB ges = do { ges' <- sequenceA ges; pure (GuardedB ges') }

-------------------------------------------------------------------------------
-- * Guard

normalG :: Quote m => m Exp -> m Guard
normalG e = do { e1 <- e; pure (NormalG e1) }

normalGE :: Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE g e = do { g1 <- g; e1 <- e; pure (NormalG g1, e1) }

patG :: Quote m => [m Stmt] -> m Guard
patG ss = do { ss' <- sequenceA ss; pure (PatG ss') }

patGE :: Quote m => [m Stmt] -> m Exp -> m (Guard, Exp)
patGE ss e = do { ss' <- sequenceA ss;
 e' <- e;
 pure (PatG ss', e') }

-------------------------------------------------------------------------------
-- * Match and Clause

-- | Use with 'caseE'
match :: Quote m => m Pat -> m Body -> [m Dec] -> m Match
match p rhs ds = do { p' <- p;
 r' <- rhs;
 ds' <- sequenceA ds;
 pure (Match p' r' ds') }

-- | Use with 'funD'
clause :: Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause
clause ps r ds = do { ps' <- sequenceA ps;
 r' <- r;
 ds' <- sequenceA ds;
 pure (Clause ps' r' ds') }


---------------------------------------------------------------------------
-- * Exp

-- | Dynamically binding a variable (unhygenic)
dyn :: Quote m => String -> m Exp
dyn s = pure (VarE (mkName s))

varE :: Quote m => Name -> m Exp
varE s = pure (VarE s)

conE :: Quote m => Name -> m Exp
conE s = pure (ConE s)

litE :: Quote m => Lit -> m Exp
litE c = pure (LitE c)

appE :: Quote m => m Exp -> m Exp -> m Exp
appE x y = do { a <- x; b <- y; pure (AppE a b)}

appTypeE :: Quote m => m Exp -> m Type -> m Exp
appTypeE x t = do { a <- x; s <- t; pure (AppTypeE a s) }

parensE :: Quote m => m Exp -> m Exp
parensE x = do { x' <- x; pure (ParensE x') }

uInfixE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
 pure (UInfixE x' s' y') }

infixE :: Quote m => Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
 pure (InfixE (Just a) s' (Just b))}
infixE Nothing s (Just y) = do { s' <- s; b <- y;
 pure (InfixE Nothing s' (Just b))}
infixE (Just x) s Nothing = do { a <- x; s' <- s;
 pure (InfixE (Just a) s' Nothing)}
infixE Nothing s Nothing = do { s' <- s; pure (InfixE Nothing s' Nothing) }

infixApp :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp x y z = infixE (Just x) y (Just z)
sectionL :: Quote m => m Exp -> m Exp -> m Exp
sectionL x y = infixE (Just x) y Nothing
sectionR :: Quote m => m Exp -> m Exp -> m Exp
sectionR x y = infixE Nothing x (Just y)

lamE :: Quote m => [m Pat] -> m Exp -> m Exp
lamE ps e = do ps' <- sequenceA ps
 e' <- e
 pure (LamE ps' e')

-- | Single-arg lambda
lam1E :: Quote m => m Pat -> m Exp -> m Exp
lam1E p e = lamE [p] e

lamCaseE :: Quote m => [m Match] -> m Exp
lamCaseE ms = LamCaseE <$> sequenceA ms

tupE :: Quote m => [Maybe (m Exp)] -> m Exp
tupE es = do { es1 <- traverse sequenceA es; pure (TupE es1)}

unboxedTupE :: Quote m => [Maybe (m Exp)] -> m Exp
unboxedTupE es = do { es1 <- traverse sequenceA es; pure (UnboxedTupE es1)}

unboxedSumE :: Quote m => m Exp -> SumAlt -> SumArity -> m Exp
unboxedSumE e alt arity = do { e1 <- e; pure (UnboxedSumE e1 alt arity) }

condE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE x y z = do { a <- x; b <- y; c <- z; pure (CondE a b c)}

multiIfE :: Quote m => [m (Guard, Exp)] -> m Exp
multiIfE alts = MultiIfE <$> sequenceA alts

letE :: Quote m => [m Dec] -> m Exp -> m Exp
letE ds e = do { ds2 <- sequenceA ds; e2 <- e; pure (LetE ds2 e2) }

caseE :: Quote m => m Exp -> [m Match] -> m Exp
caseE e ms = do { e1 <- e; ms1 <- sequenceA ms; pure (CaseE e1 ms1) }

doE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp
doE m ss = do { ss1 <- sequenceA ss; pure (DoE m ss1) }

mdoE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp
mdoE m ss = do { ss1 <- sequenceA ss; pure (MDoE m ss1) }

compE :: Quote m => [m Stmt] -> m Exp
compE ss = do { ss1 <- sequenceA ss; pure (CompE ss1) }

arithSeqE :: Quote m => m Range -> m Exp
arithSeqE r = do { r' <- r; pure (ArithSeqE r') }

listE :: Quote m => [m Exp] -> m Exp
listE es = do { es1 <- sequenceA es; pure (ListE es1) }

sigE :: Quote m => m Exp -> m Type -> m Exp
sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) }

recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp
recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) }

recUpdE :: Quote m => m Exp -> [m (Name,Exp)] -> m Exp
recUpdE e fs = do { e1 <- e; flds <- sequenceA fs; pure (RecUpdE e1 flds) }

stringE :: Quote m => String -> m Exp
stringE = litE . stringL

fieldExp :: Quote m => Name -> m Exp -> m (Name, Exp)
fieldExp s e = do { e' <- e; pure (s,e') }

-- | @staticE x = [| static x |]@
staticE :: Quote m => m Exp -> m Exp
staticE = fmap StaticE

unboundVarE :: Quote m => Name -> m Exp
unboundVarE s = pure (UnboundVarE s)

labelE :: Quote m => String -> m Exp
labelE s = pure (LabelE s)

implicitParamVarE :: Quote m => String -> m Exp
implicitParamVarE n = pure (ImplicitParamVarE n)

-- ** 'arithSeqE' Shortcuts
fromE :: Quote m => m Exp -> m Exp
fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }

fromThenE :: Quote m => m Exp -> m Exp -> m Exp
fromThenE x y = do { a <- x; b <- y; pure (ArithSeqE (FromThenR a b)) }

fromToE :: Quote m => m Exp -> m Exp -> m Exp
fromToE x y = do { a <- x; b <- y; pure (ArithSeqE (FromToR a b)) }

fromThenToE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
fromThenToE x y z = do { a <- x; b <- y; c <- z;
 pure (ArithSeqE (FromThenToR a b c)) }


-------------------------------------------------------------------------------
-- * Dec

valD :: Quote m => m Pat -> m Body -> [m Dec] -> m Dec
valD p b ds =
 do { p' <- p
 ; ds' <- sequenceA ds
 ; b' <- b
 ; pure (ValD p' b' ds')
 }

funD :: Quote m => Name -> [m Clause] -> m Dec
funD nm cs =
 do { cs1 <- sequenceA cs
 ; pure (FunD nm cs1)
 }

tySynD :: Quote m => Name -> [m (TyVarBndr ())] -> m Type -> m Dec
tySynD tc tvs rhs =
 do { tvs1 <- sequenceA tvs
 ; rhs1 <- rhs
 ; pure (TySynD tc tvs1 rhs1)
 }

dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con]
 -> [m DerivClause] -> m Dec
dataD ctxt tc tvs ksig cons derivs =
 do
 ctxt1 <- ctxt
 tvs1 <- sequenceA tvs
 ksig1 <- sequenceA ksig
 cons1 <- sequenceA cons
 derivs1 <- sequenceA derivs
 pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)

newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Con
 -> [m DerivClause] -> m Dec
newtypeD ctxt tc tvs ksig con derivs =
 do
 ctxt1 <- ctxt
 tvs1 <- sequenceA tvs
 ksig1 <- sequenceA ksig
 con1 <- con
 derivs1 <- sequenceA derivs
 pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)

classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec
classD ctxt cls tvs fds decs =
 do
 tvs1 <- sequenceA tvs
 decs1 <- sequenceA decs
 ctxt1 <- ctxt
 pure $ ClassD ctxt1 cls tvs1 fds decs1

instanceD :: Quote m => m Cxt -> m Type -> [m Dec] -> m Dec
instanceD = instanceWithOverlapD Nothing

instanceWithOverlapD :: Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec
instanceWithOverlapD o ctxt ty decs =
 do
 ctxt1 <- ctxt
 decs1 <- sequenceA decs
 ty1 <- ty
 pure $ InstanceD o ctxt1 ty1 decs1



sigD :: Quote m => Name -> m Type -> m Dec
sigD fun ty = liftA (SigD fun) $ ty

kiSigD :: Quote m => Name -> m Kind -> m Dec
kiSigD fun ki = liftA (KiSigD fun) $ ki

forImpD :: Quote m => Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD cc s str n ty
 = do ty' <- ty
 pure $ ForeignD (ImportF cc s str n ty')

infixLD :: Quote m => Int -> Name -> m Dec
infixLD prec nm = pure (InfixD (Fixity prec InfixL) nm)

infixRD :: Quote m => Int -> Name -> m Dec
infixRD prec nm = pure (InfixD (Fixity prec InfixR) nm)

infixND :: Quote m => Int -> Name -> m Dec
infixND prec nm = pure (InfixD (Fixity prec InfixN) nm)

pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD name inline rm phases
 = pure $ PragmaD $ InlineP name inline rm phases

pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec
pragSpecD n ty phases
 = do
 ty1 <- ty
 pure $ PragmaD $ SpecialiseP n ty1 Nothing phases

pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec
pragSpecInlD n ty inline phases
 = do
 ty1 <- ty
 pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases

pragSpecInstD :: Quote m => m Type -> m Dec
pragSpecInstD ty
 = do
 ty1 <- ty
 pure $ PragmaD $ SpecialiseInstP ty1

pragRuleD :: Quote m => String -> Maybe [m (TyVarBndr ())] -> [m RuleBndr] -> m Exp -> m Exp
 -> Phases -> m Dec
pragRuleD n ty_bndrs tm_bndrs lhs rhs phases
 = do
 ty_bndrs1 <- traverse sequenceA ty_bndrs
 tm_bndrs1 <- sequenceA tm_bndrs
 lhs1 <- lhs
 rhs1 <- rhs
 pure $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases

pragAnnD :: Quote m => AnnTarget -> m Exp -> m Dec
pragAnnD target expr
 = do
 exp1 <- expr
 pure $ PragmaD $ AnnP target exp1

pragLineD :: Quote m => Int -> String -> m Dec
pragLineD line file = pure $ PragmaD $ LineP line file

pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec
pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty

dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con]
 -> [m DerivClause] -> m Dec
dataInstD ctxt mb_bndrs ty ksig cons derivs =
 do
 ctxt1 <- ctxt
 mb_bndrs1 <- traverse sequenceA mb_bndrs
 ty1 <- ty
 ksig1 <- sequenceA ksig
 cons1 <- sequenceA cons
 derivs1 <- sequenceA derivs
 pure (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)

newtypeInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> m Con
 -> [m DerivClause] -> m Dec
newtypeInstD ctxt mb_bndrs ty ksig con derivs =
 do
 ctxt1 <- ctxt
 mb_bndrs1 <- traverse sequenceA mb_bndrs
 ty1 <- ty
 ksig1 <- sequenceA ksig
 con1 <- con
 derivs1 <- sequenceA derivs
 pure (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)

tySynInstD :: Quote m => m TySynEqn -> m Dec
tySynInstD eqn =
 do
 eqn1 <- eqn
 pure (TySynInstD eqn1)

dataFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Dec
dataFamilyD tc tvs kind =
 do tvs' <- sequenceA tvs
 kind' <- sequenceA kind
 pure $ DataFamilyD tc tvs' kind'

openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig
 -> Maybe InjectivityAnn -> m Dec
openTypeFamilyD tc tvs res inj =
 do tvs' <- sequenceA tvs
 res' <- res
 pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)

closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig
 -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec
closedTypeFamilyD tc tvs result injectivity eqns =
 do tvs1 <- sequenceA tvs
 result1 <- result
 eqns1 <- sequenceA eqns
 pure (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)

roleAnnotD :: Quote m => Name -> [Role] -> m Dec
roleAnnotD name roles = pure $ RoleAnnotD name roles

standaloneDerivD :: Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD = standaloneDerivWithStrategyD Nothing

standaloneDerivWithStrategyD :: Quote m => Maybe (m DerivStrategy) -> m Cxt -> m Type -> m Dec
standaloneDerivWithStrategyD mdsq ctxtq tyq =
 do
 mds <- sequenceA mdsq
 ctxt <- ctxtq
 ty <- tyq
 pure $ StandaloneDerivD mds ctxt ty

defaultSigD :: Quote m => Name -> m Type -> m Dec
defaultSigD n tyq =
 do
 ty <- tyq
 pure $ DefaultSigD n ty

-- | Pattern synonym declaration
patSynD :: Quote m => Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD name args dir pat = do
 args' <- args
 dir' <- dir
 pat' <- pat
 pure (PatSynD name args' dir' pat')

-- | Pattern synonym type signature
patSynSigD :: Quote m => Name -> m Type -> m Dec
patSynSigD nm ty =
 do ty' <- ty
 pure $ PatSynSigD nm ty'

-- | Implicit parameter binding declaration. Can only be used in let
-- and where clauses which consist entirely of implicit bindings.
implicitParamBindD :: Quote m => String -> m Exp -> m Dec
implicitParamBindD n e =
 do
 e' <- e
 pure $ ImplicitParamBindD n e'

tySynEqn :: Quote m => (Maybe [m (TyVarBndr ())]) -> m Type -> m Type -> m TySynEqn
tySynEqn mb_bndrs lhs rhs =
 do
 mb_bndrs1 <- traverse sequenceA mb_bndrs
 lhs1 <- lhs
 rhs1 <- rhs
 pure (TySynEqn mb_bndrs1 lhs1 rhs1)

cxt :: Quote m => [m Pred] -> m Cxt
cxt = sequenceA

derivClause :: Quote m => Maybe (m DerivStrategy) -> [m Pred] -> m DerivClause
derivClause mds p = do mds' <- sequenceA mds
 p' <- cxt p
 pure $ DerivClause mds' p'

stockStrategy :: Quote m => m DerivStrategy
stockStrategy = pure StockStrategy

anyclassStrategy :: Quote m => m DerivStrategy
anyclassStrategy = pure AnyclassStrategy

newtypeStrategy :: Quote m => m DerivStrategy
newtypeStrategy = pure NewtypeStrategy

viaStrategy :: Quote m => m Type -> m DerivStrategy
viaStrategy = fmap ViaStrategy

normalC :: Quote m => Name -> [m BangType] -> m Con
normalC con strtys = liftA (NormalC con) $ sequenceA strtys

recC :: Quote m => Name -> [m VarBangType] -> m Con
recC con varstrtys = liftA (RecC con) $ sequenceA varstrtys

infixC :: Quote m => m (Bang, Type) -> Name -> m (Bang, Type) -> m Con
infixC st1 con st2 = do st1' <- st1
 st2' <- st2
 pure $ InfixC st1' con st2'

forallC :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Con -> m Con
forallC ns ctxt con = do
 ns' <- sequenceA ns
 ctxt' <- ctxt
 con' <- con
 pure $ ForallC ns' ctxt' con'

gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con
gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty

recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con
recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty

-------------------------------------------------------------------------------
-- * Type

forallT :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Type -> m Type
forallT tvars ctxt ty = do
 tvars1 <- sequenceA tvars
 ctxt1 <- ctxt
 ty1 <- ty
 pure $ ForallT tvars1 ctxt1 ty1

forallVisT :: Quote m => [m (TyVarBndr ())] -> m Type -> m Type
forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty

varT :: Quote m => Name -> m Type
varT = pure . VarT

conT :: Quote m => Name -> m Type
conT = pure . ConT

infixT :: Quote m => m Type -> Name -> m Type -> m Type
infixT t1 n t2 = do t1' <- t1
 t2' <- t2
 pure (InfixT t1' n t2')

uInfixT :: Quote m => m Type -> Name -> m Type -> m Type
uInfixT t1 n t2 = do t1' <- t1
 t2' <- t2
 pure (UInfixT t1' n t2')

parensT :: Quote m => m Type -> m Type
parensT t = do t' <- t
 pure (ParensT t')

appT :: Quote m => m Type -> m Type -> m Type
appT t1 t2 = do
 t1' <- t1
 t2' <- t2
 pure $ AppT t1' t2'

appKindT :: Quote m => m Type -> m Kind -> m Type
appKindT ty ki = do
 ty' <- ty
 ki' <- ki
 pure $ AppKindT ty' ki'

arrowT :: Quote m => m Type
arrowT = pure ArrowT

mulArrowT :: Quote m => m Type
mulArrowT = pure MulArrowT

listT :: Quote m => m Type
listT = pure ListT

litT :: Quote m => m TyLit -> m Type
litT l = fmap LitT l

tupleT :: Quote m => Int -> m Type
tupleT i = pure (TupleT i)

unboxedTupleT :: Quote m => Int -> m Type
unboxedTupleT i = pure (UnboxedTupleT i)

unboxedSumT :: Quote m => SumArity -> m Type
unboxedSumT arity = pure (UnboxedSumT arity)

sigT :: Quote m => m Type -> m Kind -> m Type
sigT t k
 = do
 t' <- t
 k' <- k
 pure $ SigT t' k'

equalityT :: Quote m => m Type
equalityT = pure EqualityT

wildCardT :: Quote m => m Type
wildCardT = pure WildCardT

implicitParamT :: Quote m => String -> m Type -> m Type
implicitParamT n t
 = do
 t' <- t
 pure $ ImplicitParamT n t'

{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}
classP :: Quote m => Name -> [m Type] -> m Pred
classP cla tys
 = do
 tysl <- sequenceA tys
 pure (foldl AppT (ConT cla) tysl)

{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}
equalP :: Quote m => m Type -> m Type -> m Pred
equalP tleft tright
 = do
 tleft1 <- tleft
 tright1 <- tright
 eqT <- equalityT
 pure (foldl AppT eqT [tleft1, tright1])

promotedT :: Quote m => Name -> m Type
promotedT = pure . PromotedT

promotedTupleT :: Quote m => Int -> m Type
promotedTupleT i = pure (PromotedTupleT i)

promotedNilT :: Quote m => m Type
promotedNilT = pure PromotedNilT

promotedConsT :: Quote m => m Type
promotedConsT = pure PromotedConsT

noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: Quote m => m SourceUnpackedness
noSourceUnpackedness = pure NoSourceUnpackedness
sourceNoUnpack = pure SourceNoUnpack
sourceUnpack = pure SourceUnpack

noSourceStrictness, sourceLazy, sourceStrict :: Quote m => m SourceStrictness
noSourceStrictness = pure NoSourceStrictness
sourceLazy = pure SourceLazy
sourceStrict = pure SourceStrict

{-# DEPRECATED isStrict
 ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",
 "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}
{-# DEPRECATED notStrict
 ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",
 "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}
{-# DEPRECATED unpacked
 ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",
 "Example usage: 'bang sourceUnpack sourceStrict'"] #-}
isStrict, notStrict, unpacked :: Quote m => m Strict
isStrict = bang noSourceUnpackedness sourceStrict
notStrict = bang noSourceUnpackedness noSourceStrictness
unpacked = bang sourceUnpack sourceStrict

bang :: Quote m => m SourceUnpackedness -> m SourceStrictness -> m Bang
bang u s = do u' <- u
 s' <- s
 pure (Bang u' s')

bangType :: Quote m => m Bang -> m Type -> m BangType
bangType = liftA2 (,)

varBangType :: Quote m => Name -> m BangType -> m VarBangType
varBangType v bt = (\(b, t) -> (v, b, t)) <$> bt

{-# DEPRECATED strictType
 "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}
strictType :: Quote m => m Strict -> m Type -> m StrictType
strictType = bangType

{-# DEPRECATED varStrictType
 "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}
varStrictType :: Quote m => Name -> m StrictType -> m VarStrictType
varStrictType = varBangType

-- * Type Literals

-- MonadFail here complicates things (a lot) because it would mean we would
-- have to emit a MonadFail constraint during typechecking if there was any
-- chance the desugaring would use numTyLit, which in general is hard to
-- predict.
numTyLit :: Quote m => Integer -> m TyLit
numTyLit n = if n >= 0 then pure (NumTyLit n)
 else error ("Negative type-level number: " ++ show n)

strTyLit :: Quote m => String -> m TyLit
strTyLit s = pure (StrTyLit s)

-------------------------------------------------------------------------------
-- * Kind

plainTV :: Quote m => Name -> m (TyVarBndr ())
plainTV n = pure $ PlainTV n ()

plainInvisTV :: Quote m => Name -> Specificity -> m (TyVarBndr Specificity)
plainInvisTV n s = pure $ PlainTV n s

kindedTV :: Quote m => Name -> m Kind -> m (TyVarBndr ())
kindedTV n = fmap (KindedTV n ())

kindedInvisTV :: Quote m => Name -> Specificity -> m Kind -> m (TyVarBndr Specificity)
kindedInvisTV n s = fmap (KindedTV n s)

specifiedSpec :: Specificity
specifiedSpec = SpecifiedSpec

inferredSpec :: Specificity
inferredSpec = InferredSpec

varK :: Name -> Kind
varK = VarT

conK :: Name -> Kind
conK = ConT

tupleK :: Int -> Kind
tupleK = TupleT

arrowK :: Kind
arrowK = ArrowT

listK :: Kind
listK = ListT

appK :: Kind -> Kind -> Kind
appK = AppT

starK :: Quote m => m Kind
starK = pure StarT

constraintK :: Quote m => m Kind
constraintK = pure ConstraintT

-------------------------------------------------------------------------------
-- * Type family result

noSig :: Quote m => m FamilyResultSig
noSig = pure NoSig

kindSig :: Quote m => m Kind -> m FamilyResultSig
kindSig = fmap KindSig

tyVarSig :: Quote m => m (TyVarBndr ()) -> m FamilyResultSig
tyVarSig = fmap TyVarSig

-------------------------------------------------------------------------------
-- * Injectivity annotation

injectivityAnn :: Name -> [Name] -> InjectivityAnn
injectivityAnn = TH.InjectivityAnn

-------------------------------------------------------------------------------
-- * Role

nominalR, representationalR, phantomR, inferR :: Role
nominalR = NominalR
representationalR = RepresentationalR
phantomR = PhantomR
inferR = InferR

-------------------------------------------------------------------------------
-- * Callconv

cCall, stdCall, cApi, prim, javaScript :: Callconv
cCall = CCall
stdCall = StdCall
cApi = CApi
prim = Prim
javaScript = JavaScript

-------------------------------------------------------------------------------
-- * Safety

unsafe, safe, interruptible :: Safety
unsafe = Unsafe
safe = Safe
interruptible = Interruptible

-------------------------------------------------------------------------------
-- * FunDep

funDep :: [Name] -> [Name] -> FunDep
funDep = FunDep

-------------------------------------------------------------------------------
-- * RuleBndr
ruleVar :: Quote m => Name -> m RuleBndr
ruleVar = pure . RuleVar

typedRuleVar :: Quote m => Name -> m Type -> m RuleBndr
typedRuleVar n ty = TypedRuleVar n <$> ty

-------------------------------------------------------------------------------
-- * AnnTarget
valueAnnotation :: Name -> AnnTarget
valueAnnotation = ValueAnnotation

typeAnnotation :: Name -> AnnTarget
typeAnnotation = TypeAnnotation

moduleAnnotation :: AnnTarget
moduleAnnotation = ModuleAnnotation

-------------------------------------------------------------------------------
-- * Pattern Synonyms (sub constructs)

unidir, implBidir :: Quote m => m PatSynDir
unidir = pure Unidir
implBidir = pure ImplBidir

explBidir :: Quote m => [m Clause] -> m PatSynDir
explBidir cls = do
 cls' <- sequenceA cls
 pure (ExplBidir cls')

prefixPatSyn :: Quote m => [Name] -> m PatSynArgs
prefixPatSyn args = pure $ PrefixPatSyn args

recordPatSyn :: Quote m => [Name] -> m PatSynArgs
recordPatSyn sels = pure $ RecordPatSyn sels

infixPatSyn :: Quote m => Name -> Name -> m PatSynArgs
infixPatSyn arg1 arg2 = pure $ InfixPatSyn arg1 arg2

--------------------------------------------------------------
-- * Useful helper function

appsE :: Quote m => [m Exp] -> m Exp
appsE [] = error "appsE []"
appsE [x] = x
appsE (x:y:zs) = appsE ( (appE x y) : zs )

-- | pure the Module at the place of splicing. Can be used as an
-- input for 'reifyModule'.
thisModule :: Q Module
thisModule = do
 loc <- location
 pure $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)