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

1 files changed, 48 insertions, 65 deletions

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