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, 18 insertions, 6 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 8589b81ee5..5496fe31a2 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -47,6 +47,7 @@ import GHC.Tc.Types
 import GHC.Driver.Main
 import GHC.Driver.Env hiding ( Hsc )
 import GHC.Driver.Errors
+import GHC.Driver.Errors.Types
 import GHC.Driver.Pipeline.Monad
 import GHC.Driver.Config
 import GHC.Driver.Phases
@@ -81,7 +82,6 @@ import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Settings
 
-import GHC.Data.Bag            ( unitBag )
 import GHC.Data.FastString     ( mkFastString )
 import GHC.Data.StringBuffer   ( hGetStringBuffer, hPutStringBuffer )
 import GHC.Data.Maybe          ( expectJust )
@@ -89,6 +89,7 @@ import GHC.Data.Maybe          ( expectJust )
 import GHC.Iface.Make          ( mkFullIface )
 
 import GHC.Types.Basic       ( SuccessFlag(..) )
+import GHC.Types.Error       ( singleMessage, getMessages )
 import GHC.Types.Target
 import GHC.Types.SrcLoc
 import GHC.Types.SourceFile
@@ -130,9 +131,9 @@ preprocess :: HscEnv
            -> Maybe InputFileBuffer
            -- ^ optional buffer to use instead of reading the input file
            -> Maybe Phase -- ^ starting phase
-           -> IO (Either ErrorMessages (DynFlags, FilePath))
+           -> IO (Either DriverMessages (DynFlags, FilePath))
 preprocess hsc_env input_fn mb_input_buf mb_phase =
-  handleSourceError (\err -> return (Left (srcErrorMessages err))) $
+  handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $
   MC.handle handler $
   fmap Right $ do
   MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
@@ -148,10 +149,21 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
   return (dflags, fp)
   where
     srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
-    handler (ProgramError msg) = return $ Left $ unitBag $
-        mkPlainErrorMsgEnvelope srcspan $ text msg
+    handler (ProgramError msg) =
+      return $ Left $ singleMessage $
+        mkPlainErrorMsgEnvelope srcspan $
+        DriverUnknownMessage $ mkPlainError $ text msg
     handler ex = throwGhcExceptionIO ex
 
+    to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
+    to_driver_messages msgs = case traverse to_driver_message msgs of
+      Nothing    -> pprPanic "non-driver message in preprocess"
+                             (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))
+      Just msgs' -> msgs'
+
+    to_driver_message (GhcDriverMessage msg) = Just msg
+    to_driver_message _other                 = Nothing
+
 -- ---------------------------------------------------------------------------
 
 -- | Compile
@@ -1259,7 +1271,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn
                 popts = initParserOpts dflags
             eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
             case eimps of
-              Left errs -> throwErrors (fmap mkParserErr errs)
+              Left errs -> throwErrors (foldPsMessages mkParserErr errs)
               Right (src_imps,imps,L _ mod_name) -> return
                   (Just buf, mod_name, imps, src_imps)