From: simonpj Date: Thu, 5 Apr 2001 11:31:26 +0000 (+0000) Subject: [project @ 2001-04-05 11:31:26 by simonpj] X-Git-Tag: Approximately_9120_patches~2192 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=111972366435025b2f73bba8b4bdbfdca654528e;hp=b58e1155b0ec79ec6983c3e9a42880d511b7bc10;p=ghc-hetmet.git [project @ 2001-04-05 11:31:26 by simonpj] -------------------------------- Better grouping for ty/cls decls -------------------------------- When finding mutually-recursive groups of type and class decls, we shouldn't include classes mentioned in a deriving clause as edges. E.g. class Eq a where ... data Bool = True | False deriving( Eq ) Eq and Bool are not mutually recursive. The edges are computed by RnHsSyn.tyClDeclFVs, so we remove the derivings from there. There a consequential fix in RnSource.rnSourceDecl --- diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 80627db..8f01d67 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -15,7 +15,6 @@ import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) -import Maybes ( orElse ) import Outputable \end{code} @@ -127,8 +126,7 @@ tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos}) tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings}) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` - plusFVs (map conDeclFVs condecls) `plusFV` - mkNameSet (derivings `orElse` []) + plusFVs (map conDeclFVs condecls) tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty}) = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 491e4bf..da6a060 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -99,13 +99,13 @@ rnSourceDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> returnRn (ValD new_binds, fvs) rnSourceDecl (TyClD tycl_decl) - = rnTyClDecl tycl_decl `thenRn` \ new_decl -> - rnClassBinds tycl_decl new_decl `thenRn` \ (new_decl', fvs) -> + = rnTyClDecl tycl_decl `thenRn` \ new_decl -> + finishSourceTyClDecl tycl_decl new_decl `thenRn` \ (new_decl', fvs) -> returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl') rnSourceDecl (InstD inst) - = rnInstDecl inst `thenRn` \ new_inst -> - rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) -> + = rnInstDecl inst `thenRn` \ new_inst -> + finishSourceInstDecl inst new_inst `thenRn` \ (new_inst', fvs) -> returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst') rnSourceDecl (RuleD rule) @@ -169,9 +169,9 @@ rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) -- The typechecker checks that all the bindings are for the right class. returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc) --- Compare rnClassBinds -rnInstBinds (InstDecl _ mbinds uprags _ _ ) - (InstDecl inst_ty _ _ maybe_dfun_name src_loc) +-- Compare finishSourceTyClDecl +finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) + (InstDecl inst_ty _ _ maybe_dfun_name src_loc) -- Used for both source decls only = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl! let @@ -286,7 +286,7 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, - tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names}) + tcdLoc = src_loc, tcdSysNames = sys_names}) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> @@ -294,10 +294,9 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, checkDupOrQualNames data_doc con_names `thenRn_` mapRn rnConDecl condecls `thenRn` \ condecls' -> mapRn lookupSysBinder sys_names `thenRn` \ sys_names' -> - rnDerivs derivings `thenRn` \ derivings' -> returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs, - tcdDerivs = derivings', tcdLoc = src_loc, tcdSysNames = sys_names'}) + tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'}) where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls @@ -390,10 +389,18 @@ rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn) returnRn (ClassOpSig op_name dm_stuff' new_ty locn) -rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) +finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) -- Used for source file decls only -rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here - rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here + -- 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 -- 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 @@ -405,6 +412,7 @@ rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. -- Hence the + pushSrcLocRn src_loc $ extendTyVarEnvFVRn (map hsTyVarName tyvars) $ getLocalNameEnv `thenRn` \ name_env -> let @@ -419,7 +427,7 @@ rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here where meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl) -rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) +finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) -- Not a class declaration \end{code} @@ -431,19 +439,12 @@ rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) %********************************************************* \begin{code} -rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name]) - -rnDerivs Nothing -- derivs not specified - = returnRn Nothing - -rnDerivs (Just clss) - = mapRn do_one clss `thenRn` \ clss' -> - returnRn (Just clss') - where - do_one cls = lookupOccRn cls `thenRn` \ clas_name -> - checkRn (getUnique clas_name `elem` derivableClassKeys) - (derivingNonStdClassErr clas_name) `thenRn_` - returnRn clas_name +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}