From 90c0b29e6d8d847e5357bd0a9df98e2846046db7 Mon Sep 17 00:00:00 2001 From: sof Date: Tue, 27 Apr 1999 17:34:00 +0000 Subject: [PATCH] [project @ 1999-04-27 17:33:49 by sof] Renamer changes: - for a toplevel type signature f :: ty the name 'f' refers to a local definition of 'f' - i.e., don't report 'f' as clashing with any imported 'f's. - tidied up the handling of fixity declarations - misplaced fixity declarations inside class decls, e.g., class F a where infix 9 `f` g :: a -> Int are now caught and reported as errors. Robustified the renaming of class decls. --- ghc/compiler/hsSyn/HsBinds.lhs | 12 +-- ghc/compiler/rename/Rename.lhs | 2 +- ghc/compiler/rename/RnBinds.lhs | 160 +++++++++++++++++++++++--------------- ghc/compiler/rename/RnEnv.lhs | 24 +++--- ghc/compiler/rename/RnExpr.lhs | 4 +- ghc/compiler/rename/RnIfaces.lhs | 12 +-- ghc/compiler/rename/RnMonad.lhs | 6 ++ ghc/compiler/rename/RnNames.lhs | 8 +- ghc/compiler/rename/RnSource.lhs | 57 ++++++++++---- 9 files changed, 176 insertions(+), 109 deletions(-) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index a9a114d..5e96627 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -253,11 +253,13 @@ sigsForMe f sigs sig_for_me (SpecInstSig _ _) = False sig_for_me (FixSig (FixitySig n _ _)) = f n -nonFixitySigs :: [Sig name] -> [Sig name] -nonFixitySigs sigs = filter not_fix sigs - where - not_fix (FixSig _) = False - not_fix other = True +isFixitySig :: Sig name -> Bool +isFixitySig (FixSig _) = True +isFixitySig _ = False + +isClassOpSig :: Sig name -> Bool +isClassOpSig (ClassOpSig _ _ _ _) = True +isClassOpSig _ = False \end{code} \begin{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 5474e17..d9b7e10 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -304,7 +304,7 @@ reportUnusedNames (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentio reportableUnusedName :: Name -> Bool reportableUnusedName name - = explicitlyImported (getNameProvenance name) && + = explicitlyImported (getNameProvenance name) && not (startsWithUnderscore (occNameUserString (nameOccName name))) where explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 8cde74f..22e583b 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -12,7 +12,8 @@ they may be affected by renaming (which isn't fully worked out yet). module RnBinds ( rnTopBinds, rnTopMonoBinds, rnMethodBinds, renameSigs, - rnBinds, rnMonoBinds + rnBinds, + unknownSigErr ) where #include "HsVersions.h" @@ -27,16 +28,21 @@ import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn, isUnboundName, warnUnusedLocalBinds, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV + FreeVars, emptyFVs, plusFV, plusFVs, unitFV, + failUnboundNameErrRn ) import CmdLineOpts ( opt_WarnMissingSigs ) import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( OccName, Name ) +import Name ( OccName, Name, nameOccName ) import NameSet +import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) import Util ( thenCmp, removeDups ) +import List ( partition ) import ListSetOps ( minusList ) import Bag ( bagToList ) +import FiniteMap ( emptyFM, addListToFM, lookupFM ) +import Maybe ( isJust ) import Outputable \end{code} @@ -169,8 +175,20 @@ rnTopMonoBinds mbinds sigs = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> let binder_set = mkNameSet binder_names + + binder_occ_fm = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) binder_names) + + -- the names appearing in the sigs have to be bound by + -- this group's binders. + lookup_occ_rn_sig rdr_name = + case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of + Nothing -> failUnboundNameErrRn rdr_name + Just x -> returnRn x in - rn_mono_binds TopLevel binder_set mbinds sigs + renameSigs opt_WarnMissingSigs binder_set lookup_occ_rn_sig sigs + `thenRn` \ (siglist, sig_fvs) -> + rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> + returnRn (final_binds, bind_fvs `plusFV` sig_fvs) where binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) \end{code} @@ -197,7 +215,8 @@ rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside -- the parser doesn't produce other forms -rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] +rnMonoBinds :: RdrNameMonoBinds + -> [RdrNameSig] -> (RenamedHsBinds -> RnMS s (result, FreeVars)) -> RnMS s (result, FreeVars) @@ -209,15 +228,43 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds -- This also checks that the names form a set bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $ \ new_mbinders -> let - binder_set = mkNameSet new_mbinders + binder_set = mkNameSet new_mbinders + + -- Weed out the fixity declarations that do not + -- apply to any of the binders in this group. + (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs + + forLocalBind (FixSig sig@(FixitySig name _ _ )) = + isJust (lookupFM binder_occ_fm (rdrNameOcc name)) + forLocalBind _ = True + + binder_occ_fm = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) new_mbinders) + + -- the names appearing in the sigs have to be bound by + -- this group's binders. + lookup_occ_rn_sig rdr_name = + case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of + Nothing -> failUnboundNameErrRn rdr_name + Just x -> returnRn x + in + -- + -- Report the fixity declarations in this group that + -- don't refer to any of the group's binders. + -- + mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_` + renameSigs False binder_set lookup_occ_rn_sig sigs_for_me + `thenRn` \ (siglist, sig_fvs) -> + let + fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] in - rn_mono_binds NotTopLevel - binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) -> + -- Install the fixity declarations that do apply here and go. + extendFixityEnv fixity_sigs ( + rn_mono_binds siglist mbinds ) `thenRn` \ (binds, bind_fvs) -> -- Now do the "thing inside", and deal with the free-variable calculations thing_inside binds `thenRn` \ (result,result_fvs) -> let - all_fvs = result_fvs `plusFV` bind_fvs + all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs) in warnUnusedLocalBinds unused_binders `thenRn_` @@ -233,41 +280,42 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds %* * %************************************************************************ -@rnMonoBinds@ is used by *both* top-level and nested bindings. It +@rn_mono_binds@ is used by *both* top-level and nested bindings. It assumes that all variables bound in this group are already in scope. This is done *either* by pass 3 (for the top-level bindings), *or* by -@rnNestedMonoBinds@ (for the nested ones). +@rnMonoBinds@ (for the nested ones). \begin{code} -rn_mono_binds :: TopLevelFlag - -> NameSet -- Binders of this group +rn_mono_binds :: [RenamedSig] -- Signatures attached to this group -> RdrNameMonoBinds - -> [RdrNameSig] -- Signatures attached to this group -> RnMS s (RenamedHsBinds, -- FreeVars) -- Free variables -rn_mono_binds top_lev binders mbinds sigs +rn_mono_binds siglist mbinds = -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - renameSigs top_lev False binders sigs `thenRn` \ (siglist, sig_fvs) -> flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info -> -- Do the SCC analysis - let edges = mkEdges (mbinds_info `zip` [(0::Int)..]) + let + edges = mkEdges (mbinds_info `zip` [(0::Int)..]) scc_result = stronglyConnComp edges final_binds = foldr1 ThenBinds (map reconstructCycle scc_result) -- Deal with bound and free-var calculation rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] in - returnRn (final_binds, rhs_fvs `plusFV` sig_fvs) + returnRn (final_binds, rhs_fvs) \end{code} @flattenMonoBinds@ is ever-so-slightly magical in that it sticks unique ``vertex tags'' on its output; minor plumbing required. +Sigh - need to pass along the signatures for the group of bindings, +in case any of them + \begin{code} flattenMonoBinds :: [RenamedSig] -- Signatures -> RdrNameMonoBinds @@ -289,9 +337,7 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) names_bound_here = mkNameSet (collectPatBinders pat') sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs sigs_fvs = foldr sig_fv emptyFVs sigs_for_me - fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me] in - extendFixityEnv fixity_sigs $ rnGRHSs grhss `thenRn` \ (grhss', fvs) -> returnRn [(names_bound_here, @@ -302,25 +348,23 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) flattenMonoBinds sigs (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ - lookupBndrRn name `thenRn` \ name' -> + lookupBndrRn name `thenRn` \ new_name -> let - sigs_for_me = sigsForMe (name' ==) sigs + sigs_for_me = sigsForMe (new_name ==) sigs sigs_fvs = foldr sig_fv emptyFVs sigs_for_me - fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me] in - extendFixityEnv fixity_sigs $ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) -> - mapRn (checkPrecMatch inf name') new_matches `thenRn_` + mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` returnRn - [(unitNameSet name', + [(unitNameSet new_name, plusFVs fv_lists `plusFV` sigs_fvs, - FunMonoBind name' inf new_matches locn, + FunMonoBind new_name inf new_matches locn, sigs_for_me )] \end{code} -@rnMethodBinds@ is used for the method bindings of an instance +@rnMethodBinds@ is used for the method bindings of a class and an instance declaration. like @rnMonoBinds@ but without dependency analysis. \begin{code} @@ -340,7 +384,7 @@ rnMethodBinds (FunMonoBind name inf matches locn) -- We use the selector name as the binder mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fvs_s) -> - mapRn (checkPrecMatch inf sel_name) new_matches `thenRn_` + mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` returnRn (FunMonoBind sel_name inf new_matches locn, plusFVs fvs_s) rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn) @@ -436,19 +480,18 @@ mkEdges flat_info flaggery, that all top-level things have type signatures. At the moment we don't gather free-var info from the types in -sigatures. We'd only need this if we wanted to report unused tyvars. +signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} -renameSigs :: TopLevelFlag - -> Bool -- True <-> sigs for an instance decl - -- hence SPECIALISE instance prags ok +renameSigs :: Bool -- True => warn if (required) type signatures are missing. -> NameSet -- Set of names bound in this group + -> (RdrName -> RnMS s Name) -> [RdrNameSig] -> RnMS s ([RenamedSig], FreeVars) -- List of Sig constructors -renameSigs top_lev inst_decl binders sigs +renameSigs sigs_required binders lookup_occ_nm sigs = -- Rename the signatures - mapAndUnzipRn renameSig sigs `thenRn` \ (sigs', fvs_s) -> + mapAndUnzipRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs_s) -> -- Check for (a) duplicate signatures -- (b) signatures for things not in this group @@ -456,30 +499,19 @@ renameSigs top_lev inst_decl binders sigs let (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs') not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies - spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies] type_sig_vars = [n | Sig n _ _ <- goodies] - fixes = [f | f@(FixSig _) <- goodies] - idecl_type_sigs = [s | s@(Sig _ _ _) <- goodies] - sigs_required = case top_lev of {TopLevel -> opt_WarnMissingSigs; NotTopLevel -> False} un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars | otherwise = [] in - mapRn dupSigDeclErr dups `thenRn_` - mapRn unknownSigErr not_this_group `thenRn_` - (if not inst_decl then - mapRn unknownSigErr spec_inst_sigs - else - -- We're being strict here, outlawing the presence - -- of type signatures within an instance declaration. - mapRn unknownSigErr (fixes ++ idecl_type_sigs) - ) `thenRn_` - mapRn (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` - - returnRn (sigs', plusFVs fvs_s) -- bad ones and all: - -- we need bindings of *some* sort for every name + mapRn_ dupSigDeclErr dups `thenRn_` + mapRn_ unknownSigErr not_this_group `thenRn_` + mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` + returnRn (sigs', plusFVs fvs_s) + -- bad ones and all: + -- we need bindings of *some* sort for every name -- We use lookupOccRn in the signatures, which is a little bit unsatisfactory --- becuase this won't work for: +-- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} -- Baz.op = ... @@ -487,20 +519,20 @@ renameSigs top_lev inst_decl binders sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig (Sig v ty src_loc) +renameSig lookup_occ_nm (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookup_occ_nm v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> returnRn (Sig new_v new_ty src_loc, fvs) -renameSig (SpecInstSig ty src_loc) +renameSig _ (SpecInstSig ty src_loc) = pushSrcLocRn src_loc $ rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> returnRn (SpecInstSig new_ty src_loc, fvs) -renameSig (SpecSig v ty using src_loc) +renameSig lookup_occ_nm (SpecSig v ty using src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookup_occ_nm v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs1) -> rn_using using `thenRn` \ (new_using,fvs2) -> returnRn (SpecSig new_v new_ty new_using src_loc, fvs1 `plusFV` fvs2) @@ -509,19 +541,19 @@ renameSig (SpecSig v ty using src_loc) rn_using (Just x) = lookupOccRn x `thenRn` \ new_x -> returnRn (Just new_x, unitFV new_x) -renameSig (InlineSig v src_loc) +renameSig lookup_occ_nm (InlineSig v src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookup_occ_nm v `thenRn` \ new_v -> returnRn (InlineSig new_v src_loc, emptyFVs) -renameSig (FixSig (FixitySig v fix src_loc)) +renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookup_occ_nm v `thenRn` \ new_v -> returnRn (FixSig (FixitySig new_v fix src_loc), emptyFVs) -renameSig (NoInlineSig v src_loc) +renameSig lookup_occ_nm (NoInlineSig v src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookup_occ_nm v `thenRn` \ new_v -> returnRn (NoInlineSig new_v src_loc, emptyFVs) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 53bf1bc..7d0584e 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -198,9 +198,9 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope getLocalNameEnv `thenRn` \ name_env -> (if opt_WarnNameShadowing then - mapRn (check_shadow name_env) rdr_names_w_loc + mapRn_ (check_shadow name_env) rdr_names_w_loc else - returnRn [] + returnRn () ) `thenRn_` newLocalNames rdr_names_w_loc `thenRn` \ names -> @@ -288,15 +288,14 @@ checkDupOrQualNames, checkDupNames :: SDoc checkDupOrQualNames doc_str rdr_names_w_loc = -- Check for use of qualified names - mapRn (qualNameErr doc_str) quals `thenRn_` + mapRn_ (qualNameErr doc_str) quals `thenRn_` checkDupNames doc_str rdr_names_w_loc where quals = filter (isQual.fst) rdr_names_w_loc checkDupNames doc_str rdr_names_w_loc - = -- Check for dupicated names in a binding group - mapRn (dupNamesErr doc_str) dups `thenRn_` - returnRn () + = -- Check for duplicated names in a binding group + mapRn_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc \end{code} @@ -370,8 +369,7 @@ lookup_global_occ global_env rdr_name Nothing -> getModeRn `thenRn` \ mode -> case mode of -- Not found when processing source code; so fail - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) + SourceMode -> failUnboundNameErrRn rdr_name -- Not found when processing an imported declaration, -- so we create a new name for the purpose @@ -661,8 +659,7 @@ warnUnusedMatches names warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM s d () warnUnusedBinds warn_when_local names - = mapRn (warnUnusedGroup warn_when_local) groups `thenRn_` - returnRn () + = mapRn_ (warnUnusedGroup warn_when_local) groups where -- Group by provenance groups = equivClasses cmp names @@ -693,7 +690,7 @@ warnUnusedGroup emit_warning names = case getNameProvenance name1 of LocalDef loc _ -> (True, loc, text "Defined but not used") NonLocalDef (UserImport mod loc _) _ -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> - text "but but not used") + text "but not used") other -> (False, getSrcLoc name1, text "Strangely defined but not used") \end{code} @@ -711,6 +708,11 @@ fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) 4 (vcat [ppr how_in_scope1, ppr how_in_scope2]) +failUnboundNameErrRn :: RdrName -> RnM s d Name +failUnboundNameErrRn rdr_name = + failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 16f9da4..1c4914e 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -421,7 +421,7 @@ rnExpr (ArithSeqIn seq) \begin{code} rnRbinds str rbinds - = mapRn field_dup_err dup_fields `thenRn_` + = mapRn_ field_dup_err dup_fields `thenRn_` mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) -> returnRn (rbinds', plusFVs fvRbind_s) where @@ -435,7 +435,7 @@ rnRbinds str rbinds returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname) rnRpats rpats - = mapRn field_dup_err dup_fields `thenRn_` + = mapRn_ field_dup_err dup_fields `thenRn_` mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) -> returnRn (rpats', plusFVs fvs_s) where diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index dfd74fa..eebe37e 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -25,7 +25,7 @@ import CmdLineOpts ( opt_PruneTyDecls, opt_PruneInstDecls, import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..), FixitySig(..), - hsDeclName, countTyClDecls, isDataDecl, nonFixitySigs + hsDeclName, countTyClDecls, isDataDecl, isClassOpSig ) import BasicTypes ( Version, NewOrData(..) ) import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, @@ -765,7 +765,7 @@ getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)] getImportedInstDecls = -- First load any special-instance modules that aren't aready loaded getSpecialInstModules `thenRn` \ inst_mods -> - mapRn load_it inst_mods `thenRn_` + mapRn_ load_it inst_mods `thenRn_` -- Now we're ready to grab the instance declarations -- Find the un-gated ones and return them, @@ -820,7 +820,7 @@ getImportedFixities gbl_env not (isLocallyDefined name) ] in - mapRn load (nub home_modules) `thenRn_` + mapRn_ load (nub home_modules) `thenRn_` -- Now we can snaffle the fixity env getIfacesRn `thenRn` \ ifaces -> @@ -996,10 +996,10 @@ getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc -- Record the names for the class ops let - -- ignoring fixity declarations - nonfix_sigs = nonFixitySigs sigs + -- just want class-op sigs + op_sigs = filter isClassOpSig sigs in - mapRn (getClassOpNames new_name) nonfix_sigs `thenRn` \ sub_names -> + mapRn (getClassOpNames new_name) op_sigs `thenRn` \ sub_names -> returnRn (Just (AvailTC class_name (class_name : sub_names))) diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index de6268a..189649b 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -571,6 +571,7 @@ thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b] +mapRn_ :: (a -> RnM s d b) -> [a] -> RnM s d () mapMaybeRn :: (a -> RnM s d (Maybe b)) -> [a] -> RnM s d [b] sequenceRn :: [RnM s d a] -> RnM s d [a] foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b @@ -597,6 +598,11 @@ mapRn f (x:xs) mapRn f xs `thenRn` \ rs -> returnRn (r:rs) +mapRn_ f [] = returnRn () +mapRn_ f (x:xs) = + f x `thenRn_` + mapRn_ f xs + foldlRn k z [] = returnRn z foldlRn k z (x:xs) = k z x `thenRn` \ z' -> foldlRn k z' xs diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 881f497..db95e47 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -255,10 +255,10 @@ importsFromLocalDecls mod rec_exp_fn decls non_singleton other = False in -- Check for duplicate definitions - mapRn (addErrRn . dupDeclErr) dups `thenRn_` + mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` -- Record that locally-defined things are available - mapRn (recordSlurp Nothing Compulsory) avails `thenRn_` + mapRn_ (recordSlurp Nothing Compulsory) avails `thenRn_` -- Build the environment qualifyImports mod @@ -308,10 +308,10 @@ fixitiesFromLocalDecls gbl_env decls getFixities acc (FixD fix) = fix_decl acc fix + getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _)) = foldlRn fix_decl acc [sig | FixSig sig <- sigs] - -- Get fixities from class decl sigs too - + -- Get fixities from class decl sigs too. getFixities acc other_decl = returnRn acc diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index fbcae1c..d4d4337 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -20,7 +20,7 @@ import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, import RnHsSyn import HsCore -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, addImplicitOccRn, bindLocalsRn, @@ -193,12 +193,17 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr -- Check the signatures let - -- Filter out fixity signatures; - -- they are done at top level - nofix_sigs = nonFixitySigs sigs + -- First process the class op sigs, then the fixity sigs. + (op_sigs, non_op_sigs) = partition isClassOpSig sigs + (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapAndUnzipRn (rn_op cname' clas_tyvar_names) nofix_sigs `thenRn` \ (sigs', sig_fvs_s) -> + checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` + mapAndUnzipRn (rn_op cname' clas_tyvar_names) op_sigs `thenRn` \ (sigs', sig_fvs_s) -> + mapRn_ (unknownSigErr) non_sigs `thenRn_` + let + binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] + in + renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) -> -- Check the methods checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` @@ -210,8 +215,12 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (TyClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc), - plusFVs sig_fvs_s `plusFV` cxt_fvs `plusFV` meth_fvs) + returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds' NoClassPragmas tname' dname' src_loc), + plusFVs sig_fvs_s `plusFV` + fix_fvs `plusFV` + cxt_fvs `plusFV` + meth_fvs + ) ) where cls_doc = text "the declaration for class" <+> ppr cname @@ -232,7 +241,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sr check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs) (classTyVarNotInOpTyErr clas_tyvar sig) in - mapRn check_in_op_ty clas_tyvars `thenRn_` + mapRn_ check_in_op_ty clas_tyvars `thenRn_` -- Make the default-method name let @@ -286,10 +295,26 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) -> let binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds'))) + + -- Delete sigs (&report) sigs that aren't allowed inside an + -- instance decl: + -- + -- + type signatures + -- + fixity decls + -- + (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags + + okInInstDecl (FixSig _) = False + okInInstDecl (Sig _ _ _) = False + okInInstDecl _ = True + in - renameSigs NotTopLevel True binders uprags `thenRn` \ (new_uprags, prag_fvs) -> - mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name -> - addOccurrenceName dfun_name `thenRn_` + -- You can't have fixity decls & type signatures + -- within an instance declaration. + mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_` + renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) -> + mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name -> + addOccurrenceName dfun_name `thenRn_` -- The dfun is not optional, because we use its version number -- to identify the version of the instance declaration @@ -370,7 +395,7 @@ rnDerivs (Just ds) Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_` returnRn clas_name - Just occs -> mapRn lookupImplicitOccRn occs `thenRn_` + Just occs -> mapRn_ lookupImplicitOccRn occs `thenRn_` returnRn clas_name \end{code} @@ -557,8 +582,8 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty) (bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys forall_tyvar_names = map getTyVarName forall_tyvars in - mapRn (forAllErr doc ty) bad_guys `thenRn_` - mapRn (forAllWarn doc ty) warn_guys `thenRn_` + mapRn_ (forAllErr doc ty) bad_guys `thenRn_` + mapRn_ (forAllWarn doc ty) warn_guys `thenRn_` checkConstraints True doc forall_tyvar_names ctxt ty `thenRn` \ ctxt' -> rnForAll doc forall_tyvars ctxt' ty @@ -609,7 +634,7 @@ rnContext doc ctxt in -- Check for duplicate assertions -- If this isn't an error, then it ought to be: - mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` + mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` returnRn (theta, plusFVs fvs_s) where -- 1.7.10.4