From: simonpj Date: Mon, 30 Apr 2001 10:51:19 +0000 (+0000) Subject: [project @ 2001-04-30 10:51:18 by simonpj] X-Git-Tag: Approximately_9120_patches~2062 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e7b69c553c58133ddbdc756bec03a43d35b0be5e;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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