summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2019-11-27 15:29:44 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-01-12 21:28:47 -0500
commit9129210f7e9937c1065330295f06524661575839 (patch)
tree8eee18f92d23eb2fe39adecda1d547fa8d9fa7cb
parent49f83a0de12a7c02f4a6e99d26eaa362a373afa5 (diff)
downloadhaskell-9129210f7e9937c1065330295f06524661575839.tar.gz
Overloaded Quotation Brackets (#246)
This patch implements overloaded quotation brackets which generalise the desugaring of all quotation forms in terms of a new minimal interface. The main change is that a quotation, for example, [e| 5 |], will now have type `Quote m => m Exp` rather than `Q Exp`. The `Quote` typeclass contains a single method for generating new names which is used when desugaring binding structures. The return type of functions from the `Lift` type class, `lift` and `liftTyped` have been restricted to `forall m . Quote m => m Exp` rather than returning a result in a Q monad. More details about the feature can be read in the GHC proposal. https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs6
-rw-r--r--compiler/GHC/Hs/Expr.hs6
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/deSugar/DsExpr.hs2
-rw-r--r--compiler/deSugar/DsMeta.hs1063
-rw-r--r--compiler/main/HscTypes.hs6
-rw-r--r--compiler/prelude/THNames.hs112
-rw-r--r--compiler/typecheck/TcEnv.hs2
-rw-r--r--compiler/typecheck/TcEvidence.hs35
-rw-r--r--compiler/typecheck/TcExpr.hs5
-rw-r--r--compiler/typecheck/TcHsSyn.hs16
-rw-r--r--compiler/typecheck/TcMType.hs26
-rw-r--r--compiler/typecheck/TcOrigin.hs2
-rw-r--r--compiler/typecheck/TcRnTypes.hs7
-rw-r--r--compiler/typecheck/TcSplice.hs183
-rw-r--r--docs/users_guide/8.12.1-notes.rst4
-rw-r--r--docs/users_guide/glasgow_exts.rst69
-rw-r--r--libraries/template-haskell/Language/Haskell/TH.hs4
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs78
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs738
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs118
-rw-r--r--libraries/template-haskell/changelog.md9
-rw-r--r--testsuite/tests/cabal/cabal04/TH.hs2
-rw-r--r--testsuite/tests/driver/recomp009/Sub1.hs2
-rw-r--r--testsuite/tests/driver/recomp009/Sub2.hs2
-rw-r--r--testsuite/tests/ghci/T16670/TH.hs1
-rw-r--r--testsuite/tests/ghci/scripts/T8831.hs2
-rw-r--r--testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs2
-rw-r--r--testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs11
-rw-r--r--testsuite/tests/quotes/T6062.hs1
-rw-r--r--testsuite/tests/quotes/T8455.hs1
-rw-r--r--testsuite/tests/quotes/T8759a.hs1
-rw-r--r--testsuite/tests/quotes/T9824.hs1
-rw-r--r--testsuite/tests/quotes/TH_bracket1.hs2
-rw-r--r--testsuite/tests/quotes/TH_bracket2.hs1
-rw-r--r--testsuite/tests/quotes/TH_bracket3.hs1
-rw-r--r--testsuite/tests/quotes/TH_localname.stderr22
-rw-r--r--testsuite/tests/quotes/TH_typed_csp.hs6
-rw-r--r--testsuite/tests/quotes/all.T1
-rw-r--r--testsuite/tests/th/T10047.stdout4
-rw-r--r--testsuite/tests/th/T12993_Lib.hs1
-rw-r--r--testsuite/tests/th/T1476.hs1
-rw-r--r--testsuite/tests/th/T1476b.hs1
-rw-r--r--testsuite/tests/th/T15783B.hs1
-rw-r--r--testsuite/tests/th/T15843a.hs1
-rw-r--r--testsuite/tests/th/T2386_Lib.hs1
-rw-r--r--testsuite/tests/th/T4949.hs1
-rw-r--r--testsuite/tests/th/T7276.stderr3
-rw-r--r--testsuite/tests/th/T7276a.stdout4
-rw-r--r--testsuite/tests/th/T8028a.hs1
-rw-r--r--testsuite/tests/th/TH_NestedSplices.hs2
-rw-r--r--testsuite/tests/th/TH_StringLift.hs10
-rw-r--r--testsuite/tests/th/TH_tuple1a.hs1
-rw-r--r--testsuite/tests/th/TH_unresolvedInfix.hs1
-rw-r--r--testsuite/tests/th/TH_unresolvedInfix_Lib.hs1
-rw-r--r--testsuite/tests/th/all.T1
-rw-r--r--testsuite/tests/th/overloaded/Makefile4
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_constraints.hs32
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.hs20
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr13
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_csp.hs18
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_csp.stdout2
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_extract.hs23
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_extract.stdout6
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_no_instance.hs14
-rw-r--r--testsuite/tests/th/overloaded/TH_overloaded_no_instance.stderr5
-rw-r--r--testsuite/tests/th/overloaded/all.T23
-rw-r--r--testsuite/tests/th/should_compile/T8025/A.hs2
68 files changed, 1696 insertions, 1053 deletions
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 1512ab3842..4dd1822a5e 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -926,8 +926,10 @@ cpeApp top_env expr
(_ : ss_rest, True) -> (topDmd, ss_rest)
(ss1 : ss_rest, False) -> (ss1, ss_rest)
([], _) -> (topDmd, [])
- (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
- splitFunTy_maybe fun_ty
+ (arg_ty, res_ty) =
+ case splitFunTy_maybe fun_ty of
+ Just as -> as
+ Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)
(fs, arg') <- cpeArg top_env ss1 arg arg_ty
rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
CpeCast co ->
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 12daa75187..373c459cdb 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -451,6 +451,8 @@ data HsExpr p
| HsTcBracketOut
(XTcBracketOut p)
+ (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
+ -- to the quote.
(HsBracket GhcRn) -- Output of the type checker is the *original*
-- renamed expression, plus
[PendingTcSplice] -- _typechecked_ splices to be
@@ -1006,8 +1008,8 @@ ppr_expr (HsSpliceE _ s) = pprSplice s
ppr_expr (HsBracket _ b) = pprHsBracket b
ppr_expr (HsRnBracketOut _ e []) = ppr e
ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
-ppr_expr (HsTcBracketOut _ e []) = ppr e
-ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
+ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e
+ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 03ccc6bdd4..a3c2efe77b 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1004,7 +1004,7 @@ instance ( a ~ GhcPass p
[ toHie b
, toHie p
]
- HsTcBracketOut _ b p ->
+ HsTcBracketOut _ _wrap b p ->
[ toHie b
, toHie p
]
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index d79caead00..a5019ae042 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -709,7 +709,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- Template Haskell stuff
ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
-ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
+ds_expr _ (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps
ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index fe34e37f1c..943f180dae 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1,6 +1,9 @@
{-# LANGUAGE CPP, TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
--
@@ -60,32 +63,166 @@ import ForeignCall
import Util
import Maybes
import MonadUtils
+import TcEvidence
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class
+import Class
+import HscTypes ( MonadThings )
+import DataCon
+import Var
+import DsBinds
+
+import GHC.TypeLits
+import Data.Kind (Constraint)
import Data.ByteString ( unpack )
import Control.Monad
import Data.List
+data MetaWrappers = MetaWrappers {
+ -- Applies its argument to a type argument `m` and dictionary `Quote m`
+ quoteWrapper :: CoreExpr -> CoreExpr
+ -- Apply its argument to a type argument `m` and a dictionary `Monad m`
+ , monadWrapper :: CoreExpr -> CoreExpr
+ -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
+ , metaTy :: Type -> Type
+ -- Information about the wrappers which be printed to be inspected
+ , _debugWrappers :: (HsWrapper, HsWrapper, Type)
+ }
+
+-- | Construct the functions which will apply the relevant part of the
+-- QuoteWrapper to identifiers during desugaring.
+mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
+mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
+ let quote_var = Var quote_var_raw
+ -- Get the superclass selector to select the Monad dictionary, going
+ -- to be used to construct the monadWrapper.
+ quote_tc <- dsLookupTyCon quoteClassName
+ monad_tc <- dsLookupTyCon monadClassName
+ let Just cls = tyConClass_maybe quote_tc
+ Just monad_cls = tyConClass_maybe monad_tc
+ -- Quote m -> Monad m
+ monad_sel = classSCSelId cls 0
+
+ -- Only used for the defensive assertion that the selector has
+ -- the expected type
+ tyvars = dataConUserTyVarBinders (classDataCon cls)
+ expected_ty = mkForAllTys tyvars $
+ mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
+ (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))
+
+ MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)
+
+ let m_ty = Type m_var
+ -- Construct the contents of MetaWrappers
+ quoteWrapper = applyQuoteWrapper q
+ monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>
+ mkWpTyApps [m_var]
+ tyWrapper t = mkAppTy m_var t
+ debug = (quoteWrapper, monadWrapper, m_var)
+ q_f <- dsHsWrapper quoteWrapper
+ m_f <- dsHsWrapper monadWrapper
+ return (MetaWrappers q_f m_f tyWrapper debug)
+
+-- Turn A into m A
+wrapName :: Name -> MetaM Type
+wrapName n = do
+ t <- lookupType n
+ wrap_fn <- asks metaTy
+ return (wrap_fn t)
+
+-- The local state is always the same, calculated from the passed in
+-- wrapper
+type MetaM a = ReaderT MetaWrappers DsM a
+
-----------------------------------------------------------------------------
-dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
--- Returns a CoreExpr of type TH.ExpQ
+dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
+ -> HsBracket GhcRn
+ -> [PendingTcSplice]
+ -> DsM CoreExpr
+-- See Note [Desugaring Brackets]
+-- Returns a CoreExpr of type (M TH.Exp)
-- The quoted thing is parameterised over Name, even though it has
-- been type checked. We don't want all those type decorations!
-dsBracket brack splices
- = dsExtendMetaEnv new_bit (do_brack brack)
+dsBracket wrap brack splices
+ = do_brack brack
+
where
+ runOverloaded act = do
+ -- In the overloaded case we have to get given a wrapper, it is just
+ -- for variable quotations that there is no wrapper, because they
+ -- have a simple type.
+ mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
+ runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw
+
+
new_bit = mkNameEnv [(n, DsSplice (unLoc e))
| PendingTcSplice n e <- splices]
- do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
- do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
- do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 }
- do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 }
- do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+ do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM n ; return e1 }
+ do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
+ do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 }
+ do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 }
+ do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
- do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
do_brack (XBracket nec) = noExtCon nec
+{-
+Note [Desugaring Brackets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie
+an expression bracket was of type Q Exp. This made the desugaring process simple
+as there were no complicated type variables to keep consistent throughout the
+whole AST. Due to the overloaded quotations proposal a quotation bracket is now
+of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been
+generalised to work with any monad implementing a minimal interface.
+
+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst
+
+Users can rejoice at the flexibility but now there is some additional complexity in
+how brackets are desugared as all these polymorphic combinators need their arguments
+instantiated.
+
+> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD
+> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.
+
+What the arguments should be instantiated to is supplied by the `QuoteWrapper`
+datatype which is produced by `TcSplice`. It is a pair of an evidence variable
+for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring
+need to be applied to these two type variables.
+
+There are three important functions which do the application.
+
+1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.
+2. `rep2M` takes a function name of type `Monad m => T` as an argument
+3. `rep2_nw` takes a function name without any constraints as an argument.
+
+These functions then use the information in QuoteWrapper to apply the correct
+arguments to the functions as the representation is constructed.
+
+The `MetaM` monad carries around an environment of three functions which are
+used in order to wrap the polymorphic combinators and instantiate the arguments
+to the correct things.
+
+1. quoteWrapper wraps functions of type `forall m . Quote m => T`
+2. monadWrapper wraps functions of type `forall m . Monad m => T`
+3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.
+
+Historical note about the implementation: At the first attempt, I attempted to
+lie that the type of any quotation was `Quote m => m Exp` and then specialise it
+by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was
+simpler to implement but didn't work because of nested splices. For example,
+you might have a nested splice of a more specific type which fixes the type of
+the overall quote and so all the combinators used must also be instantiated to
+that specific type. Therefore you really have to use the contents of the quote
+wrapper to directly apply the right type to the combinators rather than
+first generate a polymorphic definition and then just apply the wrapper at the end.
+
+-}
+
{- -------------- Examples --------------------
[| \x -> x |]
@@ -105,12 +242,17 @@ dsBracket brack splices
-- Declarations
-------------------------------------------------------
-repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)
+-- Proxy for the phantom type of `Core`. All the generated fragments have
+-- type something like `Quote m => m Exp` so to keep things simple we represent fragments
+-- of that type as `M Exp`.
+data M a
+
+repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
; pat' <- addBinds ss (repLP pat)
; wrapGenSyms ss pat' }
-repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
+repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
repTopDs group@(HsGroup { hs_valds = valds
, hs_splcds = splcds
, hs_tyclds = tyclds
@@ -161,11 +303,10 @@ repTopDs group@(HsGroup { hs_valds = valds
++ inst_ds ++ rule_ds ++ for_ds
++ ann_ds ++ deriv_ds) }) ;
- decl_ty <- lookupType decQTyConName ;
- let { core_list = coreList' decl_ty decls } ;
+ core_list <- repListM decTyConName return decls ;
dec_ty <- lookupType decTyConName ;
- q_decs <- repSequenceQ dec_ty core_list ;
+ q_decs <- repSequenceM dec_ty core_list ;
wrapGenSyms ss q_decs
}
@@ -300,7 +441,7 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
-- represent associated family instances
--
-repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))
repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
repFamilyDecl (L loc fam)
@@ -331,7 +472,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; fds1 <- repLFunDeps fds
; ats1 <- repFamilyDecls ats
; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds
- ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
+ ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
; wrapGenSyms ss decls2 }
; return $ Just (loc, dec)
@@ -340,7 +481,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
repTyClD (L _ (XTyClDecl nec)) = noExtCon nec
-------------------------
-repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRoleD (L loc (RoleAnnotDecl _ tycon roles))
= do { tycon1 <- lookupLOcc tycon
; roles1 <- mapM repRole roles
@@ -350,7 +491,7 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec
-------------------------
-repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repKiSigD (L loc kisig) =
case kisig of
StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
@@ -358,12 +499,12 @@ repKiSigD (L loc kisig) =
-------------------------
repDataDefn :: Core TH.Name
- -> Either (Core [TH.TyVarBndrQ])
+ -> Either (Core [(M TH.TyVarBndr)])
-- the repTyClD case
- (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
+ (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
-- the repDataFamInstD case
-> HsDataDefn GhcRn
- -> DsM (Core TH.DecQ)
+ -> MetaM (Core (M TH.Dec))
repDataDefn tc opts
(HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
, dd_cons = cons, dd_derivs = mb_derivs })
@@ -374,25 +515,25 @@ repDataDefn tc opts
; ksig' <- repMaybeLTy ksig
; repNewtype cxt1 tc opts ksig' con'
derivs1 }
- (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
+ (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:"
<+> pprQuotedList
(getConNames $ unLoc $ head cons))
(DataType, _) -> do { ksig' <- repMaybeLTy ksig
; consL <- mapM repC cons
- ; cons1 <- coreList conQTyConName consL
+ ; cons1 <- coreListM conTyConName consL
; repData cxt1 tc opts ksig' cons1
derivs1 }
}
repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec
-repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
+repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)]
-> LHsType GhcRn
- -> DsM (Core TH.DecQ)
+ -> MetaM (Core (M TH.Dec))
repSynDecl tc bndrs ty
= do { ty1 <- repLTy ty
; repTySyn tc bndrs ty1 }
-repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
, fdLName = tc
, fdTyVars = tvs
@@ -412,7 +553,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
notHandled "abstract closed type family" (ppr decl)
ClosedTypeFamily (Just eqns) ->
do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns
- ; eqns2 <- coreList tySynEqnQTyConName eqns1
+ ; eqns2 <- coreListM tySynEqnTyConName eqns1
; result <- repFamilyResultSig resultSig
; inj <- repInjectivityAnn injectivity
; repClosedFamilyD tc1 bndrs result inj eqns2 }
@@ -428,7 +569,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec
-- | Represent result signature of a type family
-repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
+repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
repFamilyResultSig (NoSig _) = repNoSig
repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki
; repKindSig ki' }
@@ -440,41 +581,40 @@ repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec
-- where the result signature can be either missing or a kind but never a named
-- result variable.
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
- -> DsM (Core (Maybe TH.KindQ))
+ -> MetaM (Core (Maybe (M TH.Kind)))
repFamilyResultSigToMaybeKind (NoSig _) =
- do { coreNothing kindQTyConName }
+ do { coreNothingM kindTyConName }
repFamilyResultSigToMaybeKind (KindSig _ ki) =
- do { ki' <- repLTy ki
- ; coreJust kindQTyConName ki' }
+ do { coreJustM kindTyConName =<< repLTy ki }
repFamilyResultSigToMaybeKind TyVarSig{} =
panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"
repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec
-- | Represent injectivity annotation of a type family
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
- -> DsM (Core (Maybe TH.InjectivityAnn))
+ -> MetaM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
do { coreNothing injAnnTyConName }
repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
do { lhs' <- lookupBinder (unLoc lhs)
; rhs1 <- mapM (lookupBinder . unLoc) rhs
; rhs2 <- coreList nameTyConName rhs1
- ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
+ ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]
; coreJust injAnnTyConName injAnn }
-repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
+repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
-repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)
+repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
repAssocTyFamDefaultD = repTyFamInstD
-------------------------
-- represent fundeps
--
-repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
+repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
repLFunDeps fds = repList funDepTyConName repLFunDep fds
-repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
+repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
repLFunDep (L _ (xs, ys))
= do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
ys' <- repList nameTyConName (lookupBinder . unLoc) ys
@@ -482,7 +622,7 @@ repLFunDep (L _ (xs, ys))
-- Represent instance declarations
--
-repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
= do { dec <- repTyFamInstD fi_decl
; return (loc, dec) }
@@ -494,7 +634,7 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
; return (loc, dec) }
repInstD (L _ (XInstDecl nec)) = noExtCon nec
-repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
+repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_datafam_insts = adts
@@ -516,7 +656,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; (ss, sigs_binds) <- rep_sigs_binds sigs binds
; ats1 <- mapM (repTyFamInstD . unLoc) ats
; adts1 <- mapM (repDataFamInstD . unLoc) adts
- ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)
+ ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
; rOver <- repOverlap (fmap unLoc overlap)
; decls2 <- repInst rOver cxt1 inst_ty1 decls1
; wrapGenSyms ss decls2 }
@@ -524,9 +664,9 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
repClsInstD (XClsInstDecl nec) = noExtCon nec
-repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
- , deriv_type = ty }))
+ , deriv_type = ty }))
= do { dec <- addSimpleTyVarBinds tvs $
do { cxt' <- repLContext cxt
; strat' <- repDerivStrategy strat
@@ -537,12 +677,12 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
(tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec
-repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
+repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
= do { eqn1 <- repTyFamEqn eqn
; repTySynInst eqn1 }
-repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
+repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
repTyFamEqn (HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_bndrs = mb_bndrs
@@ -553,7 +693,7 @@ repTyFamEqn (HsIB { hsib_ext = var_names
; let hs_tvs = HsQTvs { hsq_ext = var_names
, hsq_explicit = fromMaybe [] mb_bndrs }
; addTyClTyVarBinds hs_tvs $ \ _ ->
- do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+ do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName
repTyVarBndr
mb_bndrs
; tys1 <- case fixity of
@@ -564,13 +704,13 @@ repTyFamEqn (HsIB { hsib_ext = var_names
; repTyArgs (repTInfix t1' tc t2') args }
; rhs1 <- repLTy rhs
; repTySynEqn mb_bndrs1 tys1 rhs1 } }
- where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+ where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
checkTys tys@(HsValArg _:HsValArg _:_) = return tys
checkTys _ = panic "repTyFamEqn:checkTys"
repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec
repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec
-repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)
+repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
repTyArgs f [] = f
repTyArgs f (HsValArg ty : as) = do { f' <- f
; ty' <- repLTy ty
@@ -580,7 +720,7 @@ repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
; repTyArgs (repTappKind f' ki') as }
repTyArgs f (HsArgPar _ : as) = repTyArgs f as
-repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
+repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repDataFamInstD (DataFamInstDecl { dfid_eqn =
(HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name
@@ -592,7 +732,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
; let hs_tvs = HsQTvs { hsq_ext = var_names
, hsq_explicit = fromMaybe [] mb_bndrs }
; addTyClTyVarBinds hs_tvs $ \ _ ->
- do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+ do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName
repTyVarBndr
mb_bndrs
; tys1 <- case fixity of
@@ -603,7 +743,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
; repTyArgs (repTInfix t1' tc t2') args }
; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
- where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+ where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
checkTys tys@(HsValArg _: HsValArg _: _) = return tys
checkTys _ = panic "repDataFamInstD:checkTys"
@@ -612,9 +752,10 @@ repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))
repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))
= noExtCon nec
-repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
+repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec))
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
- , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
+ , fd_fi = CImport (L _ cc)
+ (L _ s) mch cis _ }))
= do MkC name' <- lookupLOcc name
MkC typ' <- repHsSigType typ
MkC cc' <- repCCallConv cc
@@ -643,19 +784,19 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)
repForD (L _ (XForeignDecl nec)) = noExtCon nec
-repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
-repCCallConv CCallConv = rep2 cCallName []
-repCCallConv StdCallConv = rep2 stdCallName []
-repCCallConv CApiConv = rep2 cApiCallName []
-repCCallConv PrimCallConv = rep2 primCallName []
-repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
+repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
+repCCallConv CCallConv = rep2_nw cCallName []
+repCCallConv StdCallConv = rep2_nw stdCallName []
+repCCallConv CApiConv = rep2_nw cApiCallName []
+repCCallConv PrimCallConv = rep2_nw primCallName []
+repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []
-repSafety :: Safety -> DsM (Core TH.Safety)
-repSafety PlayRisky = rep2 unsafeName []
-repSafety PlayInterruptible = rep2 interruptibleName []
-repSafety PlaySafe = rep2 safeName []
+repSafety :: Safety -> MetaM (Core TH.Safety)
+repSafety PlayRisky = rep2_nw unsafeName []
+repSafety PlayInterruptible = rep2_nw interruptibleName []
+repSafety PlaySafe = rep2_nw safeName []
-repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+repFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
@@ -669,7 +810,7 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
; mapM do_one names }
repFixD (L _ (XFixitySig nec)) = noExtCon nec
-repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
, rd_act = act
, rd_tyvs = ty_bndrs
@@ -680,11 +821,11 @@ repRuleD (L loc (HsRule { rd_name = n
do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
; ss <- mkGenSyms tm_bndr_names
; rule <- addBinds ss $
- do { ty_bndrs' <- case ty_bndrs of
- Nothing -> coreNothingList tyVarBndrQTyConName
- Just _ -> coreJustList tyVarBndrQTyConName
- ex_bndrs
- ; tm_bndrs' <- repList ruleBndrQTyConName
+ do { elt_ty <- wrapName tyVarBndrTyConName
+ ; ty_bndrs' <- return $ case ty_bndrs of
+ Nothing -> coreNothing' (mkListTy elt_ty)
+ Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
+ ; tm_bndrs' <- repListM ruleBndrTyConName
repRuleBndr
tm_bndrs
; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
@@ -707,7 +848,7 @@ ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))
= noExtCon nec
ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec
-repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
+repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
repRuleBndr (L _ (RuleBndr _ n))
= do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [n'] }
@@ -717,7 +858,7 @@ repRuleBndr (L _ (RuleBndrSig _ n sig))
; rep2 typedRuleVarName [n', ty'] }
repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec
-repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
= do { target <- repAnnProv ann_prov
; exp' <- repE exp
@@ -725,23 +866,23 @@ repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
; return (loc, dec) }
repAnnD (L _ (XAnnDecl nec)) = noExtCon nec
-repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
+repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget)
repAnnProv (ValueAnnProvenance (L _ n))
- = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level
- ; rep2 valueAnnotationName [ n' ] }
+ = do { MkC n' <- lift $ globalVar n -- ANNs are allowed only at top-level
+ ; rep2_nw valueAnnotationName [ n' ] }
repAnnProv (TypeAnnProvenance (L _ n))
- = do { MkC n' <- globalVar n
- ; rep2 typeAnnotationName [ n' ] }
+ = do { MkC n' <- lift $ globalVar n
+ ; rep2_nw typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
- = rep2 moduleAnnotationName []
+ = rep2_nw moduleAnnotationName []
-------------------------------------------------------
-- Constructors
-------------------------------------------------------
-repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
+repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
repC (L _ (ConDeclH98 { con_name = con
- , con_forall = L _ False
+ , con_forall = (L _ False)
, con_mb_cxt = Nothing
, con_args = args }))
= repDataCon con args
@@ -782,21 +923,21 @@ repC (L _ (ConDeclGADT { con_names = cons
repC (L _ (XConDecl nec)) = noExtCon nec
-repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
+repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
repMbContext Nothing = repContext []
repMbContext (Just (L _ cxt)) = repContext cxt
-repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
+repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))
repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName []
repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
-repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
+repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness))
repSrcStrictness SrcLazy = rep2 sourceLazyName []
repSrcStrictness SrcStrict = rep2 sourceStrictName []
repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
-repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
+repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
repBangTy ty = do
MkC u <- repSrcUnpackedness su'
MkC s <- repSrcStrictness ss'
@@ -812,25 +953,25 @@ repBangTy ty = do
-- Deriving clauses
-------------------------------------------------------
-repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
+repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])
repDerivs (L _ clauses)
- = repList derivClauseQTyConName repDerivClause clauses
+ = repListM derivClauseTyConName repDerivClause clauses
repDerivClause :: LHsDerivingClause GhcRn
- -> DsM (Core TH.DerivClauseQ)
+ -> MetaM (Core (M TH.DerivClause))
repDerivClause (L _ (HsDerivingClause
{ deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct }))
= do MkC dcs' <- repDerivStrategy dcs
- MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
+ MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
rep2 derivClauseName [dcs',dct']
where
- rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
+ rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
rep_deriv_ty ty = repLTy ty
repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec
rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
- -> DsM ([GenSymBind], [Core TH.DecQ])
+ -> MetaM ([GenSymBind], [Core (M TH.Dec)])
-- Represent signatures and methods in class/instance declarations.
-- See Note [Scoped type variables in class and instance declarations]
--
@@ -849,11 +990,11 @@ rep_sigs_binds sigs binds
-- Signatures in a class decl, or a group of bindings
-------------------------------------------------------
-rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))]
-- We silently ignore ones we don't recognise
rep_sigs = concatMapM rep_sig
-rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_sig (L loc (TypeSig _ nms ty))
= mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (L loc (PatSynSig _ nms ty))
@@ -874,7 +1015,7 @@ rep_sig (L loc (CompleteMatchSig _ _st cls mty))
rep_sig (L _ (XSig nec)) = noExtCon nec
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
- -> DsM (SrcSpan, Core TH.DecQ)
+ -> MetaM (SrcSpan, Core (M TH.Dec))
-- Don't create the implicit and explicit variables when desugaring signatures,
-- see Note [Scoped type variables in class and instance declarations].
-- and Note [Don't quantify implicit type variables in quotes]
@@ -884,7 +1025,7 @@ rep_ty_sig mk_sig loc sig_ty nm
= do { nm1 <- lookupLOcc nm
; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
- ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
+ ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv
explicit_tvs
-- NB: Don't pass any implicit type variables to repList above
@@ -900,7 +1041,7 @@ rep_ty_sig mk_sig loc sig_ty nm
rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
- -> DsM (SrcSpan, Core TH.DecQ)
+ -> MetaM (SrcSpan, Core (M TH.Dec))
-- represents a pattern synonym type signature;
-- see Note [Pattern synonym type signatures and Template Haskell] in Convert
--
@@ -913,8 +1054,8 @@ rep_patsyn_ty_sig loc sig_ty nm
= do { nm1 <- lookupLOcc nm
; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
- ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
- ; th_exis <- repList tyVarBndrQTyConName rep_in_scope_tv exis
+ ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs
+ ; th_exis <- repListM tyVarBndrTyConName rep_in_scope_tv exis
-- NB: Don't pass any implicit type variables to repList above
-- See Note [Don't quantify implicit type variables in quotes]
@@ -929,14 +1070,14 @@ rep_patsyn_ty_sig loc sig_ty nm
rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
- -> DsM (SrcSpan, Core TH.DecQ)
+ -> MetaM (SrcSpan, Core (M TH.Dec))
rep_wc_ty_sig mk_sig loc sig_ty nm
= rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
rep_inline :: Located Name
-> InlinePragma -- Never defaultInlinePragma
-> SrcSpan
- -> DsM [(SrcSpan, Core TH.DecQ)]
+ -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_inline nm ispec loc
= do { nm1 <- lookupLOcc nm
; inline <- repInline $ inl_inline ispec
@@ -948,7 +1089,7 @@ rep_inline nm ispec loc
rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
-> SrcSpan
- -> DsM [(SrcSpan, Core TH.DecQ)]
+ -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialise nm ty ispec loc
= do { nm1 <- lookupLOcc nm
; ty1 <- repHsSigType ty
@@ -964,23 +1105,23 @@ rep_specialise nm ty ispec loc
}
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
- -> DsM [(SrcSpan, Core TH.DecQ)]
+ -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialiseInst ty loc
= do { ty1 <- repHsSigType ty
; pragma <- repPragSpecInst ty1
; return [(loc, pragma)] }
-repInline :: InlineSpec -> DsM (Core TH.Inline)
+repInline :: InlineSpec -> MetaM (Core TH.Inline)
repInline NoInline = dataCon noInlineDataConName
repInline Inline = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline NoUserInline = notHandled "NOUSERINLINE" empty
-repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
+repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
-repPhases :: Activation -> DsM (Core TH.Phases)
+repPhases :: Activation -> MetaM (Core TH.Phases)
repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
; dataCon' beforePhaseDataConName [arg] }
repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
@@ -990,7 +1131,7 @@ repPhases _ = dataCon allPhasesDataConName
rep_complete_sig :: Located [Located Name]
-> Maybe (Located Name)
-> SrcSpan
- -> DsM [(SrcSpan, Core TH.DecQ)]
+ -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_complete_sig (L _ cls) mty loc
= do { mty' <- repMaybe nameTyConName lookupLOcc mty
; cls' <- repList nameTyConName lookupLOcc cls
@@ -1002,20 +1143,20 @@ rep_complete_sig (L _ cls) mty loc
-------------------------------------------------------
addSimpleTyVarBinds :: [Name] -- the binders to be added
- -> DsM (Core (TH.Q a)) -- action in the ext env
- -> DsM (Core (TH.Q a))
+ -> MetaM (Core (M a)) -- action in the ext env
+ -> MetaM (Core (M a))
addSimpleTyVarBinds names thing_inside
= do { fresh_names <- mkGenSyms names
; term <- addBinds fresh_names thing_inside
; wrapGenSyms fresh_names term }
addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added
- -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
- -> DsM (Core (TH.Q a))
+ -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env
+ -> MetaM (Core (M a))
addHsTyVarBinds exp_tvs thing_inside
= do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
; term <- addBinds fresh_exp_names $
- do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+ do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr
(exp_tvs `zip` fresh_exp_names)
; thing_inside kbs }
; wrapGenSyms fresh_exp_names term }
@@ -1023,8 +1164,8 @@ addHsTyVarBinds exp_tvs thing_inside
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
- -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
- -> DsM (Core (TH.Q a))
+ -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env
+ -> MetaM (Core (M a))
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
-- meta environment and gets the *new* names on Core-level as an argument
@@ -1037,8 +1178,8 @@ addTyVarBinds (HsQTvs { hsq_ext = imp_tvs
addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec
addTyClTyVarBinds :: LHsQTyVars GhcRn
- -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
- -> DsM (Core (TH.Q a))
+ -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))
+ -> MetaM (Core (M a))
-- Used for data/newtype declarations, and family instances,
-- so that the nested type variables work right
@@ -1047,26 +1188,26 @@ addTyClTyVarBinds :: LHsQTyVars GhcRn
-- The 'a' in the type instance is the one bound by the instance decl
addTyClTyVarBinds tvs m
= do { let tv_names = hsAllLTyVarNames tvs
- ; env <- dsGetMetaEnv
+ ; env <- lift $ dsGetMetaEnv
; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
-- Make fresh names for the ones that are not already in scope
-- This makes things work for family declarations
; term <- addBinds freshNames $
- do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+ do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr
(hsQTvExplicit tvs)
; m kbs }
; wrapGenSyms freshNames term }
where
- mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
+ mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))
mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv v }
-- Produce kinded binder constructors from the Haskell tyvar binders
--
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
- -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
+ -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr))
repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
@@ -1074,7 +1215,7 @@ repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec
-- | Represent a type variable binder
-repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
+repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))
repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )
= do { nm' <- lookupBinder nm
; repPlainTV nm' }
@@ -1086,14 +1227,14 @@ repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec
-- represent a type context
--
-repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
+repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt))
repLContext ctxt = repContext (unLoc ctxt)
-repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)
-repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
+repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt))
+repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
repCtxt preds
-repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
+repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
repHsSigType (HsIB { hsib_ext = implicit_tvs
, hsib_body = body })
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
@@ -1107,20 +1248,20 @@ repHsSigType (HsIB { hsib_ext = implicit_tvs
else repTForall th_explicit_tvs th_ctxt th_ty }
repHsSigType (XHsImplicitBndrs nec) = noExtCon nec
-repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
+repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))
repHsSigWcType (HsWC { hswc_body = sig1 })
= repHsSigType sig1
repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec
-- yield the representation of a list of types
-repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
+repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
repLTys tys = mapM repLTy tys
-- represent a type
-repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
+repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
repLTy ty = repTy (unLoc ty)
-repForall :: ForallVisFlag -> HsType GhcRn -> DsM (Core TH.TypeQ)
+repForall :: ForallVisFlag -> HsType GhcRn -> MetaM (Core (M TH.Type))
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall fvf ty
| (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
@@ -1132,7 +1273,7 @@ repForall fvf ty
ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...}
}
-repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
+repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty
repTy ty@(HsQualTy {}) = repForall ForallInvis ty
@@ -1204,7 +1345,7 @@ repTy (HsIParamTy _ n t) = do
repTy ty = notHandled "Exotic form of type" (ppr ty)
-repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
+repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
rep2 numTyLitName [iExpr]
repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
@@ -1213,20 +1354,22 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
-- | Represent a type wrapped in a Maybe
repMaybeLTy :: Maybe (LHsKind GhcRn)
- -> DsM (Core (Maybe TH.TypeQ))
-repMaybeLTy = repMaybe kindQTyConName repLTy
+ -> MetaM (Core (Maybe (M TH.Type)))
+repMaybeLTy m = do
+ k_ty <- wrapName kindTyConName
+ repMaybeT k_ty repLTy m
-repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
-repRole (L _ (Just Nominal)) = rep2 nominalRName []
-repRole (L _ (Just Representational)) = rep2 representationalRName []
-repRole (L _ (Just Phantom)) = rep2 phantomRName []
-repRole (L _ Nothing) = rep2 inferRName []
+repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)
+repRole (L _ (Just Nominal)) = rep2_nw nominalRName []
+repRole (L _ (Just Representational)) = rep2_nw representationalRName []
+repRole (L _ (Just Phantom)) = rep2_nw phantomRName []
+repRole (L _ Nothing) = rep2_nw inferRName []
-----------------------------------------------------------------------------
-- Splices
-----------------------------------------------------------------------------
-repSplice :: HsSplice GhcRn -> DsM (Core a)
+repSplice :: HsSplice GhcRn -> MetaM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know
repSplice (HsTypedSplice _ _ n _) = rep_splice n
@@ -1236,11 +1379,11 @@ repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e)
repSplice (XSplice nec) = noExtCon nec
-rep_splice :: Name -> DsM (Core a)
+rep_splice :: Name -> MetaM (Core a)
rep_splice splice_name
- = do { mb_val <- dsLookupMetaEnv splice_name
+ = do { mb_val <- lift $ dsLookupMetaEnv splice_name
; case mb_val of
- Just (DsSplice e) -> do { e' <- dsExpr e
+ Just (DsSplice e) -> do { e' <- lift $ dsExpr e
; return (MkC e') }
_ -> pprPanic "HsSplice" (ppr splice_name) }
-- Should not happen; statically checked
@@ -1249,23 +1392,23 @@ rep_splice splice_name
-- Expressions
-----------------------------------------------------------------------------
-repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])
-repLEs es = repList expQTyConName repLE es
+repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)])
+repLEs es = repListM expTyConName repLE es
-- FIXME: some of these panics should be converted into proper error messages
-- unless we can make sure that constructs, which are plainly not
-- supported in TH already lead to error messages at an earlier stage
-repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
-repLE (L loc e) = putSrcSpanDs loc (repE e)
+repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))
+repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e)
-repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
+repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))
repE (HsVar _ (L _ x)) =
- do { mb_val <- dsLookupMetaEnv x
+ do { mb_val <- lift $ dsLookupMetaEnv x
; case mb_val of
- Nothing -> do { str <- globalVar x
+ Nothing -> do { str <- lift $ globalVar x
; repVarOrCon x str }
Just (DsBound y) -> repVarOrCon x (coreVar y)
- Just (DsSplice e) -> do { e' <- dsExpr e
+ Just (DsSplice e) -> do { e' <- lift $ dsExpr e
; return (MkC e') } }
repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
repE (HsOverLabel _ _ s) = repOverLabel s
@@ -1282,7 +1425,7 @@ repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
= do { ms' <- mapM repMatchTup ms
- ; core_ms <- coreList matchQTyConName ms'
+ ; core_ms <- coreListM matchTyConName ms'
; repLamCase core_ms }
repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (HsAppType _ e t) = do { a <- repLE e
@@ -1304,7 +1447,7 @@ repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
- ; core_ms2 <- coreList matchQTyConName ms2
+ ; core_ms2 <- coreListM matchTyConName ms2
; repCaseE arg core_ms2 }
repE (HsIf _ _ x y z) = do
a <- repLE x
@@ -1342,15 +1485,15 @@ repE e@(HsDo _ ctxt (L _ sts))
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE (ExplicitTuple _ es boxity) =
- let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))
+ let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))
tupArgToCoreExp (L _ a)
- | Present _ e <- a = do { e' <- repLE e
- ; coreJust expQTyConName e' }
- | otherwise = coreNothing expQTyConName
+ | (Present _ e) <- a = do { e' <- repLE e
+ ; coreJustM expTyConName e' }
+ | otherwise = coreNothingM expTyConName
in do { args <- mapM tupArgToCoreExp es
- ; expQTy <- lookupType expQTyConName
- ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy]
+ ; expTy <- wrapName expTyConName
+ ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy]
listArg = coreList' maybeExpQTy args
; if isBoxed boxity
then repTup listArg
@@ -1407,7 +1550,7 @@ repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxiliary structures like Match, Clause, Stmt,
-repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
+repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))
repMatchTup (L _ (Match { m_pats = [p]
, m_grhss = GRHSs _ guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatBinders p)
@@ -1420,7 +1563,7 @@ repMatchTup (L _ (Match { m_pats = [p]
; wrapGenSyms (ss1++ss2) match }}}
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
-repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
+repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))
repClauseTup (L _ (Match { m_pats = ps
, m_grhss = GRHSs _ guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
@@ -1434,7 +1577,7 @@ repClauseTup (L _ (Match { m_pats = ps
repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
repClauseTup (L _ (XMatch nec)) = noExtCon nec
-repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
+repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body))
repGuards [L _ (GRHS _ [] e)]
= do {a <- repLE e; repNormal a }
repGuards other
@@ -1444,7 +1587,7 @@ repGuards other
; wrapGenSyms (concat xs) gd }
repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
- -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+ -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp))))
repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
= do { guarded <- repLNormalGE e1 e2
; return ([], guarded) }
@@ -1455,20 +1598,20 @@ repLGRHS (L _ (GRHS _ ss rhs))
; return (gs, guarded) }
repLGRHS (L _ (XGRHS nec)) = noExtCon nec
-repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
+repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
repFields (HsRecFields { rec_flds = flds })
- = repList fieldExpQTyConName rep_fld flds
+ = repListM fieldExpTyConName rep_fld flds
where
rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
- -> DsM (Core (TH.Q TH.FieldExp))
+ -> MetaM (Core (M TH.FieldExp))
rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
-repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
-repUpdFields = repList fieldExpQTyConName rep_fld
+repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp])
+repUpdFields = repListM fieldExpTyConName rep_fld
where
- rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
+ rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))
rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
; e <- repLE (hsRecFieldArg fld)
@@ -1503,10 +1646,10 @@ repUpdFields = repList fieldExpQTyConName rep_fld
-- The helper function repSts computes the translation of each sub expression
-- and a bunch of prefix bindings denoting the dynamic renaming.
-repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
repLSts stmts = repSts (map unLoc stmts)
-repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
repSts (BindStmt _ p e _ _ : ss) =
do { e2 <- repLE e
; ss1 <- mkGenSyms (collectPatBinders p)
@@ -1534,10 +1677,10 @@ repSts (ParStmt _ stmt_blocks _ _ : ss) =
; return (ss1++ss2, z : zs) }
where
rep_stmt_block :: ParStmtBlock GhcRn GhcRn
- -> DsM ([GenSymBind], Core [TH.StmtQ])
+ -> MetaM ([GenSymBind], Core [(M TH.Stmt)])
rep_stmt_block (ParStmtBlock _ stmts _ _) =
do { (ss1, zs) <- repSts (map unLoc stmts)
- ; zs1 <- coreList stmtQTyConName zs
+ ; zs1 <- coreListM stmtTyConName zs
; return (ss1, zs1) }
rep_stmt_block (XParStmtBlock nec) = noExtCon nec
repSts [LastStmt _ e _ _]
@@ -1563,14 +1706,14 @@ repSts other = notHandled "Exotic statement" (ppr other)
-- Bindings
-----------------------------------------------------------
-repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
+repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)])
repBinds (EmptyLocalBinds _)
- = do { core_list <- coreList decQTyConName []
+ = do { core_list <- coreListM decTyConName []
; return ([], core_list) }
repBinds (HsIPBinds _ (IPBinds _ decs))
= do { ips <- mapM rep_implicit_param_bind decs
- ; core_list <- coreList decQTyConName
+ ; core_list <- coreListM decTyConName
(de_loc (sort_by_loc ips))
; return ([], core_list)
}
@@ -1586,12 +1729,12 @@ repBinds (HsValBinds _ decs)
-- For hsScopedTvBinders see Note [Scoped type variables in bindings]
; ss <- mkGenSyms bndrs
; prs <- addBinds ss (rep_val_binds decs)
- ; core_list <- coreList decQTyConName
+ ; core_list <- coreListM decTyConName
(de_loc (sort_by_loc prs))
; return (ss, core_list) }
repBinds (XHsLocalBindsLR nec) = noExtCon nec
-rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
= do { name <- case ename of
Left (L _ n) -> rep_implicit_param_name n
@@ -1602,10 +1745,10 @@ rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
; return (loc, ipb) }
rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec
-rep_implicit_param_name :: HsIPName -> DsM (Core String)
+rep_implicit_param_name :: HsIPName -> MetaM (Core String)
rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
-rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-- Assumes: all the binders of the binding are already in the meta-env
rep_val_binds (XValBindsLR (NValBinds binds sigs))
= do { core1 <- rep_binds (unionManyBags (map snd binds))
@@ -1614,10 +1757,10 @@ rep_val_binds (XValBindsLR (NValBinds binds sigs))
rep_val_binds (ValBinds _ _ _)
= panic "rep_val_binds: ValBinds"
-rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_binds = mapM rep_bind . bagToList
-rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-- Assumes: all the binders of the binding are already in the meta-env
-- Note GHC treats declarations of a variable (not a pattern)
@@ -1662,7 +1805,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
; e2 <- repLE e
; x <- repNormal e2
; patcore <- repPvar v'
- ; empty_decls <- coreList decQTyConName []
+ ; empty_decls <- coreListM decTyConName []
; ans <- repVal patcore x empty_decls
; return (srcLocSpan (getSrcLoc v), ans) }
@@ -1681,7 +1824,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
; patSynD'' <- wrapGenArgSyms args ss patSynD'
; return (loc, patSynD'') }
where
- mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
+ mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind]
-- for Record Pattern Synonyms we want to conflate the selector
-- and the pattern-only names in order to provide a nicer TH
-- API. Whereas inside GHC, record pattern synonym selectors and
@@ -1701,7 +1844,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
, sel == sel' ]
wrapGenArgSyms :: HsPatSynDetails (Located Name)
- -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
+ -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
@@ -1709,14 +1852,14 @@ rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec
rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec
repPatSynD :: Core TH.Name
- -> Core TH.PatSynArgsQ
- -> Core TH.PatSynDirQ
- -> Core TH.PatQ
- -> DsM (Core TH.DecQ)
+ -> Core (M TH.PatSynArgs)
+ -> Core (M TH.PatSynDir)
+ -> Core (M TH.Pat)
+ -> MetaM (Core (M TH.Dec))
repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
= rep2 patSynDName [syn, args, dir, pat]
-repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
+repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs))
repPatSynArgs (PrefixCon args)
= do { args' <- repList nameTyConName lookupLOcc args
; repPrefixPatSynArgs args' }
@@ -1729,17 +1872,17 @@ repPatSynArgs (RecCon fields)
; repRecordPatSynArgs sels' }
where sels = map recordPatSynSelectorId fields
-repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
+repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs))
repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
-repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
+repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs))
repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
repRecordPatSynArgs :: Core [TH.Name]
- -> DsM (Core TH.PatSynArgsQ)
+ -> MetaM (Core (M TH.PatSynArgs))
repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
-repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
+repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir))
repPatSynDir Unidirectional = rep2 unidirPatSynName []
repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
@@ -1747,7 +1890,7 @@ repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec
-repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
+repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir))
repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
@@ -1775,10 +1918,10 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
-- (\ p1 .. pn -> exp) by causing an error.
-repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
+repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))
repLambda (L _ (Match { m_pats = ps
, m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
- (L _ (EmptyLocalBinds _)) } ))
+ (L _ (EmptyLocalBinds _)) } ))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
@@ -1799,13 +1942,13 @@ repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)
-- variable should already appear in the environment.
-- Process a list of patterns
-repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
-repLPs ps = repList patQTyConName repLP ps
+repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)])
+repLPs ps = repListM patTyConName repLP ps
-repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
+repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
repLP p = repP (unLoc p)
-repP :: Pat GhcRn -> DsM (Core TH.PatQ)
+repP :: Pat GhcRn -> MetaM (Core (M TH.Pat))
repP (WildPat _) = repPwild
repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' }
@@ -1827,14 +1970,14 @@ repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
- RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
+ RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
; repPrec con_str fps }
InfixCon p1 p2 -> do { p1' <- repLP p1;
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
where
- rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
+ rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))
rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
; MkC p <- repLP (hsRecFieldArg fld)
; rep2 fieldPatName [v,p] }
@@ -1870,7 +2013,7 @@ type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
-- Generate a fresh name for a locally bound entity
-mkGenSyms :: [Name] -> DsM [GenSymBind]
+mkGenSyms :: [Name] -> MetaM [GenSymBind]
-- We can use the existing name. For example:
-- [| \x_77 -> x_77 + x_77 |]
-- desugars to
@@ -1885,18 +2028,18 @@ mkGenSyms ns = do { var_ty <- lookupType nameTyConName
; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
-addBinds :: [GenSymBind] -> DsM a -> DsM a
+addBinds :: [GenSymBind] -> MetaM a -> MetaM a
-- Add a list of fresh names for locally bound entities to the
-- meta environment (which is part of the state carried around
-- by the desugarer monad)
-addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
+addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m
-- Look up a locally bound name
--
-lookupLBinder :: Located Name -> DsM (Core TH.Name)
+lookupLBinder :: Located Name -> MetaM (Core TH.Name)
lookupLBinder n = lookupBinder (unLoc n)
-lookupBinder :: Name -> DsM (Core TH.Name)
+lookupBinder :: Name -> MetaM (Core TH.Name)
lookupBinder = lookupOcc
-- Binders are brought into scope before the pattern or what-not is
-- desugared. Moreover, in instance declaration the binder of a method
@@ -1908,13 +2051,16 @@ lookupBinder = lookupOcc
-- * If it is a global name, generate the "original name" representation (ie,
-- the <module>:<name> form) for the associated entity
--
-lookupLOcc :: Located Name -> DsM (Core TH.Name)
+lookupLOcc :: Located Name -> MetaM (Core TH.Name)
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
lookupLOcc n = lookupOcc (unLoc n)
-lookupOcc :: Name -> DsM (Core TH.Name)
-lookupOcc n
+lookupOcc :: Name -> MetaM (Core TH.Name)
+lookupOcc = lift . lookupOccDsM
+
+lookupOccDsM :: Name -> DsM (Core TH.Name)
+lookupOccDsM n
= do { mb_val <- dsLookupMetaEnv n ;
case mb_val of
Nothing -> globalVar n
@@ -1932,11 +2078,11 @@ globalVar name
= do { MkC mod <- coreStringLit name_mod
; MkC pkg <- coreStringLit name_pkg
; MkC occ <- nameLit name
- ; rep2 mk_varg [pkg,mod,occ] }
+ ; rep2_nwDsM mk_varg [pkg,mod,occ] }
| otherwise
= do { MkC occ <- nameLit name
; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))
- ; rep2 mkNameLName [occ,uni] }
+ ; rep2_nwDsM mkNameLName [occ,uni] }
where
mod = ASSERT( isExternalName name) nameModule name
name_mod = moduleNameString (moduleName mod)
@@ -1947,13 +2093,13 @@ globalVar name
| OccName.isTcOcc name_occ = mkNameG_tcName
| otherwise = pprPanic "DsMeta.globalVar" (ppr name)
-lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
- -> DsM Type -- The type
-lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
+lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp))
+ -> MetaM Type -- The type
+lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ;
return (mkTyConApp tc []) }
wrapGenSyms :: [GenSymBind]
- -> Core (TH.Q a) -> DsM (Core (TH.Q a))
+ -> Core (M a) -> MetaM (Core (M a))
-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
-- --> bindQ (gensym nm1) (\ id1 ->
-- bindQ (gensym nm2 (\ id2 ->
@@ -1963,23 +2109,23 @@ wrapGenSyms binds body@(MkC b)
= do { var_ty <- lookupType nameTyConName
; go var_ty binds }
where
- [elt_ty] = tcTyConAppArgs (exprType b)
- -- b :: Q a, so we can get the type 'a' by looking at the
+ (_, [elt_ty]) = tcSplitAppTys (exprType b)
+ -- b :: m a, so we can get the type 'a' by looking at the
-- argument type. NB: this relies on Q being a data/newtype,
-- not a type synonym
go _ [] = return body
go var_ty ((name,id) : binds)
= do { MkC body' <- go var_ty binds
- ; lit_str <- nameLit name
+ ; lit_str <- lift $ nameLit name
; gensym_app <- repGensym lit_str
- ; repBindQ var_ty elt_ty
+ ; repBindM var_ty elt_ty
gensym_app (MkC (Lam id body')) }
nameLit :: Name -> DsM (Core String)
nameLit n = coreStringLit (occNameString (nameOccName n))
-occNameLit :: OccName -> DsM (Core String)
+occNameLit :: OccName -> MetaM (Core String)
occNameLit name = coreStringLit (occNameString name)
@@ -1997,15 +2143,35 @@ newtype Core a = MkC CoreExpr
unC :: Core a -> CoreExpr
unC (MkC x) = x
-rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
-rep2 n xs = do { id <- dsLookupGlobalId n
- ; return (MkC (foldl' App (Var id) xs)) }
-
-dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
-dataCon' n args = do { id <- dsLookupDataCon n
+type family NotM a where
+ NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type"))
+ NotM _other = (() :: Constraint)
+
+rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a))
+rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a))
+rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a)
+rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a)
+rep2 = rep2X lift (asks quoteWrapper)
+rep2M = rep2X lift (asks monadWrapper)
+rep2_nw n xs = lift (rep2_nwDsM n xs)
+rep2_nwDsM = rep2X id (return id)
+
+rep2X :: Monad m => (forall z . DsM z -> m z)
+ -> m (CoreExpr -> CoreExpr)
+ -> Name
+ -> [ CoreExpr ]
+ -> m (Core a)
+rep2X lift_dsm get_wrap n xs = do
+ { rep_id <- lift_dsm $ dsLookupGlobalId n
+ ; wrap <- get_wrap
+ ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) }
+
+
+dataCon' :: Name -> [CoreExpr] -> MetaM (Core a)
+dataCon' n args = do { id <- lift $ dsLookupDataCon n
; return $ MkC $ mkCoreConApps id args }
-dataCon :: Name -> DsM (Core a)
+dataCon :: Name -> MetaM (Core a)
dataCon n = dataCon' n []
@@ -2016,19 +2182,19 @@ dataCon n = dataCon' n []
-- %*********************************************************************
--------------- Patterns -----------------
-repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
+repPlit :: Core TH.Lit -> MetaM (Core (M TH.Pat))
repPlit (MkC l) = rep2 litPName [l]
-repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
+repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat))
repPvar (MkC s) = rep2 varPName [s]
-repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
repPtup (MkC ps) = rep2 tupPName [ps]
-repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
-repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
+repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat))
-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
repPunboxedSum (MkC p) alt arity
= do { dflags <- getDynFlags
@@ -2036,69 +2202,69 @@ repPunboxedSum (MkC p) alt arity
, mkIntExprInt dflags alt
, mkIntExprInt dflags arity ] }
-repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
-repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
+repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))
repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
-repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
-repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
repPtilde (MkC p) = rep2 tildePName [p]
-repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
repPbang (MkC p) = rep2 bangPName [p]
-repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
-repPwild :: DsM (Core TH.PatQ)
+repPwild :: MetaM (Core (M TH.Pat))
repPwild = rep2 wildPName []
-repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
repPlist (MkC ps) = rep2 listPName [ps]
-repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
-repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
--------------- Expressions -----------------
-repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
+repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
| otherwise = repVar str
-repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
repVar (MkC s) = rep2 varEName [s]
-repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
+repCon :: Core TH.Name -> MetaM (Core (M TH.Exp))
repCon (MkC s) = rep2 conEName [s]
-repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
+repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp))
repLit (MkC c) = rep2 litEName [c]
-repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repApp (MkC x) (MkC y) = rep2 appEName [x,y]
-repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
-repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
-repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
+repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
repLamCase (MkC ms) = rep2 lamCaseEName [ms]
-repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
repTup (MkC es) = rep2 tupEName [es]
-repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
+repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
-repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
+repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp))
-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
repUnboxedSum (MkC e) alt arity
= do { dflags <- getDynFlags
@@ -2106,133 +2272,133 @@ repUnboxedSum (MkC e) alt arity
, mkIntExprInt dflags alt
, mkIntExprInt dflags arity ] }
-repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
-repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
+repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp))
repMultiIf (MkC alts) = rep2 multiIfEName [alts]
-repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
-repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
+repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
repDoE (MkC ss) = rep2 doEName [ss]
-repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
repMDoE (MkC ss) = rep2 mdoEName [ss]
-repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
repComp (MkC ss) = rep2 compEName [ss]
-repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp))
repListExp (MkC es) = rep2 listEName [es]
-repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
-repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))
repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
-repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))
repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
-repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp))
repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
-repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
-repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
-repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
-repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
+repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp))
repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
------------ Right hand sides (guarded expressions) ----
-repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
+repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body))
repGuarded (MkC pairs) = rep2 guardedBName [pairs]
-repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
+repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body))
repNormal (MkC e) = rep2 normalBName [e]
------------ Guards ----
repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
- -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+ -> MetaM (Core (M (TH.Guard, TH.Exp)))
repLNormalGE g e = do g' <- repLE g
e' <- repLE e
repNormalGE g' e'
-repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
-repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
------------- Stmts -------------------
-repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
-repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
+repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt))
repLetSt (MkC ds) = rep2 letSName [ds]
-repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
repNoBindSt (MkC e) = rep2 noBindSName [e]
-repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
+repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt))
repParSt (MkC sss) = rep2 parSName [sss]
-repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
+repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt))
repRecSt (MkC ss) = rep2 recSName [ss]
-------------- Range (Arithmetic sequences) -----------
-repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repFrom (MkC x) = rep2 fromEName [x]
-repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
-repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
-repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
------------ Match and Clause Tuples -----------
-repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match))
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
-------------- Dec -----------------------------
-repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
-repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
+repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec))
repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
-repData :: Core TH.CxtQ -> Core TH.Name
- -> Either (Core [TH.TyVarBndrQ])
- (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
- -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
- -> DsM (Core TH.DecQ)
+repData :: Core (M TH.Cxt) -> Core TH.Name
+ -> Either (Core [(M TH.TyVarBndr)])
+ (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
+ -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]
+ -> MetaM (Core (M TH.Dec))
repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
(MkC derivs)
= rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
-repNewtype :: Core TH.CxtQ -> Core TH.Name
- -> Either (Core [TH.TyVarBndrQ])
- (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
- -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
- -> DsM (Core TH.DecQ)
+repNewtype :: Core (M TH.Cxt) -> Core TH.Name
+ -> Either (Core [(M TH.TyVarBndr)])
+ (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))
+ -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause]
+ -> MetaM (Core (M TH.Dec))
repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
@@ -2240,18 +2406,18 @@ repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
-repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
- -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)]
+ -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repTySyn (MkC nm) (MkC tvs) (MkC rhs)
= rep2 tySynDName [nm, tvs, rhs]
repInst :: Core (Maybe TH.Overlap) ->
- Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+ Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
[o, cxt, ty, ds]
repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
- -> DsM (Core (Maybe TH.DerivStrategyQ))
+ -> MetaM (Core (Maybe (M TH.DerivStrategy)))
repDerivStrategy mds =
case mds of
Nothing -> nothing
@@ -2264,22 +2430,22 @@ repDerivStrategy mds =
via_strat <- repViaStrategy ty'
just via_strat
where
- nothing = coreNothing derivStrategyQTyConName
- just = coreJust derivStrategyQTyConName
+ nothing = coreNothingM derivStrategyTyConName
+ just = coreJustM derivStrategyTyConName
-repStockStrategy :: DsM (Core TH.DerivStrategyQ)
+repStockStrategy :: MetaM (Core (M TH.DerivStrategy))
repStockStrategy = rep2 stockStrategyName []
-repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
+repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy))
repAnyclassStrategy = rep2 anyclassStrategyName []
-repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
+repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy))
repNewtypeStrategy = rep2 newtypeStrategyName []
-repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
+repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy))
repViaStrategy (MkC t) = rep2 viaStrategyName [t]
-repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
+repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap))
repOverlap mb =
case mb of
Nothing -> nothing
@@ -2295,97 +2461,97 @@ repOverlap mb =
just = coreJust overlapTyConName
-repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
- -> Core [TH.FunDep] -> Core [TH.DecQ]
- -> DsM (Core TH.DecQ)
+repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)]
+ -> Core [TH.FunDep] -> Core [(M TH.Dec)]
+ -> MetaM (Core (M TH.Dec))
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds]
-repDeriv :: Core (Maybe TH.DerivStrategyQ)
- -> Core TH.CxtQ -> Core TH.TypeQ
- -> DsM (Core TH.DecQ)
+repDeriv :: Core (Maybe (M TH.DerivStrategy))
+ -> Core (M TH.Cxt) -> Core (M TH.Type)
+ -> MetaM (Core (M TH.Dec))
repDeriv (MkC ds) (MkC cxt) (MkC ty)
= rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
- -> Core TH.Phases -> DsM (Core TH.DecQ)
+ -> Core TH.Phases -> MetaM (Core (M TH.Dec))
repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
= rep2 pragInlDName [nm, inline, rm, phases]
-repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
- -> DsM (Core TH.DecQ)
+repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
+ -> MetaM (Core (M TH.Dec))
repPragSpec (MkC nm) (MkC ty) (MkC phases)
= rep2 pragSpecDName [nm, ty, phases]
-repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
- -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline
+ -> Core TH.Phases -> MetaM (Core (M TH.Dec))
repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
= rep2 pragSpecInlDName [nm, ty, inline, phases]
-repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
+repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
-repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
+repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec))
repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
-repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
- -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
- -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)])
+ -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp)
+ -> Core TH.Phases -> MetaM (Core (M TH.Dec))
repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
= rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
-repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
-repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
+repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
repTySynInst (MkC eqn)
= rep2 tySynInstDName [eqn]
-repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
- -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
+repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)]
+ -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec))
repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
= rep2 dataFamilyDName [nm, tvs, kind]
repOpenFamilyD :: Core TH.Name
- -> Core [TH.TyVarBndrQ]
- -> Core TH.FamilyResultSigQ
+ -> Core [(M TH.TyVarBndr)]
+ -> Core (M TH.FamilyResultSig)
-> Core (Maybe TH.InjectivityAnn)
- -> DsM (Core TH.DecQ)
+ -> MetaM (Core (M TH.Dec))
repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
= rep2 openTypeFamilyDName [nm, tvs, result, inj]
repClosedFamilyD :: Core TH.Name
- -> Core [TH.TyVarBndrQ]
- -> Core TH.FamilyResultSigQ
+ -> Core [(M TH.TyVarBndr)]
+ -> Core (M TH.FamilyResultSig)
-> Core (Maybe TH.InjectivityAnn)
- -> Core [TH.TySynEqnQ]
- -> DsM (Core TH.DecQ)
+ -> Core [(M TH.TySynEqn)]
+ -> MetaM (Core (M TH.Dec))
repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
= rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
-repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
- Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) ->
+ Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn))
repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
= rep2 tySynEqnName [mb_bndrs, lhs, rhs]
-repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
+repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec))
repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
-repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
-repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys]
-repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
-repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
-repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
+repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
repCtxt (MkC tys) = rep2 cxtName [tys]
repDataCon :: Located Name
-> HsConDeclDetails GhcRn
- -> DsM (Core TH.ConQ)
+ -> MetaM (Core (M TH.Con))
repDataCon con details
= do con' <- lookupLOcc con -- See Note [Binders and occurrences]
repConstr details Nothing [con']
@@ -2393,7 +2559,7 @@ repDataCon con details
repGadtDataCons :: [Located Name]
-> HsConDeclDetails GhcRn
-> LHsType GhcRn
- -> DsM (Core TH.ConQ)
+ -> MetaM (Core (M TH.Con))
repGadtDataCons cons details res_ty
= do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
repConstr details (Just res_ty) cons'
@@ -2406,19 +2572,19 @@ repGadtDataCons cons details res_ty
repConstr :: HsConDeclDetails GhcRn
-> Maybe (LHsType GhcRn)
-> [Core TH.Name]
- -> DsM (Core TH.ConQ)
+ -> MetaM (Core (M TH.Con))
repConstr (PrefixCon ps) Nothing [con]
- = do arg_tys <- repList bangTypeQTyConName repBangTy ps
+ = do arg_tys <- repListM bangTypeTyConName repBangTy ps
rep2 normalCName [unC con, unC arg_tys]
repConstr (PrefixCon ps) (Just res_ty) cons
- = do arg_tys <- repList bangTypeQTyConName repBangTy ps
+ = do arg_tys <- repListM bangTypeTyConName repBangTy ps
res_ty' <- repLTy res_ty
rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
repConstr (RecCon ips) resTy cons
= do args <- concatMapM rep_ip (unLoc ips)
- arg_vtys <- coreList varBangTypeQTyConName args
+ arg_vtys <- coreListM varBangTypeTyConName args
case resTy of
Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
Just res_ty -> do
@@ -2429,7 +2595,7 @@ repConstr (RecCon ips) resTy cons
where
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
- rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
+ rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n)
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
@@ -2446,35 +2612,35 @@ repConstr _ _ _ =
------------ Types -------------------
-repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
- -> DsM (Core TH.TypeQ)
+repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type)
+ -> MetaM (Core (M TH.Type))
repTForall (MkC tvars) (MkC ctxt) (MkC ty)
= rep2 forallTName [tvars, ctxt, ty]
-repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ
- -> DsM (Core TH.TypeQ)
+repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type)
+ -> MetaM (Core (M TH.Type))
repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]
-repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
+repTvar :: Core TH.Name -> MetaM (Core (M TH.Type))
repTvar (MkC s) = rep2 varTName [s]
-repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
-repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
+repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
-repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
repTapps f [] = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
-repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
+repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
-repTequality :: DsM (Core TH.TypeQ)
+repTequality :: MetaM (Core (M TH.Type))
repTequality = rep2 equalityTName []
-repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
repTPromotedList [] = repPromotedNilTyCon
repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
; f <- repTapp tcon t
@@ -2482,95 +2648,95 @@ repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
; repTapp f t'
}
-repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
+repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type))
repTLit (MkC lit) = rep2 litTName [lit]
-repTWildCard :: DsM (Core TH.TypeQ)
+repTWildCard :: MetaM (Core (M TH.Type))
repTWildCard = rep2 wildCardTName []
-repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
-repTStar :: DsM (Core TH.TypeQ)
+repTStar :: MetaM (Core (M TH.Type))
repTStar = rep2 starKName []
-repTConstraint :: DsM (Core TH.TypeQ)
+repTConstraint :: MetaM (Core (M TH.Type))
repTConstraint = rep2 constraintKName []
--------- Type constructors --------------
-repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type))
repNamedTyCon (MkC s) = rep2 conTName [s]
-repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ
- -> DsM (Core TH.TypeQ)
+repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type)
+ -> MetaM (Core (M TH.Type))
repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
-repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+repTupleTyCon :: Int -> MetaM (Core (M TH.Type))
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = do dflags <- getDynFlags
rep2 tupleTName [mkIntExprInt dflags i]
-repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
-- Note: not Core Int; it's easier to be direct here
repUnboxedTupleTyCon i = do dflags <- getDynFlags
rep2 unboxedTupleTName [mkIntExprInt dflags i]
-repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
+repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))
-- Note: not Core TH.SumArity; it's easier to be direct here
repUnboxedSumTyCon arity = do dflags <- getDynFlags
rep2 unboxedSumTName [mkIntExprInt dflags arity]
-repArrowTyCon :: DsM (Core TH.TypeQ)
+repArrowTyCon :: MetaM (Core (M TH.Type))
repArrowTyCon = rep2 arrowTName []
-repListTyCon :: DsM (Core TH.TypeQ)
+repListTyCon :: MetaM (Core (M TH.Type))
repListTyCon = rep2 listTName []
-repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type))
repPromotedDataCon (MkC s) = rep2 promotedTName [s]
-repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
repPromotedTupleTyCon i = do dflags <- getDynFlags
rep2 promotedTupleTName [mkIntExprInt dflags i]
-repPromotedNilTyCon :: DsM (Core TH.TypeQ)
+repPromotedNilTyCon :: MetaM (Core (M TH.Type))
repPromotedNilTyCon = rep2 promotedNilTName []
-repPromotedConsTyCon :: DsM (Core TH.TypeQ)
+repPromotedConsTyCon :: MetaM (Core (M TH.Type))
repPromotedConsTyCon = rep2 promotedConsTName []
------------ TyVarBndrs -------------------
-repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
+repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr))
repPlainTV (MkC nm) = rep2 plainTVName [nm]
-repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
+repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr))
repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
----------------------------------------------------------
-- Type family result signature
-repNoSig :: DsM (Core TH.FamilyResultSigQ)
+repNoSig :: MetaM (Core (M TH.FamilyResultSig))
repNoSig = rep2 noSigName []
-repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
+repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig))
repKindSig (MkC ki) = rep2 kindSigName [ki]
-repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
+repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig))
repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
----------------------------------------------------------
-- Literals
-repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)
+repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
repLiteral (HsStringPrim _ bs)
= do dflags <- getDynFlags
word8_ty <- lookupType word8TyConName
let w8s = unpack bs
w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
[mkWordLit dflags (toInteger w8)]) w8s
- rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
+ rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
repLiteral lit
= do lit' <- case lit of
HsIntPrim _ i -> mk_integer i
@@ -2580,9 +2746,9 @@ repLiteral lit
HsDoublePrim _ r -> mk_rational r
HsCharPrim _ c -> mk_char c
_ -> return lit
- lit_expr <- dsLit lit'
+ lit_expr <- lift $ dsLit lit'
case mb_lit_name of
- Just lit_name -> rep2 lit_name [lit_expr]
+ Just lit_name -> rep2_nw lit_name [lit_expr]
Nothing -> notHandled "Exotic literal" (ppr lit)
where
mb_lit_name = case lit of
@@ -2598,20 +2764,20 @@ repLiteral lit
HsRat _ _ _ -> Just rationalLName
_ -> Nothing
-mk_integer :: Integer -> DsM (HsLit GhcRn)
+mk_integer :: Integer -> MetaM (HsLit GhcRn)
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger NoSourceText i integer_ty
-mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
+mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat noExtField r rat_ty
-mk_string :: FastString -> DsM (HsLit GhcRn)
+mk_string :: FastString -> MetaM (HsLit GhcRn)
mk_string s = return $ HsString NoSourceText s
-mk_char :: Char -> DsM (HsLit GhcRn)
+mk_char :: Char -> MetaM (HsLit GhcRn)
mk_char c = return $ HsChar NoSourceText c
-repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
+repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit)
repOverloadedLiteral (OverLit { ol_val = val})
= do { lit <- mk_lit val; repLiteral lit }
-- The type Rational will be in the environment, because
@@ -2619,32 +2785,32 @@ repOverloadedLiteral (OverLit { ol_val = val})
-- and rationalL is sucked in when any TH stuff is used
repOverloadedLiteral (XOverLit nec) = noExtCon nec
-mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
+mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)
mk_lit (HsIntegral i) = mk_integer (il_value i)
mk_lit (HsFractional f) = mk_rational f
mk_lit (HsIsString _ s) = mk_string s
-repNameS :: Core String -> DsM (Core TH.Name)
-repNameS (MkC name) = rep2 mkNameSName [name]
+repNameS :: Core String -> MetaM (Core TH.Name)
+repNameS (MkC name) = rep2_nw mkNameSName [name]
--------------- Miscellaneous -------------------
-repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
+repGensym :: Core String -> MetaM (Core (M TH.Name))
repGensym (MkC lit_str) = rep2 newNameName [lit_str]
-repBindQ :: Type -> Type -- a and b
- -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
-repBindQ ty_a ty_b (MkC x) (MkC y)
- = rep2 bindQName [Type ty_a, Type ty_b, x, y]
+repBindM :: Type -> Type -- a and b
+ -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b))
+repBindM ty_a ty_b (MkC x) (MkC y)
+ = rep2M bindMName [Type ty_a, Type ty_b, x, y]
-repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
-repSequenceQ ty_a (MkC list)
- = rep2 sequenceQName [Type ty_a, list]
+repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a]))
+repSequenceM ty_a (MkC list)
+ = rep2M sequenceQName [Type ty_a, list]
-repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
repUnboundVar (MkC name) = rep2 unboundVarEName [name]
-repOverLabel :: FastString -> DsM (Core TH.ExpQ)
+repOverLabel :: FastString -> MetaM (Core (M TH.Exp))
repOverLabel fs = do
(MkC s) <- coreStringLit $ unpackFS fs
rep2 labelEName [s]
@@ -2653,14 +2819,25 @@ repOverLabel fs = do
------------ Lists -------------------
-- turn a list of patterns into a single pattern matching a list
-repList :: Name -> (a -> DsM (Core b))
- -> [a] -> DsM (Core [b])
+repList :: Name -> (a -> MetaM (Core b))
+ -> [a] -> MetaM (Core [b])
repList tc_name f args
= do { args1 <- mapM f args
; coreList tc_name args1 }
+-- Create a list of m a values
+repListM :: Name -> (a -> MetaM (Core b))
+ -> [a] -> MetaM (Core [b])
+repListM tc_name f args
+ = do { ty <- wrapName tc_name
+ ; args1 <- mapM f args
+ ; return $ coreList' ty args1 }
+
+coreListM :: Name -> [Core a] -> MetaM (Core [a])
+coreListM tc as = repListM tc return as
+
coreList :: Name -- Of the TyCon of the element type
- -> [Core a] -> DsM (Core [a])
+ -> [Core a] -> MetaM (Core [a])
coreList tc_name es
= do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
@@ -2674,22 +2851,33 @@ nonEmptyCoreList :: [Core a] -> Core [a]
nonEmptyCoreList [] = panic "coreList: empty argument"
nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
-coreStringLit :: String -> DsM (Core String)
+
+coreStringLit :: MonadThings m => String -> m (Core String)
coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------------- Maybe ------------------
-repMaybe :: Name -> (a -> DsM (Core b))
- -> Maybe a -> DsM (Core (Maybe b))
-repMaybe tc_name _ Nothing = coreNothing tc_name
-repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
+repMaybe :: Name -> (a -> MetaM (Core b))
+ -> Maybe a -> MetaM (Core (Maybe b))
+repMaybe tc_name f m = do
+ t <- lookupType tc_name
+ repMaybeT t f m
+
+repMaybeT :: Type -> (a -> MetaM (Core b))
+ -> Maybe a -> MetaM (Core (Maybe b))
+repMaybeT ty _ Nothing = return $ coreNothing' ty
+repMaybeT ty f (Just es) = coreJust' ty <$> f es
-- | Construct Core expression for Nothing of a given type name
coreNothing :: Name -- ^ Name of the TyCon of the element type
- -> DsM (Core (Maybe a))
+ -> MetaM (Core (Maybe a))
coreNothing tc_name =
do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
+coreNothingM :: Name -> MetaM (Core (Maybe a))
+coreNothingM tc_name =
+ do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) }
+
-- | Construct Core expression for Nothing of a given type
coreNothing' :: Type -- ^ The element type
-> Core (Maybe a)
@@ -2697,10 +2885,13 @@ coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
-- | Store given Core expression in a Just of a given type name
coreJust :: Name -- ^ Name of the TyCon of the element type
- -> Core a -> DsM (Core (Maybe a))
+ -> Core a -> MetaM (Core (Maybe a))
coreJust tc_name es
= do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
+coreJustM :: Name -> Core a -> MetaM (Core (Maybe a))
+coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) }
+
-- | Store given Core expression in a Just of a given type
coreJust' :: Type -- ^ The element type
-> Core a -> Core (Maybe a)
@@ -2708,46 +2899,46 @@ coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
------------------- Maybe Lists ------------------
-repMaybeList :: Name -> (a -> DsM (Core b))
- -> Maybe [a] -> DsM (Core (Maybe [b]))
-repMaybeList tc_name _ Nothing = coreNothingList tc_name
-repMaybeList tc_name f (Just args)
- = do { elt_ty <- lookupType tc_name
- ; args1 <- mapM f args
- ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
+-- Lookup the name and wrap it with the m variable
+repMaybeListM :: Name -> (a -> MetaM (Core b))
+ -> Maybe [a] -> MetaM (Core (Maybe [b]))
+repMaybeListM tc_name f xs = do
+ elt_ty <- wrapName tc_name
+ repMaybeListT elt_ty f xs
+
-coreNothingList :: Name -> DsM (Core (Maybe [a]))
-coreNothingList tc_name
- = do { elt_ty <- lookupType tc_name
- ; return $ coreNothing' (mkListTy elt_ty) }
+repMaybeListT :: Type -> (a -> MetaM (Core b))
+ -> Maybe [a] -> MetaM (Core (Maybe [b]))
+repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty
+repMaybeListT elt_ty f (Just args)
+ = do { args1 <- mapM f args
+ ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
-coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
-coreJustList tc_name args
- = do { elt_ty <- lookupType tc_name
- ; return $ coreJust' (mkListTy elt_ty) args }
+coreNothingList :: Type -> MetaM (Core (Maybe [a]))
+coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty)
------------ Literals & Variables -------------------
-coreIntLit :: Int -> DsM (Core Int)
+coreIntLit :: Int -> MetaM (Core Int)
coreIntLit i = do dflags <- getDynFlags
return (MkC (mkIntExprInt dflags i))
-coreIntegerLit :: Integer -> DsM (Core Integer)
+coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)
coreIntegerLit i = fmap MkC (mkIntegerExpr i)
coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
----------------- Failure -----------------------
-notHandledL :: SrcSpan -> String -> SDoc -> DsM a
+notHandledL :: SrcSpan -> String -> SDoc -> MetaM a
notHandledL loc what doc
| isGoodSrcSpan loc
- = putSrcSpanDs loc $ notHandled what doc
+ = mapReaderT (putSrcSpanDs loc) $ notHandled what doc
| otherwise
= notHandled what doc
-notHandled :: String -> SDoc -> DsM a
-notHandled what doc = failWithDs msg
+notHandled :: String -> SDoc -> MetaM a
+notHandled what doc = lift $ failWithDs msg
where
msg = hang (text what <+> text "not (yet) handled by Template Haskell")
2 doc
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 6355c5dc95..ed54987b85 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -224,6 +224,8 @@ import System.FilePath
import Control.Concurrent
import System.Process ( ProcessHandle )
import Control.DeepSeq
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class
-- -----------------------------------------------------------------------------
-- Compilation state
@@ -2324,6 +2326,10 @@ class Monad m => MonadThings m where
lookupTyCon :: Name -> m TyCon
lookupTyCon = liftM tyThingTyCon . lookupThing
+-- Instance used in DsMeta
+instance MonadThings m => MonadThings (ReaderT s m) where
+ lookupThing = lift . lookupThing
+
{-
************************************************************************
* *
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 0eedeeee9c..0da1c5200a 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -146,18 +146,18 @@ templateHaskellNames = [
derivClauseName,
-- The type classes
- liftClassName,
+ liftClassName, quoteClassName,
-- And the tycons
- qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
- clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
- stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
- varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
- typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
- patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
- predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
- roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
- overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
+ qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName,
+ expQTyConName, fieldExpTyConName, predTyConName,
+ stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName,
+ varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,
+ typeTyConName, tyVarBndrTyConName, clauseTyConName,
+ patQTyConName, funDepTyConName, decsQTyConName,
+ ruleBndrTyConName, tySynEqnTyConName,
+ roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
+ overlapTyConName, derivClauseTyConName, derivStrategyTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -183,10 +183,13 @@ qqFun = mk_known_key_name OccName.varName qqLib
liftClassName :: Name
liftClassName = thCls (fsLit "Lift") liftClassKey
+quoteClassName :: Name
+quoteClassName = thCls (fsLit "Quote") quoteClassKey
+
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
- tExpTyConName, injAnnTyConName, overlapTyConName :: Name
+ tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
@@ -194,6 +197,7 @@ patTyConName = thTc (fsLit "Pat") patTyConKey
fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
expTyConName = thTc (fsLit "Exp") expTyConKey
decTyConName = thTc (fsLit "Dec") decTyConKey
+decsTyConName = libTc (fsLit "Decs") decsTyConKey
typeTyConName = thTc (fsLit "Type") typeTyConKey
matchTyConName = thTc (fsLit "Match") matchTyConKey
clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
@@ -546,34 +550,30 @@ anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey
viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey
-matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
- decQTyConName, conQTyConName, bangTypeQTyConName,
- varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
- patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
- ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
- derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,
- derivStrategyQTyConName :: Name
-matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
-clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
+patQTyConName, expQTyConName, stmtTyConName,
+ conTyConName, bangTypeTyConName,
+ varBangTypeTyConName, typeQTyConName,
+ decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,
+ derivClauseTyConName, kindTyConName, tyVarBndrTyConName,
+ derivStrategyTyConName :: Name
+-- These are only used for the types of top-level splices
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
-stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
-decQTyConName = libTc (fsLit "DecQ") decQTyConKey
decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
-conQTyConName = libTc (fsLit "ConQ") conQTyConKey
-bangTypeQTyConName = libTc (fsLit "BangTypeQ") bangTypeQTyConKey
-varBangTypeQTyConName = libTc (fsLit "VarBangTypeQ") varBangTypeQTyConKey
typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
-fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc (fsLit "PatQ") patQTyConKey
-fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
-predQTyConName = libTc (fsLit "PredQ") predQTyConKey
-ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
-tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
+
+-- These are used in DsMeta but always wrapped in a type variable
+stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey
+conTyConName = thTc (fsLit "Con") conTyConKey
+bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey
+varBangTypeTyConName = thTc (fsLit "VarBangType") varBangTypeTyConKey
+ruleBndrTyConName = thTc (fsLit "RuleBndr") ruleBndrTyConKey
+tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey
roleTyConName = libTc (fsLit "Role") roleTyConKey
-derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey
-kindQTyConName = libTc (fsLit "KindQ") kindQTyConKey
-tyVarBndrQTyConName = libTc (fsLit "TyVarBndrQ") tyVarBndrQTyConKey
-derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey
+derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey
+kindTyConName = thTc (fsLit "Kind") kindTyConKey
+tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
+derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey
-- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -621,6 +621,9 @@ incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
liftClassKey :: Unique
liftClassKey = mkPreludeClassUnique 200
+quoteClassKey :: Unique
+quoteClassKey = mkPreludeClassUnique 201
+
{- *********************************************************************
* *
TyCon keys
@@ -631,50 +634,47 @@ liftClassKey = mkPreludeClassUnique 200
-- Check in PrelNames if you want to change this
expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
- decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
- stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
- tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
+ patTyConKey,
+ stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,
+ tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
- fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
- predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
- roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
- overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique
+ funDepTyConKey, predTyConKey,
+ predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,
+ roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
+ overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey
+ :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
qTyConKey = mkPreludeTyConUnique 203
expQTyConKey = mkPreludeTyConUnique 204
-decQTyConKey = mkPreludeTyConUnique 205
patTyConKey = mkPreludeTyConUnique 206
-matchQTyConKey = mkPreludeTyConUnique 207
-clauseQTyConKey = mkPreludeTyConUnique 208
-stmtQTyConKey = mkPreludeTyConUnique 209
-conQTyConKey = mkPreludeTyConUnique 210
+stmtTyConKey = mkPreludeTyConUnique 209
+conTyConKey = mkPreludeTyConUnique 210
typeQTyConKey = mkPreludeTyConUnique 211
typeTyConKey = mkPreludeTyConUnique 212
decTyConKey = mkPreludeTyConUnique 213
-bangTypeQTyConKey = mkPreludeTyConUnique 214
-varBangTypeQTyConKey = mkPreludeTyConUnique 215
+bangTypeTyConKey = mkPreludeTyConUnique 214
+varBangTypeTyConKey = mkPreludeTyConUnique 215
fieldExpTyConKey = mkPreludeTyConUnique 216
fieldPatTyConKey = mkPreludeTyConUnique 217
nameTyConKey = mkPreludeTyConUnique 218
patQTyConKey = mkPreludeTyConUnique 219
-fieldPatQTyConKey = mkPreludeTyConUnique 220
-fieldExpQTyConKey = mkPreludeTyConUnique 221
funDepTyConKey = mkPreludeTyConUnique 222
predTyConKey = mkPreludeTyConUnique 223
predQTyConKey = mkPreludeTyConUnique 224
-tyVarBndrQTyConKey = mkPreludeTyConUnique 225
+tyVarBndrTyConKey = mkPreludeTyConUnique 225
decsQTyConKey = mkPreludeTyConUnique 226
-ruleBndrQTyConKey = mkPreludeTyConUnique 227
-tySynEqnQTyConKey = mkPreludeTyConUnique 228
+ruleBndrTyConKey = mkPreludeTyConUnique 227
+tySynEqnTyConKey = mkPreludeTyConUnique 228
roleTyConKey = mkPreludeTyConUnique 229
tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231
-kindQTyConKey = mkPreludeTyConUnique 232
+kindTyConKey = mkPreludeTyConUnique 232
overlapTyConKey = mkPreludeTyConUnique 233
-derivClauseQTyConKey = mkPreludeTyConUnique 234
-derivStrategyQTyConKey = mkPreludeTyConUnique 235
+derivClauseTyConKey = mkPreludeTyConUnique 234
+derivStrategyTyConKey = mkPreludeTyConUnique 235
+decsTyConKey = mkPreludeTyConUnique 236
{- *********************************************************************
* *
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 4e6e367b48..5198ad6b0c 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -830,7 +830,7 @@ tcMetaTy :: Name -> TcM Type
-- E.g. given the name "Expr" return the type "Expr"
tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
- return (mkTyConApp t [])
+ return (mkTyConTy t)
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = True
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 77ea45b3d5..557ca5e2fe 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -4,14 +4,14 @@
module TcEvidence (
- -- HsWrapper
+ -- * HsWrapper
HsWrapper(..),
(<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,
mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders,
mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper,
pprHsWrapper,
- -- Evidence bindings
+ -- * Evidence bindings
TcEvBinds(..), EvBindsVar(..),
EvBindMap(..), emptyEvBindMap, extendEvBinds,
lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
@@ -19,7 +19,7 @@ module TcEvidence (
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
evBindVar, isCoEvBindsVar,
- -- EvTerm (already a CoreExpr)
+ -- * EvTerm (already a CoreExpr)
EvTerm(..), EvExpr,
evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
@@ -28,7 +28,7 @@ module TcEvidence (
EvCallStack(..),
EvTypeable(..),
- -- TcCoercion
+ -- * TcCoercion
TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,
TcMCoercion,
Role(..), LeftOrRight(..), pickLR,
@@ -45,7 +45,10 @@ module TcEvidence (
mkTcCoVarCo,
isTcReflCo, isTcReflexiveCo, isTcGReflMCo, tcCoToMCo,
tcCoercionRole,
- unwrapIP, wrapIP
+ unwrapIP, wrapIP,
+
+ -- * QuoteWrapper
+ QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy
) where
#include "HsVersions.h"
@@ -1002,3 +1005,25 @@ unwrapIP ty =
-- dictionary. See 'unwrapIP'.
wrapIP :: Type -> CoercionR
wrapIP ty = mkSymCo (unwrapIP ty)
+
+----------------------------------------------------------------------
+-- A datatype used to pass information when desugaring quotations
+----------------------------------------------------------------------
+
+-- We have to pass a `EvVar` and `Type` into `dsBracket` so that the
+-- correct evidence and types are applied to all the TH combinators.
+-- This data type bundles them up together with some convenience methods.
+--
+-- The EvVar is evidence for `Quote m`
+-- The Type is a metavariable for `m`
+--
+data QuoteWrapper = QuoteWrapper EvVar Type deriving Data.Data
+
+quoteWrapperTyVarTy :: QuoteWrapper -> Type
+quoteWrapperTyVarTy (QuoteWrapper _ t) = t
+
+-- | Convert the QuoteWrapper into a normal HsWrapper which can be used to
+-- apply its contents.
+applyQuoteWrapper :: QuoteWrapper -> HsWrapper
+applyQuoteWrapper (QuoteWrapper ev_var m_var)
+ = mkWpEvVarApps [ev_var] <.> mkWpTyApps [m_var]
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 8f4f7beb54..6fb3af4839 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1978,7 +1978,7 @@ checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
-- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but
-- this code is applied to *typed* brackets.
-checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
+checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
| isTopLevel top_lvl
= when (isExternalName id_name) (keepAlive id_name)
-- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice
@@ -2015,7 +2015,8 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
-- Update the pending splices
; ps <- readMutVar ps_var
; let pending_splice = PendingTcSplice id_name
- (nlHsApp (noLoc lift) (nlHsVar id))
+ (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift))
+ (nlHsVar id))
; writeMutVar ps_var (pending_splice : ps)
; return () }
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 13a3d179b4..8b5ee9c0bd 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -798,12 +798,18 @@ zonkExpr env (HsAppType x e t)
zonkExpr _ e@(HsRnBracketOut _ _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
-zonkExpr env (HsTcBracketOut x body bs)
- = do bs' <- mapM zonk_b bs
- return (HsTcBracketOut x body bs')
+zonkExpr env (HsTcBracketOut x wrap body bs)
+ = do wrap' <- traverse zonkQuoteWrap wrap
+ bs' <- mapM (zonk_b env) bs
+ return (HsTcBracketOut x wrap' body bs')
where
- zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
- return (PendingTcSplice n e')
+ zonkQuoteWrap (QuoteWrapper ev ty) = do
+ let ev' = zonkIdOcc env ev
+ ty' <- zonkTcTypeToTypeX env ty
+ return (QuoteWrapper ev' ty')
+
+ zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
+ return (PendingTcSplice n e')
zonkExpr env (HsSpliceE _ (HsSplicedT s)) =
runTopSplice s >>= zonkExpr env
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 0ac553c0ea..49833ac773 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -17,6 +17,7 @@ module TcMType (
--------------------------------
-- Creating new mutable type variables
newFlexiTyVar,
+ newNamedFlexiTyVar,
newFlexiTyVarTy, -- Kind -> TcM TcType
newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType]
newOpenFlexiTyVarTy, newOpenTypeKind,
@@ -730,15 +731,22 @@ And there no reason /not/ to clone the Name when making a
unification variable. So that's what we do.
-}
+metaInfoToTyVarName :: MetaInfo -> FastString
+metaInfoToTyVarName meta_info =
+ case meta_info of
+ TauTv -> fsLit "t"
+ FlatMetaTv -> fsLit "fmv"
+ FlatSkolTv -> fsLit "fsk"
+ TyVarTv -> fsLit "a"
+
newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
+newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi
+
+newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
-newAnonMetaTyVar meta_info kind
- = do { let s = case meta_info of
- TauTv -> fsLit "t"
- FlatMetaTv -> fsLit "fmv"
- FlatSkolTv -> fsLit "fsk"
- TyVarTv -> fsLit "a"
- ; name <- newMetaTyVarName s
+newNamedAnonMetaTyVar tyvar_name meta_info kind
+
+ = do { name <- newMetaTyVarName tyvar_name
; details <- newMetaDetails meta_info
; let tyvar = mkTcTyVar name kind details
; traceTc "newAnonMetaTyVar" (ppr tyvar)
@@ -963,6 +971,10 @@ that can't ever appear in user code, so we're safe!
newFlexiTyVar :: Kind -> TcM TcTyVar
newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
+-- | Create a new flexi ty var with a specific name
+newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar
+newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind
+
newFlexiTyVarTy :: Kind -> TcM TcType
newFlexiTyVarTy kind = do
tc_tyvar <- newFlexiTyVar kind
diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs
index c3af30e615..0ad9a6cc51 100644
--- a/compiler/typecheck/TcOrigin.hs
+++ b/compiler/typecheck/TcOrigin.hs
@@ -430,6 +430,7 @@ data CtOrigin
| HoleOrigin
| UnboundOccurrenceOf OccName
| ListOrigin -- An overloaded list
+ | BracketOrigin -- An overloaded quotation bracket
| StaticOrigin -- A static form
| FailablePattern (LPat GhcTcId) -- A failable pattern in do-notation for the
-- MonadFail Proposal (MFP). Obsolete when
@@ -655,4 +656,5 @@ pprCtO AnnOrigin = text "an annotation"
pprCtO HoleOrigin = text "a use of" <+> quotes (text "_")
pprCtO ListOrigin = text "an overloaded list"
pprCtO StaticOrigin = text "a static form"
+pprCtO BracketOrigin = text "a quotation bracket"
pprCtO _ = panic "pprCtOrigin"
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 25b0ad5f36..20f6133206 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -948,6 +948,13 @@ data PendingStuff
| TcPending -- Typechecking the inside of a typed bracket
(TcRef [PendingTcSplice]) -- Accumulate pending splices here
(TcRef WantedConstraints) -- and type constraints here
+ QuoteWrapper -- A type variable and evidence variable
+ -- for the overall monad of
+ -- the bracket. Splices are checked
+ -- against this monad. The evidence
+ -- variable is used for desugaring
+ -- `lift`.
+
topStage, topAnnStage, topSpliceStage :: ThStage
topStage = Comp
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 0351864199..051c87da44 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -15,6 +15,7 @@ TcSplice: Template Haskell splices
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TcSplice(
@@ -93,7 +94,7 @@ import CoAxiom
import PatSyn
import ConLike
import DataCon
-import TcEvidence( TcEvBinds(..) )
+import TcEvidence
import Id
import IdInfo
import DsExpr
@@ -172,68 +173,132 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
-- should get thrown into the constraint set
-- from outside the bracket
+ -- Make a new type variable for the type of the overall quote
+ ; m_var <- mkTyVarTy <$> mkMetaTyVar
+ -- Make sure the type variable satisfies Quote
+ ; ev_var <- emitQuoteWanted m_var
+ -- Bundle them together so they can be used in DsMeta for desugaring
+ -- brackets.
+ ; let wrapper = QuoteWrapper ev_var m_var
-- Typecheck expr to make sure it is valid,
-- Throw away the typechecked expression but return its type.
-- We'll typecheck it again when we splice it in somewhere
- ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
+ ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
tcInferRhoNC expr
-- NC for no context; tcBracket does that
; let rep = getRuntimeRep expr_ty
-
- ; meta_ty <- tcTExpTy expr_ty
+ ; meta_ty <- tcTExpTy m_var expr_ty
; ps' <- readMutVar ps_ref
; texpco <- tcLookupId unsafeTExpCoerceName
; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
rn_expr
- (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])
- (noLoc (HsTcBracketOut noExtField brack ps'))))
+ (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
+ (nlHsTyApp texpco [rep, expr_ty]))
+ (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps'))))
meta_ty res_ty }
tcTypedBracket _ other_brack _
= pprPanic "tcTypedBracket" (ppr other_brack)
-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
+-- See Note [Typechecking Overloaded Quotes]
tcUntypedBracket rn_expr brack ps res_ty
= do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
- ; ps' <- mapM tcPendingSplice ps
- ; meta_ty <- tcBrackTy brack
- ; traceTc "tc_bracket done untyped" (ppr meta_ty)
- ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
- rn_expr (HsTcBracketOut noExtField brack ps') meta_ty res_ty }
+
+
+ -- Create the type m Exp for expression bracket, m Type for a type
+ -- bracket and so on. The brack_info is a Maybe because the
+ -- VarBracket ('a) isn't overloaded, but also shouldn't contain any
+ -- splices.
+ ; (brack_info, expected_type) <- brackTy brack
+
+ -- Match the expected type with the type of all the internal
+ -- splices. They might have further constrained types and if they do
+ -- we want to reflect that in the overall type of the bracket.
+ ; ps' <- case quoteWrapperTyVarTy <$> brack_info of
+ Just m_var -> mapM (tcPendingSplice m_var) ps
+ Nothing -> ASSERT(null ps) return []
+
+ ; traceTc "tc_bracket done untyped" (ppr expected_type)
+
+ -- Unify the overall type of the bracket with the expected result
+ -- type
+ ; tcWrapResultO BracketOrigin rn_expr
+ (HsTcBracketOut noExtField brack_info brack ps')
+ expected_type res_ty
+
+ }
+
+-- | A type variable with kind * -> * named "m"
+mkMetaTyVar :: TcM TyVar
+mkMetaTyVar =
+ newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind)
+
+
+-- | For a type 'm', emit the constraint 'Quote m'.
+emitQuoteWanted :: Type -> TcM EvVar
+emitQuoteWanted m_var = do
+ quote_con <- tcLookupTyCon quoteClassName
+ emitWantedEvVar BracketOrigin $
+ mkTyConApp quote_con [m_var]
---------------
-tcBrackTy :: HsBracket GhcRn -> TcM TcType
-tcBrackTy (VarBr {}) = tcMetaTy nameTyConName
- -- Result type is Var (not Q-monadic)
-tcBrackTy (ExpBr {}) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
-tcBrackTy (TypBr {}) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
-tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
-tcBrackTy (PatBr {}) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
-tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL"
-tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr"
-tcBrackTy (XBracket nec) = noExtCon nec
+-- | Compute the expected type of a quotation, and also the QuoteWrapper in
+-- the case where it is an overloaded quotation. All quotation forms are
+-- overloaded aprt from Variable quotations ('foo)
+brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)
+brackTy b =
+ let mkTy n = do
+ -- New polymorphic type variable for the bracket
+ m_var <- mkTyVarTy <$> mkMetaTyVar
+ -- Emit a Quote constraint for the bracket
+ ev_var <- emitQuoteWanted m_var
+ -- Construct the final expected type of the quote, for example
+ -- m Exp or m Type
+ final_ty <- mkAppTy m_var <$> tcMetaTy n
+ -- Return the evidence variable and metavariable to be used during
+ -- desugaring.
+ let wrapper = QuoteWrapper ev_var m_var
+ return (Just wrapper, final_ty)
+ in
+ case b of
+ (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName
+ -- Result type is Var (not Quote-monadic)
+ (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp
+ (TypBr {}) -> mkTy typeTyConName -- Result type is m Type
+ (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]
+ (PatBr {}) -> mkTy patTyConName -- Result type is m Pat
+ (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"
+ (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr"
+ (XBracket nec) -> noExtCon nec
---------------
-tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
-tcPendingSplice (PendingRnSplice flavour splice_name expr)
- = do { res_ty <- tcMetaTy meta_ty_name
- ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)
+-- | Typechecking a pending splice from a untyped bracket
+tcPendingSplice :: TcType -- Metavariable for the expected overall type of the
+ -- quotation.
+ -> PendingRnSplice
+ -> TcM PendingTcSplice
+tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)
+ -- See Note [Typechecking Overloaded Quotes]
+ = do { meta_ty <- tcMetaTy meta_ty_name
+ -- Expected type of splice, e.g. m Exp
+ ; let expected_type = mkAppTy m_var meta_ty
+ ; expr' <- tcPolyExpr expr expected_type
; return (PendingTcSplice splice_name expr') }
where
meta_ty_name = case flavour of
- UntypedExpSplice -> expQTyConName
- UntypedPatSplice -> patQTyConName
- UntypedTypeSplice -> typeQTyConName
- UntypedDeclSplice -> decsQTyConName
+ UntypedExpSplice -> expTyConName
+ UntypedPatSplice -> patTyConName
+ UntypedTypeSplice -> typeTyConName
+ UntypedDeclSplice -> decsTyConName
---------------
--- Takes a tau and returns the type Q (TExp tau)
-tcTExpTy :: TcType -> TcM TcType
-tcTExpTy exp_ty
+-- Takes a m and tau and returns the type m (TExp tau)
+tcTExpTy :: TcType -> TcType -> TcM TcType
+tcTExpTy m_ty exp_ty
= do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
- ; q <- tcLookupTyCon qTyConName
; texp <- tcLookupTyCon tExpTyConName
; let rep = getRuntimeRep exp_ty
- ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }
+ ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) }
where
err_msg ty
= vcat [ text "Illegal polytype:" <+> ppr ty
@@ -429,6 +494,44 @@ When a variable is used, we compare
g1 = $(map ...) is OK
g2 = $(f ...) is not OK; because we havn't compiled f yet
+Note [Typechecking Overloaded Quotes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The main function for typechecking untyped quotations is `tcUntypedBracket`.
+
+Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`.
+When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and
+emit a constraint `Quote m`. All this is done in the `brackTy` function.
+`brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc).
+
+The meta variable and the constraint evidence variable are
+returned together in a `QuoteWrapper` and then passed along to two further places
+during compilation:
+
+1. Typechecking nested splices (immediately in tcPendingSplice)
+2. Desugaring quotations (see DsMeta)
+
+`tcPendingSplice` takes the `m` type variable as an argument and checks
+each nested splice against this variable `m`. During this
+process the variable `m` can either be fixed to a specific value or further constrained by the
+nested splices.
+
+Once we have checked all the nested splices, the quote type is checked against
+the expected return type.
+
+The process is very simple and like typechecking a list where the quotation is
+like the container and the splices are the elements of the list which must have
+a specific type.
+
+After the typechecking process is completed, the evidence variable for `Quote m`
+and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline
+and used when desugaring quotations.
+
+Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored
+in the `PendingStuff` as the nested splices are gathered up in a different way
+to untyped splices. Untyped splices are found in the renamer but typed splices are
+not typechecked and extracted until during typechecking.
+
-}
-- | We only want to produce warnings for TH-splices if the user requests so.
@@ -503,15 +606,17 @@ tcNestedSplice :: ThStage -> PendingStuff -> Name
-> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
-tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
+tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty
= do { res_ty <- expTypeToType res_ty
; let rep = getRuntimeRep res_ty
- ; meta_exp_ty <- tcTExpTy res_ty
+ ; meta_exp_ty <- tcTExpTy m_var res_ty
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr (mkCheckExpType meta_exp_ty)
; untypeq <- tcLookupId unTypeQName
- ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'
+ ; let expr'' = mkHsApp
+ (mkLHsWrap (applyQuoteWrapper q)
+ (nlHsTyApp untypeq [rep, res_ty])) expr'
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
@@ -526,7 +631,9 @@ tcTopSplice expr res_ty
= do { -- Typecheck the expression,
-- making sure it has type Q (T res_ty)
res_ty <- expTypeToType res_ty
- ; meta_exp_ty <- tcTExpTy res_ty
+ ; q_type <- tcMetaTy qTyConName
+ -- Top level splices must still be of type Q (TExp a)
+ ; meta_exp_ty <- tcTExpTy q_type res_ty
; q_expr <- tcTopSpliceExpr Typed $
tcMonoExpr expr (mkCheckExpType meta_exp_ty)
; lcl_env <- getLclEnv
diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst
index 69890b2c10..70bb901b07 100644
--- a/docs/users_guide/8.12.1-notes.rst
+++ b/docs/users_guide/8.12.1-notes.rst
@@ -32,6 +32,10 @@ Runtime system
Template Haskell
~~~~~~~~~~~~~~~~
+ - Implement the Overloaded Quotations proposal (#246). The type of all quotation
+ forms have now been generalised in terms of a minimal interface necessary for the
+ implementation rather than the overapproximation of the ``Q`` monad.
+
``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index dcc43f9623..ea7bbac9cc 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -13117,7 +13117,7 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
overrides the meaning of "." as an infix operator. If you want the
infix operator, put spaces around it.
- A splice can occur in place of
+ A top-level splice can occur in place of
- an expression; the spliced expression must have type ``Q Exp``
@@ -13133,32 +13133,70 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
that declaration splices are not allowed anywhere except at top level
(outside any other declarations).
+ The ``Q`` monad is a monad defined in ``Language.Haskell.TH.Syntax`` which
+ supports several useful operations during code generation such as reporting
+ errors or looking up identifiers in the environment.
+
- A expression quotation is written in Oxford brackets, thus:
- ``[| ... |]``, or ``[e| ... |]``, where the "..." is an
- expression; the quotation has type ``Q Exp``.
+ expression; the quotation has type ``Quote m => m Exp``.
- ``[d| ... |]``, where the "..." is a list of top-level
- declarations; the quotation has type ``Q [Dec]``.
+ declarations; the quotation has type ``Quote m => m [Dec]``.
- ``[t| ... |]``, where the "..." is a type; the quotation has type
- ``Q Type``.
+ ``Quote m => m Type``.
- ``[p| ... |]``, where the "..." is a pattern; the quotation has
- type ``Q Pat``.
+ type ``Quote m => m Pat``.
+
+ The ``Quote`` type class is the minimal interface necessary to implement
+ the desugaring of quotations. The ``Q`` monad is an instance of ``Quote`` but
+ contains many more operations which are not needed for defining quotations.
See :ref:`pts-where` for using partial type signatures in quotations.
+- Splices can be nested inside quotation brackets. For example the fragment
+ representing ``1 + 2`` can be constructed using nested splices::
+
+ oneC, twoC, plusC :: Quote m => m Exp
+ oneC = [| 1 |]
+
+ twoC = [| 2 |]
+
+ plusC = [| $oneC + $twoC |]
+
+- The precise type of a quotation depends on the types of the nested splices inside it::
+
+ -- Add a redundant constraint to demonstrate that constraints on the
+ -- monad used to build the representation are propagated when using nested
+ -- splices.
+ f :: (Quote m, C m) => m Exp
+ f = [| 5 | ]
+
+ -- f is used in a nested splice so the constraint on f, namely C, is propagated
+ -- to a constraint on the whole representation.
+ g :: (Quote m, C m) => m Exp
+ g = [| $f + $f |]
+
+ Remember, a top-level splice still requires its argument to be of type ``Q Exp``.
+ So then splicing in ``g`` will cause ``m`` to be instantiated to ``Q``::
+
+ h :: Int
+ h = $(g) -- m ~ Q
+
+
- A *typed* expression splice is written ``$$x``, where ``x`` is
is an arbitrary expression.
- A typed expression splice can occur in place of an expression; the
+ A top-level typed expression splice can occur in place of an expression; the
spliced expression must have type ``Q (TExp a)``
- A *typed* expression quotation is written as ``[|| ... ||]``, or
``[e|| ... ||]``, where the "..." is an expression; if the "..."
expression has type ``a``, then the quotation has type
- ``Q (TExp a)``.
+ ``Quote m => m (TExp a)``.
Values of type ``TExp a`` may be converted to values of type ``Exp``
using the function ``unType :: TExp a -> Exp``.
@@ -13200,7 +13238,7 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
import Language.Haskell.TH
- add1 :: Int -> Q Exp
+ add1 :: Quote m => Int -> m Exp
add1 x = [| x + 1 |]
Now consider a splice using ``add1`` in a separate
@@ -13215,13 +13253,14 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
Template Haskell cannot know what the argument to ``add1`` will be at the
function's definition site, so a lifting mechanism is used to promote
- ``x`` into a value of type ``Q Exp``. This functionality is exposed to the
+ ``x`` into a value of type ``Quote m => m Exp``. This functionality is exposed to the
user as the ``Lift`` typeclass in the ``Language.Haskell.TH.Syntax``
module. If a type has a ``Lift`` instance, then any of its values can be
lifted to a Template Haskell expression: ::
class Lift t where
- lift :: t -> Q Exp
+ lift :: Quote m => t -> m Exp
+ liftTyped :: Quote m => t -> m (TExp t)
In general, if GHC sees an expression within Oxford brackets (e.g., ``[|
foo bar |]``, then GHC looks up each name within the brackets. If a name
@@ -13265,14 +13304,14 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
quotation bracket are *not* run at compile time; they are run when the
bracket is spliced in, sometime later. For example, ::
- mkPat :: Q Pat
+ mkPat :: Quote m => m Pat
mkPat = [p| (x, y) |]
-- in another module:
foo :: (Char, String) -> String
foo $(mkPat) = x : z
- bar :: Q Exp
+ bar :: Quote m => m Exp
bar = [| \ $(mkPat) -> x : w |]
will fail with ``z`` being out of scope in the definition of ``foo`` but it
@@ -13402,7 +13441,7 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
(Compared to the original paper, there are many differences of detail.
The syntax for a declaration splice uses "``$``" not "``splice``". The type of
-the enclosed expression must be ``Q [Dec]``, not ``[Q Dec]``. Typed expression
+the enclosed expression must be ``Quote m => m [Dec]``, not ``[Q Dec]``. Typed expression
splices and quotations are supported.)
.. ghc-flag:: -fenable-th-splice-warnings
@@ -13538,14 +13577,14 @@ and :file:`Printf.hs`:
-- Generate Haskell source code from a parsed representation
-- of the format string. This code will be spliced into
-- the module which calls "pr", at compile time.
- gen :: [Format] -> Q Exp
+ gen :: Quote m => [Format] -> m Exp
gen [D] = [| \n -> show n |]
gen [S] = [| \s -> s |]
gen [L s] = stringE s
-- Here we generate the Haskell code for the splice
-- from an input format string.
- pr :: String -> Q Exp
+ pr :: Quote m => String -> m Exp
pr s = gen (parse s)
Now run the compiler,
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 5b03b2649c..b818535576 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -8,6 +8,7 @@ module Language.Haskell.TH(
-- * The monad and its operations
Q,
runQ,
+ Quote(..),
-- ** Administration: errors, locations and IO
reportError, -- :: String -> Q ()
reportWarning, -- :: String -> Q ()
@@ -53,7 +54,6 @@ module Language.Haskell.TH(
Name, NameSpace, -- Abstract
-- ** Constructing names
mkName, -- :: String -> Name
- newName, -- :: String -> Q Name
-- ** Deconstructing names
nameBase, -- :: Name -> String
nameModule, -- :: Name -> Maybe String
@@ -84,7 +84,7 @@ module Language.Haskell.TH(
Pat(..), FieldExp, FieldPat,
-- ** Types
Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),
- FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType,
+ FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType,
-- * Library functions
module Language.Haskell.TH.Lib,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 7bb4eb50dd..77c85d907c 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -159,7 +159,7 @@ import Language.Haskell.TH.Lib.Internal hiding
)
import Language.Haskell.TH.Syntax
-import Control.Monad (liftM2)
+import Control.Applicative ( liftA2 )
import Foreign.ForeignPtr
import Data.Word
import Prelude
@@ -172,97 +172,97 @@ import Prelude
-------------------------------------------------------------------------------
-- * Dec
-tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
+tySynD :: Quote m => Name -> [TyVarBndr] -> m Type -> m Dec
tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
-dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
- -> DecQ
+dataD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [m Con] -> [m DerivClause]
+ -> m Dec
dataD ctxt tc tvs ksig cons derivs =
do
ctxt1 <- ctxt
- cons1 <- sequence cons
- derivs1 <- sequence derivs
+ cons1 <- sequenceA cons
+ derivs1 <- sequenceA derivs
return (DataD ctxt1 tc tvs ksig cons1 derivs1)
-newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ]
- -> DecQ
+newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> m Con -> [m DerivClause]
+ -> m Dec
newtypeD ctxt tc tvs ksig con derivs =
do
ctxt1 <- ctxt
con1 <- con
- derivs1 <- sequence derivs
+ derivs1 <- sequenceA derivs
return (NewtypeD ctxt1 tc tvs ksig con1 derivs1)
-classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
+classD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [m Dec] -> m Dec
classD ctxt cls tvs fds decs =
do
- decs1 <- sequence decs
+ decs1 <- sequenceA decs
ctxt1 <- ctxt
return $ ClassD ctxt1 cls tvs fds decs1
-pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
+pragRuleD :: Quote m => String -> [m RuleBndr] -> m Exp -> m Exp -> Phases -> m Dec
pragRuleD n bndrs lhs rhs phases
= do
- bndrs1 <- sequence bndrs
+ bndrs1 <- sequenceA bndrs
lhs1 <- lhs
rhs1 <- rhs
return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases
-dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
- -> DecQ
+dataInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> [m Con] -> [m DerivClause]
+ -> m Dec
dataInstD ctxt tc tys ksig cons derivs =
do
ctxt1 <- ctxt
ty1 <- foldl appT (conT tc) tys
- cons1 <- sequence cons
- derivs1 <- sequence derivs
+ cons1 <- sequenceA cons
+ derivs1 <- sequenceA derivs
return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1)
-newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ]
- -> DecQ
+newtypeInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> m Con -> [m DerivClause]
+ -> m Dec
newtypeInstD ctxt tc tys ksig con derivs =
do
ctxt1 <- ctxt
ty1 <- foldl appT (conT tc) tys
con1 <- con
- derivs1 <- sequence derivs
+ derivs1 <- sequenceA derivs
return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1)
-dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ
+dataFamilyD :: Quote m => Name -> [TyVarBndr] -> Maybe Kind -> m Dec
dataFamilyD tc tvs kind
- = return $ DataFamilyD tc tvs kind
+ = pure $ DataFamilyD tc tvs kind
-openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
- -> Maybe InjectivityAnn -> DecQ
+openTypeFamilyD :: Quote m => Name -> [TyVarBndr] -> FamilyResultSig
+ -> Maybe InjectivityAnn -> m Dec
openTypeFamilyD tc tvs res inj
- = return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj)
+ = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj)
-closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
- -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
+closedTypeFamilyD :: Quote m => Name -> [TyVarBndr] -> FamilyResultSig
+ -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec
closedTypeFamilyD tc tvs result injectivity eqns =
- do eqns1 <- sequence eqns
+ do eqns1 <- sequenceA eqns
return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1)
-tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ
+tySynEqn :: Quote m => (Maybe [TyVarBndr]) -> m Type -> m Type -> m TySynEqn
tySynEqn tvs lhs rhs =
do
lhs1 <- lhs
rhs1 <- rhs
return (TySynEqn tvs lhs1 rhs1)
-forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
-forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
+forallC :: Quote m => [TyVarBndr] -> m Cxt -> m Con -> m Con
+forallC ns ctxt con = liftA2 (ForallC ns) ctxt con
-------------------------------------------------------------------------------
-- * Type
-forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
+forallT :: Quote m => [TyVarBndr] -> m Cxt -> m Type -> m Type
forallT tvars ctxt ty = do
ctxt1 <- ctxt
ty1 <- ty
return $ ForallT tvars ctxt1 ty1
-sigT :: TypeQ -> Kind -> TypeQ
+sigT :: Quote m => m Type -> Kind -> m Type
sigT t k
= do
t' <- t
@@ -298,12 +298,12 @@ tyVarSig = TyVarSig
-------------------------------------------------------------------------------
-- * Top Level Declarations
-derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
+derivClause :: Quote m => Maybe DerivStrategy -> [m Pred] -> m DerivClause
derivClause mds p = do
p' <- cxt p
return $ DerivClause mds p'
-standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ
+standaloneDerivWithStrategyD :: Quote m => Maybe DerivStrategy -> m Cxt -> m Type -> m Dec
standaloneDerivWithStrategyD mds ctxt ty = do
ctxt' <- ctxt
ty' <- ty
@@ -326,8 +326,8 @@ mkBytes = Bytes
-------------------------------------------------------------------------------
-- * Tuple expressions
-tupE :: [ExpQ] -> ExpQ
-tupE es = do { es1 <- sequence es; return (TupE $ map Just es1)}
+tupE :: Quote m => [m Exp] -> m Exp
+tupE es = do { es1 <- sequenceA es; return (TupE $ map Just es1)}
-unboxedTupE :: [ExpQ] -> ExpQ
-unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE $ map Just es1)}
+unboxedTupE :: Quote m => [m Exp] -> m Exp
+unboxedTupE es = do { es1 <- sequenceA es; return (UnboxedTupE $ map Just es1)}
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 4d3887baf2..3a55f7a96a 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -16,7 +16,7 @@ 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.Monad( liftM, liftM2 )
+import Control.Applicative(liftA, liftA2)
import Data.Word( Word8 )
import Prelude
@@ -31,6 +31,7 @@ type ExpQ = Q Exp
type TExpQ a = Q (TExp a)
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
@@ -91,675 +92,675 @@ bytesPrimL = BytesPrimL
rationalL :: Rational -> Lit
rationalL = RationalL
-litP :: Lit -> PatQ
-litP l = return (LitP l)
+litP :: Quote m => Lit -> m Pat
+litP l = pure (LitP l)
-varP :: Name -> PatQ
-varP v = return (VarP v)
+varP :: Quote m => Name -> m Pat
+varP v = pure (VarP v)
-tupP :: [PatQ] -> PatQ
-tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
+tupP :: Quote m => [m Pat] -> m Pat
+tupP ps = do { ps1 <- sequenceA ps; pure (TupP ps1)}
-unboxedTupP :: [PatQ] -> PatQ
-unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
+unboxedTupP :: Quote m => [m Pat] -> m Pat
+unboxedTupP ps = do { ps1 <- sequenceA ps; pure (UnboxedTupP ps1)}
-unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ
-unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }
+unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat
+unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) }
-conP :: Name -> [PatQ] -> PatQ
-conP n ps = do ps' <- sequence ps
- return (ConP n ps')
-infixP :: PatQ -> Name -> PatQ -> PatQ
+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
- return (InfixP p1' n p2')
-uInfixP :: PatQ -> Name -> PatQ -> PatQ
+ pure (InfixP p1' n p2')
+uInfixP :: Quote m => m Pat -> Name -> m Pat -> m Pat
uInfixP p1 n p2 = do p1' <- p1
p2' <- p2
- return (UInfixP p1' n p2')
-parensP :: PatQ -> PatQ
+ pure (UInfixP p1' n p2')
+parensP :: Quote m => m Pat -> m Pat
parensP p = do p' <- p
- return (ParensP p')
+ pure (ParensP p')
-tildeP :: PatQ -> PatQ
+tildeP :: Quote m => m Pat -> m Pat
tildeP p = do p' <- p
- return (TildeP p')
-bangP :: PatQ -> PatQ
+ pure (TildeP p')
+bangP :: Quote m => m Pat -> m Pat
bangP p = do p' <- p
- return (BangP p')
-asP :: Name -> PatQ -> PatQ
+ pure (BangP p')
+asP :: Quote m => Name -> m Pat -> m Pat
asP n p = do p' <- p
- return (AsP n p')
-wildP :: PatQ
-wildP = return WildP
-recP :: Name -> [FieldPatQ] -> PatQ
-recP n fps = do fps' <- sequence fps
- return (RecP n fps')
-listP :: [PatQ] -> PatQ
-listP ps = do ps' <- sequence ps
- return (ListP ps')
-sigP :: PatQ -> TypeQ -> PatQ
+ 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
- return (SigP p' t')
-viewP :: ExpQ -> PatQ -> PatQ
+ pure (SigP p' t')
+viewP :: Quote m => m Exp -> m Pat -> m Pat
viewP e p = do e' <- e
p' <- p
- return (ViewP e' p')
+ pure (ViewP e' p')
-fieldPat :: Name -> PatQ -> FieldPatQ
+fieldPat :: Quote m => Name -> m Pat -> m FieldPat
fieldPat n p = do p' <- p
- return (n, p')
+ pure (n, p')
-------------------------------------------------------------------------------
-- * Stmt
-bindS :: PatQ -> ExpQ -> StmtQ
-bindS p e = liftM2 BindS p e
+bindS :: Quote m => m Pat -> m Exp -> m Stmt
+bindS p e = liftA2 BindS p e
-letS :: [DecQ] -> StmtQ
-letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
+letS :: Quote m => [m Dec] -> m Stmt
+letS ds = do { ds1 <- sequenceA ds; pure (LetS ds1) }
-noBindS :: ExpQ -> StmtQ
-noBindS e = do { e1 <- e; return (NoBindS e1) }
+noBindS :: Quote m => m Exp -> m Stmt
+noBindS e = do { e1 <- e; pure (NoBindS e1) }
-parS :: [[StmtQ]] -> StmtQ
-parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }
+parS :: Quote m => [[m Stmt]] -> m Stmt
+parS sss = do { sss1 <- traverse sequenceA sss; pure (ParS sss1) }
-recS :: [StmtQ] -> StmtQ
-recS ss = do { ss1 <- sequence ss; return (RecS ss1) }
+recS :: Quote m => [m Stmt] -> m Stmt
+recS ss = do { ss1 <- sequenceA ss; pure (RecS ss1) }
-------------------------------------------------------------------------------
-- * Range
-fromR :: ExpQ -> RangeQ
-fromR x = do { a <- x; return (FromR a) }
+fromR :: Quote m => m Exp -> m Range
+fromR x = do { a <- x; pure (FromR a) }
-fromThenR :: ExpQ -> ExpQ -> RangeQ
-fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
+fromThenR :: Quote m => m Exp -> m Exp -> m Range
+fromThenR x y = do { a <- x; b <- y; pure (FromThenR a b) }
-fromToR :: ExpQ -> ExpQ -> RangeQ
-fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
+fromToR :: Quote m => m Exp -> m Exp -> m Range
+fromToR x y = do { a <- x; b <- y; pure (FromToR a b) }
-fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
+fromThenToR :: Quote m => m Exp -> m Exp -> m Exp -> m Range
fromThenToR x y z = do { a <- x; b <- y; c <- z;
- return (FromThenToR a b c) }
+ pure (FromThenToR a b c) }
-------------------------------------------------------------------------------
-- * Body
-normalB :: ExpQ -> BodyQ
-normalB e = do { e1 <- e; return (NormalB e1) }
+normalB :: Quote m => m Exp -> m Body
+normalB e = do { e1 <- e; pure (NormalB e1) }
-guardedB :: [Q (Guard,Exp)] -> BodyQ
-guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
+guardedB :: Quote m => [m (Guard,Exp)] -> m Body
+guardedB ges = do { ges' <- sequenceA ges; pure (GuardedB ges') }
-------------------------------------------------------------------------------
-- * Guard
-normalG :: ExpQ -> GuardQ
-normalG e = do { e1 <- e; return (NormalG e1) }
+normalG :: Quote m => m Exp -> m Guard
+normalG e = do { e1 <- e; pure (NormalG e1) }
-normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
-normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
+normalGE :: Quote m => m Exp -> m Exp -> m (Guard, Exp)
+normalGE g e = do { g1 <- g; e1 <- e; pure (NormalG g1, e1) }
-patG :: [StmtQ] -> GuardQ
-patG ss = do { ss' <- sequence ss; return (PatG ss') }
+patG :: Quote m => [m Stmt] -> m Guard
+patG ss = do { ss' <- sequenceA ss; pure (PatG ss') }
-patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
-patGE ss e = do { ss' <- sequence ss;
+patGE :: Quote m => [m Stmt] -> m Exp -> m (Guard, Exp)
+patGE ss e = do { ss' <- sequenceA ss;
e' <- e;
- return (PatG ss', e') }
+ pure (PatG ss', e') }
-------------------------------------------------------------------------------
-- * Match and Clause
-- | Use with 'caseE'
-match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
+match :: Quote m => m Pat -> m Body -> [m Dec] -> m Match
match p rhs ds = do { p' <- p;
r' <- rhs;
- ds' <- sequence ds;
- return (Match p' r' ds') }
+ ds' <- sequenceA ds;
+ pure (Match p' r' ds') }
-- | Use with 'funD'
-clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
-clause ps r ds = do { ps' <- sequence ps;
+clause :: Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause
+clause ps r ds = do { ps' <- sequenceA ps;
r' <- r;
- ds' <- sequence ds;
- return (Clause ps' r' ds') }
+ ds' <- sequenceA ds;
+ pure (Clause ps' r' ds') }
---------------------------------------------------------------------------
-- * Exp
-- | Dynamically binding a variable (unhygenic)
-dyn :: String -> ExpQ
-dyn s = return (VarE (mkName s))
+dyn :: Quote m => String -> m Exp
+dyn s = pure (VarE (mkName s))
-varE :: Name -> ExpQ
-varE s = return (VarE s)
+varE :: Quote m => Name -> m Exp
+varE s = pure (VarE s)
-conE :: Name -> ExpQ
-conE s = return (ConE s)
+conE :: Quote m => Name -> m Exp
+conE s = pure (ConE s)
-litE :: Lit -> ExpQ
-litE c = return (LitE c)
+litE :: Quote m => Lit -> m Exp
+litE c = pure (LitE c)
-appE :: ExpQ -> ExpQ -> ExpQ
-appE x y = do { a <- x; b <- y; return (AppE a b)}
+appE :: Quote m => m Exp -> m Exp -> m Exp
+appE x y = do { a <- x; b <- y; pure (AppE a b)}
-appTypeE :: ExpQ -> TypeQ -> ExpQ
-appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) }
+appTypeE :: Quote m => m Exp -> m Type -> m Exp
+appTypeE x t = do { a <- x; s <- t; pure (AppTypeE a s) }
-parensE :: ExpQ -> ExpQ
-parensE x = do { x' <- x; return (ParensE x') }
+parensE :: Quote m => m Exp -> m Exp
+parensE x = do { x' <- x; pure (ParensE x') }
-uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+uInfixE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
- return (UInfixE x' s' y') }
+ pure (UInfixE x' s' y') }
-infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
+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;
- return (InfixE (Just a) s' (Just b))}
+ pure (InfixE (Just a) s' (Just b))}
infixE Nothing s (Just y) = do { s' <- s; b <- y;
- return (InfixE Nothing s' (Just b))}
+ pure (InfixE Nothing s' (Just b))}
infixE (Just x) s Nothing = do { a <- x; s' <- s;
- return (InfixE (Just a) s' Nothing)}
-infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }
+ pure (InfixE (Just a) s' Nothing)}
+infixE Nothing s Nothing = do { s' <- s; pure (InfixE Nothing s' Nothing) }
-infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+infixApp :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp x y z = infixE (Just x) y (Just z)
-sectionL :: ExpQ -> ExpQ -> ExpQ
+sectionL :: Quote m => m Exp -> m Exp -> m Exp
sectionL x y = infixE (Just x) y Nothing
-sectionR :: ExpQ -> ExpQ -> ExpQ
+sectionR :: Quote m => m Exp -> m Exp -> m Exp
sectionR x y = infixE Nothing x (Just y)
-lamE :: [PatQ] -> ExpQ -> ExpQ
-lamE ps e = do ps' <- sequence ps
+lamE :: Quote m => [m Pat] -> m Exp -> m Exp
+lamE ps e = do ps' <- sequenceA ps
e' <- e
- return (LamE ps' e')
+ pure (LamE ps' e')
-- | Single-arg lambda
-lam1E :: PatQ -> ExpQ -> ExpQ
+lam1E :: Quote m => m Pat -> m Exp -> m Exp
lam1E p e = lamE [p] e
-lamCaseE :: [MatchQ] -> ExpQ
-lamCaseE ms = sequence ms >>= return . LamCaseE
+lamCaseE :: Quote m => [m Match] -> m Exp
+lamCaseE ms = LamCaseE <$> sequenceA ms
-tupE :: [Maybe ExpQ] -> ExpQ
-tupE es = do { es1 <- traverse sequence es; return (TupE es1)}
+tupE :: Quote m => [Maybe (m Exp)] -> m Exp
+tupE es = do { es1 <- traverse sequenceA es; pure (TupE es1)}
-unboxedTupE :: [Maybe ExpQ] -> ExpQ
-unboxedTupE es = do { es1 <- traverse sequence es; return (UnboxedTupE es1)}
+unboxedTupE :: Quote m => [Maybe (m Exp)] -> m Exp
+unboxedTupE es = do { es1 <- traverse sequenceA es; pure (UnboxedTupE es1)}
-unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
-unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
+unboxedSumE :: Quote m => m Exp -> SumAlt -> SumArity -> m Exp
+unboxedSumE e alt arity = do { e1 <- e; pure (UnboxedSumE e1 alt arity) }
-condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
-condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
+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 :: [Q (Guard, Exp)] -> ExpQ
-multiIfE alts = sequence alts >>= return . MultiIfE
+multiIfE :: Quote m => [m (Guard, Exp)] -> m Exp
+multiIfE alts = MultiIfE <$> sequenceA alts
-letE :: [DecQ] -> ExpQ -> ExpQ
-letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
+letE :: Quote m => [m Dec] -> m Exp -> m Exp
+letE ds e = do { ds2 <- sequenceA ds; e2 <- e; pure (LetE ds2 e2) }
-caseE :: ExpQ -> [MatchQ] -> ExpQ
-caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
+caseE :: Quote m => m Exp -> [m Match] -> m Exp
+caseE e ms = do { e1 <- e; ms1 <- sequenceA ms; pure (CaseE e1 ms1) }
-doE :: [StmtQ] -> ExpQ
-doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
+doE :: Quote m => [m Stmt] -> m Exp
+doE ss = do { ss1 <- sequenceA ss; pure (DoE ss1) }
-mdoE :: [StmtQ] -> ExpQ
-mdoE ss = do { ss1 <- sequence ss; return (MDoE ss1) }
+mdoE :: Quote m => [m Stmt] -> m Exp
+mdoE ss = do { ss1 <- sequenceA ss; pure (MDoE ss1) }
-compE :: [StmtQ] -> ExpQ
-compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
+compE :: Quote m => [m Stmt] -> m Exp
+compE ss = do { ss1 <- sequenceA ss; pure (CompE ss1) }
-arithSeqE :: RangeQ -> ExpQ
-arithSeqE r = do { r' <- r; return (ArithSeqE r') }
+arithSeqE :: Quote m => m Range -> m Exp
+arithSeqE r = do { r' <- r; pure (ArithSeqE r') }
-listE :: [ExpQ] -> ExpQ
-listE es = do { es1 <- sequence es; return (ListE es1) }
+listE :: Quote m => [m Exp] -> m Exp
+listE es = do { es1 <- sequenceA es; pure (ListE es1) }
-sigE :: ExpQ -> TypeQ -> ExpQ
-sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
+sigE :: Quote m => m Exp -> m Type -> m Exp
+sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) }
-recConE :: Name -> [Q (Name,Exp)] -> ExpQ
-recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
+recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp
+recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) }
-recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
-recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 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 :: String -> ExpQ
+stringE :: Quote m => String -> m Exp
stringE = litE . stringL
-fieldExp :: Name -> ExpQ -> Q (Name, Exp)
-fieldExp s e = do { e' <- e; return (s,e') }
+fieldExp :: Quote m => Name -> m Exp -> m (Name, Exp)
+fieldExp s e = do { e' <- e; pure (s,e') }
-- | @staticE x = [| static x |]@
-staticE :: ExpQ -> ExpQ
+staticE :: Quote m => m Exp -> m Exp
staticE = fmap StaticE
-unboundVarE :: Name -> ExpQ
-unboundVarE s = return (UnboundVarE s)
+unboundVarE :: Quote m => Name -> m Exp
+unboundVarE s = pure (UnboundVarE s)
-labelE :: String -> ExpQ
-labelE s = return (LabelE s)
+labelE :: Quote m => String -> m Exp
+labelE s = pure (LabelE s)
-implicitParamVarE :: String -> ExpQ
-implicitParamVarE n = return (ImplicitParamVarE n)
+implicitParamVarE :: Quote m => String -> m Exp
+implicitParamVarE n = pure (ImplicitParamVarE n)
-- ** 'arithSeqE' Shortcuts
-fromE :: ExpQ -> ExpQ
-fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
+fromE :: Quote m => m Exp -> m Exp
+fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }
-fromThenE :: ExpQ -> ExpQ -> ExpQ
-fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
+fromThenE :: Quote m => m Exp -> m Exp -> m Exp
+fromThenE x y = do { a <- x; b <- y; pure (ArithSeqE (FromThenR a b)) }
-fromToE :: ExpQ -> ExpQ -> ExpQ
-fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR 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 :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+fromThenToE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
fromThenToE x y z = do { a <- x; b <- y; c <- z;
- return (ArithSeqE (FromThenToR a b c)) }
+ pure (ArithSeqE (FromThenToR a b c)) }
-------------------------------------------------------------------------------
-- * Dec
-valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
+valD :: Quote m => m Pat -> m Body -> [m Dec] -> m Dec
valD p b ds =
do { p' <- p
- ; ds' <- sequence ds
+ ; ds' <- sequenceA ds
; b' <- b
- ; return (ValD p' b' ds')
+ ; pure (ValD p' b' ds')
}
-funD :: Name -> [ClauseQ] -> DecQ
+funD :: Quote m => Name -> [m Clause] -> m Dec
funD nm cs =
- do { cs1 <- sequence cs
- ; return (FunD nm cs1)
+ do { cs1 <- sequenceA cs
+ ; pure (FunD nm cs1)
}
-tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ
+tySynD :: Quote m => Name -> [m TyVarBndr] -> m Type -> m Dec
tySynD tc tvs rhs =
do { tvs1 <- sequenceA tvs
; rhs1 <- rhs
- ; return (TySynD tc tvs1 rhs1)
+ ; pure (TySynD tc tvs1 rhs1)
}
-dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ]
- -> [DerivClauseQ] -> DecQ
+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 <- sequence cons
- derivs1 <- sequence derivs
- return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)
+ cons1 <- sequenceA cons
+ derivs1 <- sequenceA derivs
+ pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)
-newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ
- -> [DerivClauseQ] -> DecQ
+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 <- sequence derivs
- return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)
+ derivs1 <- sequenceA derivs
+ pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)
-classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ
+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
- return $ ClassD ctxt1 cls tvs1 fds decs1
+ pure $ ClassD ctxt1 cls tvs1 fds decs1
-instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
+instanceD :: Quote m => m Cxt -> m Type -> [m Dec] -> m Dec
instanceD = instanceWithOverlapD Nothing
-instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ
+instanceWithOverlapD :: Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec
instanceWithOverlapD o ctxt ty decs =
do
ctxt1 <- ctxt
- decs1 <- sequence decs
+ decs1 <- sequenceA decs
ty1 <- ty
- return $ InstanceD o ctxt1 ty1 decs1
+ pure $ InstanceD o ctxt1 ty1 decs1
-sigD :: Name -> TypeQ -> DecQ
-sigD fun ty = liftM (SigD fun) $ ty
+sigD :: Quote m => Name -> m Type -> m Dec
+sigD fun ty = liftA (SigD fun) $ ty
-kiSigD :: Name -> KindQ -> DecQ
-kiSigD fun ki = liftM (KiSigD fun) $ ki
+kiSigD :: Quote m => Name -> m Kind -> m Dec
+kiSigD fun ki = liftA (KiSigD fun) $ ki
-forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
+forImpD :: Quote m => Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD cc s str n ty
= do ty' <- ty
- return $ ForeignD (ImportF cc s str n ty')
+ pure $ ForeignD (ImportF cc s str n ty')
-infixLD :: Int -> Name -> DecQ
-infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)
+infixLD :: Quote m => Int -> Name -> m Dec
+infixLD prec nm = pure (InfixD (Fixity prec InfixL) nm)
-infixRD :: Int -> Name -> DecQ
-infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)
+infixRD :: Quote m => Int -> Name -> m Dec
+infixRD prec nm = pure (InfixD (Fixity prec InfixR) nm)
-infixND :: Int -> Name -> DecQ
-infixND prec nm = return (InfixD (Fixity prec InfixN) nm)
+infixND :: Quote m => Int -> Name -> m Dec
+infixND prec nm = pure (InfixD (Fixity prec InfixN) nm)
-pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ
+pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD name inline rm phases
- = return $ PragmaD $ InlineP name inline rm phases
+ = pure $ PragmaD $ InlineP name inline rm phases
-pragSpecD :: Name -> TypeQ -> Phases -> DecQ
+pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec
pragSpecD n ty phases
= do
ty1 <- ty
- return $ PragmaD $ SpecialiseP n ty1 Nothing phases
+ pure $ PragmaD $ SpecialiseP n ty1 Nothing phases
-pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ
+pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec
pragSpecInlD n ty inline phases
= do
ty1 <- ty
- return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
+ pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
-pragSpecInstD :: TypeQ -> DecQ
+pragSpecInstD :: Quote m => m Type -> m Dec
pragSpecInstD ty
= do
ty1 <- ty
- return $ PragmaD $ SpecialiseInstP ty1
+ pure $ PragmaD $ SpecialiseInstP ty1
-pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ
- -> Phases -> DecQ
+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 sequence ty_bndrs
- tm_bndrs1 <- sequence tm_bndrs
+ ty_bndrs1 <- traverse sequenceA ty_bndrs
+ tm_bndrs1 <- sequenceA tm_bndrs
lhs1 <- lhs
rhs1 <- rhs
- return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases
+ pure $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases
-pragAnnD :: AnnTarget -> ExpQ -> DecQ
+pragAnnD :: Quote m => AnnTarget -> m Exp -> m Dec
pragAnnD target expr
= do
exp1 <- expr
- return $ PragmaD $ AnnP target exp1
+ pure $ PragmaD $ AnnP target exp1
-pragLineD :: Int -> String -> DecQ
-pragLineD line file = return $ PragmaD $ LineP line file
+pragLineD :: Quote m => Int -> String -> m Dec
+pragLineD line file = pure $ PragmaD $ LineP line file
-pragCompleteD :: [Name] -> Maybe Name -> DecQ
-pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
+pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec
+pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty
-dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ]
- -> [DerivClauseQ] -> DecQ
+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 sequence mb_bndrs
+ mb_bndrs1 <- traverse sequenceA mb_bndrs
ty1 <- ty
ksig1 <- sequenceA ksig
cons1 <- sequenceA cons
derivs1 <- sequenceA derivs
- return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)
+ pure (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)
-newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ
- -> [DerivClauseQ] -> DecQ
+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 sequence mb_bndrs
+ mb_bndrs1 <- traverse sequenceA mb_bndrs
ty1 <- ty
ksig1 <- sequenceA ksig
con1 <- con
- derivs1 <- sequence derivs
- return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)
+ derivs1 <- sequenceA derivs
+ pure (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)
-tySynInstD :: TySynEqnQ -> DecQ
+tySynInstD :: Quote m => m TySynEqn -> m Dec
tySynInstD eqn =
do
eqn1 <- eqn
- return (TySynInstD eqn1)
+ pure (TySynInstD eqn1)
-dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ
+dataFamilyD :: Quote m => Name -> [m TyVarBndr] -> Maybe (m Kind) -> m Dec
dataFamilyD tc tvs kind =
do tvs' <- sequenceA tvs
kind' <- sequenceA kind
- return $ DataFamilyD tc tvs' kind'
+ pure $ DataFamilyD tc tvs' kind'
-openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
- -> Maybe InjectivityAnn -> DecQ
+openTypeFamilyD :: Quote m => Name -> [m TyVarBndr] -> m FamilyResultSig
+ -> Maybe InjectivityAnn -> m Dec
openTypeFamilyD tc tvs res inj =
do tvs' <- sequenceA tvs
res' <- res
- return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)
+ pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)
-closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
- -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
+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
- return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)
+ pure (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)
-roleAnnotD :: Name -> [Role] -> DecQ
-roleAnnotD name roles = return $ RoleAnnotD name roles
+roleAnnotD :: Quote m => Name -> [Role] -> m Dec
+roleAnnotD name roles = pure $ RoleAnnotD name roles
-standaloneDerivD :: CxtQ -> TypeQ -> DecQ
+standaloneDerivD :: Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD = standaloneDerivWithStrategyD Nothing
-standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ
+standaloneDerivWithStrategyD :: Quote m => Maybe (m DerivStrategy) -> m Cxt -> m Type -> m Dec
standaloneDerivWithStrategyD mdsq ctxtq tyq =
do
mds <- sequenceA mdsq
ctxt <- ctxtq
ty <- tyq
- return $ StandaloneDerivD mds ctxt ty
+ pure $ StandaloneDerivD mds ctxt ty
-defaultSigD :: Name -> TypeQ -> DecQ
+defaultSigD :: Quote m => Name -> m Type -> m Dec
defaultSigD n tyq =
do
ty <- tyq
- return $ DefaultSigD n ty
+ pure $ DefaultSigD n ty
-- | Pattern synonym declaration
-patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
+patSynD :: Quote m => Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD name args dir pat = do
args' <- args
dir' <- dir
pat' <- pat
- return (PatSynD name args' dir' pat')
+ pure (PatSynD name args' dir' pat')
-- | Pattern synonym type signature
-patSynSigD :: Name -> TypeQ -> DecQ
+patSynSigD :: Quote m => Name -> m Type -> m Dec
patSynSigD nm ty =
do ty' <- ty
- return $ PatSynSigD nm 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 :: String -> ExpQ -> DecQ
+implicitParamBindD :: Quote m => String -> m Exp -> m Dec
implicitParamBindD n e =
do
e' <- e
- return $ ImplicitParamBindD n e'
+ pure $ ImplicitParamBindD n e'
-tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ
+tySynEqn :: Quote m => (Maybe [m TyVarBndr]) -> m Type -> m Type -> m TySynEqn
tySynEqn mb_bndrs lhs rhs =
do
- mb_bndrs1 <- traverse sequence mb_bndrs
+ mb_bndrs1 <- traverse sequenceA mb_bndrs
lhs1 <- lhs
rhs1 <- rhs
- return (TySynEqn mb_bndrs1 lhs1 rhs1)
+ pure (TySynEqn mb_bndrs1 lhs1 rhs1)
-cxt :: [PredQ] -> CxtQ
-cxt = sequence
+cxt :: Quote m => [m Pred] -> m Cxt
+cxt = sequenceA
-derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ
+derivClause :: Quote m => Maybe (m DerivStrategy) -> [m Pred] -> m DerivClause
derivClause mds p = do mds' <- sequenceA mds
p' <- cxt p
- return $ DerivClause mds' p'
+ pure $ DerivClause mds' p'
-stockStrategy :: DerivStrategyQ
+stockStrategy :: Quote m => m DerivStrategy
stockStrategy = pure StockStrategy
-anyclassStrategy :: DerivStrategyQ
+anyclassStrategy :: Quote m => m DerivStrategy
anyclassStrategy = pure AnyclassStrategy
-newtypeStrategy :: DerivStrategyQ
+newtypeStrategy :: Quote m => m DerivStrategy
newtypeStrategy = pure NewtypeStrategy
-viaStrategy :: TypeQ -> DerivStrategyQ
+viaStrategy :: Quote m => m Type -> m DerivStrategy
viaStrategy = fmap ViaStrategy
-normalC :: Name -> [BangTypeQ] -> ConQ
-normalC con strtys = liftM (NormalC con) $ sequence strtys
+normalC :: Quote m => Name -> [m BangType] -> m Con
+normalC con strtys = liftA (NormalC con) $ sequenceA strtys
-recC :: Name -> [VarBangTypeQ] -> ConQ
-recC con varstrtys = liftM (RecC con) $ sequence varstrtys
+recC :: Quote m => Name -> [m VarBangType] -> m Con
+recC con varstrtys = liftA (RecC con) $ sequenceA varstrtys
-infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ
+infixC :: Quote m => m (Bang, Type) -> Name -> m (Bang, Type) -> m Con
infixC st1 con st2 = do st1' <- st1
st2' <- st2
- return $ InfixC st1' con st2'
+ pure $ InfixC st1' con st2'
-forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ
+forallC :: Quote m => [m TyVarBndr] -> m Cxt -> m Con -> m Con
forallC ns ctxt con = do
ns' <- sequenceA ns
ctxt' <- ctxt
con' <- con
pure $ ForallC ns' ctxt' con'
-gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
-gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty
+gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con
+gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty
-recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
-recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty
+recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con
+recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty
-------------------------------------------------------------------------------
-- * Type
-forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ
+forallT :: Quote m => [m TyVarBndr] -> m Cxt -> m Type -> m Type
forallT tvars ctxt ty = do
tvars1 <- sequenceA tvars
ctxt1 <- ctxt
ty1 <- ty
- return $ ForallT tvars1 ctxt1 ty1
+ pure $ ForallT tvars1 ctxt1 ty1
-forallVisT :: [TyVarBndrQ] -> TypeQ -> TypeQ
+forallVisT :: Quote m => [m TyVarBndr] -> m Type -> m Type
forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty
-varT :: Name -> TypeQ
-varT = return . VarT
+varT :: Quote m => Name -> m Type
+varT = pure . VarT
-conT :: Name -> TypeQ
-conT = return . ConT
+conT :: Quote m => Name -> m Type
+conT = pure . ConT
-infixT :: TypeQ -> Name -> TypeQ -> TypeQ
+infixT :: Quote m => m Type -> Name -> m Type -> m Type
infixT t1 n t2 = do t1' <- t1
t2' <- t2
- return (InfixT t1' n t2')
+ pure (InfixT t1' n t2')
-uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ
+uInfixT :: Quote m => m Type -> Name -> m Type -> m Type
uInfixT t1 n t2 = do t1' <- t1
t2' <- t2
- return (UInfixT t1' n t2')
+ pure (UInfixT t1' n t2')
-parensT :: TypeQ -> TypeQ
+parensT :: Quote m => m Type -> m Type
parensT t = do t' <- t
- return (ParensT t')
+ pure (ParensT t')
-appT :: TypeQ -> TypeQ -> TypeQ
+appT :: Quote m => m Type -> m Type -> m Type
appT t1 t2 = do
t1' <- t1
t2' <- t2
- return $ AppT t1' t2'
+ pure $ AppT t1' t2'
-appKindT :: TypeQ -> KindQ -> TypeQ
+appKindT :: Quote m => m Type -> m Kind -> m Type
appKindT ty ki = do
ty' <- ty
ki' <- ki
- return $ AppKindT ty' ki'
+ pure $ AppKindT ty' ki'
-arrowT :: TypeQ
-arrowT = return ArrowT
+arrowT :: Quote m => m Type
+arrowT = pure ArrowT
-listT :: TypeQ
-listT = return ListT
+listT :: Quote m => m Type
+listT = pure ListT
-litT :: TyLitQ -> TypeQ
+litT :: Quote m => m TyLit -> m Type
litT l = fmap LitT l
-tupleT :: Int -> TypeQ
-tupleT i = return (TupleT i)
+tupleT :: Quote m => Int -> m Type
+tupleT i = pure (TupleT i)
-unboxedTupleT :: Int -> TypeQ
-unboxedTupleT i = return (UnboxedTupleT i)
+unboxedTupleT :: Quote m => Int -> m Type
+unboxedTupleT i = pure (UnboxedTupleT i)
-unboxedSumT :: SumArity -> TypeQ
-unboxedSumT arity = return (UnboxedSumT arity)
+unboxedSumT :: Quote m => SumArity -> m Type
+unboxedSumT arity = pure (UnboxedSumT arity)
-sigT :: TypeQ -> KindQ -> TypeQ
+sigT :: Quote m => m Type -> m Kind -> m Type
sigT t k
= do
t' <- t
k' <- k
- return $ SigT t' k'
+ pure $ SigT t' k'
-equalityT :: TypeQ
-equalityT = return EqualityT
+equalityT :: Quote m => m Type
+equalityT = pure EqualityT
-wildCardT :: TypeQ
-wildCardT = return WildCardT
+wildCardT :: Quote m => m Type
+wildCardT = pure WildCardT
-implicitParamT :: String -> TypeQ -> TypeQ
+implicitParamT :: Quote m => String -> m Type -> m Type
implicitParamT n t
= do
t' <- t
- return $ ImplicitParamT n 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 :: Name -> [Q Type] -> Q Pred
+classP :: Quote m => Name -> [m Type] -> m Pred
classP cla tys
= do
- tysl <- sequence tys
- return (foldl AppT (ConT cla) tysl)
+ 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 :: TypeQ -> TypeQ -> PredQ
+equalP :: Quote m => m Type -> m Type -> m Pred
equalP tleft tright
= do
tleft1 <- tleft
tright1 <- tright
eqT <- equalityT
- return (foldl AppT eqT [tleft1, tright1])
+ pure (foldl AppT eqT [tleft1, tright1])
-promotedT :: Name -> TypeQ
-promotedT = return . PromotedT
+promotedT :: Quote m => Name -> m Type
+promotedT = pure . PromotedT
-promotedTupleT :: Int -> TypeQ
-promotedTupleT i = return (PromotedTupleT i)
+promotedTupleT :: Quote m => Int -> m Type
+promotedTupleT i = pure (PromotedTupleT i)
-promotedNilT :: TypeQ
-promotedNilT = return PromotedNilT
+promotedNilT :: Quote m => m Type
+promotedNilT = pure PromotedNilT
-promotedConsT :: TypeQ
-promotedConsT = return PromotedConsT
+promotedConsT :: Quote m => m Type
+promotedConsT = pure PromotedConsT
-noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ
-noSourceUnpackedness = return NoSourceUnpackedness
-sourceNoUnpack = return SourceNoUnpack
-sourceUnpack = return SourceUnpack
+noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: Quote m => m SourceUnpackedness
+noSourceUnpackedness = pure NoSourceUnpackedness
+sourceNoUnpack = pure SourceNoUnpack
+sourceUnpack = pure SourceUnpack
-noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ
-noSourceStrictness = return NoSourceStrictness
-sourceLazy = return SourceLazy
-sourceStrict = return SourceStrict
+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. ",
@@ -770,49 +771,52 @@ sourceStrict = return SourceStrict
{-# DEPRECATED unpacked
["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ",
"Example usage: 'bang sourceUnpack sourceStrict'"] #-}
-isStrict, notStrict, unpacked :: Q Strict
+isStrict, notStrict, unpacked :: Quote m => m Strict
isStrict = bang noSourceUnpackedness sourceStrict
notStrict = bang noSourceUnpackedness noSourceStrictness
unpacked = bang sourceUnpack sourceStrict
-bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
+bang :: Quote m => m SourceUnpackedness -> m SourceStrictness -> m Bang
bang u s = do u' <- u
s' <- s
- return (Bang u' s')
+ pure (Bang u' s')
-bangType :: BangQ -> TypeQ -> BangTypeQ
-bangType = liftM2 (,)
+bangType :: Quote m => m Bang -> m Type -> m BangType
+bangType = liftA2 (,)
-varBangType :: Name -> BangTypeQ -> VarBangTypeQ
-varBangType v bt = do (b, t) <- bt
- return (v, b, t)
+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 :: Q Strict -> TypeQ -> StrictTypeQ
+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 :: Name -> StrictTypeQ -> VarStrictTypeQ
+varStrictType :: Quote m => Name -> m StrictType -> m VarStrictType
varStrictType = varBangType
-- * Type Literals
-numTyLit :: Integer -> TyLitQ
-numTyLit n = if n >= 0 then return (NumTyLit n)
- else fail ("Negative type-level number: " ++ show n)
+-- 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 :: String -> TyLitQ
-strTyLit s = return (StrTyLit s)
+strTyLit :: Quote m => String -> m TyLit
+strTyLit s = pure (StrTyLit s)
-------------------------------------------------------------------------------
-- * Kind
-plainTV :: Name -> TyVarBndrQ
+plainTV :: Quote m => Name -> m TyVarBndr
plainTV = pure . PlainTV
-kindedTV :: Name -> KindQ -> TyVarBndrQ
+kindedTV :: Quote m => Name -> m Kind -> m TyVarBndr
kindedTV n = fmap (KindedTV n)
varK :: Name -> Kind
@@ -824,31 +828,31 @@ conK = ConT
tupleK :: Int -> Kind
tupleK = TupleT
-arrowK :: Kind
+arrowK :: Kind
arrowK = ArrowT
-listK :: Kind
+listK :: Kind
listK = ListT
appK :: Kind -> Kind -> Kind
appK = AppT
-starK :: KindQ
+starK :: Quote m => m Kind
starK = pure StarT
-constraintK :: KindQ
+constraintK :: Quote m => m Kind
constraintK = pure ConstraintT
-------------------------------------------------------------------------------
-- * Type family result
-noSig :: FamilyResultSigQ
+noSig :: Quote m => m FamilyResultSig
noSig = pure NoSig
-kindSig :: KindQ -> FamilyResultSigQ
+kindSig :: Quote m => m Kind -> m FamilyResultSig
kindSig = fmap KindSig
-tyVarSig :: TyVarBndrQ -> FamilyResultSigQ
+tyVarSig :: Quote m => m TyVarBndr -> m FamilyResultSig
tyVarSig = fmap TyVarSig
-------------------------------------------------------------------------------
@@ -887,23 +891,23 @@ interruptible = Interruptible
-------------------------------------------------------------------------------
-- * FunDep
-funDep :: [Name] -> [Name] -> FunDep
+funDep :: [Name] -> [Name] -> FunDep
funDep = FunDep
-------------------------------------------------------------------------------
-- * RuleBndr
-ruleVar :: Name -> RuleBndrQ
-ruleVar = return . RuleVar
+ruleVar :: Quote m => Name -> m RuleBndr
+ruleVar = pure . RuleVar
-typedRuleVar :: Name -> TypeQ -> RuleBndrQ
-typedRuleVar n ty = ty >>= return . TypedRuleVar n
+typedRuleVar :: Quote m => Name -> m Type -> m RuleBndr
+typedRuleVar n ty = TypedRuleVar n <$> ty
-------------------------------------------------------------------------------
-- * AnnTarget
-valueAnnotation :: Name -> AnnTarget
+valueAnnotation :: Name -> AnnTarget
valueAnnotation = ValueAnnotation
-typeAnnotation :: Name -> AnnTarget
+typeAnnotation :: Name -> AnnTarget
typeAnnotation = TypeAnnotation
moduleAnnotation :: AnnTarget
@@ -912,35 +916,35 @@ moduleAnnotation = ModuleAnnotation
-------------------------------------------------------------------------------
-- * Pattern Synonyms (sub constructs)
-unidir, implBidir :: PatSynDirQ
-unidir = return Unidir
-implBidir = return ImplBidir
+unidir, implBidir :: Quote m => m PatSynDir
+unidir = pure Unidir
+implBidir = pure ImplBidir
-explBidir :: [ClauseQ] -> PatSynDirQ
+explBidir :: Quote m => [m Clause] -> m PatSynDir
explBidir cls = do
- cls' <- sequence cls
- return (ExplBidir cls')
+ cls' <- sequenceA cls
+ pure (ExplBidir cls')
-prefixPatSyn :: [Name] -> PatSynArgsQ
-prefixPatSyn args = return $ PrefixPatSyn args
+prefixPatSyn :: Quote m => [Name] -> m PatSynArgs
+prefixPatSyn args = pure $ PrefixPatSyn args
-recordPatSyn :: [Name] -> PatSynArgsQ
-recordPatSyn sels = return $ RecordPatSyn sels
+recordPatSyn :: Quote m => [Name] -> m PatSynArgs
+recordPatSyn sels = pure $ RecordPatSyn sels
-infixPatSyn :: Name -> Name -> PatSynArgsQ
-infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2
+infixPatSyn :: Quote m => Name -> Name -> m PatSynArgs
+infixPatSyn arg1 arg2 = pure $ InfixPatSyn arg1 arg2
--------------------------------------------------------------
-- * Useful helper function
-appsE :: [ExpQ] -> ExpQ
+appsE :: Quote m => [m Exp] -> m Exp
appsE [] = error "appsE []"
appsE [x] = x
appsE (x:y:zs) = appsE ( (appE x y) : zs )
--- | Return the Module at the place of splicing. Can be used as an
+-- | pure the Module at the place of splicing. Can be used as an
-- input for 'reifyModule'.
thisModule :: Q Module
thisModule = do
loc <- location
- return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)
+ pure $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index fb9556db54..0abe15f3ea 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -204,6 +204,67 @@ instance Applicative Q where
-----------------------------------------------------
--
+-- The Quote class
+--
+-----------------------------------------------------
+
+
+
+-- | The 'Quote' class implements the minimal interface which is necessary for
+-- desugaring quotations.
+--
+-- * The @Monad m@ superclass is needed to stitch together the different
+-- AST fragments.
+-- * 'newName' is used when desugaring binding structures such as lambdas
+-- to generate fresh names.
+--
+-- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp`
+--
+-- For many years the type of a quotation was fixed to be `Q Exp` but by
+-- more precisely specifying the minimal interface it enables the `Exp` to
+-- be extracted purely from the quotation without interacting with `Q`.
+class Monad m => Quote m where
+ {- |
+ Generate a fresh name, which cannot be captured.
+
+ For example, this:
+
+ @f = $(do
+ nm1 <- newName \"x\"
+ let nm2 = 'mkName' \"x\"
+ return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
+ )@
+
+ will produce the splice
+
+ >f = \x0 -> \x -> x0
+
+ In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
+ and is not captured by the binding @VarP nm2@.
+
+ Although names generated by @newName@ cannot /be captured/, they can
+ /capture/ other names. For example, this:
+
+ >g = $(do
+ > nm1 <- newName "x"
+ > let nm2 = mkName "x"
+ > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
+ > )
+
+ will produce the splice
+
+ >g = \x -> \x0 -> x0
+
+ since the occurrence @VarE nm2@ is captured by the innermost binding
+ of @x@, namely @VarP nm1@.
+ -}
+ newName :: String -> m Name
+
+instance Quote Q where
+ newName s = Q (qNewName s)
+
+-----------------------------------------------------
+--
-- The TExp type
--
-----------------------------------------------------
@@ -250,7 +311,7 @@ newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp
-- expression
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
-unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r). Q (TExp a) -> Q Exp
+unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp
unTypeQ m = do { TExp e <- m
; return e }
@@ -260,7 +321,8 @@ unTypeQ m = do { TExp e <- m
-- really does have the type you claim it has.
--
-- Levity-polymorphic since /template-haskell-2.16.0.0/.
-unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> Q (TExp a)
+unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
+ Quote m => m Exp -> m (TExp a)
unsafeTExpCoerce m = do { e <- m
; return (TExp e) }
@@ -280,42 +342,6 @@ The splice will evaluate to (MkAge 3) and you can't add that to
----------------------------------------------------
-- Packaged versions for the programmer, hiding the Quasi-ness
-{- |
-Generate a fresh name, which cannot be captured.
-
-For example, this:
-
-@f = $(do
- nm1 <- newName \"x\"
- let nm2 = 'mkName' \"x\"
- return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
- )@
-
-will produce the splice
-
->f = \x0 -> \x -> x0
-
-In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
-and is not captured by the binding @VarP nm2@.
-
-Although names generated by @newName@ cannot /be captured/, they can
-/capture/ other names. For example, this:
-
->g = $(do
-> nm1 <- newName "x"
-> let nm2 = mkName "x"
-> return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
-> )
-
-will produce the splice
-
->g = \x -> \x0 -> x0
-
-since the occurrence @VarE nm2@ is captured by the innermost binding
-of @x@, namely @VarP nm1@.
--}
-newName :: String -> Q Name
-newName s = Q (qNewName s)
-- | Report an error (True) or warning (False),
-- but carry on; use 'fail' to stop.
@@ -654,13 +680,7 @@ instance Quasi Q where
-- The following operations are used solely in DsMeta when desugaring brackets
-- They are not necessary for the user, who can use ordinary return and (>>=) etc
-returnQ :: a -> Q a
-returnQ = return
-
-bindQ :: Q a -> (a -> Q b) -> Q b
-bindQ = (>>=)
-
-sequenceQ :: [Q a] -> Q [a]
+sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a]
sequenceQ = sequence
@@ -700,15 +720,15 @@ sequenceQ = sequence
class Lift (t :: TYPE r) where
-- | Turn a value into a Template Haskell expression, suitable for use in
-- a splice.
- lift :: t -> Q Exp
- default lift :: (r ~ 'LiftedRep) => t -> Q Exp
+ lift :: Quote m => t -> m Exp
+ default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp
lift = unTypeQ . liftTyped
-- | Turn a value into a Template Haskell typed expression, suitable for use
-- in a typed splice.
--
-- @since 2.16.0.0
- liftTyped :: t -> Q (TExp t)
+ liftTyped :: Quote m => t -> m (TExp t)
-- If you add any instances here, consider updating test th/TH_Lift
@@ -832,7 +852,7 @@ instance Lift a => Lift [a] where
liftTyped x = unsafeTExpCoerce (lift x)
lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
-liftString :: String -> Q Exp
+liftString :: Quote m => String -> m Exp
-- Used in TcExpr to short-circuit the lifting for strings
liftString s = return (LitE (StringL s))
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 18b12fd4e7..a6d6307b7e 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -1,5 +1,14 @@
# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
+## 2.17.0.0
+
+ * Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a
+ few fundamental things in the API. All the library combinators are generalised
+ to be in terms of a new minimal class `Quote`. The type of `lift` and `liftTyped`
+ are modified to return `m Exp` rather than `Q Exp`. Instances written in terms
+ of `Q` are now disallowed. The types of `unsafeTExpCoerce` and `unTypeQ`
+ are also generalised in terms of `Quote` rather than specific to `Q`.
+
## 2.16.0.0 *TBA*
* Add support for tuple sections. (#15843) The type signatures of `TupE` and
diff --git a/testsuite/tests/cabal/cabal04/TH.hs b/testsuite/tests/cabal/cabal04/TH.hs
index 8719c7d550..d37efa1acc 100644
--- a/testsuite/tests/cabal/cabal04/TH.hs
+++ b/testsuite/tests/cabal/cabal04/TH.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-}
module TH where
import Language.Haskell.TH
diff --git a/testsuite/tests/driver/recomp009/Sub1.hs b/testsuite/tests/driver/recomp009/Sub1.hs
index 25ea7552e4..9420c7a3f9 100644
--- a/testsuite/tests/driver/recomp009/Sub1.hs
+++ b/testsuite/tests/driver/recomp009/Sub1.hs
@@ -1,3 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-}
module Sub where
x = [| 1 |]
diff --git a/testsuite/tests/driver/recomp009/Sub2.hs b/testsuite/tests/driver/recomp009/Sub2.hs
index 7ca8b12c33..78bd05fc18 100644
--- a/testsuite/tests/driver/recomp009/Sub2.hs
+++ b/testsuite/tests/driver/recomp009/Sub2.hs
@@ -1,3 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-}
module Sub where
x = [| 2 |]
diff --git a/testsuite/tests/ghci/T16670/TH.hs b/testsuite/tests/ghci/T16670/TH.hs
index f288c784f0..36f705e2bd 100644
--- a/testsuite/tests/ghci/T16670/TH.hs
+++ b/testsuite/tests/ghci/T16670/TH.hs
@@ -1,3 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module TH where
th = [|909|]
diff --git a/testsuite/tests/ghci/scripts/T8831.hs b/testsuite/tests/ghci/scripts/T8831.hs
index b0a3cc5bdf..4bf9f6d870 100644
--- a/testsuite/tests/ghci/scripts/T8831.hs
+++ b/testsuite/tests/ghci/scripts/T8831.hs
@@ -1,3 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-}
module T8831 where
foo = [| 3 |]
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs
index 40d82bb7a2..0f8198d22d 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-}
+{-# LANGUAGE DuplicateRecordFields, TemplateHaskell, NoMonomorphismRestriction #-}
data S = MkS { x :: Int }
data T = MkT { x :: Int }
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
index 89464451ee..3867404d2c 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
@@ -17,6 +17,7 @@ import OccName
import RdrName
import Name
import Avail
+import GHC.Hs.Dump
plugin :: Plugin
plugin = defaultPlugin { parsedResultAction = parsedPlugin
@@ -52,11 +53,13 @@ typecheckPlugin [name, "typecheck"] _ tc
typecheckPlugin _ _ tc = return tc
metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
-metaPlugin' opts (L l (HsPar x e)) = (\e' -> L l (HsPar x e')) <$> metaPlugin' opts e
-metaPlugin' [name, "meta"] (L _ (HsApp noExt (L l (HsVar _ (L _ id))) e))
+metaPlugin' [name, "meta"] (L l (HsWrap ne w (HsPar x (L _ (HsApp noExt (L _ (HsVar _ (L _ id))) e)))))
| occNameString (getOccName id) == name
- = return e
-metaPlugin' _ meta = return meta
+ = return (L l (HsWrap ne w (unLoc e)))
+-- The test should always match this first case. If the desugaring changes
+-- again in the future then the panic is more useful than the previous
+-- inscrutable failure.
+metaPlugin' _ meta = pprPanic "meta" (showAstData BlankSrcSpan meta)
interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
interfaceLoadPlugin' [name, "interface"] iface
diff --git a/testsuite/tests/quotes/T6062.hs b/testsuite/tests/quotes/T6062.hs
index 342850e853..efce7b2752 100644
--- a/testsuite/tests/quotes/T6062.hs
+++ b/testsuite/tests/quotes/T6062.hs
@@ -1,2 +1,3 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T6062 where
x = [| False True |]
diff --git a/testsuite/tests/quotes/T8455.hs b/testsuite/tests/quotes/T8455.hs
index 69d1271b40..c55c5272f9 100644
--- a/testsuite/tests/quotes/T8455.hs
+++ b/testsuite/tests/quotes/T8455.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T8455 where
diff --git a/testsuite/tests/quotes/T8759a.hs b/testsuite/tests/quotes/T8759a.hs
index 37b65d6fcc..c56a363e7a 100644
--- a/testsuite/tests/quotes/T8759a.hs
+++ b/testsuite/tests/quotes/T8759a.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T8759a where
diff --git a/testsuite/tests/quotes/T9824.hs b/testsuite/tests/quotes/T9824.hs
index 9a2d6fdfef..d8e2098c07 100644
--- a/testsuite/tests/quotes/T9824.hs
+++ b/testsuite/tests/quotes/T9824.hs
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fwarn-unused-matches #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T9824 where
diff --git a/testsuite/tests/quotes/TH_bracket1.hs b/testsuite/tests/quotes/TH_bracket1.hs
index 7dee21ba01..bc0126a91d 100644
--- a/testsuite/tests/quotes/TH_bracket1.hs
+++ b/testsuite/tests/quotes/TH_bracket1.hs
@@ -1,6 +1,6 @@
-- Check that declarations in a bracket shadow the top-level
-- declarations, rather than clashing with them.
-
+{-# LANGUAGE NoMonomorphismRestriction #-}
module TH_bracket1 where
foo = 1
diff --git a/testsuite/tests/quotes/TH_bracket2.hs b/testsuite/tests/quotes/TH_bracket2.hs
index 2b06b9eecb..e903b673db 100644
--- a/testsuite/tests/quotes/TH_bracket2.hs
+++ b/testsuite/tests/quotes/TH_bracket2.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
module TH_bracket2 where
d_show = [d| data A = A
diff --git a/testsuite/tests/quotes/TH_bracket3.hs b/testsuite/tests/quotes/TH_bracket3.hs
index c746d61cd3..281b8cb081 100644
--- a/testsuite/tests/quotes/TH_bracket3.hs
+++ b/testsuite/tests/quotes/TH_bracket3.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module TH_bracket3 where
diff --git a/testsuite/tests/quotes/TH_localname.stderr b/testsuite/tests/quotes/TH_localname.stderr
index d872a622b3..6d0ccc91ec 100644
--- a/testsuite/tests/quotes/TH_localname.stderr
+++ b/testsuite/tests/quotes/TH_localname.stderr
@@ -1,21 +1,23 @@
TH_localname.hs:3:11: error:
- • Ambiguous type variable ‘t0’ arising from a use of ‘Language.Haskell.TH.Syntax.lift’
- prevents the constraint ‘(Language.Haskell.TH.Syntax.Lift
- t0)’ from being solved.
+ • Ambiguous type variable ‘m0’ arising from a quotation bracket
+ prevents the constraint ‘(Language.Haskell.TH.Syntax.Quote
+ m0)’ from being solved.
Relevant bindings include
- y :: t0 (bound at TH_localname.hs:3:6)
- x :: t0 -> Language.Haskell.TH.Lib.Internal.ExpQ
+ x :: t0 -> m0 Language.Haskell.TH.Syntax.Exp
(bound at TH_localname.hs:3:1)
- Probable fix: use a type annotation to specify what ‘t0’ should be.
- These potential instances exist:
- 29 instances involving out-of-scope types
+ Probable fix: use a type annotation to specify what ‘m0’ should be.
+ These potential instance exist:
+ one instance involving out-of-scope types
(use -fprint-potential-instances to see them all)
- • In the expression: Language.Haskell.TH.Syntax.lift y
- In the expression:
+ • In the expression:
[| y |]
pending(rn) [<y, Language.Haskell.TH.Syntax.lift y>]
In the expression:
\ y
-> [| y |]
pending(rn) [<y, Language.Haskell.TH.Syntax.lift y>]
+ In an equation for ‘x’:
+ x = \ y
+ -> [| y |]
+ pending(rn) [<y, Language.Haskell.TH.Syntax.lift y>]
diff --git a/testsuite/tests/quotes/TH_typed_csp.hs b/testsuite/tests/quotes/TH_typed_csp.hs
new file mode 100644
index 0000000000..4660fffd7f
--- /dev/null
+++ b/testsuite/tests/quotes/TH_typed_csp.hs
@@ -0,0 +1,6 @@
+-- Check that CSP works for typed quotations.. there was no test for this
+-- before apart from the deriving tests.
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module TH_typed_csp where
+
+bar = (\x -> [|| x ||]) ()
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index feefc41433..a10da1046f 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -29,3 +29,4 @@ test('TH_repE1', normal, compile, [''])
test('TH_repE3', normal, compile, [''])
test('TH_abstractFamily', normal, compile_fail, [''])
test('TH_localname', normal, compile_fail, [''])
+test('TH_typed_csp', normal, compile, [''])
diff --git a/testsuite/tests/th/T10047.stdout b/testsuite/tests/th/T10047.stdout
index ea22d78254..6855b00bdf 100644
--- a/testsuite/tests/th/T10047.stdout
+++ b/testsuite/tests/th/T10047.stdout
@@ -1,2 +1,2 @@
-[| $(dyn "foo") |] :: ExpQ
-[| [n|foo|] |] :: ExpQ
+[| $(dyn "foo") |] :: Quote m => m Exp
+[| [n|foo|] |] :: Q Exp
diff --git a/testsuite/tests/th/T12993_Lib.hs b/testsuite/tests/th/T12993_Lib.hs
index 441b783812..344cd034d0 100644
--- a/testsuite/tests/th/T12993_Lib.hs
+++ b/testsuite/tests/th/T12993_Lib.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T12993_Lib (q) where
data X = X { x :: Int }
q = [|x|]
diff --git a/testsuite/tests/th/T1476.hs b/testsuite/tests/th/T1476.hs
index 7e3a192ba0..be08f59082 100644
--- a/testsuite/tests/th/T1476.hs
+++ b/testsuite/tests/th/T1476.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T1476 where
diff --git a/testsuite/tests/th/T1476b.hs b/testsuite/tests/th/T1476b.hs
index 7d62850904..8481be1ce2 100644
--- a/testsuite/tests/th/T1476b.hs
+++ b/testsuite/tests/th/T1476b.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T1476b where
diff --git a/testsuite/tests/th/T15783B.hs b/testsuite/tests/th/T15783B.hs
index 818f57d52e..b58b2baa51 100644
--- a/testsuite/tests/th/T15783B.hs
+++ b/testsuite/tests/th/T15783B.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T15783B(f) where
d = 0
diff --git a/testsuite/tests/th/T15843a.hs b/testsuite/tests/th/T15843a.hs
index 2f413fd2c1..e0fb69ce0f 100644
--- a/testsuite/tests/th/T15843a.hs
+++ b/testsuite/tests/th/T15843a.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T15843a where
import Language.Haskell.TH
diff --git a/testsuite/tests/th/T2386_Lib.hs b/testsuite/tests/th/T2386_Lib.hs
index 4322cc9584..96fa324ef1 100644
--- a/testsuite/tests/th/T2386_Lib.hs
+++ b/testsuite/tests/th/T2386_Lib.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module T2386_Lib(ExportedAbstract, makeOne) where
diff --git a/testsuite/tests/th/T4949.hs b/testsuite/tests/th/T4949.hs
index a1cb8b4d99..b3c37eea57 100644
--- a/testsuite/tests/th/T4949.hs
+++ b/testsuite/tests/th/T4949.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module Foo where
import Language.Haskell.TH
diff --git a/testsuite/tests/th/T7276.stderr b/testsuite/tests/th/T7276.stderr
index 4fa2a3c4c9..10a592f4a5 100644
--- a/testsuite/tests/th/T7276.stderr
+++ b/testsuite/tests/th/T7276.stderr
@@ -3,6 +3,7 @@ T7276.hs:6:8: error:
• Couldn't match type ‘[Language.Haskell.TH.Syntax.Dec]’
with ‘Language.Haskell.TH.Syntax.Exp’
Expected type: Language.Haskell.TH.Lib.Internal.ExpQ
- Actual type: Language.Haskell.TH.Lib.Internal.DecsQ
+ Actual type: Language.Haskell.TH.Syntax.Q
+ Language.Haskell.TH.Lib.Internal.Decs
• In the expression: [d| y = 3 |]
In the untyped splice: $([d| y = 3 |])
diff --git a/testsuite/tests/th/T7276a.stdout b/testsuite/tests/th/T7276a.stdout
index ebcf5be338..048d305562 100644
--- a/testsuite/tests/th/T7276a.stdout
+++ b/testsuite/tests/th/T7276a.stdout
@@ -2,7 +2,7 @@
<interactive>:3:9: warning: [-Wdeferred-type-errors (in -Wdefault)]
• Couldn't match type ‘[Dec]’ with ‘Exp’
Expected type: Q Exp
- Actual type: DecsQ
+ Actual type: Q Language.Haskell.TH.Lib.Internal.Decs
• In the expression: [d| a = () |] :: Q Exp
In an equation for ‘x’: x = [d| a = () |] :: Q Exp
@@ -11,7 +11,7 @@
<interactive>:3:9: error:
• Couldn't match type ‘[Dec]’ with ‘Exp’
Expected type: Q Exp
- Actual type: DecsQ
+ Actual type: Q Language.Haskell.TH.Lib.Internal.Decs
• In the expression: [d| a = () |] :: Q Exp
In an equation for ‘x’: x = [d| a = () |] :: Q Exp
(deferred type error)
diff --git a/testsuite/tests/th/T8028a.hs b/testsuite/tests/th/T8028a.hs
index 5bdff99f4d..b944634ac1 100644
--- a/testsuite/tests/th/T8028a.hs
+++ b/testsuite/tests/th/T8028a.hs
@@ -2,5 +2,6 @@ module T8028a where
import Language.Haskell.TH
+x :: Q [Dec]
x = do n <- newName "F"
return [ClosedTypeFamilyD (TypeFamilyHead n [] NoSig Nothing) []]
diff --git a/testsuite/tests/th/TH_NestedSplices.hs b/testsuite/tests/th/TH_NestedSplices.hs
index 1af80dbcf9..f5950ef5cb 100644
--- a/testsuite/tests/th/TH_NestedSplices.hs
+++ b/testsuite/tests/th/TH_NestedSplices.hs
@@ -24,8 +24,10 @@ f x = $(spliceExpr "boo" [| x |])
g x = $(spliceExpr $(litE (stringL "boo")) [| x |])
-- Ordinary splice inside bracket
+h1 :: Q Exp
h1 = [| $(litE (integerL 3)) |]
-- Splice inside splice inside bracket
+h2 :: Q Exp
h2 = [| $(litE ($(varE 'integerL) 3)) |]
diff --git a/testsuite/tests/th/TH_StringLift.hs b/testsuite/tests/th/TH_StringLift.hs
new file mode 100644
index 0000000000..334ba14353
--- /dev/null
+++ b/testsuite/tests/th/TH_StringLift.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module TH_StringLift where
+
+import Language.Haskell.TH.Syntax
+
+foo :: Quote m => String -> m (TExp String)
+foo x = [|| x ||]
+
+foo2 :: Quote m => String -> m Exp
+foo2 x = [| x |]
diff --git a/testsuite/tests/th/TH_tuple1a.hs b/testsuite/tests/th/TH_tuple1a.hs
index 2b4bb5014b..c6894b6817 100644
--- a/testsuite/tests/th/TH_tuple1a.hs
+++ b/testsuite/tests/th/TH_tuple1a.hs
@@ -4,6 +4,7 @@ module TH_tuple1a where
import Language.Haskell.TH
+tp2, tp1, tp2u, tp1u :: Q Exp
tp2 = sigE (appsE [conE (tupleDataName 2),
litE (integerL 1),
litE (integerL 2)])
diff --git a/testsuite/tests/th/TH_unresolvedInfix.hs b/testsuite/tests/th/TH_unresolvedInfix.hs
index 49a6b03871..3c34b976a3 100644
--- a/testsuite/tests/th/TH_unresolvedInfix.hs
+++ b/testsuite/tests/th/TH_unresolvedInfix.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module Main where
diff --git a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
index 56930be3b7..04dead18ae 100644
--- a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
+++ b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoStarIsType #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module TH_unresolvedInfix_Lib where
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 3d73107231..bcaf5fbd1b 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -496,3 +496,4 @@ test('T17379b', normal, compile_fail, [''])
test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T17511', normal, compile, [''])
test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
+test('TH_StringLift', normal, compile, [''])
diff --git a/testsuite/tests/th/overloaded/Makefile b/testsuite/tests/th/overloaded/Makefile
new file mode 100644
index 0000000000..4a268530f1
--- /dev/null
+++ b/testsuite/tests/th/overloaded/Makefile
@@ -0,0 +1,4 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs
new file mode 100644
index 0000000000..565ef41c1d
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs
@@ -0,0 +1,32 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_overloaded_constraints where
+-- Test that constraints are collected properly from nested splices
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+class C m where
+ cid :: m a -> m a
+
+class D m where
+ did :: m a -> m a
+
+cq :: (C m, Quote m) => m Exp
+cq = [| 5 |]
+
+dq :: (D m, Quote m) => m Exp
+dq = [| 5 |]
+
+top_level :: (C m, D m, Quote m) => m Exp
+top_level = [| $cq + $dq |]
+
+cqt :: (C m, Quote m) => m (TExp Int)
+cqt = [|| 5 ||]
+
+dqt :: (D m, Quote m) => m (TExp Int)
+dqt = [|| 5 ||]
+
+top_level_t :: (C m, D m, Quote m) => m (TExp Int)
+top_level_t = [|| $$cqt + $$dqt ||]
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.hs b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.hs
new file mode 100644
index 0000000000..07c2163bbc
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_overloaded_constraints_fail where
+-- Test the error message when there are conflicting nested splices
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+instance Quote Identity where
+ -- Not the correct implementation, just for testing
+ newName s = Identity (Name (mkOccName s) NameS)
+
+idQ :: Identity Exp
+idQ = [| 5 |]
+
+qq :: Q Exp
+qq = [| 5 |]
+
+quote = [| $(idQ) $(qq) |]
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr
new file mode 100644
index 0000000000..d76db558c6
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr
@@ -0,0 +1,13 @@
+
+TH_overloaded_constraints_fail.hs:20:14: error:
+ • Couldn't match type ‘Identity’ with ‘Q’
+ Expected type: Q Exp
+ Actual type: Identity Exp
+ • In the expression: idQ
+ In the expression:
+ [| $(idQ) $(qq) |]
+ pending(rn) [<splice, qq>, <splice, idQ>]
+ In an equation for ‘quote’:
+ quote
+ = [| $(idQ) $(qq) |]
+ pending(rn) [<splice, qq>, <splice, idQ>]
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_csp.hs b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs
new file mode 100644
index 0000000000..c87707c01e
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+-- A test to check that CSP works with overloaded quotes
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+
+instance Quote Identity where
+ -- Not the correct implementation, just for testing
+ newName s = Identity (Name (mkOccName s) NameS)
+
+main = do
+ print $ runIdentity ((\x -> [| x |]) ())
+ print $ unType $ runIdentity ((\x -> [|| x ||]) ())
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_csp.stdout b/testsuite/tests/th/overloaded/TH_overloaded_csp.stdout
new file mode 100644
index 0000000000..5a64654110
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_csp.stdout
@@ -0,0 +1,2 @@
+ConE GHC.Tuple.()
+ConE GHC.Tuple.()
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_extract.hs b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs
new file mode 100644
index 0000000000..23c5ac5257
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs
@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+-- A simple test to check that defining a custom instance is easily
+-- possible and extraction works as expected.
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+
+instance Quote Identity where
+ -- Not the correct implementation, just for testing
+ newName s = Identity (Name (mkOccName s) NameS)
+
+main = do
+ print $ runIdentity [| 1 + 2 |]
+ print $ runIdentity [| \x -> 1 + 2 |]
+ print $ runIdentity [d| data Foo = Foo |]
+ print $ runIdentity [p| () |]
+ print $ runIdentity [t| [Int] |]
+ print $ unType $ runIdentity [|| (+1) ||]
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_extract.stdout b/testsuite/tests/th/overloaded/TH_overloaded_extract.stdout
new file mode 100644
index 0000000000..e636c0c4f1
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_extract.stdout
@@ -0,0 +1,6 @@
+InfixE (Just (LitE (IntegerL 1))) (VarE GHC.Num.+) (Just (LitE (IntegerL 2)))
+LamE [VarP x] (InfixE (Just (LitE (IntegerL 1))) (VarE GHC.Num.+) (Just (LitE (IntegerL 2))))
+[DataD [] Foo [] Nothing [NormalC Foo []] []]
+ConP GHC.Tuple.() []
+AppT ListT (ConT GHC.Types.Int)
+InfixE Nothing (VarE GHC.Num.+) (Just (LitE (IntegerL 1)))
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_no_instance.hs b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.hs
new file mode 100644
index 0000000000..18dd9e7a3e
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_overloaded_constraints_no_instance where
+-- Test the error message when there is no instance
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data NewType a
+
+-- No instance for Quote NewType
+quote2 :: NewType Exp
+quote2 = [| 5 |]
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_no_instance.stderr b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.stderr
new file mode 100644
index 0000000000..78f70c4d85
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.stderr
@@ -0,0 +1,5 @@
+
+TH_overloaded_no_instance.hs:13:10: error:
+ • No instance for (Quote NewType) arising from a quotation bracket
+ • In the expression: [| 5 |]
+ In an equation for ‘quote2’: quote2 = [| 5 |]
diff --git a/testsuite/tests/th/overloaded/all.T b/testsuite/tests/th/overloaded/all.T
new file mode 100644
index 0000000000..e5c9194ee2
--- /dev/null
+++ b/testsuite/tests/th/overloaded/all.T
@@ -0,0 +1,23 @@
+# NOTICE TO DEVELOPERS
+# ~~~~~~~~~~~~~~~~~~~~
+# Adding a TemplateHaskell test? If it only contains (non-quasi) quotes
+# and no splices, consider adding it to the quotes/ directory instead
+# of the th/ directory; this way, we can test it on the stage 1 compiler too!
+
+def f(name, opts):
+ opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell'
+setTestOpts(f)
+setTestOpts(req_interp)
+# TH should work with -fexternal-interpreter too
+if config.have_ext_interp :
+ setTestOpts(extra_ways(['ext-interp']))
+ setTestOpts(only_ways(['normal','ghci','ext-interp']))
+
+ if llvm_build():
+ setTestOpts(fragile_for(16087, ['ext-interp']))
+
+test('TH_overloaded_extract', normal, compile_and_run, [''])
+test('TH_overloaded_constraints', normal, compile, ['-v0'])
+test('TH_overloaded_constraints_fail', normal, compile_fail, ['-v0'])
+test('TH_overloaded_no_instance', normal, compile_fail, ['-v0'])
+test('TH_overloaded_csp', normal, compile_and_run, ['-v0'])
diff --git a/testsuite/tests/th/should_compile/T8025/A.hs b/testsuite/tests/th/should_compile/T8025/A.hs
index c0e3083a01..f02a57a7c5 100644
--- a/testsuite/tests/th/should_compile/T8025/A.hs
+++ b/testsuite/tests/th/should_compile/T8025/A.hs
@@ -1,3 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module A where
+
a = [|3|]