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

12 files changed, 184 insertions, 83 deletions

diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 40761ed38c..c71ad4b7b8 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -2007,7 +2007,7 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
          -- See Note [Deriving strategies]
        ; when (exotic_mechanism && className clas `elem` genericClassNames) $
          do { failIfTc (safeLanguageOn dflags) gen_inst_err
-            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }
+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } }
   where
     exotic_mechanism = not $ isDerivSpecStock mechanism
 
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 1f972c6425..9de37b0313 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1029,26 +1029,26 @@ mkErrorReport :: DiagnosticReason
               -> ReportErrCtxt
               -> TcLclEnv
               -> Report
-              -> TcM (MsgEnvelope DiagnosticMessage)
+              -> TcM (MsgEnvelope TcRnMessage)
 mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs)
   = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
-       ; mkDecoratedSDocAt rea
-                           (RealSrcSpan (tcl_loc tcl_env) Nothing)
-                           (vcat important)
-                           context
-                           (vcat $ relevant_bindings ++ valid_subs)
+       ; mkTcRnMessage rea
+           (RealSrcSpan (tcl_loc tcl_env) Nothing)
+           (vcat important)
+           context
+           (vcat $ relevant_bindings ++ valid_subs)
        }
 
 -- This version does not include the context
 mkErrorReportNC :: DiagnosticReason
                 -> TcLclEnv
                 -> Report
-                -> TcM (MsgEnvelope DiagnosticMessage)
+                -> TcM (MsgEnvelope TcRnMessage)
 mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs)
-  = mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc tcl_env) Nothing)
-                      (vcat important)
-                      O.empty
-                      (vcat $ relevant_bindings ++ valid_subs)
+  = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Nothing)
+    (vcat important)
+    O.empty
+    (vcat $ relevant_bindings ++ valid_subs)
 
 type UserGiven = Implication
 
@@ -1186,7 +1186,7 @@ See also 'reportUnsolved'.
 
 ----------------
 -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].
-mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DiagnosticMessage)
+mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)
 mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ
                                            , hole_ty = hole_ty
                                            , hole_loc = ct_loc })
@@ -1310,7 +1310,6 @@ mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ
 When working with typed holes we have to deal with the case where
 we want holes to be reported as warnings to users during compile time but
 as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings'
-with a function which is able to override the 'DiagnosticReason' of a 'DiagnosticMessage',
 so that the correct 'Severity' can be computed out of that later on.
 
 -}
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
new file mode 100644
index 0000000000..c6da9f1b9b
--- /dev/null
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
+
+module GHC.Tc.Errors.Ppr where
+
+import GHC.Tc.Errors.Types
+import GHC.Types.Error
+
+instance Diagnostic TcRnMessage where
+  diagnosticMessage (TcRnUnknownMessage m) = diagnosticMessage m
+  diagnosticReason  (TcRnUnknownMessage m) = diagnosticReason m
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
new file mode 100644
index 0000000000..1241735191
--- /dev/null
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -0,0 +1,12 @@
+module GHC.Tc.Errors.Types (
+  -- * Main types
+    TcRnMessage(..)
+  ) where
+
+import GHC.Types.Error
+
+-- | An error which might arise during typechecking/renaming.
+data TcRnMessage
+  = TcRnUnknownMessage !DiagnosticMessage
+  -- ^ Simply rewraps a generic 'DiagnosticMessage'. More
+  -- constructors will be added in the future (#18516).
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 57b99e703a..166f366038 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -475,7 +475,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty
 
            -- handle safe infer fail
            _ | check_safe && safeInferOn dflags
-               -> recordUnsafeInfer emptyBag
+               -> recordUnsafeInfer emptyMessages
 
            -- handle safe language typecheck fail
            _ | check_safe && safeLanguageOn dflags
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 589513af97..7124dcd52e 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -34,6 +34,7 @@ module GHC.Tc.Gen.Splice(
 
 import GHC.Prelude
 
+import GHC.Driver.Errors
 import GHC.Driver.Plugins
 import GHC.Driver.Main
 import GHC.Driver.Session
@@ -42,6 +43,7 @@ import GHC.Driver.Hooks
 
 import GHC.Hs
 
+import GHC.Tc.Errors.Types
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Gen.Expr
@@ -917,6 +919,48 @@ runMetaD :: LHsExpr GhcTc          -- Of type Q [Dec]
          -> TcM [LHsDecl GhcPs]
 runMetaD = runMeta metaRequestD
 
+{- Note [Errors in desugaring a splice]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we do if there are errors when desugaring a splice? We should
+abort. There are several cases to consider:
+
+(a) The desugarer hits an unrecoverable error and fails in the monad.
+(b) The desugarer hits a recoverable error, reports it, and continues.
+(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues.
+(d) The desugarer reports a non-fatal warning, and continues.
+
+Each case is tested in th/T19709[abcd].
+
+General principle: we wish to report all messages from dealing with a splice
+eagerly, as these messages arise during an earlier stage than type-checking
+generally. It's also likely that a compile-time warning from spliced code
+will be easier to understand then an error that arises from processing the
+code the splice produces. (Rationale: the warning will be about the code the
+user actually wrote, not what is generated.)
+
+Case (a): We have no choice but to abort here, but we must make sure that
+the messages are printed or logged before aborting. Logging them is annoying,
+because we're in the type-checker, and the messages are DsMessages, from the
+desugarer. So we report and then fail in the monad. This case is detected
+by the fact that initDsTc returns Nothing.
+
+Case (b): We detect this case by looking for errors in the messages returned
+from initDsTc and aborting if we spot any (after printing, of course). Note
+that initDsTc will return a Just ds_expr in this case, but we don't wish to
+use the (likely very bogus) expression.
+
+Case (c): This is functionally the same as (b), except that the expression
+isn't bogus. We still don't wish to use it, as the user's request for -Werror
+tells us not to.
+
+Case (d): We report the warnings and then carry on with the expression.
+This might result in warnings printed out of source order, but this is
+appropriate, as the warnings from the splice arise from an earlier stage
+of compilation.
+
+Previously, we failed to abort in cases (b) and (c), leading to #19709.
+-}
+
 ---------------
 runMeta' :: Bool                 -- Whether code should be printed in the exception message
          -> (hs_syn -> SDoc)                                    -- how to print the code
@@ -932,11 +976,11 @@ runMeta' show_code ppr_hs run_and_convert expr
         -- Check that we've had no errors of any sort so far.
         -- For example, if we found an error in an earlier defn f, but
         -- recovered giving it type f :: forall a.a, it'd be very dodgy
-        -- to carry ont.  Mind you, the staging restrictions mean we won't
+        -- to carry on.  Mind you, the staging restrictions mean we won't
         -- actually run f, but it still seems wrong. And, more concretely,
         -- see #5358 for an example that fell over when trying to
         -- reify a function with a "?" kind in it.  (These don't occur
-        -- in type-correct programs.
+        -- in type-correct programs.)
         ; failIfErrsM
 
         -- run plugins
@@ -944,7 +988,23 @@ runMeta' show_code ppr_hs run_and_convert expr
         ; expr' <- withPlugins hsc_env spliceRunAction expr
 
         -- Desugar
-        ; ds_expr <- initDsTc (dsLExpr expr')
+        ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')
+
+        -- Print any messages (even warnings) eagerly: they might be helpful if anything
+        -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all
+        -- cases.
+        ; logger <- getLogger
+        ; dflags <- getDynFlags
+        ; liftIO $ printMessages logger dflags ds_msgs
+
+        ; ds_expr <- case mb_ds_expr of
+            Nothing      -> failM   -- Case (a) from Note [Errors in desugaring a splice]
+            Just ds_expr ->  -- There still might be a fatal warning or recoverable
+                             -- Cases (b) and (c) from Note [Errors in desugaring a splice]
+              do { when (errorsOrFatalWarningsFound ds_msgs)
+                     failM
+                 ; return ds_expr }
+
         -- Compile and link it; might fail if linking fails
         ; src_span <- getSrcSpanM
         ; traceTc "About to run (desugared)" (ppr ds_expr)
@@ -1442,7 +1502,7 @@ runTH ty fhv = do
 -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
 runRemoteTH
   :: IServInstance
-  -> [Messages DiagnosticMessage]   --  saved from nested calls to qRecover
+  -> [Messages TcRnMessage]   --  saved from nested calls to qRecover
   -> TcM ()
 runRemoteTH iserv recovers = do
   THMsg msg <- liftIO $ readIServ iserv getTHMessage
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 777086343b..0511e1e268 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -54,6 +54,7 @@ import GHC.Driver.Plugins
 import GHC.Driver.Session
 
 import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )
+import GHC.Tc.Errors.Types
 import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
 import GHC.Tc.Gen.HsType
 import GHC.Tc.Validity( checkValidType )
@@ -191,7 +192,7 @@ tcRnModule :: HscEnv
            -> ModSummary
            -> Bool              -- True <=> save renamed syntax
            -> HsParsedModule
-           -> IO (Messages DiagnosticMessage, Maybe TcGblEnv)
+           -> IO (Messages TcRnMessage, Maybe TcGblEnv)
 
 tcRnModule hsc_env mod_sum save_rn_syntax
    parsedModule@HsParsedModule {hpm_module= L loc this_module}
@@ -213,7 +214,8 @@ tcRnModule hsc_env mod_sum save_rn_syntax
     logger  = hsc_logger hsc_env
     home_unit = hsc_home_unit hsc_env
     err_msg = mkPlainErrorMsgEnvelope loc $
-              text "Module does not have a RealSrcSpan:" <+> ppr this_mod
+              TcRnUnknownMessage $ mkPlainError $
+                text "Module does not have a RealSrcSpan:" <+> ppr this_mod
 
     pair :: (Module, SrcSpan)
     pair@(this_mod,_)
@@ -2010,7 +2012,7 @@ get two defns for 'main' in the interface file!
 *********************************************************
 -}
 
-runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DiagnosticMessage, Maybe a)
+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
 -- Initialise the tcg_inst_env with instances from all home modules.
 -- This mimics the more selective call to hptInstances in tcRnImports
 runTcInteractive hsc_env thing_inside
@@ -2126,7 +2128,7 @@ We don't bother with the tcl_th_bndrs environment either.
 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
 -- values, coerced to ().
 tcRnStmt :: HscEnv -> GhciLStmt GhcPs
-         -> IO (Messages DiagnosticMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
+         -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
 tcRnStmt hsc_env rdr_stmt
   = runTcInteractive hsc_env $ do {
 
@@ -2507,7 +2509,7 @@ getGhciStepIO = do
 
     return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
 
-isGHCiMonad :: HscEnv -> String -> IO (Messages DiagnosticMessage, Maybe Name)
+isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name)
 isGHCiMonad hsc_env ty
   = runTcInteractive hsc_env $ do
         rdrEnv <- getGlobalRdrEnv
@@ -2534,7 +2536,7 @@ data TcRnExprMode = TM_Inst     -- ^ Instantiate inferred quantifiers only (:typ
 tcRnExpr :: HscEnv
          -> TcRnExprMode
          -> LHsExpr GhcPs
-         -> IO (Messages DiagnosticMessage, Maybe Type)
+         -> IO (Messages TcRnMessage, Maybe Type)
 tcRnExpr hsc_env mode rdr_expr
   = runTcInteractive hsc_env $
     do {
@@ -2603,7 +2605,7 @@ has a special case for application chains.
 --------------------------
 tcRnImportDecls :: HscEnv
                 -> [LImportDecl GhcPs]
-                -> IO (Messages DiagnosticMessage, Maybe GlobalRdrEnv)
+                -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
 -- Find the new chunk of GlobalRdrEnv created by this list of import
 -- decls.  In contract tcRnImports *extends* the TcGblEnv.
 tcRnImportDecls hsc_env import_decls
@@ -2619,7 +2621,7 @@ tcRnType :: HscEnv
          -> ZonkFlexi
          -> Bool        -- Normalise the returned type
          -> LHsType GhcPs
-         -> IO (Messages DiagnosticMessage, Maybe (Type, Kind))
+         -> IO (Messages TcRnMessage, Maybe (Type, Kind))
 tcRnType hsc_env flexi normalise rdr_type
   = runTcInteractive hsc_env $
     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
@@ -2753,7 +2755,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
 
 tcRnDeclsi :: HscEnv
            -> [LHsDecl GhcPs]
-           -> IO (Messages DiagnosticMessage, Maybe TcGblEnv)
+           -> IO (Messages TcRnMessage, Maybe TcGblEnv)
 tcRnDeclsi hsc_env local_decls
   = runTcInteractive hsc_env $
     tcRnSrcDecls False Nothing local_decls
@@ -2778,13 +2780,13 @@ externaliseAndTidyId this_mod id
 -- a package module with an interface on disk.  If neither of these is
 -- true, then the result will be an error indicating the interface
 -- could not be found.
-getModuleInterface :: HscEnv -> Module -> IO (Messages DiagnosticMessage, Maybe ModIface)
+getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
 getModuleInterface hsc_env mod
   = runTcInteractive hsc_env $
     loadModuleInterface (text "getModuleInterface") mod
 
 tcRnLookupRdrName :: HscEnv -> LocatedN RdrName
-                  -> IO (Messages DiagnosticMessage, Maybe [Name])
+                  -> IO (Messages TcRnMessage, Maybe [Name])
 -- ^ Find all the Names that this RdrName could mean, in GHCi
 tcRnLookupRdrName hsc_env (L loc rdr_name)
   = runTcInteractive hsc_env $
@@ -2798,7 +2800,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name)
        ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))
        ; return names }
 
-tcRnLookupName :: HscEnv -> Name -> IO (Messages DiagnosticMessage, Maybe TyThing)
+tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
 tcRnLookupName hsc_env name
   = runTcInteractive hsc_env $
     tcRnLookupName' name
@@ -2817,7 +2819,7 @@ tcRnLookupName' name = do
 
 tcRnGetInfo :: HscEnv
             -> Name
-            -> IO ( Messages DiagnosticMessage
+            -> IO ( Messages TcRnMessage
                   , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
 
 -- Used to implement :info in GHCi
@@ -3147,5 +3149,9 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
   recordUnsafeInfer pluginUnsafe
   where
     unsafeText = "Use of plugins makes the module unsafe"
-    pluginUnsafe = unitBag ( mkPlainMsgEnvelope dflags WarningWithoutFlag noSrcSpan
-                                   (Outputable.text unsafeText) )
+    pluginUnsafe =
+      singleMessage $
+      mkPlainMsgEnvelope dflags noSrcSpan $
+      TcRnUnknownMessage $
+      mkPlainDiagnostic WarningWithoutFlag $
+      Outputable.text unsafeText
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 5e79a75472..76ce179b9d 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -152,7 +152,7 @@ simplifyTop wanteds
 
            ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var
            ; TcM.writeTcRef errs_var saved_msg
-           ; recordUnsafeInfer whyUnsafe
+           ; recordUnsafeInfer (mkMessages whyUnsafe)
            }
        ; traceTc "reportUnsolved (unsafe overlapping) }" empty
 
@@ -708,10 +708,10 @@ How is this implemented? It's complicated! So we'll step through it all:
     available and how they overlap. So we once again call `lookupInstEnv` to
     figure that out so we can generate a helpful error message.
 
- 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an
-      IORef called `tcg_safeInfer`.
+ 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in
+      IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`.
 
- 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling
+ 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling
     `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence
     failed.
 
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 40cdf54d12..8e9e1db1b7 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -81,7 +81,10 @@ module GHC.Tc.Types(
         lookupRoleAnnot, getRoleAnnots,
 
         -- Linting
-        lintGblEnv
+        lintGblEnv,
+
+        -- Diagnostics
+        TcRnMessage
   ) where
 
 #include "HsVersions.h"
@@ -100,6 +103,7 @@ import GHC.Tc.Types.Constraint
 import GHC.Tc.Types.Origin
 import GHC.Tc.Types.Evidence
 import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )
+import GHC.Tc.Errors.Types
 
 import GHC.Core.Type
 import GHC.Core.TyCon  ( TyCon, tyConKind )
@@ -130,7 +134,6 @@ import GHC.Types.Unique.FM
 import GHC.Types.Basic
 import GHC.Types.CostCentre.State
 import GHC.Types.HpcInfo
-import GHC.Types.Error ( DiagnosticMessage )
 
 import GHC.Data.IOEnv
 import GHC.Data.Bag
@@ -560,11 +563,18 @@ data TcGblEnv
                                              -- function, if this module is
                                              -- the main module.
 
-        tcg_safeInfer :: TcRef (Bool, WarningMessages),
-        -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)
+        tcg_safe_infer :: TcRef Bool,
+        -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell)?
         -- See Note [Safe Haskell Overlapping Instances Implementation],
         -- although this is used for more than just that failure case.
 
+        tcg_safe_infer_reasons :: TcRef (Messages TcRnMessage),
+        -- ^ Unreported reasons why tcg_safe_infer is False.
+        -- INVARIANT: If this Messages is non-empty, then tcg_safe_infer is False.
+        -- It may be that tcg_safe_infer is False but this is empty, if no reasons
+        -- are supplied (#19714), or if those reasons have already been
+        -- reported by GHC.Driver.Main.markUnsafeInfer
+
         tcg_tc_plugins :: [TcPluginSolver],
         -- ^ A list of user-defined plugins for the constraint solver.
         tcg_hf_plugins :: [HoleFitPlugin],
@@ -769,7 +779,7 @@ data TcLclEnv           -- Changes as we move inside an expression
                                       -- and for tidying types
 
         tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints
-        tcl_errs :: TcRef (Messages DiagnosticMessage)     -- Place to accumulate errors
+        tcl_errs :: TcRef (Messages TcRnMessage)     -- Place to accumulate diagnostics
     }
 
 setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index a1f802b254..a27c4de082 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -23,7 +23,6 @@ import GHC.Driver.Env
 import GHC.Driver.Ppr
 
 import GHC.Types.Basic (TypeOrKind(..))
-import GHC.Types.Error ( DiagnosticMessage )
 import GHC.Types.Fixity (defaultFixity)
 import GHC.Types.Fixity.Env
 import GHC.Types.TypeEnv
@@ -372,7 +371,7 @@ checkUnit (VirtUnit indef) = do
 -- an @hsig@ file.)
 tcRnCheckUnit ::
     HscEnv -> Unit ->
-    IO (Messages DiagnosticMessage, Maybe ())
+    IO (Messages TcRnMessage, Maybe ())
 tcRnCheckUnit hsc_env uid =
    withTiming logger dflags
               (text "Check unit id" <+> ppr uid)
@@ -393,7 +392,7 @@ tcRnCheckUnit hsc_env uid =
 -- | Top-level driver for signature merging (run after typechecking
 -- an @hsig@ file).
 tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
-                    -> IO (Messages DiagnosticMessage, Maybe TcGblEnv)
+                    -> IO (Messages TcRnMessage, Maybe TcGblEnv)
 tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
   withTiming logger dflags
              (text "Signature merging" <+> brackets (ppr this_mod))
@@ -931,7 +930,7 @@ mergeSignatures
 -- an @hsig@ file.)
 tcRnInstantiateSignature ::
     HscEnv -> Module -> RealSrcSpan ->
-    IO (Messages DiagnosticMessage, Maybe TcGblEnv)
+    IO (Messages TcRnMessage, Maybe TcGblEnv)
 tcRnInstantiateSignature hsc_env this_mod real_loc =
    withTiming logger dflags
               (text "Signature instantiation"<+>brackets (ppr this_mod))
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
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 91f1bcdbe7..a85158c122 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -68,7 +68,6 @@ import GHC.Types.SrcLoc
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Builtin.Uniques  ( mkAlphaTyVarUnique )
-import GHC.Data.Bag      ( emptyBag )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
@@ -1565,7 +1564,7 @@ check_special_inst_head dflags is_boot is_sig ctxt clas cls_args
   | clas_nm `elem` genericClassNames
   , hand_written_bindings
   =  do { failIfTc (safeLanguageOn dflags) gen_inst_err
-        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) }
 
   | clas_nm == hasFieldClassName
   = checkHasFieldInst clas cls_args