[project @ 2001-04-30 10:51:18 by simonpj]

-----------------------------
	Better filtering for warnings
	-----------------------------

* Add Opt_WarnMisc, to enable warnings not otherwise covered by Opt_Warn*
  in the renamer

* Add RnMonad.ifOptRn :: DynFlag -> RnM d a -> RnM d ()
  and use it many places instead of the clumsy direct code

ghc/compiler/main/CmdLineOpts.lhs

@@ -276,6 +276,7 @@ data DynFlag
    | Opt_WarnUnusedImports
    | Opt_WarnUnusedMatches
    | Opt_WarnDeprecations
+   | Opt_WarnMisc
 
    -- language opts
    | Opt_AllowOverlappingInstances
@@ -381,7 +382,8 @@ standardWarnings
 	Opt_WarnOverlappingPatterns,
 	Opt_WarnMissingFields,
 	Opt_WarnMissingMethods,
-	Opt_WarnDuplicateExports
+	Opt_WarnDuplicateExports,
+	Opt_WarnMisc
       ]
 
 minusWOpts

ghc/compiler/rename/Rename.lhs

@@ -688,8 +688,7 @@ printMinimalImports :: Module 	-- This module
 		    -> FiniteMap ModuleName AvailEnv	-- Minimal imports
 		    -> RnMG ()
 printMinimalImports this_mod unqual imps
-  = doptRn Opt_D_dump_minimal_imports		`thenRn` \ dump_minimal ->
-    if not dump_minimal then returnRn () else
+  = ifOptRn Opt_D_dump_minimal_imports 		$
 
     mapRn to_ies (fmToList imps)		`thenRn` \ mod_ies ->
     ioToRnM (do { h <- openFile filename WriteMode ;

ghc/compiler/rename/RnBinds.lhs

@@ -167,16 +167,16 @@ rnTopMonoBinds mbinds sigs
 	bndr_name_set = mkNameSet binder_names
     in
     renameSigsFVs (okBindSig bndr_name_set) sigs 	`thenRn` \ (siglist, sig_fvs) ->
-    doptRn Opt_WarnMissingSigs				`thenRn` \ warnMissing ->
-    let
-	type_sig_vars	= [n | Sig n _ _ <- siglist]
-	un_sigd_binders | warnMissing = nameSetToList (delListFromNameSet 
-                                                          bndr_name_set type_sig_vars)
-			| otherwise   = []
-    in
-    mapRn_ missingSigWarn un_sigd_binders	`thenRn_`
 
-    rn_mono_binds siglist mbinds		   `thenRn` \ (final_binds, bind_fvs) ->
+    ifOptRn Opt_WarnMissingSigs (
+	let
+	    type_sig_vars   = [n | Sig n _ _ <- siglist]
+	    un_sigd_binders = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
+	in
+        mapRn_ missingSigWarn un_sigd_binders
+    )						`thenRn_`
+
+    rn_mono_binds siglist mbinds		`thenRn` \ (final_binds, bind_fvs) ->
     returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
   where
     binder_rdr_names = collectMonoBinders mbinds

ghc/compiler/rename/RnEnv.lhs

@@ -494,12 +494,11 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 	-- Check for duplicate names
     checkDupOrQualNames doc_str rdr_names_w_loc	`thenRn_`
 
-    doptRn Opt_WarnNameShadowing 		`thenRn` \ warn_shadow ->
-
     	-- Warn about shadowing, but only in source modules
     (case mode of
-	SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc
-	other				   -> returnRn ()
+	SourceMode -> ifOptRn Opt_WarnNameShadowing	$
+		      mapRn_ (check_shadow name_env) rdr_names_w_loc
+	other	   -> returnRn ()
     )					`thenRn_`
 	
     newLocalsRn rdr_names_w_loc		`thenRn` \ names ->
@@ -915,9 +914,7 @@ mapFvRn f xs = mapRn f xs	`thenRn` \ stuff ->
 \begin{code}
 warnUnusedModules :: [ModuleName] -> RnM d ()
 warnUnusedModules mods
-  = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
-    if warn then mapRn_ (addWarnRn . unused_mod) mods
-	    else returnRn ()
+  = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods)
   where
     unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> 
 			   text "is imported, but nothing from it is used",
@@ -926,19 +923,14 @@ warnUnusedModules mods
 
 warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
 warnUnusedImports names
-  = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
-    if warn then warnUnusedBinds names else returnRn ()
+  = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names)
 
 warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
 warnUnusedLocalBinds names
-  = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
-    if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
-	    else returnRn ()
+  = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names])
 
 warnUnusedMatches names
-  = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
-    if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
-	    else returnRn ()
+  = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names])
 
 -------------------------
 
@@ -1012,8 +1004,7 @@ dupNamesErr descriptor ((name,loc) : dup_things)
 
 warnDeprec :: Name -> DeprecTxt -> RnM d ()
 warnDeprec name txt
-  = doptRn Opt_WarnDeprecations				`thenRn` \ warn_drs ->
-    if not warn_drs then returnRn () else
+  = ifOptRn Opt_WarnDeprecations	$
     addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> 
 		     quotes (ppr name) <+> text "is deprecated:", 
 		     nest 4 (ppr txt) ])

ghc/compiler/rename/RnMonad.lhs

@@ -93,14 +93,10 @@ ioToRnM_no_fail io rn_down g_down
      (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!")
 	    
 traceRn :: SDoc -> RnM d ()
-traceRn msg
-   = doptRn Opt_D_dump_rn_trace `thenRn` \b ->
-     if b then putDocRn msg else returnRn ()
+traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg)
 
 traceHiDiffsRn :: SDoc -> RnM d ()
-traceHiDiffsRn msg
-   = doptRn Opt_D_dump_hi_diffs `thenRn` \b ->
-     if b then putDocRn msg else returnRn ()
+traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg)
 
 putDocRn :: SDoc -> RnM d ()
 putDocRn msg = ioToRnM (printErrs alwaysQualify msg)	`thenRn_`
@@ -575,6 +571,11 @@ doptRn :: DynFlag -> RnM d Bool
 doptRn dflag (RnDown { rn_dflags = dflags}) l_down
    = return (dopt dflag dflags)
 
+ifOptRn :: DynFlag -> RnM d a -> RnM d ()
+ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down
+  | dopt dflag dflags = thing_inside down l_down >> return ()
+  | otherwise	      = return ()
+
 getDOptsRn :: RnM d DynFlags
 getDOptsRn (RnDown { rn_dflags = dflags}) l_down
    = return dflags

ghc/compiler/rename/RnNames.lhs

@@ -161,9 +161,10 @@ importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_m
     else
 
 	-- Complain if we import a deprecated module
-    (case deprecs of	
-	DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt)
-	other	      -> returnRn ()
+    ifOptRn Opt_WarnDeprecations	(
+       case deprecs of	
+	  DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt)
+	  other	        -> returnRn ()
     )							`thenRn_`
 
 	-- Filter the imports according to the import list
@@ -323,7 +324,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails
 	  Just avail@(AvailTC _ [n]) -> 	-- This occurs when you import T(..), but
 						-- only export T abstractly.  The single [n]
 						-- in the AvailTC is the type or class itself
-					addWarnRn (dodgyImportWarn mod item)	`thenRn_`
+					ifOptRn opt_WarnMisc (addWarnRn (dodgyImportWarn mod item))	`thenRn_`
 		     	 		returnRn [(avail, [availName avail])]
 	  Just avail 		     -> returnRn [(avail, [availName avail])]
 

ghc/compiler/rename/RnSource.lhs

@@ -633,13 +633,17 @@ rnForAll doc forall_tyvars ctxt ty
 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 rnContext doc ctxt
   = mapRn rn_pred ctxt		`thenRn` \ theta ->
-    let
-	(_, dups) = removeDupsEq theta
-		-- We only have equality, not ordering
-    in
+
 	-- Check for duplicate assertions
 	-- If this isn't an error, then it ought to be:
-    mapRn (addWarnRn . dupClassAssertWarn theta) dups		`thenRn_`
+    ifOptRn Opt_WarnMisc (
+        let
+	    (_, dups) = removeDupsEq theta
+		-- We only have equality, not ordering
+        in
+        mapRn (addWarnRn . dupClassAssertWarn theta) dups
+    )				`thenRn_`
+
     returnRn theta
   where
    	--Someone discovered that @CCallable@ and @CReturnable@
@@ -854,11 +858,9 @@ badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
 forAllWarn doc ty tyvar
-  = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
-    () | not warn_unused -> returnRn ()
-       | otherwise
-       -> getModeRn		`thenRn` \ mode ->
-          case mode of {
+  = ifOptRn Opt_WarnUnusedMatches 	$
+    getModeRn				`thenRn` \ mode ->
+    case mode of {
 #ifndef DEBUG
 	     InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
 		                            -- unless DEBUG is on, in which case it is slightly