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

1 files changed, 13 insertions, 10 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 59f49453ed..2a75c2b840 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -307,6 +307,7 @@ import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename
                            , isSourceFilename, startPhase )
 import GHC.Driver.Env
 import GHC.Driver.Errors
+import GHC.Driver.Errors.Types
 import GHC.Driver.CmdLine
 import GHC.Driver.Session
 import qualified GHC.Driver.Session as Session
@@ -338,7 +339,6 @@ import GHC.Iface.Load        ( loadSysInterface )
 import GHC.Hs
 import GHC.Builtin.Types.Prim ( alphaTyVars )
 import GHC.Iface.Tidy
-import GHC.Data.Bag        ( listToBag )
 import GHC.Data.StringBuffer
 import GHC.Data.FastString
 import qualified GHC.LanguageExtensions as LangExt
@@ -382,6 +382,7 @@ import GHC.Types.Name.Set
 import GHC.Types.Name.Reader
 import GHC.Types.SourceError
 import GHC.Types.SafeHaskell
+import GHC.Types.Error hiding ( getMessages, getErrorMessages )
 import GHC.Types.Fixity
 import GHC.Types.Target
 import GHC.Types.Basic
@@ -390,7 +391,6 @@ import GHC.Types.Name.Env
 import GHC.Types.Name.Ppr
 import GHC.Types.TypeEnv
 import GHC.Types.SourceFile
-import GHC.Types.Error ( DiagnosticMessage )
 
 import GHC.Unit
 import GHC.Unit.Env
@@ -912,9 +912,11 @@ checkNewInteractiveDynFlags logger dflags0 = do
   -- We currently don't support use of StaticPointers in expressions entered on
   -- the REPL. See #12356.
   if xopt LangExt.StaticPointers dflags0
-  then do liftIO $ printOrThrowDiagnostics logger dflags0 $ listToBag
-            [mkPlainMsgEnvelope dflags0 Session.WarningWithoutFlag interactiveSrcSpan
-             $ text "StaticPointers is not supported in GHCi interactive expressions."]
+  then do liftIO $ printOrThrowDiagnostics logger dflags0 $ singleMessage
+            $ mkPlainMsgEnvelope dflags0 interactiveSrcSpan
+               $ GhcDriverMessage $ DriverUnknownMessage
+               $ mkPlainDiagnostic Session.WarningWithoutFlag
+               $ text "StaticPointers is not supported in GHCi interactive expressions."
           return $ xopt_unset dflags0 LangExt.StaticPointers
   else return dflags0
 
@@ -1505,7 +1507,7 @@ getNameToInstancesIndex :: GhcMonad m
                      -- if it is visible from at least one module in the list.
   -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load
                      -- modules for everything that is in scope unqualified.
-  -> m (Messages DiagnosticMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
+  -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
 getNameToInstancesIndex visible_mods mods_to_load = do
   hsc_env <- getSession
   liftIO $ runTcInteractive hsc_env $
@@ -1610,7 +1612,7 @@ getTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream (initParserOpts dflags) source startLoc of
     POk _ ts    -> return ts
-    PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
+    PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst))
 
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
@@ -1621,7 +1623,7 @@ getRichTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream (initParserOpts dflags) source startLoc of
     POk _ ts    -> return $ addSourceToTokens startLoc source ts
-    PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
+    PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst))
 
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
@@ -1801,11 +1803,12 @@ parser str dflags filename =
 
      PFailed pst ->
          let (warns,errs) = getMessages pst in
-         (fmap (mkParserWarn dflags) warns, Left (fmap mkParserErr errs))
+         (foldPsMessages (mkParserWarn dflags) warns
+         , Left (foldPsMessages mkParserErr errs))
 
      POk pst rdr_module ->
          let (warns,_) = getMessages pst in
-         (fmap (mkParserWarn dflags) warns, Right rdr_module)
+         (foldPsMessages (mkParserWarn dflags) warns, Right rdr_module)
 
 -- -----------------------------------------------------------------------------
 -- | Find the package environment (if one exists)