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)) ...@@ -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] do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
; lhs' <- unsetOptM Opt_EnableRewriteRules $ ; lhs' <- unsetOptM Opt_EnableRewriteRules $
unsetOptM Opt_WarnIdentities $ unsetWOptM Opt_WarnIdentities $
dsLExpr lhs -- Note [Desugaring RULE left hand sides] dsLExpr lhs -- Note [Desugaring RULE left hand sides]
; rhs' <- dsLExpr rhs ; rhs' <- dsLExpr rhs
......
...@@ -225,7 +225,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit ...@@ -225,7 +225,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit
dsExpr (HsWrap co_fn e) dsExpr (HsWrap co_fn e)
= do { co_fn' <- dsHsWrapper co_fn = do { co_fn' <- dsHsWrapper co_fn
; e' <- dsExpr e ; e' <- dsExpr e
; warn_id <- doptDs Opt_WarnIdentities ; warn_id <- woptDs Opt_WarnIdentities
; when warn_id $ warnAboutIdentities e' co_fn' ; when warn_id $ warnAboutIdentities e' co_fn'
; return (co_fn' e') } ; return (co_fn' e') }
...@@ -830,13 +830,13 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () ...@@ -830,13 +830,13 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty warnDiscardedDoBindings rhs rhs_ty
| Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
= do { -- Warn about discarding non-() things in 'monadic' binding = 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) ; if warn_unused && not (isUnitTy elt_ty)
then warnDs (unusedMonadBind rhs elt_ty) then warnDs (unusedMonadBind rhs elt_ty)
else else
-- Warn about discarding m a things in 'monadic' binding of the same type, -- 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 -- 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 ; case tcSplitAppTy_maybe elt_ty of
Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
-> warnDs (wrongMonadBind rhs elt_ty) -> warnDs (wrongMonadBind rhs elt_ty)
......
...@@ -9,7 +9,7 @@ ...@@ -9,7 +9,7 @@
module DsMonad ( module DsMonad (
DsM, mapM, mapAndUnzipM, DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs, initDs, initDsTc, fixDs,
foldlM, foldrM, ifDOptM, unsetOptM, foldlM, foldrM, ifDOptM, unsetOptM, unsetWOptM,
Applicative(..),(<$>), Applicative(..),(<$>),
newLocalName, newLocalName,
...@@ -20,7 +20,7 @@ module DsMonad ( ...@@ -20,7 +20,7 @@ module DsMonad (
mkPrintUnqualifiedDs, mkPrintUnqualifiedDs,
newUnique, newUnique,
UniqSupply, newUniqueSupply, UniqSupply, newUniqueSupply,
getDOptsDs, getGhcModeDs, doptDs, getDOptsDs, getGhcModeDs, doptDs, woptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon, dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
dsLookupClass, dsLookupClass,
...@@ -257,6 +257,9 @@ getDOptsDs = getDOpts ...@@ -257,6 +257,9 @@ getDOptsDs = getDOpts
doptDs :: DynFlag -> TcRnIf gbl lcl Bool doptDs :: DynFlag -> TcRnIf gbl lcl Bool
doptDs = doptM doptDs = doptM
woptDs :: WarningFlag -> TcRnIf gbl lcl Bool
woptDs = woptM
getGhcModeDs :: DsM GhcMode getGhcModeDs :: DsM GhcMode
getGhcModeDs = getDOptsDs >>= return . ghcMode getGhcModeDs = getDOptsDs >>= return . ghcMode
......
...@@ -74,18 +74,18 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs ...@@ -74,18 +74,18 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
where where
(pats, eqns_shadow) = check qs (pats, eqns_shadow) = check qs
incomplete = incomplete_flag hs_ctx && (notNull pats) incomplete = incomplete_flag hs_ctx && (notNull pats)
shadow = dopt Opt_WarnOverlappingPatterns dflags shadow = wopt Opt_WarnOverlappingPatterns dflags
&& notNull eqns_shadow && notNull eqns_shadow
incomplete_flag :: HsMatchContext id -> Bool incomplete_flag :: HsMatchContext id -> Bool
incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags
incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags
incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags
incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags
incomplete_flag ProcExpr = dopt 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 ThPatQuote = False
incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns
......
...@@ -289,8 +289,8 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -289,8 +289,8 @@ mkIface_ hsc_env maybe_old_fingerprint
intermediate_iface decls intermediate_iface decls
-- Warn about orphans -- Warn about orphans
; let warn_orphs = dopt Opt_WarnOrphans dflags ; let warn_orphs = wopt Opt_WarnOrphans dflags
warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
orph_warnings --- Laziness means no work done unless -fwarn-orphans orph_warnings --- Laziness means no work done unless -fwarn-orphans
| warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
| otherwise = emptyBag | otherwise = emptyBag
......
This diff is collapsed.
...@@ -130,8 +130,7 @@ import TyCon ...@@ -130,8 +130,7 @@ import TyCon
import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import DataCon ( DataCon, dataConImplicitIds, dataConWrapId )
import PrelNames ( gHC_PRIM ) import PrelNames ( gHC_PRIM )
import Packages hiding ( Version(..) ) import Packages hiding ( Version(..) )
import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, import DynFlags
DynFlag(..), SafeHaskellMode(..), dynFlagDependencies )
import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase )
import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) )
import OptimizationFuel ( OptFuelState ) import OptimizationFuel ( OptFuelState )
...@@ -235,7 +234,7 @@ printOrThrowWarnings dflags warns ...@@ -235,7 +234,7 @@ printOrThrowWarnings dflags warns
handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
handleFlagWarnings dflags warns 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 -- It would be nicer if warns :: [Located Message], but that
-- has circular import problems. -- has circular import problems.
let bag = listToBag [ mkPlainWarnMsg loc (text warn) let bag = listToBag [ mkPlainWarnMsg loc (text warn)
......
...@@ -197,7 +197,7 @@ runStmtWithLocation source linenumber expr step = ...@@ -197,7 +197,7 @@ runStmtWithLocation source linenumber expr step =
-- Turn off -fwarn-unused-bindings when running a statement, to hide -- Turn off -fwarn-unused-bindings when running a statement, to hide
-- warnings about the implicit bindings we introduce. -- 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' } hsc_env' = hsc_env{ hsc_dflags = dflags' }
r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
......
...@@ -1445,12 +1445,12 @@ lex_quasiquote s = do ...@@ -1445,12 +1445,12 @@ lex_quasiquote s = do
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Warnings -- Warnings
warn :: DynFlag -> SDoc -> Action warn :: WarningFlag -> SDoc -> Action
warn option warning srcspan _buf _len = do warn option warning srcspan _buf _len = do
addWarning option (RealSrcSpan srcspan) warning addWarning option (RealSrcSpan srcspan) warning
lexToken lexToken
warnThen :: DynFlag -> SDoc -> Action -> Action warnThen :: WarningFlag -> SDoc -> Action -> Action
warnThen option warning action srcspan buf len = do warnThen option warning action srcspan buf len = do
addWarning option (RealSrcSpan srcspan) warning addWarning option (RealSrcSpan srcspan) warning
action srcspan buf len action srcspan buf len
...@@ -1878,11 +1878,11 @@ mkPState flags buf loc = ...@@ -1878,11 +1878,11 @@ mkPState flags buf loc =
b `setBitIf` cond | cond = bit b b `setBitIf` cond | cond = bit b
| otherwise = 0 | otherwise = 0
addWarning :: DynFlag -> SrcSpan -> SDoc -> P () addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning addWarning option srcspan warning
= P $ \s@PState{messages=(ws,es), dflags=d} -> = P $ \s@PState{messages=(ws,es), dflags=d} ->
let warning' = mkWarnMsg srcspan alwaysQualify warning 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)} () in POk s{messages=(ws', es)} ()
getMessages :: PState -> Messages getMessages :: PState -> Messages
......
...@@ -980,7 +980,7 @@ checkDupAndShadowedNames envs names ...@@ -980,7 +980,7 @@ checkDupAndShadowedNames envs names
------------------------------------- -------------------------------------
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM ()
checkShadowedOccs (global_env,local_env) loc_occs checkShadowedOccs (global_env,local_env) loc_occs
= ifDOptM Opt_WarnNameShadowing $ = ifWOptM Opt_WarnNameShadowing $
do { traceRn (text "shadow" <+> ppr loc_occs) do { traceRn (text "shadow" <+> ppr loc_occs)
; mapM_ check_shadow loc_occs } ; mapM_ check_shadow loc_occs }
where where
...@@ -1214,7 +1214,7 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' -> ...@@ -1214,7 +1214,7 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' ->
\begin{code} \begin{code}
warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds gres warnUnusedTopBinds gres
= ifDOptM Opt_WarnUnusedBinds = ifWOptM Opt_WarnUnusedBinds
$ do isBoot <- tcIsHsBoot $ do isBoot <- tcIsHsBoot
let noParent gre = case gre_par gre of let noParent gre = case gre_par gre of
NoParent -> True NoParent -> True
...@@ -1230,9 +1230,9 @@ warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM () ...@@ -1230,9 +1230,9 @@ warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
warnUnusedMatches = check_unused Opt_WarnUnusedMatches warnUnusedMatches = check_unused Opt_WarnUnusedMatches
check_unused :: DynFlag -> [Name] -> FreeVars -> RnM () check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
check_unused flag bound_names used_names 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 -- Helpers
......
...@@ -146,7 +146,7 @@ rnImports imports ...@@ -146,7 +146,7 @@ rnImports imports
(source, ordinary) = partition is_source_import imports (source, ordinary) = partition is_source_import imports
is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot
ifDOptM Opt_WarnImplicitPrelude $ ifWOptM Opt_WarnImplicitPrelude $
when (notNull prel_imports) $ addWarn (implicitPreludeWarn) when (notNull prel_imports) $ addWarn (implicitPreludeWarn)
stuff1 <- mapM (rnImportDecl this_mod True) prel_imports stuff1 <- mapM (rnImportDecl this_mod True) prel_imports
...@@ -197,7 +197,7 @@ rnImportDecl this_mod implicit_prelude ...@@ -197,7 +197,7 @@ rnImportDecl this_mod implicit_prelude
Just (False, _) -> return () -- Explicit import list Just (False, _) -> return () -- Explicit import list
_ | implicit_prelude -> return () _ | implicit_prelude -> return ()
| qual_only -> return () | qual_only -> return ()
| otherwise -> ifDOptM Opt_WarnMissingImportList $ | otherwise -> ifWOptM Opt_WarnMissingImportList $
addWarn (missingImportListWarn imp_mod_name) addWarn (missingImportListWarn imp_mod_name)
iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
...@@ -333,7 +333,7 @@ rnImportDecl this_mod implicit_prelude ...@@ -333,7 +333,7 @@ rnImportDecl this_mod implicit_prelude
} }
-- Complain if we import a deprecated module -- Complain if we import a deprecated module
ifDOptM Opt_WarnWarningsDeprecations ( ifWOptM Opt_WarnWarningsDeprecations (
case warns of case warns of
WarnAll txt -> addWarn (moduleWarn imp_mod_name txt) WarnAll txt -> addWarn (moduleWarn imp_mod_name txt)
_ -> return () _ -> return ()
...@@ -690,11 +690,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails ...@@ -690,11 +690,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails
-- Warn when importing T(..) if T was exported abstractly -- Warn when importing T(..) if T was exported abstractly
checkDodgyImport stuff checkDodgyImport stuff
| IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- 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 -- NB. use the RdrName for reporting the warning
| IEThingAll {} <- ieRdr | IEThingAll {} <- ieRdr
, not (is_qual decl_spec) , not (is_qual decl_spec)
= ifDOptM Opt_WarnMissingImportList $ = ifWOptM Opt_WarnMissingImportList $
addWarn (missingImportListItem ieRdr) addWarn (missingImportListItem ieRdr)
checkDodgyImport _ checkDodgyImport _
= return () = return ()
...@@ -1021,13 +1021,13 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod ...@@ -1021,13 +1021,13 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
(L loc (IEModuleContents mod)) (L loc (IEModuleContents mod))
| let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ]
, mod `elem` earlier_mods -- Duplicate export of M , 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) ; warnIf warn_dup_exports (dupModuleExport mod) ;
return acc } return acc }
| otherwise | otherwise
= do { implicit_prelude <- xoptM Opt_ImplicitPrelude = do { implicit_prelude <- xoptM Opt_ImplicitPrelude
; warnDodgyExports <- doptM Opt_WarnDodgyExports ; warnDodgyExports <- woptM Opt_WarnDodgyExports
; let { exportValid = (mod `elem` imported_modules) ; let { exportValid = (mod `elem` imported_modules)
|| (moduleName this_mod == mod) || (moduleName this_mod == mod)
; gres = filter (isModuleExported implicit_prelude mod) ; gres = filter (isModuleExported implicit_prelude mod)
...@@ -1090,7 +1090,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod ...@@ -1090,7 +1090,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
Nothing -> mkRdrUnqual Nothing -> mkRdrUnqual
Just (modName, _) -> mkRdrQual modName Just (modName, _) -> mkRdrQual modName
addUsedRdrNames $ map (mkKidRdrName . nameOccName) kids addUsedRdrNames $ map (mkKidRdrName . nameOccName) kids
warnDodgyExports <- doptM Opt_WarnDodgyExports warnDodgyExports <- woptM Opt_WarnDodgyExports
when (null kids) $ when (null kids) $
if isTyConName name if isTyConName name
then when warnDodgyExports $ addWarn (dodgyExportWarn name) then when warnDodgyExports $ addWarn (dodgyExportWarn name)
...@@ -1173,7 +1173,7 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie' ...@@ -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 -- But we don't want to warn if the same thing is exported
-- by two different module exports. See ticket #4478. -- by two different module exports. See ticket #4478.
-> do unless (dupExport_ok name ie ie') $ do -> 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') warnIf warn_dup_exports (dupExportWarn name_occ ie ie')
return occs return occs
...@@ -1239,7 +1239,7 @@ finishWarnings :: DynFlags -> Maybe WarningTxt ...@@ -1239,7 +1239,7 @@ finishWarnings :: DynFlags -> Maybe WarningTxt
-- All this happens only once per module -- All this happens only once per module
finishWarnings dflags mod_warn tcg_env finishWarnings dflags mod_warn tcg_env
= do { (eps,hpt) <- getEpsAndHpt = do { (eps,hpt) <- getEpsAndHpt
; ifDOptM Opt_WarnWarningsDeprecations $ ; ifWOptM Opt_WarnWarningsDeprecations $
mapM_ (check hpt (eps_PIT eps)) all_gres mapM_ (check hpt (eps_PIT eps)) all_gres
-- By this time, typechecking is complete, -- By this time, typechecking is complete,
-- so the PIT is fully populated -- so the PIT is fully populated
...@@ -1394,7 +1394,7 @@ warnUnusedImportDecls gbl_env ...@@ -1394,7 +1394,7 @@ warnUnusedImportDecls gbl_env
usage = findImportUsage imports rdr_env (Set.elems uses) usage = findImportUsage imports rdr_env (Set.elems uses)
; traceRn (ptext (sLit "Import usage") <+> ppr usage) ; traceRn (ptext (sLit "Import usage") <+> ppr usage)
; ifDOptM Opt_WarnUnusedImports $ ; ifWOptM Opt_WarnUnusedImports $
mapM_ warnUnusedImport usage mapM_ warnUnusedImport usage
; ifDOptM Opt_D_dump_minimal_imports $ ; ifDOptM Opt_D_dump_minimal_imports $
......
...@@ -563,7 +563,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) ...@@ -563,7 +563,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
-> TcRnIf TcGblEnv TcLclEnv () -> TcRnIf TcGblEnv TcLclEnv ()
forAllWarn doc ty (L loc tyvar) 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), 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))] 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 ...@@ -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 -- This should be a checkTc, not a warnTc, but as of GHC 6.11
-- the versions of alex and happy available have non-conforming -- the versions of alex and happy available have non-conforming
-- templates, so the GHC build fails if it's an error: -- 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) ; warnTc (warnUnlifted && not bang_pat && lifted_pat)
-- No outer bang, but it's a compound pattern -- No outer bang, but it's a compound pattern
-- E.g (I# x#) = blah -- E.g (I# x#) = blah
......
...@@ -818,7 +818,7 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing) ...@@ -818,7 +818,7 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
warnDefaulting :: [FlavoredEvVar] -> Type -> TcM () warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
warnDefaulting wanteds default_ty warnDefaulting wanteds default_ty
= do { warn_default <- doptM Opt_WarnTypeDefaults = do { warn_default <- woptM Opt_WarnTypeDefaults
; env0 <- tcInitTidyEnv ; env0 <- tcInitTidyEnv
; let wanted_bag = listToBag wanteds ; let wanted_bag = listToBag wanteds
tidy_env = tidyFreeTyVars env0 $ tidy_env = tidyFreeTyVars env0 $
......
...@@ -1321,7 +1321,7 @@ checkMissingFields data_con rbinds ...@@ -1321,7 +1321,7 @@ checkMissingFields data_con rbinds
unless (null missing_s_fields) unless (null missing_s_fields)
(addErrTc (missingStrictFields data_con 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)) unless (not (warn && notNull missing_ns_fields))
(warnTc True (missingFields data_con missing_ns_fields)) (warnTc True (missingFields data_con missing_ns_fields))
......
...@@ -169,7 +169,7 @@ checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" ...@@ -169,7 +169,7 @@ checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand dflags arg_tys res_ty checkMissingAmpersand dflags arg_tys res_ty
| null arg_tys && isFunPtrTy 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")) = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
| otherwise | otherwise
= return () = return ()
......
...@@ -44,7 +44,7 @@ import NameSet ...@@ -44,7 +44,7 @@ import NameSet
import Var import Var
import VarSet import VarSet
import VarEnv import VarEnv
import DynFlags( DynFlag(..) ) import DynFlags
import Literal import Literal
import BasicTypes import BasicTypes
import Maybes import Maybes
...@@ -286,7 +286,7 @@ zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords ...@@ -286,7 +286,7 @@ zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
-- Warn about missing signatures -- Warn about missing signatures
-- Do this only when we we have a type to offer -- 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 ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
| otherwise = noSigWarn | otherwise = noSigWarn
...@@ -307,7 +307,7 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {})) ...@@ -307,7 +307,7 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
= panic "zonkLocalBinds" -- Not in typechecker output = panic "zonkLocalBinds" -- Not in typechecker output
zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) 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 ; let sig_warn | not warn_missing_sigs = noSigWarn
| otherwise = localSigWarn sig_ns | otherwise = localSigWarn sig_ns
sig_ns = getTypeSigNames vb sig_ns = getTypeSigNames vb
......
...@@ -473,7 +473,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ...@@ -473,7 +473,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
; let class_ats = map tyConName (classATs clas) ; let class_ats = map tyConName (classATs clas)
defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
omitted = filterOut (`elemNameSet` defined_ats) class_ats omitted = filterOut (`elemNameSet` defined_ats) class_ats
; warn <- doptM Opt_WarnMissingMethods ; warn <- woptM Opt_WarnMissingMethods
; mapM_ (warnTc warn . omittedATWarn) omitted ; mapM_ (warnTc warn . omittedATWarn) omitted
-- Ensure that all AT indexes that correspond to class parameters -- Ensure that all AT indexes that correspond to class parameters
...@@ -1250,7 +1250,7 @@ derivBindCtxt sel_id clas tys _bind ...@@ -1250,7 +1250,7 @@ derivBindCtxt sel_id clas tys _bind
warnMissingMethod :: Id -> TcM () warnMissingMethod :: Id -> TcM ()
warnMissingMethod sel_id warnMissingMethod sel_id
= do { warn <- doptM Opt_WarnMissingMethods = do { warn <- woptM Opt_WarnMissingMethods
; warnTc (warn -- Warn only if -fwarn-missing-methods ; warnTc (warn -- Warn only if -fwarn-missing-methods
&& not (startsWithUnderscore (getOccName sel_id))) && not (startsWithUnderscore (getOccName sel_id)))
-- Don't warn about _foo methods -- Don't warn about _foo methods
......
...@@ -248,6 +248,9 @@ xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } ...@@ -248,6 +248,9 @@ xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) }
doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM :: DynFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } 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. -- XXX setOptM and unsetOptM operate on different types. One should be renamed.
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
...@@ -258,11 +261,19 @@ unsetOptM :: DynFlag -> 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 }) -> unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) 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 -- | Do it flag is true
ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifDOptM flag thing_inside = do { b <- doptM flag; ifDOptM flag thing_inside = do { b <- doptM flag;
if b then thing_inside else return () } 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 :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifXOptM flag thing_inside = do { b <- xoptM flag; ifXOptM flag thing_inside = do { b <- xoptM flag;
if b then thing_inside else return () } 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