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)