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
......
This diff is collapsed.
......@@ -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) }
-- 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 () }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment