X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=b5386a3d1ab543975eaed852020c52c31e23cb12;hb=0299e1a135c5805e09ed8e2271b3b17fc8a04869;hp=b74e3e77a470cb5238e78a21ea68125403d24c15;hpb=56883a7f06775ed47b21f5ff5c0c31ed99665195;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index b74e3e7..b5386a3 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -11,7 +11,7 @@ module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, import RnExpr import HsSyn -import HscTypes ( GlobalRdrEnv ) +import HscTypes ( GlobalRdrEnv, AvailEnv ) import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, extractGenericPatTyVars @@ -25,8 +25,7 @@ import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs ) import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName, lookupOrigNames, lookupSysBinder, newLocalsRn, bindLocalsFVRn, bindPatSigTyVars, - bindTyVarsRn, bindTyVars2Rn, - extendTyVarEnvFVRn, + bindTyVarsRn, extendTyVarEnvFVRn, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, checkDupOrQualNames, checkDupNames, mapFvRn ) @@ -37,8 +36,8 @@ import DataCon ( dataConId ) import Name ( Name, NamedThing(..) ) import NameSet import PrelInfo ( derivableClassKeys ) -import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR, - bindIO_RDR, returnIO_RDR +import PrelNames ( deRefStablePtrName, newStablePtrName, + bindIOName, returnIOName ) import TysWiredIn ( tupleCon ) import List ( partition ) @@ -73,13 +72,13 @@ Checks the @(..)@ etc constraints in the export list. %********************************************************* \begin{code} -rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv +rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv -> [RdrNameHsDecl] -> RnMG ([RenamedHsDecl], FreeVars) -- The decls get reversed, but that's ok -rnSourceDecls gbl_env local_fixity_env decls - = initRnMS gbl_env emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls) +rnSourceDecls gbl_env avails local_fixity_env decls + = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls) where -- Fixity and deprecations have been dealt with already; ignore them go fvs ds' [] = returnRn (ds', fvs) @@ -128,22 +127,24 @@ rnSourceDecl (DefD (DefaultDecl tys src_loc)) %********************************************************* \begin{code} -rnHsForeignDecl (ForeignImport name ty spec src_loc) +rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) = pushSrcLocRn src_loc $ lookupTopBndrRn name `thenRn` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) -> - lookupOrigNames (extras spec) `thenRn` \ fvs2 -> - returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2) + rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) -> + returnRn (ForeignImport name' ty' spec isDeprec src_loc, + fvs `plusFV` extras spec) where - extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR] - extras other = [] + extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName, + deRefStablePtrName, + bindIOName, returnIOName] + extras _ = emptyFVs -rnHsForeignDecl (ForeignExport name ty spec src_loc) +rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc) = pushSrcLocRn src_loc $ lookupOccRn name `thenRn` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) -> - lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 -> - returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2) + rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) -> + returnRn (ForeignExport name' ty' spec isDeprec src_loc, + mkFVs [bindIOName, returnIOName] `plusFV` fvs) fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name \end{code} @@ -178,9 +179,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) let meth_doc = text "In the bindings in an instance declaration" meth_names = collectLocatedMonoBinders mbinds - inst_tyvars = case inst_ty of - HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars - other -> [] + (inst_tyvars, (cls,_)) = getHsInstHead inst_ty -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too in @@ -189,7 +188,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) -- NB meth_names can be qualified! checkDupNames meth_doc meth_names `thenRn_` extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) ( - rnMethodBinds [] mbinds + rnMethodBinds cls [] mbinds ) `thenRn` \ (mbinds', meth_fvs) -> let binders = collectMonoBinders mbinds' @@ -294,11 +293,12 @@ rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_n rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, - tcdLoc = src_loc, tcdSysNames = sys_names}) + tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names}) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenRn` \ context' -> + rn_derivs derivs `thenRn` \ derivs' -> checkDupOrQualNames data_doc con_names `thenRn_` -- Check that there's at least one condecl, @@ -315,11 +315,14 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, mapRn lookupSysBinder sys_names `thenRn` \ sys_names' -> returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs, - tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'}) + tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'}) where data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls + rn_derivs Nothing = returnRn Nothing + rn_derivs (Just ds) = rnContext data_doc ds `thenRn` \ ds' -> returnRn (Just ds') + rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) = pushSrcLocRn src_loc $ lookupTopBndrRn name `thenRn` \ name' -> @@ -344,7 +347,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, mapRn lookupSysBinder names `thenRn` \ names' -> -- Tyvars scope over bindings and context - bindTyVars2Rn cls_doc tyvars $ \ clas_tyvar_names tyvars' -> + bindTyVarsRn cls_doc tyvars $ \ tyvars' -> -- Check the superclasses rnContext cls_doc context `thenRn` \ context' -> @@ -358,8 +361,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, (op_sigs, non_op_sigs) = partition isClassOpSig sigs sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs `thenRn` \ sigs' -> + checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` + mapRn (rnClassOp cname' fds') op_sigs `thenRn` \ sigs' -> let binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] in @@ -377,7 +380,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, cls_doc = text "In the declaration for class" <+> ppr cname sig_doc = text "In the signatures for class" <+> ppr cname -rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn) +rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn) = pushSrcLocRn locn $ lookupTopBndrRn op `thenRn` \ op_name -> @@ -404,15 +407,8 @@ rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn) finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) -- Used for source file decls only -- Renames the default-bindings of a class decl - -- the derivings of a data decl -finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Derivings in here - rn_ty_decl -- Everything else is here - = pushSrcLocRn src_loc $ - mapRn rnDeriv derivs `thenRn` \ derivs' -> - returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs') - finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here - rn_cls_decl@(ClassDecl {tcdTyVars = tyvars}) -- Everything else is here + rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- 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 @@ -434,13 +430,13 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G in 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) -> + rnMethodBinds cls gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) where meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) - -- Not a class or data type declaration + -- Not a class declaration \end{code} @@ -451,15 +447,6 @@ finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) %********************************************************* \begin{code} -rnDeriv :: RdrName -> RnMS Name -rnDeriv cls - = lookupOccRn cls `thenRn` \ clas_name -> - checkRn (getUnique clas_name `elem` derivableClassKeys) - (derivingNonStdClassErr clas_name) `thenRn_` - returnRn clas_name -\end{code} - -\begin{code} conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) conDeclName (ConDecl n _ _ _ _ l) = (n,l) @@ -706,11 +693,9 @@ validRuleLhs foralls lhs %********************************************************* \begin{code} -derivingNonStdClassErr clas - = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")] - badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] + badRuleLhsErr name lhs = sep [ptext SLIT("Rule") <+> ptext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]