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`.

11 files changed, 72 insertions, 103 deletions

diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 198bfa2477..40761ed38c 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -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"
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index abb58cd58b..dda7c0eeac 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -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
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 228c3d3644..10294998c0 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -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
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 552b010994..a874e04fd7 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -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)
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 662a418116..ecd07c6059 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -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 []))
 
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index d823cdbafb..57b99e703a 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -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 ()
+checkMissingAmpersand arg_tys res_ty
+  | null arg_tys && isFunPtrTy res_ty
   = addDiagnosticTc (WarningWithFlag Opt_WarnDodgyForeignImports)
                     (text "possible missing & in foreign import of FunPtr")
   | otherwise
@@ -534,9 +533,8 @@ checkCConv StdCallConv  = do dflags <- getDynFlags
                              if platformArch platform == ArchX86
                                  then return StdCallConv
                                  else do -- This is a warning, not an error. see #3336
-                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
-                                             addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions)
-                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
+                                         addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions)
+                                           (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
                                          return CCallConv
 checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
                              return PrimCallConv
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 0f1859ab55..85fd9d51f4 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -1114,10 +1114,9 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
                                        [getRuntimeRep id_ty, id_ty]
 
                    -- Warning for implicit lift (#17804)
-        ; whenWOptM Opt_WarnImplicitLift $
-            addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)
-                            (text "The variable" <+> quotes (ppr id) <+>
-                             text "is implicitly lifted in the TH quotation")
+        ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)
+                          (text "The variable" <+> quotes (ppr id) <+>
+                           text "is implicitly lifted in the TH quotation")
 
                    -- Update the pending splices
         ; ps <- readMutVar ps_var
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 0883ba1c8b..e906dd267f 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -258,9 +258,8 @@ tcRnModuleTcRnM hsc_env mod_sum
         ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
                                implicit_prelude import_decls }
 
-        ; whenWOptM Opt_WarnImplicitPrelude $
-             when (notNull prel_imports) $
-                addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn)
+        ; when (notNull prel_imports) $
+            addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn)
 
         ; -- TODO This is a little skeevy; maybe handle a bit more directly
           let { simplifyImport (L _ idecl) =
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index b4efeaabdd..d4e9003b72 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -1344,8 +1344,7 @@ decideMonoTyVars infer_mode name_taus psigs candidates
              mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs
 
            -- Warn about the monomorphism restriction
-       ; warn_mono <- woptM Opt_WarnMonomorphism
-       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $
+       ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $
          diagnosticTc (WarningWithFlag Opt_WarnMonomorphism)
                       (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)
                       mr_msg
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index a8f6cbbc19..bddb585a51 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1507,9 +1507,8 @@ failIfTcM True  err = failWithTcM err
 --   and the warning is enabled
 warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn ()
 warnIfFlag warn_flag is_bad msg
-  = do { warn_on <- woptM warn_flag
-       ; when (warn_on && is_bad) $
-         addDiagnostic (WarningWithFlag warn_flag) msg }
+  = do { -- No need to check the flag here, it will be done in 'diagReasonSeverity'.
+       ; when is_bad $ addDiagnostic (WarningWithFlag warn_flag) msg }
 
 -- | Display a warning if a condition is met.
 warnIf :: Bool -> SDoc -> TcRn ()
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 610c31789c..173a8e68cf 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -1103,7 +1103,7 @@ check_valid_theta _ _ _ []
 check_valid_theta env ctxt expand theta
   = do { dflags <- getDynFlags
        ; diagnosticTcM (WarningWithFlag Opt_WarnDuplicateConstraints)
-                       (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)
+                       (notNull dups)
                        (dupPredWarn env dups)
        ; traceTc "check_valid_theta" (ppr theta)
        ; mapM_ (check_pred_ty env dflags ctxt expand) theta }