[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

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index a8e232b..b0627c2 100644 (file)
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/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

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 265a34f..de1e0be 100644 (file)
--- a/ghc/compiler/rename/Rename.lhs
+++ b/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 ;

diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 32e37cd..7b2cf88 100644 (file)
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/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

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 3c25da0..1db8e37 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/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) ])

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 71db387..6a6acbb 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/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

diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 51918de..92712b1 100644 (file)
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/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])]
 

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index e1af3e5..50a9dcd 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/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