summaryrefslogtreecommitdiff
path: root/compiler/deSugar/DsMeta.hs
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2017-05-19 14:56:09 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2017-06-06 00:16:20 +0200
commit8e6ec0fa7431b0454b09c0011a615f0845df1198 (patch)
treed6b3604e0ceac3d81d0510669f7ccce9a2bf3ae2 /compiler/deSugar/DsMeta.hs
parentc9eb4385aad248118650725b7b699bb97ee21c0d (diff)
downloadhaskell-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.hs231
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) }