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