Compute Severity of diagnostics at birth

This commit further expand on the design for #18516 by getting rid of
the `defaultReasonSeverity` in favour of a function called
`diagReasonSeverity` which correctly takes the `DynFlags` as input. The
idea is to compute the `Severity` and the `DiagnosticReason` of each
message "at birth", without doing any later re-classifications, which
are potentially error prone, as the `DynFlags` might evolve during the
course of the program.

In preparation for a proper refactoring, now `pprWarning` from the
Parser.Ppr module has been renamed to `mkParserWarn`, which now takes a
`DynFlags` as input.

We also get rid of the reclassification we were performing inside `printOrThrowWarnings`.

Last but not least, this commit removes the need for reclassify inside GHC.Tc.Errors,
and also simplifies the implementation of `maybeReportError`.

Update Haddock submodule

1 files changed, 25 insertions, 81 deletions

diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 7edf599c9f..48cb9eaedd 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -19,7 +19,6 @@ module GHC.Types.Error
 
    , MessageClass (..)
    , Severity (..)
-   , mkMCDiagnostic
    , Diagnostic (..)
    , DiagnosticMessage (..)
    , DiagnosticReason (..)
@@ -33,14 +32,8 @@ module GHC.Types.Error
    , mkLocMessage
    , mkLocMessageAnn
    , getCaretDiagnostic
-   -- * Constructing individual diagnostic messages
-   , mkMsgEnvelope
-   , mkPlainMsgEnvelope
-   , mkLongMsgEnvelope
-   , mkShortMsgEnvelope
-   , defaultReasonSeverity
    -- * Queries
-   , isErrorMessage
+   , isIntrinsicErrorMessage
    , isWarningMessage
    , getErrorMessages
    , getWarningMessages
@@ -193,9 +186,9 @@ data DiagnosticReason
 
 instance Outputable DiagnosticReason where
   ppr = \case
-    WarningWithoutFlag              -> text "WarningWithoutFlag"
-    WarningWithFlag wf              -> text ("WarningWithFlag " ++ show wf)
-    ErrorWithoutFlag                -> text "ErrorWithoutFlag"
+    WarningWithoutFlag  -> text "WarningWithoutFlag"
+    WarningWithFlag wf  -> text ("WarningWithFlag " ++ show wf)
+    ErrorWithoutFlag    -> text "ErrorWithoutFlag"
 
 -- | An envelope for GHC's facts about a running program, parameterised over the
 -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.
@@ -237,11 +230,6 @@ data MessageClass
     -- /especially/ when emitting compiler diagnostics, use the smart constructor.
   deriving (Eq, Show)
 
--- | Make a 'MessageClass' for a given 'DiagnosticReason', without consulting the 'DynFlags'.
--- This will not respect -Werror or warning suppression and so is probably wrong
--- for any warning.
-mkMCDiagnostic :: DiagnosticReason -> MessageClass
-mkMCDiagnostic reason = MCDiagnostic (defaultReasonSeverity reason) reason
 
 -- | Used to describe warnings and errors
 --   o The message has a file\/line\/column heading,
@@ -325,14 +313,6 @@ mkLocMessageAnn ann msg_class locn msg
         MCFatal                         -> text "fatal:"
         _                               -> empty
 
--- | Computes a severity from a reason in the absence of DynFlags. This will likely
--- be wrong in the presence of -Werror. It will be removed in the context of #18516.
-defaultReasonSeverity :: DiagnosticReason -> Severity
-defaultReasonSeverity = \case
-  WarningWithoutFlag    -> SevWarning
-  WarningWithFlag _flag -> SevWarning
-  ErrorWithoutFlag      -> SevError
-
 getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
 getMessageClassColour (MCDiagnostic SevError _reason)   = Col.sError
 getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning
@@ -416,76 +396,40 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) =
         caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
 
 --
--- Creating MsgEnvelope(s)
+-- Queries
 --
 
-mkMsgEnvelope
-  :: Diagnostic e
-  => Severity
-  -> SrcSpan
-  -> PrintUnqualified
-  -> e
-  -> MsgEnvelope e
-mkMsgEnvelope sev locn print_unqual err
- = MsgEnvelope { errMsgSpan = locn
-               , errMsgContext = print_unqual
-               , errMsgDiagnostic = err
-               , errMsgSeverity = sev
-               }
-
--- | A long (multi-line) diagnostic message.
--- The 'Severity' will be calculated out of the 'DiagnosticReason', and will likely be
--- incorrect in the presence of '-Werror'.
-mkLongMsgEnvelope :: DiagnosticReason
-                  -> SrcSpan
-                  -> PrintUnqualified
-                  -> SDoc
-                  -> SDoc
-                  -> MsgEnvelope DiagnosticMessage
-mkLongMsgEnvelope rea locn unqual msg extra =
-  mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings
-                locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea)
-
--- | A short (one-line) diagnostic message.
--- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
-mkShortMsgEnvelope :: DiagnosticReason
-                   -> SrcSpan
-                   -> PrintUnqualified
-                   -> SDoc
-                   -> MsgEnvelope DiagnosticMessage
-mkShortMsgEnvelope rea locn unqual msg =
-  mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings
-                locn unqual (DiagnosticMessage (mkDecorated [msg]) rea)
-
--- | Variant that doesn't care about qualified/unqualified names.
--- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
-mkPlainMsgEnvelope :: DiagnosticReason
-                   -> SrcSpan
-                   -> SDoc
-                   -> MsgEnvelope DiagnosticMessage
-mkPlainMsgEnvelope rea locn msg =
-  mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings
-                locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea)
+{- Note [Intrinsic And Extrinsic Failures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in the former category
+those diagnostics which are /essentially/ failures, and their nature can't be changed. This is
+the case for 'ErrorWithoutFlag'. We classify as /extrinsic/ all those diagnostics (like fatal warnings)
+which are born as warnings but which are still failures under particular 'DynFlags' settings. It's important
+to be aware of such logic distinction, because when we are inside the typechecker or the desugarer, we are
+interested about intrinsic errors, and to bail out as soon as we find one of them. Conversely, if we find
+an /extrinsic/ one, for example because a particular 'WarningFlag' makes a warning and error, we /don't/
+want to bail out, that's still not the right time to do so: Rather, we want to first collect all the
+diagnostics, and later classify and report them appropriately (in the driver).
+
+-}
 
---
--- Queries
---
 
-isErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
-isErrorMessage MsgEnvelope { errMsgSeverity = SevError } = True
-isErrorMessage _ = False
+-- | Returns 'True' if this is, intrinsically, a failure. See Note [Intrinsic And Extrinsic Failures].
+isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
+isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic
 
 isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool
-isWarningMessage = not . isErrorMessage
+isWarningMessage = not . isIntrinsicErrorMessage
 
 errorsFound :: Diagnostic e => Messages e -> Bool
-errorsFound (Messages msgs) = any isErrorMessage msgs
+errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs
 
 getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
 getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs
 
 getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
-getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs
+getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs
 
 -- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the
 -- second the errors.