diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2017-05-19 14:56:09 +0200 |
---|---|---|
committer | Alan Zimmerman <alan.zimm@gmail.com> | 2017-06-06 00:16:20 +0200 |
commit | 8e6ec0fa7431b0454b09c0011a615f0845df1198 (patch) | |
tree | d6b3604e0ceac3d81d0510669f7ccce9a2bf3ae2 /compiler/deSugar/DsMeta.hs | |
parent | c9eb4385aad248118650725b7b699bb97ee21c0d (diff) | |
download | haskell-8e6ec0fa7431b0454b09c0011a615f0845df1198.tar.gz |
Udate hsSyn AST to use Trees that Grow
Summary:
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow
This commit prepares the ground for a full extensible AST, by replacing the type
parameter for the hsSyn data types with a set of indices into type families,
data GhcPs -- ^ Index for GHC parser output
data GhcRn -- ^ Index for GHC renamer output
data GhcTc -- ^ Index for GHC typechecker output
These are now used instead of `RdrName`, `Name` and `Id`/`TcId`/`Var`
Where the original name type is required in a polymorphic context, this is
accessible via the IdP type family, defined as
type family IdP p
type instance IdP GhcPs = RdrName
type instance IdP GhcRn = Name
type instance IdP GhcTc = Id
These types are declared in the new 'hsSyn/HsExtension.hs' module.
To gain a better understanding of the extension mechanism, it has been applied
to `HsLit` only, also replacing the `SourceText` fields in them with extension
types.
To preserve extension generality, a type class is introduced to capture the
`SourceText` interface, which must be honoured by all of the extension points
which originally had a `SourceText`. The class is defined as
class HasSourceText a where
-- Provide setters to mimic existing constructors
noSourceText :: a
sourceText :: String -> a
setSourceText :: SourceText -> a
getSourceText :: a -> SourceText
And the constraint is captured in `SourceTextX`, which is a constraint type
listing all the extension points that make use of the class.
Updating Haddock submodule to match.
Test Plan: ./validate
Reviewers: simonpj, shayan-najd, goldfire, austin, bgamari
Subscribers: rwbarton, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D3609
Diffstat (limited to 'compiler/deSugar/DsMeta.hs')
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 231 |
1 files changed, 119 insertions, 112 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index bb4361e34a..f7f2fd597e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- @@ -64,7 +65,7 @@ import Control.Monad import Data.List ----------------------------------------------------------------------------- -dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr +dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr -- Returns a CoreExpr of type TH.ExpQ -- The quoted thing is parameterised over Name, even though it has -- been type checked. We don't want all those type decorations! @@ -101,12 +102,12 @@ dsBracket brack splices -- Declarations ------------------------------------------------------- -repTopP :: LPat Name -> DsM (Core TH.PatQ) +repTopP :: LPat GhcRn -> DsM (Core TH.PatQ) repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) ; pat' <- addBinds ss (repLP pat) ; wrapGenSyms ss pat' } -repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) +repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec])) repTopDs group@(HsGroup { hs_valds = valds , hs_splcds = splcds , hs_tyclds = tyclds @@ -178,12 +179,12 @@ repTopDs group@(HsGroup { hs_valds = valds no_doc (L loc _) = notHandledL loc "Haddock documentation" empty -hsSigTvBinders :: HsValBinds Name -> [Name] +hsSigTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings] hsSigTvBinders binds = concatMap get_scoped_tvs sigs where - get_scoped_tvs :: LSig Name -> [Name] + get_scoped_tvs :: LSig GhcRn -> [Name] -- Both implicit and explicit quantified variables -- We need the implicit ones for f :: forall (a::k). blah -- here 'k' scopes too @@ -262,7 +263,7 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. -- represent associated family instances -- -repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam) @@ -297,7 +298,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, } ------------------------- -repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRoleD (L loc (RoleAnnotDecl tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles @@ -308,7 +309,7 @@ repRoleD (L loc (RoleAnnotDecl tycon roles)) ------------------------- repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) - -> HsDataDefn Name + -> HsDataDefn GhcRn -> DsM (Core TH.DecQ) repDataDefn tc bndrs opt_tys (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig @@ -331,20 +332,20 @@ repDataDefn tc bndrs opt_tys } repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] - -> LHsType Name + -> LHsType GhcRn -> DsM (Core TH.DecQ) repSynDecl tc bndrs ty = do { ty1 <- repLTy ty ; repTySyn tc bndrs ty1 } -repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdLName = tc, fdTyVars = tvs, fdResultSig = L _ resultSig, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name + ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs , hsq_dependent = emptyNameSet } resTyVar = case resultSig of @@ -372,7 +373,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, } -- | Represent result signature of a type family -repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig) +repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSig) repFamilyResultSig NoSig = repNoSig repFamilyResultSig (KindSig ki) = do { ki' <- repLKind ki ; repKindSig ki' } @@ -382,7 +383,7 @@ repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named -- result variable. -repFamilyResultSigToMaybeKind :: FamilyResultSig Name +repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn -> DsM (Core (Maybe TH.Kind)) repFamilyResultSigToMaybeKind NoSig = do { coreNothing kindTyConName } @@ -392,7 +393,7 @@ repFamilyResultSigToMaybeKind (KindSig ki) = repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" -- | Represent injectivity annotation of a type family -repInjectivityAnn :: Maybe (LInjectivityAnn Name) +repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> DsM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = do { coreNothing injAnnTyConName } @@ -403,14 +404,14 @@ repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2] ; coreJust injAnnTyConName injAnn } -repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] +repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ] repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) -repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ] +repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ] repAssocTyFamDefaults = mapM rep_deflt where -- very like repTyFamEqn, but different in the details - rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ) + rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ) rep_deflt (L _ (TyFamEqn { tfe_tycon = tc , tfe_pats = bndrs , tfe_rhs = rhs })) @@ -436,7 +437,7 @@ repLFunDep (L _ (xs, ys)) -- Represent instance declarations -- -repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl ; return (loc, dec) } @@ -447,7 +448,7 @@ repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } -repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) +repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds , cid_sigs = prags, cid_tyfam_insts = ats , cid_datafam_insts = adts @@ -475,7 +476,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat , deriv_type = ty })) = do { dec <- addSimpleTyVarBinds tvs $ @@ -487,14 +488,14 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) +repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) = do { let tc_name = tyFamInstDeclLName decl ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; eqn1 <- repTyFamEqn eqn ; repTySynInst tc eqn1 } -repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) +repTyFamEqn :: LTyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys , hsib_vars = var_names } , tfe_rhs = rhs })) @@ -507,7 +508,7 @@ repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys ; rhs1 <- repLTy rhs ; repTySynEqn tys2 rhs1 } } -repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) +repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names } , dfid_defn = defn }) @@ -519,7 +520,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name do { tys1 <- repList typeQTyConName repLTy tys ; repDataDefn tc bndrs (Just tys1) defn } } -repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) +repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name @@ -560,7 +561,7 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] -repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)] +repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] repFixD (L loc (FixitySig names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of @@ -573,7 +574,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir))) ; return (loc,dec) } ; mapM do_one names } -repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) = do { let bndr_names = concatMap ruleBndrNames bndrs ; ss <- mkGenSyms bndr_names @@ -587,13 +588,13 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ; rule2 <- wrapGenSyms ss rule1 ; return (loc, rule2) } -ruleBndrNames :: LRuleBndr Name -> [Name] +ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] ruleBndrNames (L _ (RuleBndrSig n sig)) | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig = unLoc n : vars -repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) +repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) repRuleBndr (L _ (RuleBndr n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } @@ -602,7 +603,7 @@ repRuleBndr (L _ (RuleBndrSig n sig)) ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } -repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp @@ -623,7 +624,7 @@ repAnnProv ModuleAnnProvenance -- Constructors ------------------------------------------------------- -repC :: LConDecl Name -> DsM (Core TH.ConQ) +repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) repC (L _ (ConDeclH98 { con_name = con , con_qvars = Nothing, con_cxt = Nothing , con_details = details })) @@ -681,7 +682,7 @@ repSrcStrictness SrcLazy = rep2 sourceLazyName [] repSrcStrictness SrcStrict = rep2 sourceStrictName [] repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] -repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ)) +repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ)) repBangTy ty = do MkC u <- repSrcUnpackedness su' MkC s <- repSrcStrictness ss' @@ -697,10 +698,10 @@ repBangTy ty = do -- Deriving clauses ------------------------------------------------------- -repDerivs :: HsDeriving Name -> DsM (Core [TH.DerivClauseQ]) +repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses -repDerivClause :: LHsDerivingClause Name +repDerivClause :: LHsDerivingClause GhcRn -> DsM (Core TH.DerivClauseQ) repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct })) @@ -708,22 +709,22 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct'] where - rep_deriv_ty :: LHsType Name -> DsM (Core TH.TypeQ) + rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) rep_deriv_ty (L _ ty) = repTy ty ------------------------------------------------------- -- Signatures in a class decl, or a group of bindings ------------------------------------------------------- -rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ] +rep_sigs :: [LSig GhcRn] -> DsM [Core TH.DecQ] rep_sigs sigs = do locs_cores <- rep_sigs' sigs return $ de_loc $ sort_by_loc locs_cores -rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sigs' :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] -- We silently ignore ones we don't recognise rep_sigs' = concatMapM rep_sig -rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms rep_sig (L loc (ClassOpSig is_deflt nms ty)) @@ -740,7 +741,7 @@ rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc -rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) rep_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm @@ -748,7 +749,7 @@ rep_ty_sig mk_sig loc sig_ty nm ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -- represents a pattern synonym type signature; -- see Note [Pattern synonym type signatures and Template Haskell] in Convert @@ -758,7 +759,7 @@ rep_patsyn_ty_sig loc sig_ty nm ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -- We must special-case the top-level explicit for-all of a TypeSig -- See Note [Scoped type variables in bindings] @@ -794,7 +795,8 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan +rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm @@ -810,7 +812,8 @@ rep_specialise nm ty ispec loc ; return [(loc, pragma)] } -rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialiseInst ty loc = do { ty1 <- repHsSigType ty ; pragma <- repPragSpecInst ty1 @@ -860,7 +863,7 @@ addSimpleTyVarBinds names thing_inside ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } -addTyVarBinds :: LHsQTyVars Name -- the binders to be added +addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; @@ -879,7 +882,7 @@ addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -addTyClTyVarBinds :: LHsQTyVars Name +addTyClTyVarBinds :: LHsQTyVars GhcRn -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -> DsM (Core (TH.Q a)) @@ -906,7 +909,7 @@ addTyClTyVarBinds tvs m -- Produce kinded binder constructors from the Haskell tyvar binders -- -repTyVarBndrWithKind :: LHsTyVarBndr Name +repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar _)) nm = repPlainTV nm @@ -914,7 +917,7 @@ repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm = repLKind ki >>= repKindedTV nm -- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr) +repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndr) repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm ; repPlainTV nm' } repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm @@ -923,14 +926,14 @@ repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm -- represent a type context -- -repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) +repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ) repLContext (L _ ctxt) = repContext ctxt -repContext :: HsContext Name -> DsM (Core TH.CxtQ) +repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt repCtxt preds -repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) +repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body @@ -946,7 +949,7 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } -repHsPatSynSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) +repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs , hsib_body = body }) = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs -> @@ -965,19 +968,19 @@ repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body -repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) +repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1 -- yield the representation of a list of types -repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] +repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] repLTys tys = mapM repLTy tys -- represent a type -repLTy :: LHsType Name -> DsM (Core TH.TypeQ) +repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ) repLTy (L _ ty) = repTy ty -repForall :: HsType Name -> DsM (Core TH.TypeQ) +repForall :: HsType GhcRn -> DsM (Core TH.TypeQ) -- Arg of repForall is always HsForAllTy or HsQualTy repForall ty | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) @@ -987,7 +990,7 @@ repForall ty ; ty1 <- repLTy tau ; repTForall bndrs ctxt1 ty1 } -repTy :: HsType Name -> DsM (Core TH.TypeQ) +repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty @@ -1066,7 +1069,7 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s -- represent a kind -- -repLKind :: LHsKind Name -> DsM (Core TH.Kind) +repLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) repLKind ki = do { let (kis, ki') = splitHsFunType ki ; kis_rep <- mapM repLKind kis @@ -1077,7 +1080,7 @@ repLKind ki } -- | Represent a kind wrapped in a Maybe -repMaybeLKind :: Maybe (LHsKind Name) +repMaybeLKind :: Maybe (LHsKind GhcRn) -> DsM (Core (Maybe TH.Kind)) repMaybeLKind Nothing = do { coreNothing kindTyConName } @@ -1085,10 +1088,10 @@ repMaybeLKind (Just ki) = do { ki' <- repLKind ki ; coreJust kindTyConName ki' } -repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) +repNonArrowLKind :: LHsKind GhcRn -> DsM (Core TH.Kind) repNonArrowLKind (L _ ki) = repNonArrowKind ki -repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) +repNonArrowKind :: HsKind GhcRn -> DsM (Core TH.Kind) repNonArrowKind (HsTyVar _ (L _ name)) | isLiftedTypeKindTyConName name = repKStar | name `hasKey` constraintKindTyConKey = repKConstraint @@ -1118,7 +1121,7 @@ repRole (L _ Nothing) = rep2 inferRName [] -- Splices ----------------------------------------------------------------------------- -repSplice :: HsSplice Name -> DsM (Core a) +repSplice :: HsSplice GhcRn -> DsM (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 @@ -1139,16 +1142,16 @@ rep_splice splice_name -- Expressions ----------------------------------------------------------------------------- -repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) +repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ]) repLEs es = repList expQTyConName 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 Name -> DsM (Core TH.ExpQ) +repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) -repE :: HsExpr Name -> DsM (Core TH.ExpQ) +repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) repE (HsVar (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of @@ -1284,7 +1287,7 @@ repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, -repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) +repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -1296,7 +1299,7 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = ; wrapGenSyms (ss1++ss2) match }}} repMatchTup _ = panic "repMatchTup: case alt with more than one arg" -repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) +repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { @@ -1307,7 +1310,7 @@ repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ) +repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] = do {a <- repLE e; repNormal a } repGuards other @@ -1316,7 +1319,8 @@ repGuards other ; gd <- repGuarded (nonEmptyCoreList ys) ; wrapGenSyms (concat xs) gd } -repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) +repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) + -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } @@ -1326,19 +1330,20 @@ repLGRHS (L _ (GRHS ss rhs)) ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' ; return (gs, guarded) } -repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) +repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) = repList fieldExpQTyConName rep_fld flds where - rep_fld :: LHsRecField Name (LHsExpr Name) -> DsM (Core (TH.Q TH.FieldExp)) + rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) + -> DsM (Core (TH.Q TH.FieldExp)) rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } -repUpdFields :: [LHsRecUpdField Name] -> DsM (Core [TH.Q TH.FieldExp]) +repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) repUpdFields = repList fieldExpQTyConName rep_fld where - rep_fld :: LHsRecUpdField Name -> DsM (Core (TH.Q TH.FieldExp)) + rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q 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) @@ -1372,10 +1377,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 Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) -repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repSts (BindStmt p e _ _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) @@ -1402,7 +1407,8 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) = ; (ss2, zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } where - rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ]) + rep_stmt_block :: ParStmtBlock GhcRn GhcRn + -> DsM ([GenSymBind], Core [TH.StmtQ]) rep_stmt_block (ParStmtBlock stmts _ _) = do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs @@ -1419,7 +1425,7 @@ repSts other = notHandled "Exotic statement" (ppr other) -- Bindings ----------------------------------------------------------- -repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds EmptyLocalBinds = do { core_list <- coreList decQTyConName [] ; return ([], core_list) } @@ -1439,7 +1445,7 @@ repBinds (HsValBinds decs) (de_loc (sort_by_loc prs)) ; return (ss, core_list) } -rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are already in the meta-env rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) @@ -1448,14 +1454,14 @@ rep_val_binds (ValBindsOut binds sigs) rep_val_binds (ValBindsIn _ _) = panic "rep_val_binds: ValBindsIn" -rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] +rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds ; return (de_loc (sort_by_loc binds_w_locs)) } -rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds' :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] rep_binds' = mapM rep_bind . bagToList -rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) +rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are already in the meta-env -- Note GHC treats declarations of a variable (not a pattern) @@ -1571,7 +1577,7 @@ repRecordPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ) repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] -repPatSynDir :: HsPatSynDir Name -> DsM (Core TH.PatSynDirQ) +repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) repPatSynDir Unidirectional = rep2 unidirPatSynName [] repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses })) @@ -1606,7 +1612,7 @@ 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 Name (LHsExpr Name) -> DsM (Core TH.ExpQ) +repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs @@ -1625,13 +1631,13 @@ repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m) -- variable should already appear in the environment. -- Process a list of patterns -repLPs :: [LPat Name] -> DsM (Core [TH.PatQ]) +repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ]) repLPs ps = repList patQTyConName repLP ps -repLP :: LPat Name -> DsM (Core TH.PatQ) +repLP :: LPat GhcRn -> DsM (Core TH.PatQ) repLP (L _ p) = repP p -repP :: Pat Name -> DsM (Core TH.PatQ) +repP :: Pat GhcRn -> DsM (Core TH.PatQ) repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } @@ -1656,7 +1662,7 @@ repP (ConPatIn dc details) repPinfix p1' con_str p2' } } where - rep_fld :: LHsRecField Name (LPat Name) -> DsM (Core (TH.Name,TH.PatQ)) + rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ)) rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } @@ -1977,7 +1983,8 @@ repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) repNormal (MkC e) = rep2 normalBName [e] ------------ Guards ---- -repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn + -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) repLNormalGE g e = do g' <- repLE g e' <- repLE e repNormalGE g' e' @@ -2171,15 +2178,15 @@ repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] repDataCon :: Located Name - -> HsConDeclDetails Name + -> HsConDeclDetails GhcRn -> DsM (Core TH.ConQ) repDataCon con details = do con' <- lookupLOcc con -- See Note [Binders and occurrences] repConstr details Nothing [con'] repGadtDataCons :: [Located Name] - -> HsConDeclDetails Name - -> LHsType Name + -> HsConDeclDetails GhcRn + -> LHsType GhcRn -> DsM (Core TH.ConQ) repGadtDataCons cons details res_ty = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] @@ -2190,8 +2197,8 @@ repGadtDataCons cons details res_ty -- argument is a singleton list -- * for GADTs data constructors second argument is (Just return_type) and -- third argument is a non-empty list -repConstr :: HsConDeclDetails Name - -> Maybe (LHsType Name) +repConstr :: HsConDeclDetails GhcRn + -> Maybe (LHsType GhcRn) -> [Core TH.Name] -> DsM (Core TH.ConQ) repConstr (PrefixCon ps) Nothing [con] @@ -2216,7 +2223,7 @@ repConstr (RecCon (L _ ips)) resTy cons where rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) - rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a) + rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } @@ -2359,7 +2366,7 @@ repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] ---------------------------------------------------------- -- Literals -repLiteral :: HsLit -> DsM (Core TH.Lit) +repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit) repLiteral (HsStringPrim _ bs) = do dflags <- getDynFlags word8_ty <- lookupType word8TyConName @@ -2371,9 +2378,9 @@ repLiteral lit = do lit' <- case lit of HsIntPrim _ i -> mk_integer i HsWordPrim _ w -> mk_integer w - HsInt i -> mk_integer (il_value i) - HsFloatPrim r -> mk_rational r - HsDoublePrim r -> mk_rational r + HsInt _ i -> mk_integer (il_value i) + HsFloatPrim _ r -> mk_rational r + HsDoublePrim _ r -> mk_rational r HsCharPrim _ c -> mk_char c _ -> return lit lit_expr <- dsLit lit' @@ -2383,38 +2390,38 @@ repLiteral lit where mb_lit_name = case lit of HsInteger _ _ _ -> Just integerLName - HsInt _ -> Just integerLName + HsInt _ _ -> Just integerLName HsIntPrim _ _ -> Just intPrimLName HsWordPrim _ _ -> Just wordPrimLName - HsFloatPrim _ -> Just floatPrimLName - HsDoublePrim _ -> Just doublePrimLName + HsFloatPrim _ _ -> Just floatPrimLName + HsDoublePrim _ _ -> Just doublePrimLName HsChar _ _ -> Just charLName HsCharPrim _ _ -> Just charPrimLName HsString _ _ -> Just stringLName - HsRat _ _ -> Just rationalLName + HsRat _ _ _ -> Just rationalLName _ -> Nothing -mk_integer :: Integer -> DsM HsLit +mk_integer :: Integer -> DsM (HsLit GhcRn) mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger NoSourceText i integer_ty + return $ HsInteger noSourceText i integer_ty -mk_rational :: FractionalLit -> DsM HsLit +mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty -mk_string :: FastString -> DsM HsLit -mk_string s = return $ HsString NoSourceText s + return $ HsRat def r rat_ty +mk_string :: FastString -> DsM (HsLit GhcRn) +mk_string s = return $ HsString noSourceText s -mk_char :: Char -> DsM HsLit -mk_char c = return $ HsChar NoSourceText c +mk_char :: Char -> DsM (HsLit GhcRn) +mk_char c = return $ HsChar noSourceText c -repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) +repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) = do { lit <- mk_lit val; repLiteral lit } -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used -mk_lit :: OverLitVal -> DsM HsLit +mk_lit :: OverLitVal -> DsM (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 @@ -2443,12 +2450,12 @@ repUnboundVar (MkC name) = rep2 unboundVarEName [name] -- turn a list of patterns into a single pattern matching a list repList :: Name -> (a -> DsM (Core b)) - -> [a] -> DsM (Core [b]) + -> [a] -> DsM (Core [b]) repList tc_name f args = do { args1 <- mapM f args ; coreList tc_name args1 } -coreList :: Name -- Of the TyCon of the element type +coreList :: Name -- Of the TyCon of the element type -> [Core a] -> DsM (Core [a]) coreList tc_name es = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } |