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

4 files changed, 43 insertions, 11 deletions

diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
new file mode 100644
index 0000000000..f453a82743
--- /dev/null
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -0,0 +1,11 @@
+
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage
+
+module GHC.HsToCore.Errors.Ppr where
+
+import GHC.Types.Error
+import GHC.HsToCore.Errors.Types
+
+instance Diagnostic DsMessage where
+  diagnosticMessage (DsUnknownMessage m) = diagnosticMessage m
+  diagnosticReason  (DsUnknownMessage m) = diagnosticReason m
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
new file mode 100644
index 0000000000..45a47d5c30
--- /dev/null
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -0,0 +1,10 @@
+
+module GHC.HsToCore.Errors.Types where
+
+import GHC.Types.Error
+
+-- | Diagnostics messages emitted during desugaring.
+data DsMessage =
+  DsUnknownMessage !DiagnosticMessage
+  -- ^ Simply rewraps a generic 'DiagnosticMessage'. More
+  -- constructors will be added in the future (#18516).
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 788f4828e2..9bc893f814 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -64,6 +64,7 @@ import GHC.Driver.Ppr
 import GHC.Hs
 
 import GHC.HsToCore.Types
+import GHC.HsToCore.Errors.Types
 import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)
 
 import GHC.Core.FamInstEnv
@@ -204,17 +205,22 @@ type DsWarning = (SrcSpan, SDoc)
         -- into a Doc.
 
 -- | Run a 'DsM' action inside the 'TcM' monad.
-initDsTc :: DsM a -> TcM a
+initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a)
 initDsTc thing_inside
   = do { tcg_env  <- getGblEnv
-       ; msg_var  <- getErrsVar
+       ; msg_var  <- liftIO $ newIORef emptyMessages
        ; hsc_env  <- getTopEnv
        ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
-       ; setEnvs envs thing_inside
+       ; e_result <- tryM $  -- need to tryM so that we don't discard
+                             -- DsMessages
+                     setEnvs envs thing_inside
+       ; msgs     <- liftIO $ readIORef msg_var
+       ; return (msgs, case e_result of Left _  -> Nothing
+                                        Right x -> Just x)
        }
 
 -- | Run a 'DsM' action inside the 'IO' monad.
-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DiagnosticMessage, Maybe a)
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
 initDs hsc_env tcg_env thing_inside
   = do { msg_var <- newIORef emptyMessages
        ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
@@ -223,7 +229,7 @@ initDs hsc_env tcg_env thing_inside
 
 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
 mkDsEnvsFromTcGbl :: MonadIO m
-                  => HscEnv -> IORef (Messages DiagnosticMessage) -> TcGblEnv
+                  => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv
                   -> m (DsGblEnv, DsLclEnv)
 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
@@ -242,7 +248,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
                            msg_var cc_st_var next_wrapper_num_var complete_matches
        }
 
-runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DiagnosticMessage, Maybe a)
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
                               (tryM thing_inside)
@@ -255,7 +261,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside
        }
 
 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DiagnosticMessage, Maybe a)
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
 initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
                                    , mg_tcs = tycons, mg_fam_insts = fam_insts
                                    , mg_patsyns = patsyns, mg_rdr_env = rdr_env
@@ -316,7 +322,7 @@ initTcDsForSolver thing_inside
            Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }
 
 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState
+         -> IORef (Messages DsMessage) -> IORef CostCentreState
          -> IORef (ModuleEnv Int) -> CompleteMatches
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
@@ -466,7 +472,9 @@ diagnosticDs reason warn
   = do { env <- getGblEnv
        ; loc <- getSrcSpanDs
        ; dflags <- getDynFlags
-       ; let msg = mkShortMsgEnvelope dflags reason loc (ds_unqual env) warn
+       ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $
+                   DsUnknownMessage $
+                   mkPlainDiagnostic reason warn
        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags
@@ -479,7 +487,9 @@ errDs :: SDoc -> DsM ()
 errDs err
   = do  { env <- getGblEnv
         ; loc <- getSrcSpanDs
-        ; let msg = mkShortErrorMsgEnvelope loc (ds_unqual env) err
+        ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $
+                    DsUnknownMessage $
+                    mkPlainError err
         ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Issue an error, but return the expression for (), so that we can continue
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index 58273e250e..bc9d7b4c1d 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -19,6 +19,7 @@ import GHC.Types.Name.Reader (GlobalRdrEnv)
 import GHC.Hs (LForeignDecl, HsExpr, GhcTc)
 import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches)
 import GHC.HsToCore.Pmc.Types (Nablas)
+import GHC.HsToCore.Errors.Types
 import GHC.Core (CoreExpr)
 import GHC.Core.FamInstEnv
 import GHC.Utils.Outputable as Outputable
@@ -49,7 +50,7 @@ data DsGblEnv
                                           -- constructors are in scope during
                                           -- pattern-match satisfiability checking
   , ds_unqual  :: PrintUnqualified
-  , ds_msgs    :: IORef (Messages DiagnosticMessage) -- Diagnostic messages
+  , ds_msgs    :: IORef (Messages DsMessage) -- Diagnostic messages
   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
                                           -- possibly-imported things
   , ds_complete_matches :: CompleteMatches