diff options
Diffstat (limited to 'compiler/deSugar/DsMeta.hs')
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 1063 |
1 files changed, 627 insertions, 436 deletions
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 |