Commit 493ea4ab authored by Ian Lynagh's avatar Ian Lynagh

Separate the warning flags into their own datatype

The -w flag wasn't turning off a few warnings (Opt_WarnMissingImportList,
Opt_WarnMissingLocalSigs, Opt_WarnIdentities). Rather than just adding
them, I've separated the Opt_Warn* contructors off into their own type,
so -w now just sets the list of warning flags to [].
parent 9652dab1
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -2139,6 +2152,11 @@ setDynFlag, unSetDynFlag :: DynFlag -> DynP ()
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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 $
......
......@@ -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))]
$$
......
......@@ -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
......
......@@ -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 $
......
......@@ -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))
......
......@@ -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 ()
......
......@@ -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
......
......@@ -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
......
......@@ -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) }