diff options
| -rw-r--r-- | compiler/deSugar/Desugar.lhs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 6 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.lhs | 7 | ||||
| -rw-r--r-- | compiler/deSugar/Match.lhs | 14 | ||||
| -rw-r--r-- | compiler/iface/MkIface.lhs | 4 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 152 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 5 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 2 | ||||
| -rw-r--r-- | compiler/parser/Lexer.x | 8 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 8 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 22 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcErrors.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcForeign.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.lhs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.lhs | 11 |
19 files changed, 146 insertions, 115 deletions
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 15d547eab0..6a11b9e4bd 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -347,7 +347,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) do { let bndrs' = [var | RuleBndr (L _ var) <- vars] ; lhs' <- unsetOptM Opt_EnableRewriteRules $ - unsetOptM Opt_WarnIdentities $ + unsetWOptM Opt_WarnIdentities $ dsLExpr lhs -- Note [Desugaring RULE left hand sides] ; rhs' <- dsLExpr rhs diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 11eedbe496..a68214d1b1 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -225,7 +225,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn ; e' <- dsExpr e - ; warn_id <- doptDs Opt_WarnIdentities + ; warn_id <- woptDs Opt_WarnIdentities ; when warn_id $ warnAboutIdentities e' co_fn' ; return (co_fn' e') } @@ -830,13 +830,13 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () warnDiscardedDoBindings rhs rhs_ty | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty = do { -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; warn_unused <- woptDs Opt_WarnUnusedDoBind ; if warn_unused && not (isUnitTy elt_ty) then warnDs (unusedMonadBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - do { warn_wrong <- doptDs Opt_WarnWrongDoBind + do { warn_wrong <- woptDs Opt_WarnWrongDoBind ; case tcSplitAppTy_maybe elt_ty of Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty -> warnDs (wrongMonadBind rhs elt_ty) diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 62e805334e..221621d742 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -9,7 +9,7 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, - foldlM, foldrM, ifDOptM, unsetOptM, + foldlM, foldrM, ifDOptM, unsetOptM, unsetWOptM, Applicative(..),(<$>), newLocalName, @@ -20,7 +20,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, + getDOptsDs, getGhcModeDs, doptDs, woptDs, dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon, dsLookupClass, @@ -257,6 +257,9 @@ getDOptsDs = getDOpts doptDs :: DynFlag -> TcRnIf gbl lcl Bool doptDs = doptM +woptDs :: WarningFlag -> TcRnIf gbl lcl Bool +woptDs = woptM + getGhcModeDs :: DsM GhcMode getGhcModeDs = getDOptsDs >>= return . ghcMode diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 1a044d3471..25dab9370c 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -74,18 +74,18 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs where (pats, eqns_shadow) = check qs incomplete = incomplete_flag hs_ctx && (notNull pats) - shadow = dopt Opt_WarnOverlappingPatterns dflags + shadow = wopt Opt_WarnOverlappingPatterns dflags && notNull eqns_shadow incomplete_flag :: HsMatchContext id -> Bool - incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags - incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags + incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags + incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags - incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag ProcExpr = dopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag ProcExpr = wopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag RecUpd = dopt Opt_WarnIncompletePatternsRecUpd dflags + incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags incomplete_flag ThPatQuote = False incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 506268a32a..50406d2fac 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -289,8 +289,8 @@ mkIface_ hsc_env maybe_old_fingerprint intermediate_iface decls -- Warn about orphans - ; let warn_orphs = dopt Opt_WarnOrphans dflags - warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags + ; let warn_orphs = wopt Opt_WarnOrphans dflags + warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags orph_warnings --- Laziness means no work done unless -fwarn-orphans | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns | otherwise = emptyBag diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 35aa2ed98d..68410cdb64 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -12,12 +12,16 @@ module DynFlags ( -- * Dynamic flags and associated configuration types DynFlag(..), + WarningFlag(..), ExtensionFlag(..), LogAction, glasgowExtsFlags, dopt, dopt_set, dopt_unset, + wopt, + wopt_set, + wopt_unset, xopt, xopt_set, xopt_unset, @@ -29,7 +33,7 @@ module DynFlags ( PackageFlag(..), Option(..), showOpt, DynLibLoader(..), - fFlags, fLangFlags, xFlags, + fFlags, fWarningFlags, fLangFlags, xFlags, DPHBackend(..), dphPackageMaybe, wayNames, dynFlagDependencies, @@ -214,38 +218,6 @@ data DynFlag | Opt_DoAsmLinting | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_WarnDuplicateExports - | Opt_WarnHiShadows - | Opt_WarnImplicitPrelude - | Opt_WarnIncompletePatterns - | Opt_WarnIncompleteUniPatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnMissingFields - | Opt_WarnMissingImportList - | Opt_WarnMissingMethods - | Opt_WarnMissingSigs - | Opt_WarnMissingLocalSigs - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnTypeDefaults - | Opt_WarnMonomorphism - | Opt_WarnUnusedBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnWarningsDeprecations - | Opt_WarnDeprecatedFlags - | Opt_WarnDodgyExports - | Opt_WarnDodgyImports - | Opt_WarnOrphans - | Opt_WarnAutoOrphans - | Opt_WarnIdentities - | Opt_WarnTabs - | Opt_WarnUnrecognisedPragmas - | Opt_WarnDodgyForeignImports - | Opt_WarnLazyUnliftedBindings - | Opt_WarnUnusedDoBind - | Opt_WarnWrongDoBind - | Opt_WarnAlternativeLayoutRuleTransitional | Opt_PrintExplicitForalls @@ -325,6 +297,41 @@ data DynFlag deriving (Eq, Show) +data WarningFlag = + Opt_WarnDuplicateExports + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnMissingLocalSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnLazyUnliftedBindings + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + deriving (Eq, Show) + data Language = Haskell98 | Haskell2010 -- | The various Safe Haskell modes @@ -531,6 +538,7 @@ data DynFlags = DynFlags { -- hsc dynamic flags flags :: [DynFlag], + warningFlags :: [WarningFlag], -- Don't change this without updating extensionFlags: language :: Maybe Language, -- | Safe Haskell mode @@ -853,6 +861,7 @@ defaultDynFlags mySettings = generatedDumps = panic "defaultDynFlags: No generatedDumps", haddockOptions = Nothing, flags = defaultFlags, + warningFlags = standardWarnings, language = Nothing, safeHaskell = Sf_None, extensions = [], @@ -949,6 +958,18 @@ dopt_set dfs f = dfs{ flags = f : flags dfs } dopt_unset :: DynFlags -> DynFlag -> DynFlags dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `elem` (warningFlags dflags) + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = f : warningFlags dfs } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = filter (/= f) (warningFlags dfs) } + -- | Test whether a 'ExtensionFlag' is set xopt :: ExtensionFlag -> DynFlags -> Bool xopt f dflags = f `elem` extensionFlags dflags @@ -1272,14 +1293,15 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags allFlags :: [String] allFlags = map ('-':) $ [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++ - map ("fno-"++) flags ++ - map ("f"++) flags ++ - map ("f"++) flags' ++ + map ("fno-"++) fflags ++ + map ("f"++) fflags ++ map ("X"++) supportedExtensions where ok (PrefixPred _ _) = False ok _ = True - flags = [ name | (name, _, _, _) <- fFlags ] - flags' = [ name | (name, _, _, _) <- fLangFlags ] + fflags = fflags0 ++ fflags1 ++ fflags2 + fflags0 = [ name | (name, _, _, _) <- fFlags ] + fflags1 = [ name | (name, _, _, _) <- fWarningFlags ] + fflags2 = [ name | (name, _, _, _) <- fLangFlags ] --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] @@ -1502,14 +1524,14 @@ dynamic_flags = [ , flagA "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- - , flagA "W" (NoArg (mapM_ setDynFlag minusWOpts)) - , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) - , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) - , flagA "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) - , flagA "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts - ; deprecate "Use -w instead" })) - , flagA "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) - + , flagA "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , flagA "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) + , flagA "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = []}) + deprecate "Use -w instead")) + , flagA "w" (NoArg (upd (\dfs -> dfs {warningFlags = []}))) + ------ Plugin flags ------------------------------------------------ , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) , flagA "fplugin" (hasArg addPluginModuleName) @@ -1575,6 +1597,8 @@ dynamic_flags = [ ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags + ++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags + ++ map (mkFlag turnOff "fno-" unSetWarningFlag) fWarningFlags ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlags ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlags ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags @@ -1641,8 +1665,8 @@ nop :: TurnOnFlag -> DynP () nop _ = return () -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ -fFlags :: [FlagSpec DynFlag] -fFlags = [ +fWarningFlags :: [FlagSpec WarningFlag] +fWarningFlags = [ ( "warn-dodgy-foreign-imports", AlwaysAllowed, Opt_WarnDodgyForeignImports, nop ), ( "warn-dodgy-exports", AlwaysAllowed, Opt_WarnDodgyExports, nop ), ( "warn-dodgy-imports", AlwaysAllowed, Opt_WarnDodgyImports, nop ), @@ -1675,7 +1699,11 @@ fFlags = [ ( "warn-lazy-unlifted-bindings", AlwaysAllowed, Opt_WarnLazyUnliftedBindings, nop), ( "warn-unused-do-bind", AlwaysAllowed, Opt_WarnUnusedDoBind, nop ), ( "warn-wrong-do-bind", AlwaysAllowed, Opt_WarnWrongDoBind, nop ), - ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop ), + ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop )] + +-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ +fFlags :: [FlagSpec DynFlag] +fFlags = [ ( "print-explicit-foralls", AlwaysAllowed, Opt_PrintExplicitForalls, nop ), ( "strictness", AlwaysAllowed, Opt_Strictness, nop ), ( "specialise", AlwaysAllowed, Opt_Specialise, nop ), @@ -1897,8 +1925,6 @@ defaultFlags ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] -- The default -O0 options - ++ standardWarnings - impliedFlags :: [(ExtensionFlag, TurnOnFlag, ExtensionFlag)] impliedFlags = [ (Opt_RankNTypes, turnOn, Opt_ExplicitForAll) @@ -1970,7 +1996,7 @@ optLevelFlags -- ----------------------------------------------------------------------------- -- Standard sets of warning options -standardWarnings :: [DynFlag] +standardWarnings :: [WarningFlag] standardWarnings = [ Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, @@ -1985,7 +2011,7 @@ standardWarnings Opt_WarnAlternativeLayoutRuleTransitional ] -minusWOpts :: [DynFlag] +minusWOpts :: [WarningFlag] -- Things you get with -W minusWOpts = standardWarnings ++ @@ -1997,7 +2023,7 @@ minusWOpts Opt_WarnDodgyImports ] -minusWallOpts :: [DynFlag] +minusWallOpts :: [WarningFlag] -- Things you get with -Wall minusWallOpts = minusWOpts ++ @@ -2009,19 +2035,6 @@ minusWallOpts Opt_WarnUnusedDoBind ] -minuswRemovesOpts :: [DynFlag] --- minuswRemovesOpts should be every warning option -minuswRemovesOpts - = minusWallOpts ++ - [Opt_WarnTabs, - Opt_WarnIncompletePatternsRecUpd, - Opt_WarnIncompleteUniPatterns, - Opt_WarnMonomorphism, - Opt_WarnUnrecognisedPragmas, - Opt_WarnAutoOrphans, - Opt_WarnImplicitPrelude - ] - enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls mapM_ setExtensionFlag glasgowExtsFlags @@ -2140,6 +2153,11 @@ setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +-------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f) ; sequence_ deps } diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 045feeabcb..f6494beff3 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -130,8 +130,7 @@ import TyCon import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) -import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, - DynFlag(..), SafeHaskellMode(..), dynFlagDependencies ) +import DynFlags import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -235,7 +234,7 @@ printOrThrowWarnings dflags warns handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns - = when (dopt Opt_WarnDeprecatedFlags dflags) $ do + = when (wopt Opt_WarnDeprecatedFlags dflags) $ do -- It would be nicer if warns :: [Located Message], but that -- has circular import problems. let bag = listToBag [ mkPlainWarnMsg loc (text warn) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 1df5255dbe..0386273de8 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -197,7 +197,7 @@ runStmtWithLocation source linenumber expr step = -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index c043f8bdff..fd1e1afa05 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1445,12 +1445,12 @@ lex_quasiquote s = do -- ----------------------------------------------------------------------------- -- Warnings -warn :: DynFlag -> SDoc -> Action +warn :: WarningFlag -> SDoc -> Action warn option warning srcspan _buf _len = do addWarning option (RealSrcSpan srcspan) warning lexToken -warnThen :: DynFlag -> SDoc -> Action -> Action +warnThen :: WarningFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do addWarning option (RealSrcSpan srcspan) warning action srcspan buf len @@ -1878,11 +1878,11 @@ mkPState flags buf loc = b `setBitIf` cond | cond = bit b | otherwise = 0 -addWarning :: DynFlag -> SrcSpan -> SDoc -> P () +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning = P $ \s@PState{messages=(ws,es), dflags=d} -> let warning' = mkWarnMsg srcspan alwaysQualify warning - ws' = if dopt option d then ws `snocBag` warning' else ws + ws' = if wopt option d then ws `snocBag` warning' else ws in POk s{messages=(ws', es)} () getMessages :: PState -> Messages diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 58df462532..e14f6a8d1b 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -980,7 +980,7 @@ checkDupAndShadowedNames envs names ------------------------------------- checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () checkShadowedOccs (global_env,local_env) loc_occs - = ifDOptM Opt_WarnNameShadowing $ + = ifWOptM Opt_WarnNameShadowing $ do { traceRn (text "shadow" <+> ppr loc_occs) ; mapM_ check_shadow loc_occs } where @@ -1214,7 +1214,7 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' -> \begin{code} warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedTopBinds gres - = ifDOptM Opt_WarnUnusedBinds + = ifWOptM Opt_WarnUnusedBinds $ do isBoot <- tcIsHsBoot let noParent gre = case gre_par gre of NoParent -> True @@ -1230,9 +1230,9 @@ warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM () warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds warnUnusedMatches = check_unused Opt_WarnUnusedMatches -check_unused :: DynFlag -> [Name] -> FreeVars -> RnM () +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () check_unused flag bound_names used_names - = ifDOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) + = ifWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) ------------------------- -- Helpers diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 303b247c5f..1a70068210 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -146,7 +146,7 @@ rnImports imports (source, ordinary) = partition is_source_import imports is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot - ifDOptM Opt_WarnImplicitPrelude $ + ifWOptM Opt_WarnImplicitPrelude $ when (notNull prel_imports) $ addWarn (implicitPreludeWarn) stuff1 <- mapM (rnImportDecl this_mod True) prel_imports @@ -197,7 +197,7 @@ rnImportDecl this_mod implicit_prelude Just (False, _) -> return () -- Explicit import list _ | implicit_prelude -> return () | qual_only -> return () - | otherwise -> ifDOptM Opt_WarnMissingImportList $ + | otherwise -> ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg @@ -333,7 +333,7 @@ rnImportDecl this_mod implicit_prelude } -- Complain if we import a deprecated module - ifDOptM Opt_WarnWarningsDeprecations ( + ifWOptM Opt_WarnWarningsDeprecations ( case warns of WarnAll txt -> addWarn (moduleWarn imp_mod_name txt) _ -> return () @@ -690,11 +690,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails -- Warn when importing T(..) if T was exported abstractly checkDodgyImport stuff | IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff - = ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) + = ifWOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) -- NB. use the RdrName for reporting the warning | IEThingAll {} <- ieRdr , not (is_qual decl_spec) - = ifDOptM Opt_WarnMissingImportList $ + = ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListItem ieRdr) checkDodgyImport _ = return () @@ -1021,13 +1021,13 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod (L loc (IEModuleContents mod)) | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] , mod `elem` earlier_mods -- Duplicate export of M - = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; + = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; warnIf warn_dup_exports (dupModuleExport mod) ; return acc } | otherwise = do { implicit_prelude <- xoptM Opt_ImplicitPrelude - ; warnDodgyExports <- doptM Opt_WarnDodgyExports + ; warnDodgyExports <- woptM Opt_WarnDodgyExports ; let { exportValid = (mod `elem` imported_modules) || (moduleName this_mod == mod) ; gres = filter (isModuleExported implicit_prelude mod) @@ -1090,7 +1090,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod Nothing -> mkRdrUnqual Just (modName, _) -> mkRdrQual modName addUsedRdrNames $ map (mkKidRdrName . nameOccName) kids - warnDodgyExports <- doptM Opt_WarnDodgyExports + warnDodgyExports <- woptM Opt_WarnDodgyExports when (null kids) $ if isTyConName name then when warnDodgyExports $ addWarn (dodgyExportWarn name) @@ -1173,7 +1173,7 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie' -- But we don't want to warn if the same thing is exported -- by two different module exports. See ticket #4478. -> do unless (dupExport_ok name ie ie') $ do - warn_dup_exports <- doptM Opt_WarnDuplicateExports + warn_dup_exports <- woptM Opt_WarnDuplicateExports warnIf warn_dup_exports (dupExportWarn name_occ ie ie') return occs @@ -1239,7 +1239,7 @@ finishWarnings :: DynFlags -> Maybe WarningTxt -- All this happens only once per module finishWarnings dflags mod_warn tcg_env = do { (eps,hpt) <- getEpsAndHpt - ; ifDOptM Opt_WarnWarningsDeprecations $ + ; ifWOptM Opt_WarnWarningsDeprecations $ mapM_ (check hpt (eps_PIT eps)) all_gres -- By this time, typechecking is complete, -- so the PIT is fully populated @@ -1394,7 +1394,7 @@ warnUnusedImportDecls gbl_env usage = findImportUsage imports rdr_env (Set.elems uses) ; traceRn (ptext (sLit "Import usage") <+> ppr usage) - ; ifDOptM Opt_WarnUnusedImports $ + ; ifWOptM Opt_WarnUnusedImports $ mapM_ warnUnusedImport usage ; ifDOptM Opt_D_dump_minimal_imports $ diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index be90d7d0a9..dd55f6f6a5 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -563,7 +563,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName -> TcRnIf TcGblEnv TcLclEnv () forAllWarn doc ty (L loc tyvar) - = ifDOptM Opt_WarnUnusedMatches $ + = ifWOptM Opt_WarnUnusedMatches $ addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))] $$ diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 33254c1b5a..ce40f56e24 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1216,7 +1216,7 @@ checkStrictBinds top_lvl rec_group binds poly_ids -- This should be a checkTc, not a warnTc, but as of GHC 6.11 -- the versions of alex and happy available have non-conforming -- templates, so the GHC build fails if it's an error: - ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings + ; warnUnlifted <- woptM Opt_WarnLazyUnliftedBindings ; warnTc (warnUnlifted && not bang_pat && lifted_pat) -- No outer bang, but it's a compound pattern -- E.g (I# x#) = blah diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index d298a10f19..b7b0151c61 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -818,7 +818,7 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing) warnDefaulting :: [FlavoredEvVar] -> Type -> TcM () warnDefaulting wanteds default_ty - = do { warn_default <- doptM Opt_WarnTypeDefaults + = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let wanted_bag = listToBag wanteds tidy_env = tidyFreeTyVars env0 $ diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index e547340954..29a4756171 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1321,7 +1321,7 @@ checkMissingFields data_con rbinds unless (null missing_s_fields) (addErrTc (missingStrictFields data_con missing_s_fields)) - warn <- doptM Opt_WarnMissingFields + warn <- woptM Opt_WarnMissingFields unless (not (warn && notNull missing_ns_fields)) (warnTc True (missingFields data_con missing_ns_fields)) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 36ab1e2d93..ba3feef2f0 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -169,7 +169,7 @@ checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && - dopt Opt_WarnDodgyForeignImports dflags + wopt Opt_WarnDodgyForeignImports dflags = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) | otherwise = return () diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index be0bc49dbe..5887fb57e2 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -44,7 +44,7 @@ import NameSet import Var import VarSet import VarEnv -import DynFlags( DynFlag(..) ) +import DynFlags import Literal import BasicTypes import Maybes @@ -286,7 +286,7 @@ zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords -- Warn about missing signatures -- Do this only when we we have a type to offer - ; warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; warn_missing_sigs <- woptM Opt_WarnMissingSigs ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns | otherwise = noSigWarn @@ -307,7 +307,7 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {})) = panic "zonkLocalBinds" -- Not in typechecker output zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) - = do { warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs + = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs ; let sig_warn | not warn_missing_sigs = noSigWarn | otherwise = localSigWarn sig_ns sig_ns = getTypeSigNames vb diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 528bb0e4ec..67e5a971da 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -473,7 +473,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; let class_ats = map tyConName (classATs clas) defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats omitted = filterOut (`elemNameSet` defined_ats) class_ats - ; warn <- doptM Opt_WarnMissingMethods + ; warn <- woptM Opt_WarnMissingMethods ; mapM_ (warnTc warn . omittedATWarn) omitted -- Ensure that all AT indexes that correspond to class parameters @@ -1250,7 +1250,7 @@ derivBindCtxt sel_id clas tys _bind warnMissingMethod :: Id -> TcM () warnMissingMethod sel_id - = do { warn <- doptM Opt_WarnMissingMethods + = do { warn <- woptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods && not (startsWithUnderscore (getOccName sel_id))) -- Don't warn about _foo methods diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index bd5cf8d0f5..e14c6949c4 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -248,6 +248,9 @@ xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = do { dflags <- getDOpts; return (wopt flag dflags) } + -- XXX setOptM and unsetOptM operate on different types. One should be renamed. setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a @@ -258,11 +261,19 @@ unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} ) + -- | Do it flag is true ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifDOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } +ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifWOptM flag thing_inside = do { b <- woptM flag; + if b then thing_inside else return () } + ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifXOptM flag thing_inside = do { b <- xoptM flag; if b then thing_inside else return () } |