summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-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
15 files changed, 917 insertions, 556 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 13ca6b0eff..d05c5db68b 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 5974b4ec63..59882aa9bd 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
@@ -2323,6 +2325,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 ee5b72033f..c5b42264c9 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 bfbb4d260c..d0079bc763 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 RnSplice, 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 RnSplice
@@ -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 b2248073d8..9c520e071f 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 b256edb911..45cbe7ec4e 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
View Lorry Controller Status