import RnExpr
import HsSyn
+import HscTypes ( GlobalRdrEnv )
import HsTypes ( hsTyVarNames, pprHsContext )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
-import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName,
+import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName,
lookupOrigNames, lookupSysBinder, newLocalsRn,
- bindLocalsFVRn, bindUVarRn,
+ bindLocalsFVRn,
bindTyVarsRn, bindTyVars2Rn,
bindTyVarsFV2Rn, extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
import PrelInfo ( derivableClassKeys, cCallishClassKeys )
-import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
+import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR,
bindIO_RDR, returnIO_RDR
)
import List ( partition, nub )
%*********************************************************
\begin{code}
-rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars)
+rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv
+ -> [RdrNameHsDecl]
+ -> RnMG ([RenamedHsDecl], FreeVars)
-- The decls get reversed, but that's ok
-rnSourceDecls decls
- = go emptyFVs [] decls
+rnSourceDecls gbl_env local_fixity_env decls
+ = initRnMS gbl_env local_fixity_env SourceMode (go emptyFVs [] decls)
where
-- Fixity and deprecations have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs)
lookupOccRn name `thenRn` \ name' ->
let
extra_fvs FoExport
- | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
+ | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
bindIO_RDR, returnIO_RDR]
| otherwise =
lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
(case maybe_dfun_rdr_name of
Nothing -> returnRn Nothing
- Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
+ Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name `thenRn` \ dfun_name ->
returnRn (Just dfun_name)
) `thenRn` \ maybe_dfun_name ->
However, we can also do some scoping checks at the same time.
\begin{code}
-rnTyClDecl (IfaceSig name ty id_infos loc)
+rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
= pushSrcLocRn loc $
lookupTopBndrRn name `thenRn` \ name' ->
rnHsType doc_str ty `thenRn` \ ty' ->
mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
- returnRn (IfaceSig name' ty' id_infos' loc)
+ returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
-rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)
+rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
+ tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
+ tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names})
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ context' ->
checkDupOrQualNames data_doc con_names `thenRn_`
mapRn rnConDecl condecls `thenRn` \ condecls' ->
- lookupSysBinder gen_name1 `thenRn` \ name1' ->
- lookupSysBinder gen_name2 `thenRn` \ name2' ->
+ mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
rnDerivs derivings `thenRn` \ derivings' ->
- returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' src_loc name1' name2')
+ returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
+ tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
+ tcdDerivs = derivings', tcdLoc = src_loc, tcdSysNames = sys_names'})
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
-rnTyClDecl (TySynonym name tyvars ty src_loc)
+rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
- returnRn (TySynonym name' tyvars' ty' src_loc)
+ returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
-- For H98 we do *not* universally quantify on the RHS of a synonym
-- Silently discard context... but the tyvars in the rest won't be in scope
+ -- In interface files all types are quantified, so this is a no-op
unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
unquantify glaExys ty = ty
-rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc)
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
+ tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+ tcdSysNames = names, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') EmptyMonoBinds names' src_loc)
+ returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
+ tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
+ tcdSysNames = names', tcdLoc = src_loc})
where
cls_doc = text "the declaration for class" <+> ppr cname
sig_doc = text "the signatures for class" <+> ppr cname
-rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
+rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
= pushSrcLocRn locn $
lookupTopBndrRn op `thenRn` \ op_name ->
rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
-- Make the default-method name
- (case maybe_dm_stuff of
- Nothing -> returnRn Nothing -- Source-file class decl
-
- Just (DefMeth dm_rdr_name)
+ (case dm_stuff of
+ DefMeth dm_rdr_name
-> -- Imported class that has a default method decl
-- See comments with tname, snames, above
lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
- returnRn (Just (DefMeth dm_name))
+ returnRn (DefMeth dm_name)
-- An imported class decl for a class decl that had an explicit default
-- method, mentions, rather than defines,
-- the default method, so we must arrange to pull it in
- Just GenDefMeth -> returnRn (Just GenDefMeth)
- Just NoDefMeth -> returnRn (Just NoDefMeth)
- ) `thenRn` \ maybe_dm_stuff' ->
+ GenDefMeth -> returnRn GenDefMeth
+ NoDefMeth -> returnRn NoDefMeth
+ ) `thenRn` \ dm_stuff' ->
- returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn)
+ returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
- -- Rename the mbinds only; the rest is done already
-rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- Get mbinds from here
- (ClassDecl context cname tyvars fds sigs _ names src_loc) -- Everything else is here
+rnClassBinds (ClassDecl {tcdMeths = Nothing})
+ rn_cls_decl@(ClassDecl {tcdSigs = sigs})
+ -- No method bindings, so this class decl comes from an interface file,
+ -- However we want to treat the default-method names as free (they should
+ -- be defined somewhere else). [In source code this is not so; the class
+ -- decl will bind whatever default-methods are necessary.]
+ = returnRn (rn_cls_decl, mkFVs [v | ClassOpSig _ (DefMeth v) _ _ <- sigs])
+
+rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here
+ rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here
+ -- There are some default-method bindings (abeit possibly empty) so
+ -- this is a source-code class declaration
= -- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op :: a -> a
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
- returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs)
+ returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where
- meth_doc = text "the default-methods for class" <+> ppr cname
+ meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
-- Not a class declaration
= rnPred doc pred `thenRn` \ pred' ->
returnRn (HsPredTy pred')
-rnHsType doc (HsUsgForAllTy uv_rdr ty)
- = bindUVarRn uv_rdr $ \ uv_name ->
- rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsUsgForAllTy uv_name ty')
-
-rnHsType doc (HsUsgTy usg ty)
- = newUsg usg `thenRn` \ usg' ->
- rnHsType doc ty `thenRn` \ ty' ->
- -- A for-all can occur inside a usage annotation
- returnRn (HsUsgTy usg' ty')
- where
- newUsg usg = case usg of
- HsUsOnce -> returnRn HsUsOnce
- HsUsMany -> returnRn HsUsMany
- HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
- returnRn (HsUsVar uv_name)
-
rnHsTypes doc tys = mapRn (rnHsType doc) tys
\end{code}
projects / ghc-hetmet.git / blobdiff