Add `MessageClass`, rework `Severity` and add `DiagnosticReason`.wip/adinapoli-message-class-new-design

Other than that:

* Fix T16167,json,json2,T7478,T10637 tests to reflect the introduction of
  the `MessageClass` type

* Remove `makeIntoWarning`

* Remove `warningsToMessages`

* Refactor GHC.Tc.Errors

  1. Refactors GHC.Tc.Errors so that we use `DiagnosticReason` for "choices"
     (defer types errors, holes, etc);

  2. We get rid of `reportWarning` and `reportError` in favour of a general
     `reportDiagnostic`.

* Introduce `DiagnosticReason`, `Severity` is an enum: This big commit makes
  `Severity` a simple enumeration, and introduces the concept of `DiagnosticReason`,
  which classifies the /reason/ why we are emitting a particular diagnostic.
  It also adds a monomorphic `DiagnosticMessage` type which is used for
  generic messages.

* The `Severity` is computed (for now) from the reason, statically.
  Later improvement will add a `diagReasonSeverity` function to compute
  the `Severity` taking `DynFlags` into account.

* Rename `logWarnings` into `logDiagnostics`

* Add note and expand description of the `mkHoleError` function

1 files changed, 37 insertions, 37 deletions

diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index d779fc06f8..9127e7d094 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,9 +1,8 @@
 module GHC.Driver.Errors (
-    warningsToMessages
-  , printOrThrowWarnings
+    printOrThrowWarnings
   , printBagOfErrors
-  , isWarnMsgFatal
   , handleFlagWarnings
+  , partitionMessageBag
   ) where
 
 import GHC.Driver.Session
@@ -18,27 +17,20 @@ import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )
 import GHC.Utils.Logger
 import qualified GHC.Driver.CmdLine as CmdLine
 
--- | Converts a list of 'WarningMessages' into a tuple where the second element contains only
--- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'.
-warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, ErrorMessages)
-warningsToMessages dflags =
-  partitionBagWith $ \warn ->
-    case isWarnMsgFatal dflags warn of
-      Nothing -> Left warn
-      Just err_reason ->
-        Right warn{ errMsgSeverity = SevError
-                  , errMsgReason = ErrReason err_reason }
+-- | Partitions the messages and returns a tuple which first element are the warnings, and the
+-- second the errors.
+partitionMessageBag :: Diagnostic e => Bag (MsgEnvelope e) -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
+partitionMessageBag = partitionBag isWarningMessage
 
-printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
+printBagOfErrors :: Diagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
 printBagOfErrors logger dflags bag_of_errors
   = sequence_ [ let style = mkErrStyle unqual
                     ctx   = initSDocContext dflags style
-                in putLogMsg logger dflags reason sev s $
-                   withPprStyle style (formatBulleted ctx (renderDiagnostic doc))
+                in putLogMsg logger dflags (MCDiagnostic sev . diagnosticReason $ dia) s $
+                   withPprStyle style (formatBulleted ctx (diagnosticMessage dia))
               | MsgEnvelope { errMsgSpan      = s,
-                              errMsgDiagnostic = doc,
-                              errMsgSeverity  = sev,
-                              errMsgReason    = reason,
+                              errMsgDiagnostic = dia,
+                              errMsgSeverity = sev,
                               errMsgContext   = unqual } <- sortMsgBag (Just dflags)
                                                                        bag_of_errors ]
 
@@ -48,22 +40,11 @@ handleFlagWarnings logger dflags warns = do
 
       -- It would be nicer if warns :: [Located SDoc], but that
       -- has circular import problems.
-      bag = listToBag [ mkPlainWarnMsg loc (text warn)
+      bag = listToBag [ mkPlainMsgEnvelope WarningWithoutFlag loc (text warn)
                       | CmdLine.Warn _ (L loc warn) <- warns' ]
 
   printOrThrowWarnings logger dflags bag
 
--- | Checks if given 'WarnMsg' is a fatal warning.
-isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
-isWarnMsgFatal dflags MsgEnvelope{errMsgReason = Reason wflag}
-  = if wopt_fatal wflag dflags
-      then Just (Just wflag)
-      else Nothing
-isWarnMsgFatal dflags _
-  = if gopt Opt_WarnIsError dflags
-      then Just Nothing
-      else Nothing
-
 -- Given a warn reason, check to see if it's associated -W opt is enabled
 shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
 shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag
@@ -80,14 +61,33 @@ printOrThrowWarnings logger dflags warns = do
   let (make_error, warns') =
         mapAccumBagL
           (\make_err warn ->
-            case isWarnMsgFatal dflags warn of
-              Nothing ->
+            case warn_msg_severity dflags warn of
+              SevWarning ->
                 (make_err, warn)
-              Just err_reason ->
-                (True, warn{ errMsgSeverity = SevError
-                           , errMsgReason = ErrReason err_reason
-                           }))
+              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 }
+