Add GhcMessage and ancillary types

This commit adds GhcMessage and ancillary (PsMessage, TcRnMessage, ..)
types.
These types will be expanded to represent more errors generated
by different subsystems within GHC. Right now, they are underused,
but more will come in the glorious future.

See
https://gitlab.haskell.org/ghc/ghc/-/wikis/Errors-as-(structured)-values
for a design overview.

Along the way, lots of other things had to happen:

* Adds Semigroup and Monoid instance for Bag

* Fixes #19746 by parsing OPTIONS_GHC pragmas into Located Strings.
  See GHC.Parser.Header.toArgs (moved from GHC.Utils.Misc, where it
  didn't belong anyway).

* Addresses (but does not completely fix) #19709, now reporting
  desugarer warnings and errors appropriately for TH splices.
  Not done: reporting type-checker warnings for TH splices.

* Some small refactoring around Safe Haskell inference, in order
  to keep separate classes of messages separate.

* Some small refactoring around initDsTc, in order to keep separate
  classes of messages separate.

* Separate out the generation of messages (that is, the construction
  of the text block) from the wrapping of messages (that is, assigning
  a SrcSpan). This is more modular than the previous design, which
  mixed the two.

Close #19746.

This was a collaborative effort by Alfredo di Napoli and
Richard Eisenberg, with a key assist on #19746 by Iavor
Diatchki.

Metric Increase:
    MultiLayerModules

2 files changed, 41 insertions, 119 deletions

diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 99bff97a5b..7e614588f6 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -15,13 +15,13 @@ module GHC.Utils.Error (
         Severity(..),
 
         -- * Messages
-        WarnMsg,
+        Diagnostic(..),
         MsgEnvelope(..),
         MessageClass(..),
         SDoc,
         DecoratedSDoc(unDecorated),
-        Messages, ErrorMessages, WarningMessages,
-        unionMessages,
+        Messages,
+        mkMessages, unionMessages,
         errorsFound, isEmptyMessages,
 
         -- ** Formatting
@@ -33,9 +33,14 @@ module GHC.Utils.Error (
         -- ** Construction
         emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,
         mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
-        mkShortMsgEnvelope, mkShortErrorMsgEnvelope, mkLongMsgEnvelope,
+        mkErrorMsgEnvelope,
         mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,
 
+        mkPlainError,
+        mkPlainDiagnostic,
+        mkDecoratedError,
+        mkDecoratedDiagnostic,
+
         -- * Utilities
         doIfSet, doIfSet_dyn,
         getCaretDiagnostic,
@@ -97,6 +102,15 @@ diagReasonSeverity _      ErrorWithoutFlag
 
 
 
+-- | 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
+
 --
 -- Creating MsgEnvelope(s)
 --
@@ -115,6 +129,9 @@ mk_msg_envelope severity locn print_unqual err
                , errMsgSeverity = severity
                }
 
+-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
+-- If you know your 'Diagnostic' is an error, consider using 'mkErrorMsgEnvelope',
+-- which does not require looking at the 'DynFlags'
 mkMsgEnvelope
   :: Diagnostic e
   => DynFlags
@@ -125,63 +142,34 @@ mkMsgEnvelope
 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
+-- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
+-- Precondition: the diagnostic is, in fact, an error. That is,
+-- @diagnosticReason msg == ErrorWithoutFlag@.
+mkErrorMsgEnvelope :: Diagnostic e
+                   => 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)
+                   -> e
+                   -> MsgEnvelope e
+mkErrorMsgEnvelope locn unqual msg =
+  mk_msg_envelope SevError locn unqual msg
 
 -- | Variant that doesn't care about qualified/unqualified names.
--- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
-mkPlainMsgEnvelope :: DynFlags
-                   -> DiagnosticReason
+mkPlainMsgEnvelope :: Diagnostic e
+                   => DynFlags
                    -> SrcSpan
-                   -> SDoc
-                   -> MsgEnvelope DiagnosticMessage
-mkPlainMsgEnvelope dflags rea locn msg =
-  mkMsgEnvelope dflags locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea)
+                   -> e
+                   -> MsgEnvelope e
+mkPlainMsgEnvelope dflags locn msg =
+  mkMsgEnvelope dflags locn alwaysQualify msg
 
 -- | 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 :: Diagnostic e
+                        => SrcSpan
+                        -> e
+                        -> MsgEnvelope e
 mkPlainErrorMsgEnvelope locn msg =
-  mk_msg_envelope SevError locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag)
+  mk_msg_envelope SevError locn alwaysQualify msg
 
 -------------------------
 data Validity
@@ -582,5 +570,3 @@ of the execution through the various labels) and ghc.totals.txt (total time
 spent in each label).
 
 -}
-
-
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index c977f89078..67d3f11c67 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -91,9 +91,6 @@ module GHC.Utils.Misc (
         looksLikeModuleName,
         looksLikePackageName,
 
-        -- * Argument processing
-        getCmd, toCmdArgs, toArgs,
-
         -- * Integers
         exactLog2,
 
@@ -1102,67 +1099,6 @@ looksLikeModuleName (c:cs) = isUpper c && go cs
 looksLikePackageName :: String -> Bool
 looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-'
 
-{-
-Akin to @Prelude.words@, but acts like the Bourne shell, treating
-quoted strings as Haskell Strings, and also parses Haskell [String]
-syntax.
--}
-
-getCmd :: String -> Either String             -- Error
-                           (String, String) -- (Cmd, Rest)
-getCmd s = case break isSpace $ dropWhile isSpace s of
-           ([], _) -> Left ("Couldn't find command in " ++ show s)
-           res -> Right res
-
-toCmdArgs :: String -> Either String             -- Error
-                              (String, [String]) -- (Cmd, Args)
-toCmdArgs s = case getCmd s of
-              Left err -> Left err
-              Right (cmd, s') -> case toArgs s' of
-                                 Left err -> Left err
-                                 Right args -> Right (cmd, args)
-
-toArgs :: String -> Either String   -- Error
-                           [String] -- Args
-toArgs str
-    = case dropWhile isSpace str of
-      s@('[':_) -> case reads s of
-                   [(args, spaces)]
-                    | all isSpace spaces ->
-                       Right args
-                   _ ->
-                       Left ("Couldn't read " ++ show str ++ " as [String]")
-      s -> toArgs' s
- where
-  toArgs' :: String -> Either String [String]
-  -- Remove outer quotes:
-  -- > toArgs' "\"foo\" \"bar baz\""
-  -- Right ["foo", "bar baz"]
-  --
-  -- Keep inner quotes:
-  -- > toArgs' "-DFOO=\"bar baz\""
-  -- Right ["-DFOO=\"bar baz\""]
-  toArgs' s = case dropWhile isSpace s of
-              [] -> Right []
-              ('"' : _) -> do
-                    -- readAsString removes outer quotes
-                    (arg, rest) <- readAsString s
-                    (arg:) `fmap` toArgs' rest
-              s' -> case break (isSpace <||> (== '"')) s' of
-                    (argPart1, s''@('"':_)) -> do
-                        (argPart2, rest) <- readAsString s''
-                        -- show argPart2 to keep inner quotes
-                        ((argPart1 ++ show argPart2):) `fmap` toArgs' rest
-                    (arg, s'') -> (arg:) `fmap` toArgs' s''
-
-  readAsString :: String -> Either String (String, String)
-  readAsString s = case reads s of
-                [(arg, rest)]
-                    -- rest must either be [] or start with a space
-                    | all isSpace (take 1 rest) ->
-                    Right (arg, rest)
-                _ ->
-                    Left ("Couldn't read " ++ show s ++ " as String")
 -----------------------------------------------------------------------------
 -- Integers