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, 40 insertions, 34 deletions

diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 5568e34b75..3243be77de 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -76,7 +76,7 @@ module GHC.Tc.Utils.Monad(
   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
 
   -- * Shared error message stuff: renamer and typechecker
-  mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportDiagnostic, reportDiagnostics,
+  mkLongErrAt, mkTcRnMessage, addLongErrAt, reportDiagnostic, reportDiagnostics,
   recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
   attemptM, tryTc,
   askNoErrs, discardErrs, tryTcDiscardingErrs,
@@ -215,6 +215,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import Data.IORef
 import Control.Monad
 
+import GHC.Tc.Errors.Types
 import {-# SOURCE #-} GHC.Tc.Utils.Env    ( tcInitTidyEnv )
 
 import qualified Data.Map as Map
@@ -234,7 +235,7 @@ initTc :: HscEnv
        -> Module
        -> RealSrcSpan
        -> TcM r
-       -> IO (Messages DiagnosticMessage, Maybe r)
+       -> IO (Messages TcRnMessage, Maybe r)
                 -- Nothing => error thrown by the thing inside
                 -- (error messages should have been printed already)
 
@@ -243,7 +244,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         used_gre_var <- newIORef [] ;
         th_var       <- newIORef False ;
         th_splice_var<- newIORef False ;
-        infer_var    <- newIORef (True, emptyBag) ;
+        infer_var    <- newIORef True ;
+        infer_reasons_var <- newIORef emptyMessages ;
         dfun_n_var   <- newIORef emptyOccSet ;
         type_env_var <- case hsc_type_env_var hsc_env of {
                            Just (_mod, te_var) -> return te_var ;
@@ -341,7 +343,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_hpc            = False,
                 tcg_main           = Nothing,
                 tcg_self_boot      = NoSelfBoot,
-                tcg_safeInfer      = infer_var,
+                tcg_safe_infer     = infer_var,
+                tcg_safe_infer_reasons = infer_reasons_var,
                 tcg_dependent_files = dependent_files_var,
                 tcg_tc_plugins     = [],
                 tcg_hf_plugins     = [],
@@ -362,7 +365,7 @@ initTcWithGbl :: HscEnv
               -> TcGblEnv
               -> RealSrcSpan
               -> TcM r
-              -> IO (Messages DiagnosticMessage, Maybe r)
+              -> IO (Messages TcRnMessage, Maybe r)
 initTcWithGbl hsc_env gbl_env loc do_this
  = do { lie_var      <- newIORef emptyWC
       ; errs_var     <- newIORef emptyMessages
@@ -408,7 +411,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
       ; return (msgs, final_res)
       }
 
-initTcInteractive :: HscEnv -> TcM a -> IO (Messages DiagnosticMessage, Maybe a)
+initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
 -- Initialise the type checker monad for use in GHCi
 initTcInteractive hsc_env thing_inside
   = initTc hsc_env HsSrcFile False
@@ -968,10 +971,10 @@ wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a)
 
 -- Reporting errors
 
-getErrsVar :: TcRn (TcRef (Messages DiagnosticMessage))
+getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 
-setErrsVar :: TcRef (Messages DiagnosticMessage) -> TcRn a -> TcRn a
+setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a
 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 
 addErr :: SDoc -> TcRn ()
@@ -1001,7 +1004,7 @@ checkErr :: Bool -> SDoc -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = unless ok (addErr msg)
 
-addMessages :: Messages DiagnosticMessage -> TcRn ()
+addMessages :: Messages TcRnMessage -> TcRn ()
 addMessages msgs1
   = do { errs_var <- getErrsVar ;
          msgs0 <- readTcRef errs_var ;
@@ -1030,40 +1033,42 @@ discardWarnings thing_inside
 ************************************************************************
 -}
 
-mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage)
+mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope TcRnMessage)
 mkLongErrAt loc msg extra
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
-         dflags <- getDynFlags ;
          let msg' = pprWithUnitState unit_state msg in
-         return $ mkLongMsgEnvelope dflags ErrorWithoutFlag loc printer msg' extra }
+         return $ mkErrorMsgEnvelope loc printer
+                $ TcRnUnknownMessage
+                $ mkDecoratedError [msg', extra] }
 
-mkDecoratedSDocAt :: DiagnosticReason
-                  -> SrcSpan
-                  -> SDoc
+mkTcRnMessage :: DiagnosticReason
+              -> SrcSpan
+              -> SDoc
                   -- ^ The important part of the message
-                  -> SDoc
+              -> SDoc
                   -- ^ The context of the message
-                  -> SDoc
+              -> SDoc
                   -- ^ Any supplementary information.
-                  -> TcRn (MsgEnvelope DiagnosticMessage)
-mkDecoratedSDocAt reason loc important context extra
+              -> TcRn (MsgEnvelope TcRnMessage)
+mkTcRnMessage reason loc important context extra
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
          dflags <- getDynFlags ;
-         let f = pprWithUnitState unit_state
-             errDoc  = [important, context, extra]
-             errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason
+         let errDocs  = map (pprWithUnitState unit_state)
+                            [important, context, extra]
          in
-         return $ mkMsgEnvelope dflags loc printer errDoc' }
+         return $ mkMsgEnvelope dflags loc printer
+                $ TcRnUnknownMessage
+                $ mkDecoratedDiagnostic reason errDocs }
 
 addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()
 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic
 
-reportDiagnostics :: [MsgEnvelope DiagnosticMessage] -> TcM ()
+reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
 reportDiagnostics = mapM_ reportDiagnostic
 
-reportDiagnostic :: MsgEnvelope DiagnosticMessage -> TcRn ()
+reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
 reportDiagnostic msg
   = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;
          errs_var <- getErrsVar ;
@@ -1241,7 +1246,7 @@ capture_constraints thing_inside
        ; lie <- readTcRef lie_var
        ; return (res, lie) }
 
-capture_messages :: TcM r -> TcM (r, Messages DiagnosticMessage)
+capture_messages :: TcM r -> TcM (r, Messages TcRnMessage)
 -- capture_messages simply captures and returns the
 --                  errors arnd warnings generated by thing_inside
 -- Precondition: thing_inside must not throw an exception!
@@ -1411,7 +1416,7 @@ foldAndRecoverM f acc (x:xs) =
                                 Just acc' -> foldAndRecoverM f acc' xs  }
 
 -----------------------
-tryTc :: TcRn a -> TcRn (Maybe a, Messages DiagnosticMessage)
+tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
 -- (tryTc m) executes m, and returns
 --      Just r,  if m succeeds (returning r)
 --      Nothing, if m fails
@@ -1561,9 +1566,9 @@ add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn ()
 add_diagnostic_at reason loc msg extra_info
   = do { printer <- getPrintUnqualified ;
          dflags  <- getDynFlags ;
-         let { dia = mkLongMsgEnvelope dflags reason
-                                       loc printer
-                                       msg extra_info } ;
+         let { dia = mkMsgEnvelope dflags loc printer $
+                     TcRnUnknownMessage $
+                     mkDecoratedDiagnostic reason [msg, extra_info] } ;
          reportDiagnostic dia }
 
 
@@ -1982,14 +1987,15 @@ addModFinalizersWithLclEnv mod_finalizers
 -- | Mark that safe inference has failed
 -- See Note [Safe Haskell Overlapping Instances Implementation]
 -- although this is used for more than just that failure case.
-recordUnsafeInfer :: WarningMessages -> TcM ()
-recordUnsafeInfer warns =
-    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
+recordUnsafeInfer :: Messages TcRnMessage -> TcM ()
+recordUnsafeInfer msgs =
+    getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False
+                             writeTcRef (tcg_safe_infer_reasons env) msgs
 
 -- | Figure out the final correct safe haskell mode
 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
 finalSafeMode dflags tcg_env = do
-    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
+    safeInf <- readIORef (tcg_safe_infer tcg_env)
     return $ case safeHaskell dflags of
         Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred
                 | otherwise                     -> Sf_None