Commit 49528121 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli Committed by Marge Bot

Introduce SevIgnore Severity to suppress warnings

This commit introduces a new `Severity` type constructor called
`SevIgnore`, which can be used to classify diagnostic messages which are
not meant to be displayed to the user, for example suppressed warnings.

This extra constructor allows us to get rid of a bunch of redundant
checks when emitting diagnostics, typically in the form of the pattern:

```
when (optM Opt_XXX) $
  addDiagnosticTc (WarningWithFlag Opt_XXX) ...
```

Fair warning! Not all checks should be omitted/skipped, as evaluating some data
structures used to produce a diagnostic might still be expensive (e.g.
zonking, etc). Therefore, a case-by-case analysis must be conducted when
deciding if a check can be removed or not.

Last but not least, we remove the unnecessary `CmdLine.WarnReason` type, which is now
redundant with `DiagnosticReason`.
parent 77772bb1
......@@ -899,7 +899,7 @@ checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags logger dflags = do
-- See Note [DynFlags consistency]
let (dflags', warnings) = makeDynFlagsConsistent dflags
liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings)
liftIO $ handleFlagWarnings logger dflags (map (Warn WarningWithoutFlag) warnings)
return dflags'
checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
......@@ -1949,4 +1949,3 @@ instance Exception GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
......@@ -20,8 +20,7 @@ module GHC.Driver.CmdLine
Err(..), Warn(..), WarnReason(..),
EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM,
deprecate
EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM
) where
#include "HsVersions.h"
......@@ -35,6 +34,8 @@ import GHC.Data.Bag
import GHC.Types.SrcLoc
import GHC.Utils.Json
import GHC.Types.Error ( DiagnosticReason(..) )
import Data.Function
import Data.List (sortBy, intercalate, stripPrefix)
......@@ -107,7 +108,7 @@ newtype Err = Err { errMsg :: Located String }
-- | A command-line warning message and the reason it arose
data Warn = Warn
{ warnReason :: WarnReason,
{ warnReason :: DiagnosticReason,
warnMsg :: Located String
}
......@@ -141,17 +142,12 @@ addErr :: Monad m => String -> EwM m ()
addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))
addWarn :: Monad m => String -> EwM m ()
addWarn = addFlagWarn NoReason
addWarn = addFlagWarn WarningWithoutFlag
addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()
addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m ()
addFlagWarn reason msg = EwM $
(\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))
deprecate :: Monad m => String -> EwM m ()
deprecate s = do
arg <- getArg
addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s)
getArg :: Monad m => EwM m String
getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
......
......@@ -36,23 +36,22 @@ printBagOfErrors logger dflags bag_of_errors
handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()
handleFlagWarnings logger dflags warns = do
let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns
let warns' = filter (should_print_warning dflags . CmdLine.warnReason) warns
-- It would be nicer if warns :: [Located SDoc], but that
-- has circular import problems.
bag = listToBag [ mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text warn)
| CmdLine.Warn _ (L loc warn) <- warns' ]
printOrThrowDiagnostics logger dflags bag
-- Given a warn reason, check to see if it's associated -W opt is enabled
shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag
= wopt Opt_WarnDeprecatedFlags dflags
shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag
= wopt Opt_WarnUnrecognisedWarningFlags dflags
shouldPrintWarning _ _
= True
where
-- Given a warn reason, check to see if it's associated -W opt is enabled
should_print_warning :: DynFlags -> DiagnosticReason -> Bool
should_print_warning dflags (WarningWithFlag Opt_WarnDeprecatedFlags)
= wopt Opt_WarnDeprecatedFlags dflags
should_print_warning dflags (WarningWithFlag Opt_WarnUnrecognisedWarningFlags)
= wopt Opt_WarnUnrecognisedWarningFlags dflags
should_print_warning _ _
= True
-- | Given a bag of diagnostics, turn them into an exception if
-- any has 'SevError', or print them out otherwise.
......
......@@ -270,7 +270,7 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check
-- The warning in enabled by `-Wmissing-home-modules`. See #13129
warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules hsc_env mod_graph =
when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $
when (not (null missing)) $
logWarnings (listToBag [warn])
where
dflags = hsc_dflags hsc_env
......@@ -391,7 +391,7 @@ warnUnusedPackages = do
, text "but were not needed for compilation:"
, nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]
when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $
when (not (null unusedArgs)) $
logWarnings (listToBag [warn])
where
......
......@@ -235,7 +235,6 @@ import GHC.Settings.Config
import GHC.Utils.CliOption
import {-# SOURCE #-} GHC.Core.Unfold
import GHC.Driver.CmdLine
import qualified GHC.Driver.CmdLine as Cmd
import GHC.Settings.Constants
import GHC.Utils.Panic
import qualified GHC.Utils.Ppr.Colour as Col
......@@ -1869,7 +1868,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
liftIO $ setUnsafeGlobalDynFlags dflags4
let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)
let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns)
return (dflags4, leftover, warns' ++ warns)
......@@ -2889,7 +2888,7 @@ unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action)
action :: String -> EwM (CmdLineP DynFlags) ()
action flag = do
f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState
when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $
when f $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $
"unrecognised warning flag: -" ++ prefix ++ flag
-- See Note [Supporting CLI completion]
......@@ -3050,6 +3049,12 @@ mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))
= (dep,
Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)
-- here to avoid module cycle with GHC.Driver.CmdLine
deprecate :: Monad m => String -> EwM m ()
deprecate s = do
arg <- getArg
addFlagWarn (WarningWithFlag Opt_WarnDeprecatedFlags) (arg ++ " is deprecated: " ++ s)
deprecatedForExtension :: String -> TurnOnFlag -> String
deprecatedForExtension lang turn_on
= "use -X" ++ flag ++
......
......@@ -90,7 +90,6 @@ import GHC.Unit.Module.ModIface
import Data.List (partition)
import Data.IORef
import Control.Monad( when )
import GHC.Driver.Plugins ( LoadedPlugin(..) )
{-
......@@ -438,8 +437,7 @@ dsRule (L loc (HsRule { rd_name = name
; rule <- dsMkUserRule this_mod is_local
rule_name rule_act fn_name final_bndrs args
final_rhs
; when (wopt Opt_WarnInlineRuleShadowing dflags) $
warnRuleShadowing rule_name rule_act fn_id arg_ids
; warnRuleShadowing rule_name rule_act fn_id arg_ids
; return (Just rule)
} } }
......
......@@ -767,8 +767,7 @@ dsMkUserRule :: Module -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
let rule = mkRule this_mod False is_local name act fn bndrs args rhs
dflags <- getDynFlags
when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
when (isOrphan (ru_orphan rule)) $
diagnosticDs (WarningWithFlag Opt_WarnOrphans) (ruleOrphWarn rule)
return rule
......
......@@ -1047,8 +1047,7 @@ lookup_demoted rdr_name
; case mb_demoted_name of
Nothing -> unboundNameX WL_Any rdr_name star_info
Just demoted_name ->
do { whenWOptM Opt_WarnUntickedPromotedConstructors $
addDiagnostic
do { addDiagnostic
(WarningWithFlag Opt_WarnUntickedPromotedConstructors)
(untickedPromConstrWarn demoted_name)
; return demoted_name } }
......
......@@ -1648,8 +1648,7 @@ dataKindsErr env thing
warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll doc (L loc tv) used_names
= whenWOptM Opt_WarnUnusedForalls $
unless (hsTyVarName tv `elemNameSet` used_names) $
= unless (hsTyVarName tv `elemNameSet` used_names) $
addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $
vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
, inHsDocContext doc ]
......
......@@ -1945,16 +1945,15 @@ warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
-> RnM ()
warnNoDerivStrat mds loc
= do { dyn_flags <- getDynFlags
; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $
case mds of
Nothing -> addDiagnosticAt
(WarningWithFlag Opt_WarnMissingDerivingStrategies)
loc
(if xopt LangExt.DerivingStrategies dyn_flags
then no_strat_warning
else no_strat_warning $+$ deriv_strat_nenabled
)
_ -> pure ()
; case mds of
Nothing -> addDiagnosticAt
(WarningWithFlag Opt_WarnMissingDerivingStrategies)
loc
(if xopt LangExt.DerivingStrategies dyn_flags
then no_strat_warning
else no_strat_warning $+$ deriv_strat_nenabled
)
_ -> pure ()
}
where
no_strat_warning :: SDoc
......
......@@ -394,12 +394,10 @@ rnImportDecl this_mod
imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)
-- Complain if we import a deprecated module
whenWOptM Opt_WarnWarningsDeprecations (
case (mi_warns iface) of
WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
(moduleWarn imp_mod_name txt)
_ -> return ()
)
case mi_warns iface of
WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
(moduleWarn imp_mod_name txt)
_ -> return ()
-- Complain about -Wcompat-unqualified-imports violations.
warnUnqualifiedImport decl iface
......@@ -522,8 +520,7 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by =
-- Currently not used for anything.
warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM ()
warnUnqualifiedImport decl iface =
whenWOptM Opt_WarnCompatUnqualifiedImports
$ when bad_import
when bad_import
$ addDiagnosticAt (WarningWithFlag Opt_WarnCompatUnqualifiedImports) loc warning
where
mod = mi_module iface
......
......@@ -912,10 +912,9 @@ check_cross_stage_lifting top_lvl name ps_var
pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
-- Warning for implicit lift (#17804)
; whenWOptM Opt_WarnImplicitLift $
addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)
(text "The variable" <+> quotes (ppr name) <+>
text "is implicitly lifted in the TH quotation")
; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)
(text "The variable" <+> quotes (ppr name) <+>
text "is implicitly lifted in the TH quotation")
-- Update the pending splices
; ps <- readMutVar ps_var
......
......@@ -738,10 +738,9 @@ tcStandaloneDerivInstType ctxt
warnUselessTypeable :: TcM ()
warnUselessTypeable
= do { warn <- woptM Opt_WarnDerivingTypeable
; when warn $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable)
$ text "Deriving" <+> quotes (ppr typeableClassName) <+>
text "has no effect: all types now auto-derive Typeable" }
= do { addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable)
$ text "Deriving" <+> quotes (ppr typeableClassName) <+>
text "has no effect: all types now auto-derive Typeable" }
------------------------------------------------------------------
deriveTyData :: TyCon -> [Type] -- LHS of data or data instance
......@@ -1610,8 +1609,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys
-- DeriveAnyClass, but emitting a warning about the choice.
-- See Note [Deriving strategies]
when (newtype_deriving && deriveAnyClass) $
lift $ whenWOptM Opt_WarnDerivingDefaults $
addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep
lift $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep
[ text "Both DeriveAnyClass and"
<+> text "GeneralizedNewtypeDeriving are enabled"
, text "Defaulting to the DeriveAnyClass strategy"
......
......@@ -50,7 +50,7 @@ import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Name.Set
import GHC.Data.Bag
import GHC.Utils.Error ( pprLocMsgEnvelope )
import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope )
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Core.ConLike ( ConLike(..))
......@@ -66,10 +66,9 @@ import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.FV ( fvVarList, unionFV )
import Control.Monad ( unless, when )
import Control.Monad ( unless, when, forM_ )
import Data.Foldable ( toList )
import Data.List ( partition, mapAccumL, sortBy, unfoldr )
import Data.Traversable ( for )
import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )
......@@ -132,34 +131,24 @@ reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
reportUnsolved wanted
= do { binds_var <- newTcEvBinds
; defer_errors <- goptM Opt_DeferTypeErrors
; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
; let type_errors | not defer_errors = Just ErrorWithoutFlag
| warn_errors = Just (WarningWithFlag Opt_WarnDeferredTypeErrors)
| otherwise = Nothing
; let type_errors | not defer_errors = ErrorWithoutFlag
| otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors
; defer_holes <- goptM Opt_DeferTypedHoles
; warn_holes <- woptM Opt_WarnTypedHoles
; let expr_holes | not defer_holes = Just ErrorWithoutFlag
| warn_holes = Just (WarningWithFlag Opt_WarnTypedHoles)
| otherwise = Nothing
; let expr_holes | not defer_holes = ErrorWithoutFlag
| otherwise = WarningWithFlag Opt_WarnTypedHoles
; partial_sigs <- xoptM LangExt.PartialTypeSignatures
; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
; let type_holes | not partial_sigs
= Just ErrorWithoutFlag
| warn_partial_sigs
= Just (WarningWithFlag Opt_WarnPartialTypeSignatures)
= ErrorWithoutFlag
| otherwise
= Nothing
= WarningWithFlag Opt_WarnPartialTypeSignatures
; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables
; let out_of_scope_holes | not defer_out_of_scope
= Just ErrorWithoutFlag
| warn_out_of_scope
= Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables)
= ErrorWithoutFlag
| otherwise
= Nothing
= WarningWithFlag Opt_WarnDeferredOutOfScopeVariables
; report_unsolved type_errors expr_holes
type_holes out_of_scope_holes
......@@ -180,13 +169,11 @@ reportAllUnsolved wanted
= do { ev_binds <- newNoTcEvBinds
; partial_sigs <- xoptM LangExt.PartialTypeSignatures
; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
; let type_holes | not partial_sigs = Just ErrorWithoutFlag
| warn_partial_sigs = Just (WarningWithFlag Opt_WarnPartialTypeSignatures)
| otherwise = Nothing
; let type_holes | not partial_sigs = ErrorWithoutFlag
| otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures
; report_unsolved (Just ErrorWithoutFlag)
(Just ErrorWithoutFlag) type_holes (Just ErrorWithoutFlag)
; report_unsolved ErrorWithoutFlag
ErrorWithoutFlag type_holes ErrorWithoutFlag
ev_binds wanted }
-- | Report all unsolved goals as warnings (but without deferring any errors to
......@@ -195,17 +182,17 @@ reportAllUnsolved wanted
warnAllUnsolved :: WantedConstraints -> TcM ()
warnAllUnsolved wanted
= do { ev_binds <- newTcEvBinds
; report_unsolved (Just WarningWithoutFlag)
(Just WarningWithoutFlag)
(Just WarningWithoutFlag)
(Just WarningWithoutFlag)
; report_unsolved WarningWithoutFlag
WarningWithoutFlag
WarningWithoutFlag
WarningWithoutFlag
ev_binds wanted }
-- | Report unsolved goals as errors or warnings.
report_unsolved :: Maybe DiagnosticReason -- Deferred type errors
-> Maybe DiagnosticReason -- Expression holes
-> Maybe DiagnosticReason -- Type holes
-> Maybe DiagnosticReason -- Out of scope holes
report_unsolved :: DiagnosticReason -- Deferred type errors
-> DiagnosticReason -- Expression holes
-> DiagnosticReason -- Type holes
-> DiagnosticReason -- Out of scope holes
-> EvBindsVar -- cec_binds
-> WantedConstraints -> TcM ()
report_unsolved type_errors expr_holes
......@@ -320,15 +307,15 @@ data ReportErrCtxt
-- into warnings, and emit evidence bindings
-- into 'cec_binds' for unsolved constraints
, cec_defer_type_errors :: Maybe DiagnosticReason -- Nothing: Defer type errors until runtime
, cec_defer_type_errors :: DiagnosticReason -- Defer type errors until runtime
-- cec_expr_holes is a union of:
-- cec_type_holes - a set of typed holes: '_', '_a', '_foo'
-- cec_out_of_scope_holes - a set of variables which are
-- out of scope: 'x', 'y', 'bar'
, cec_expr_holes :: Maybe DiagnosticReason -- Holes in expressions. Nothing: defer/suppress errors.
, cec_type_holes :: Maybe DiagnosticReason -- Holes in types. Nothing: defer/suppress errors.
, cec_out_of_scope_holes :: Maybe DiagnosticReason -- Out of scope holes. Nothing: defer/suppress errors.
, cec_expr_holes :: DiagnosticReason -- Holes in expressions.
, cec_type_holes :: DiagnosticReason -- Holes in types.
, cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes.
, cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints
, cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms
......@@ -361,19 +348,19 @@ instance Outputable ReportErrCtxt where
-- | Returns True <=> the ReportErrCtxt indicates that something is deferred
deferringAnyBindings :: ReportErrCtxt -> Bool
-- Don't check cec_type_holes, as these don't cause bindings to be deferred
deferringAnyBindings (CEC { cec_defer_type_errors = Just ErrorWithoutFlag
, cec_expr_holes = Just ErrorWithoutFlag
, cec_out_of_scope_holes = Just ErrorWithoutFlag }) = False
deferringAnyBindings _ = True
deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag
, cec_expr_holes = ErrorWithoutFlag
, cec_out_of_scope_holes = ErrorWithoutFlag }) = False
deferringAnyBindings _ = True
maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt
-- Switch off defer-type-errors inside CoEvBindsVar
-- See Note [Failing equalities with no evidence bindings]
maybeSwitchOffDefer evb ctxt
| CoEvBindsVar{} <- evb
= ctxt { cec_defer_type_errors = Just ErrorWithoutFlag
, cec_expr_holes = Just ErrorWithoutFlag
, cec_out_of_scope_holes = Just ErrorWithoutFlag }
= ctxt { cec_defer_type_errors = ErrorWithoutFlag
, cec_expr_holes = ErrorWithoutFlag
, cec_out_of_scope_holes = ErrorWithoutFlag }
| otherwise
= ctxt
......@@ -727,22 +714,22 @@ mkSkolReporter ctxt cts
reportHoles :: [Ct] -- other (tidied) constraints
-> ReportErrCtxt -> [Hole] -> TcM ()
reportHoles tidy_cts ctxt
= mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $
do { msg_mb <- mkHoleError tidy_cts ctxt hole
; whenIsJust msg_mb reportDiagnostic }
reportHoles tidy_cts ctxt holes
= do df <- getDynFlags
forM_ holes $ \hole -> unless (ignoreThisHole df ctxt hole) $
mkHoleError tidy_cts ctxt hole >>= reportDiagnostic
ignoreThisHole :: ReportErrCtxt -> Hole -> Bool
ignoreThisHole :: DynFlags -> ReportErrCtxt -> Hole -> Bool
-- See Note [Skip type holes rapidly]
ignoreThisHole ctxt hole
ignoreThisHole df ctxt hole
= case hole_sort hole of
ExprHole {} -> False
TypeHole -> ignore_type_hole
ConstraintHole -> ignore_type_hole
where
ignore_type_hole = case cec_type_holes ctxt of
Nothing -> True
_ -> False
ignore_type_hole = case diagReasonSeverity df (cec_type_holes ctxt) of
SevIgnore -> True
_ -> False
{- Note [Skip type holes rapidly]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -894,14 +881,11 @@ suppressGroup mk_err ctxt cts
maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM ()
maybeReportError ctxt ct report
| Just reason <- cec_defer_type_errors ctxt
= unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic
do msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report
do let reason = cec_defer_type_errors ctxt
msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report
reportDiagnostic msg
| otherwise
= return () -- nothing to report
addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
addDeferredBinding ctxt err ct
......@@ -1164,7 +1148,7 @@ See also 'reportUnsolved'.
----------------
-- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].
mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (Maybe (MsgEnvelope DiagnosticMessage))
mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DiagnosticMessage)
mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ
, hole_ty = hole_ty
, hole_loc = ct_loc })
......@@ -1180,8 +1164,7 @@ mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ
(tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))
; maybeAddDeferredBindings ctxt hole err
; for (cec_out_of_scope_holes ctxt) $ \ rea ->
mkErrorReportNC rea lcl_env err
; mkErrorReportNC (cec_out_of_scope_holes ctxt) lcl_env err
-- Use NC variant: the context is generally not helpful here
}
where
......@@ -1223,7 +1206,7 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
; let holes | ExprHole _ <- sort = cec_expr_holes ctxt
| otherwise = cec_type_holes ctxt
; for holes $ \ rea -> mkErrorReport rea ctxt lcl_env err
; mkErrorReport holes ctxt lcl_env err
}
where
......@@ -1260,7 +1243,7 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
-- hole, via kind casts
type_hole_hint
| Just ErrorWithoutFlag <- cec_type_holes ctxt
| ErrorWithoutFlag <- cec_type_holes ctxt
= text "To use the inferred type, enable PartialTypeSignatures"
| otherwise
= empty
......
......@@ -801,9 +801,7 @@ mkExport prag_fn insoluble qtvs theta
else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $
tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty
; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
; when warn_missing_sigs $
localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
; localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
; return (ABE { abe_ext = noExtField
, abe_wrap = wrap
......
......@@ -236,9 +236,8 @@ exports_from_avail Nothing rdr_env _imports _this_mod
-- so that's how we handle it, except we also export the data family
-- when a data instance is exported.
= do {
; warnMissingExportList <- woptM Opt_WarnMissingExportList
; warnIfFlag Opt_WarnMissingExportList
warnMissingExportList
True
(missingModuleExportWarn $ moduleName _this_mod)
; let avails =
map fix_faminst . gresToAvailInfo
......@@ -393,12 +392,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
let gres = findChildren kids_env name
(non_flds, flds) = classifyGREs gres
addUsedKids (ieWrappedName rdr) gres
warnDodgyExports <- woptM Opt_WarnDodgyExports
when (null gres) $
if isTyConName name
then when warnDodgyExports $
addDiagnostic (WarningWithFlag Opt_WarnDodgyExports)
(dodgyExportWarn name)
then addDiagnostic (WarningWithFlag Opt_WarnDodgyExports)
(dodgyExportWarn name)
else -- This occurs when you export T(..), but
-- only import T abstractly, or T is a synonym.
addErr (exportItemErr ie)
......
......@@ -1409,8 +1409,7 @@ checkMissingFields con_like rbinds arg_tys
-- Illegal if any arg is strict
addErrTc (missingStrictFields con_like [])
else do
warn <- woptM Opt_WarnMissingFields
when (warn && notNull field_strs && null field_labels)
when (notNull field_strs && null field_labels)
(diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True
(missingFields con_like []))
......
......@@ -324,7 +324,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
dflags <- getDynFlags
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty
checkMissingAmpersand (map scaledThing arg_tys) res_ty
case target of
StaticTarget _ _ _ False
| not (null arg_tys) ->
......@@ -343,10 +343,9 @@ checkCTarget (StaticTarget _ str _ _) = do
checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand dflags arg_tys res_ty
| null arg_tys && isFunPtrTy res_ty &&
wopt Opt_WarnDodgyForeignImports dflags
checkMissingAmpersand :: [Type] -> Type -> TcM ()