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, 105 insertions, 4 deletions

diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index aba5e64357..2ee1763ebb 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -31,8 +31,9 @@ module GHC.Utils.Error (
 
         -- ** Construction
         emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,
-        mkMsgEnvelope, mkPlainMsgEnvelope, mkLongMsgEnvelope,
-        mkMCDiagnostic,
+        mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
+        mkShortMsgEnvelope, mkShortErrorMsgEnvelope, mkLongMsgEnvelope,
+        mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,
 
         -- * Utilities
         doIfSet, doIfSet_dyn,
@@ -80,6 +81,106 @@ import Control.Monad.Catch as MC (handle)
 import GHC.Conc         ( getAllocationCounter )
 import System.CPUTime
 
+-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
+-- the 'DynFlags'. This function /has/ to be called when a diagnostic is constructed,
+-- i.e. with a 'DynFlags' \"snapshot\" taken as close as possible to where a
+-- particular diagnostic message is built, otherwise the computed 'Severity' might
+-- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
+diagReasonSeverity :: DynFlags -> DiagnosticReason -> Severity
+diagReasonSeverity dflags (WarningWithFlag wflag) | wopt_fatal wflag dflags     = SevError
+                                                  | otherwise                   = SevWarning
+diagReasonSeverity dflags WarningWithoutFlag      | gopt Opt_WarnIsError dflags = SevError
+                                                  | otherwise                   = SevWarning
+diagReasonSeverity _      ErrorWithoutFlag                                      = SevError
+
+
+
+--
+-- Creating MsgEnvelope(s)
+--
+
+mk_msg_envelope
+  :: Diagnostic e
+  => Severity
+  -> SrcSpan
+  -> PrintUnqualified
+  -> e
+  -> MsgEnvelope e
+mk_msg_envelope severity locn print_unqual err
+ = MsgEnvelope { errMsgSpan = locn
+               , errMsgContext = print_unqual
+               , errMsgDiagnostic = err
+               , errMsgSeverity = severity
+               }
+
+mkMsgEnvelope
+  :: Diagnostic e
+  => DynFlags
+  -> SrcSpan
+  -> PrintUnqualified
+  -> e
+  -> MsgEnvelope e
+mkMsgEnvelope dflags locn print_unqual err
+ = mk_msg_envelope (diagReasonSeverity dflags (diagnosticReason err)) locn print_unqual err
+
+-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the 'DynFlags'.
+mkMCDiagnostic :: DynFlags -> DiagnosticReason -> MessageClass
+mkMCDiagnostic dflags reason = MCDiagnostic (diagReasonSeverity dflags reason) reason
+
+-- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
+-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'.
+errorDiagnostic :: MessageClass
+errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag
+
+-- | 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 :: DynFlags
+                  -> DiagnosticReason
+                  -> SrcSpan
+                  -> PrintUnqualified
+                  -> SDoc
+                  -> SDoc
+                  -> MsgEnvelope DiagnosticMessage
+mkLongMsgEnvelope dflags rea locn unqual msg extra =
+  mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea)
+
+-- | A short (one-line) diagnostic message.
+-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
+mkShortMsgEnvelope :: DynFlags
+                   -> DiagnosticReason
+                   -> SrcSpan
+                   -> PrintUnqualified
+                   -> SDoc
+                   -> MsgEnvelope DiagnosticMessage
+mkShortMsgEnvelope dflags rea locn unqual msg =
+  mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg]) rea)
+
+mkShortErrorMsgEnvelope :: SrcSpan
+                        -> PrintUnqualified
+                        -> SDoc
+                        -> MsgEnvelope DiagnosticMessage
+mkShortErrorMsgEnvelope locn unqual msg =
+  mk_msg_envelope SevError locn unqual (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag)
+
+-- | Variant that doesn't care about qualified/unqualified names.
+-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
+mkPlainMsgEnvelope :: DynFlags
+                   -> DiagnosticReason
+                   -> SrcSpan
+                   -> SDoc
+                   -> MsgEnvelope DiagnosticMessage
+mkPlainMsgEnvelope dflags rea locn msg =
+  mkMsgEnvelope dflags locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea)
+
+-- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we
+-- are constructing a diagnostic with a 'ErrorWithoutFlag' reason.
+mkPlainErrorMsgEnvelope :: SrcSpan
+                        -> SDoc
+                        -> MsgEnvelope DiagnosticMessage
+mkPlainErrorMsgEnvelope locn msg =
+  mk_msg_envelope SevError locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag)
+
 -------------------------
 data Validity
   = IsValid            -- ^ Everything is fine
@@ -171,12 +272,12 @@ ifVerbose dflags val act
 
 errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
 errorMsg logger dflags msg
-   = putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) noSrcSpan $
+   = putLogMsg logger dflags errorDiagnostic noSrcSpan $
      withPprStyle defaultErrStyle msg
 
 warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
 warningMsg logger dflags msg
-   = putLogMsg logger dflags (mkMCDiagnostic WarningWithoutFlag) noSrcSpan $
+   = putLogMsg logger dflags (mkMCDiagnostic dflags WarningWithoutFlag) noSrcSpan $
      withPprStyle defaultErrStyle msg
 
 fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()