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, 12 insertions, 41 deletions

diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 9127e7d094..b6fdee5c9b 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,5 +1,5 @@
 module GHC.Driver.Errors (
-    printOrThrowWarnings
+    printOrThrowDiagnostics
   , printBagOfErrors
   , handleFlagWarnings
   , partitionMessageBag
@@ -8,7 +8,7 @@ module GHC.Driver.Errors (
 import GHC.Driver.Session
 import GHC.Data.Bag
 import GHC.Utils.Exception
-import GHC.Utils.Error ( formatBulleted, sortMsgBag )
+import GHC.Utils.Error ( formatBulleted, sortMsgBag, mkPlainMsgEnvelope )
 import GHC.Types.SourceError ( mkSrcErr )
 import GHC.Prelude
 import GHC.Types.SrcLoc
@@ -40,10 +40,10 @@ handleFlagWarnings logger dflags warns = do
 
       -- It would be nicer if warns :: [Located SDoc], but that
       -- has circular import problems.
-      bag = listToBag [ mkPlainMsgEnvelope WarningWithoutFlag loc (text warn)
+      bag = listToBag [ mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text warn)
                       | CmdLine.Warn _ (L loc warn) <- warns' ]
 
-  printOrThrowWarnings logger dflags bag
+  printOrThrowDiagnostics logger dflags bag
 
 -- Given a warn reason, check to see if it's associated -W opt is enabled
 shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
@@ -54,40 +54,11 @@ shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag
 shouldPrintWarning _ _
   = True
 
--- | Given a bag of warnings, turn them into an exception if
--- -Werror is enabled, or print them out otherwise.
-printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
-printOrThrowWarnings logger dflags warns = do
-  let (make_error, warns') =
-        mapAccumBagL
-          (\make_err warn ->
-            case warn_msg_severity dflags warn of
-              SevWarning ->
-                (make_err, warn)
-              SevError ->
-                (True, set_severity SevError warn))
-          False warns
-  if make_error
-    then throwIO (mkSrcErr warns')
-    else printBagOfErrors logger dflags warns
-
-  where
-
-    -- | Sets the 'Severity' of the input 'WarnMsg' according to the 'DynFlags'.
-    warn_msg_severity :: DynFlags -> WarnMsg -> Severity
-    warn_msg_severity dflags msg =
-      case diagnosticReason (errMsgDiagnostic msg) of
-        ErrorWithoutFlag   -> SevError
-        WarningWithoutFlag ->
-          if gopt Opt_WarnIsError dflags
-            then SevError
-            else SevWarning
-        WarningWithFlag wflag ->
-          if wopt_fatal wflag dflags
-            then SevError
-            else SevWarning
-
-    -- | Adjust the 'Severity' of the input 'WarnMsg'.
-    set_severity :: Severity -> WarnMsg -> MsgEnvelope DiagnosticMessage
-    set_severity newSeverity msg = msg { errMsgSeverity = newSeverity }
-
+-- | Given a bag of diagnostics, turn them into an exception if
+-- any has 'SevError', or print them out otherwise.
+printOrThrowDiagnostics :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
+printOrThrowDiagnostics logger dflags warns
+  | any ((==) SevError . errMsgSeverity) warns
+  = throwIO (mkSrcErr warns)
+  | otherwise
+  = printBagOfErrors logger dflags warns