Use the new error infrastructurewip/adinapoli-introduce-error-domain-specific-types

24 files changed, 216 insertions, 150 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index aaab5ad112..2b286dc0eb 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -303,6 +303,8 @@ import GHC.Prelude hiding (init)
 import GHC.Platform
 import GHC.Platform.Ways
 
+import GHC.Diagnostics hiding (getMessages, getErrorMessages, getWarningMessages)
+
 import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename
                            , isSourceFilename, startPhase )
 import GHC.Driver.Env
@@ -331,14 +333,12 @@ import GHCi.RemoteTypes
 import qualified GHC.Parser as Parser
 import GHC.Parser.Lexer
 import GHC.Parser.Annotation
-import GHC.Parser.Errors.Ppr
 import GHC.Parser.Utils
 
 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
@@ -354,12 +354,10 @@ import GHC.Utils.TmpFs
 import GHC.SysTools
 import GHC.SysTools.BaseDir
 
-import GHC.Utils.Error
 import GHC.Utils.Monad
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
-import GHC.Utils.Logger
 
 import GHC.Core.Predicate
 import GHC.Core.Type  hiding( typeKind )
@@ -380,7 +378,6 @@ import GHC.Types.TyThing.Ppr  ( pprFamInst )
 import GHC.Types.Annotations
 import GHC.Types.Name.Set
 import GHC.Types.Name.Reader
-import GHC.Types.SourceError
 import GHC.Types.SafeHaskell
 import GHC.Types.Fixity
 import GHC.Types.Target
@@ -390,7 +387,6 @@ import GHC.Types.Name.Env
 import GHC.Types.Name.Ppr
 import GHC.Types.TypeEnv
 import GHC.Types.SourceFile
-import GHC.Types.Error ( mkMessages, DiagnosticMessage )
 
 import GHC.Unit
 import GHC.Unit.Env
@@ -900,9 +896,10 @@ 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
+            $ fmap (GhcDriverMessage . DriverUnknownMessage)
+            $ mkPlainMsgEnvelope dflags0 Session.WarningWithoutFlag interactiveSrcSpan
+               $ text "StaticPointers is not supported in GHCi interactive expressions."
           return $ xopt_unset dflags0 LangExt.StaticPointers
   else return dflags0
 
@@ -1493,7 +1490,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 $
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 0ee969160b..158c4c1569 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -48,6 +48,7 @@ import GHC.Core.InstEnv ( ClsInst )
 
 import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
 import GHC.Types.CompleteMatch
+import GHC.Types.Error ( emptyMessages )
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Types.TyThing
@@ -55,7 +56,6 @@ import GHC.Types.TyThing
 import GHC.Builtin.Names ( gHC_PRIM )
 
 import GHC.Data.Maybe
-import GHC.Data.Bag
 
 import GHC.Utils.Outputable
 import GHC.Utils.Monad
@@ -67,7 +67,7 @@ import Data.IORef
 
 runHsc :: HscEnv -> Hsc a -> IO a
 runHsc hsc_env (Hsc hsc) = do
-    (a, w) <- hsc hsc_env emptyBag
+    (a, w) <- hsc hsc_env emptyMessages
     printOrThrowDiagnostics (hsc_logger hsc_env) (hsc_dflags hsc_env) w
     return a
 
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index abf19a0afa..6b93a6b508 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -9,7 +9,7 @@ import GHC.Driver.Session ( DynFlags, HasDynFlags(..) )
 import GHC.Prelude
 import GHC.Runtime.Context
 import GHC.Runtime.Interpreter.Types ( Interp )
-import GHC.Types.Error ( WarningMessages )
+import GHC.Types.Error ( Messages )
 import GHC.Types.Name.Cache
 import GHC.Types.Target
 import GHC.Types.TypeEnv
@@ -27,9 +27,10 @@ import {-# SOURCE #-} GHC.Driver.Plugins
 import Control.Monad ( ap )
 import Control.Monad.IO.Class
 import Data.IORef
+import GHC.Driver.Errors.Types
 
 -- | The Hsc monad: Passing an environment and warning state
-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
+newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
     deriving (Functor)
 
 instance Applicative Hsc where
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index bbbacc8067..e99b08cd09 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ViewPatterns #-}
 module GHC.Driver.Errors (
     printOrThrowDiagnostics
   , printBagOfErrors
@@ -16,6 +17,7 @@ import GHC.Types.Error
 import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )
 import GHC.Utils.Logger
 import qualified GHC.Driver.CmdLine as CmdLine
+import Data.Typeable
 
 -- | Partitions the messages and returns a tuple which first element are the warnings, and the
 -- second the errors.
@@ -42,7 +44,7 @@ handleFlagWarnings logger dflags warns = do
       bag = listToBag [ mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text warn)
                       | CmdLine.Warn _ (L loc warn) <- warns' ]
 
-  printOrThrowDiagnostics logger dflags bag
+  printOrThrowDiagnostics logger dflags (mkMessages bag)
   where
     -- Given a warn reason, check to see if it's associated -W opt is enabled
     should_print_warning :: DynFlags -> DiagnosticReason -> Bool
@@ -55,9 +57,9 @@ handleFlagWarnings logger dflags warns = do
 
 -- | Given a bag of diagnostics, turn them into an exception if
 -- any has 'SevError', or print them out otherwise.
-printOrThrowDiagnostics :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
-printOrThrowDiagnostics logger dflags warns
-  | any ((==) SevError . errMsgSeverity) warns
-  = throwIO (mkSrcErr . mkMessages $ warns)
+printOrThrowDiagnostics :: (Diagnostic e, Typeable e) => Logger -> DynFlags -> Messages e -> IO ()
+printOrThrowDiagnostics logger dflags (getMessages -> msgs)
+  | any ((==) SevError . errMsgSeverity) msgs
+  = throwIO (mkSrcErr . mkMessages $ msgs)
   | otherwise
-  = printBagOfErrors logger dflags warns
+  = printBagOfErrors logger dflags msgs
diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs
index cafa522ab8..bb79acd5f6 100644
--- a/compiler/GHC/Driver/Errors/Ppr.hs
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -11,7 +11,7 @@ import GHC.Types.Basic
 import GHC.Types.Error
 import GHC.Types.Name ( nameSrcSpan, getName )
 import GHC.Driver.Errors.Types
--- import GHC.Iface.Load  ( cannotFindModule )
+import GHC.Iface.Errors  ( cannotFindModule' )
 import GHC.Unit.State
 import GHC.Utils.Error
 import GHC.Utils.Outputable
@@ -46,14 +46,38 @@ instance Diagnostic GhcMessage where
       -> diagnosticReason m
 
 instance Diagnostic DriverMessage where
-  diagnosticReason _ = ErrorWithoutFlag -- FIXME(adn)
+  diagnosticReason  = \case
+    DriverUnknownMessage d
+      -> diagnosticReason d
+
+    DriverCannotFindModule{}
+      -> ErrorWithoutFlag
+
+    DriverNotAnExpression{}
+      -> ErrorWithoutFlag
+
+    DriverParseErrorImport
+      -> ErrorWithoutFlag
+
+    DriverPkgRequiredTrusted{}
+      -> ErrorWithoutFlag
+
+    DriverCantLoadIfaceForSafe{}
+      -> ErrorWithoutFlag
+
+    DriverWarnModuleInferredUnsafe{}
+      -> WarningWithoutFlag
+
+    DriverWarnInferredSafeImports{}
+      -> WarningWithoutFlag
+
   diagnosticMessage = \case
 
     DriverUnknownMessage d
-      -> d
+      -> diagnosticMessage d
 
-    DriverCannotFindModule _env _m _res
-      -> mkDecorated [ {- cannotFindModule env m res -} ]
+    DriverCannotFindModule df unitEnv profile modName res
+      -> mkDecorated [ cannotFindModule' df unitEnv profile modName res ]
 
     DriverNotAnExpression str
       -> mkDecorated [ text "not an expression:" <+> quotes (text str) ]
diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs
index a5851ff9f2..2dc2f115c8 100644
--- a/compiler/GHC/Driver/Errors/Types.hs
+++ b/compiler/GHC/Driver/Errors/Types.hs
@@ -5,18 +5,22 @@ module GHC.Driver.Errors.Types (
   , DriverMessage(..)
   -- * Constructors
   , ghcUnknownMessage
+  -- * Utility functions
+  , liftTcRnMessage
   ) where
 
 import Data.Typeable
+import Data.Bifunctor
 
 import GHC.Core.InstEnv ( ClsInst )
-import GHC.Driver.Env.Types
 import GHC.Driver.Session ( DynFlags )
-import GHC.Prelude ( String )
+import GHC.Prelude
+import GHC.Platform.Profile ( Profile )
 import GHC.Types.Error
 import GHC.Unit.Finder.Types ( FindResult )
 import GHC.Unit.Module.Name ( ModuleName )
 import GHC.Unit.State
+import GHC.Unit.Env ( UnitEnv )
 import GHC.Unit.Types ( UnitId, Module )
 
 import GHC.Parser.Errors.Types ( PsMessage )
@@ -71,6 +75,11 @@ data GhcMessage where
 ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage
 ghcUnknownMessage = GhcUnknownMessage
 
+-- | Abstracts away the classic pattern where we are calling 'ioMsgMaybe' on the result of
+-- 'IO (Messages TcRnMessage, a)'.
+liftTcRnMessage :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
+liftTcRnMessage = fmap (first (fmap GhcTcRnMessage))
+
 -- | A message from the driver.
 data DriverMessage
   = -- Warnings
@@ -78,9 +87,9 @@ data DriverMessage
   | DriverWarnInferredSafeImports  !ModuleName
 
     -- Errors
-  | DriverCannotFindModule !HscEnv !ModuleName !FindResult
+  | DriverCannotFindModule !DynFlags !UnitEnv !Profile !ModuleName !FindResult
   | DriverNotAnExpression !String
   | DriverParseErrorImport
   | DriverPkgRequiredTrusted !UnitState !UnitId
   | DriverCantLoadIfaceForSafe !Module
-  | DriverUnknownMessage !DecoratedSDoc
+  | DriverUnknownMessage !DiagnosticMessage
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index b43da83b07..a05162958e 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -94,7 +94,7 @@ import GHC.Driver.Session
 import GHC.Driver.Backend
 import GHC.Driver.Env
 import GHC.Driver.Errors
-import GHC.Driver.Errors.Types ( ghcUnknownMessage )
+import GHC.Driver.Errors.Types ( liftTcRnMessage,  GhcMessage(..),  ghcUnknownMessage )
 import GHC.Driver.CodeOutput
 import GHC.Driver.Config
 import GHC.Driver.Hooks
@@ -144,9 +144,11 @@ import GHC.CoreToStg    ( coreToStg )
 
 import GHC.Parser.Errors
 import GHC.Parser.Errors.Ppr
+import GHC.Parser.Errors.Types
 import GHC.Parser
 import GHC.Parser.Lexer as Lexer
 
+import GHC.Tc.Errors.Types
 import GHC.Tc.Module
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )
@@ -188,6 +190,7 @@ import GHC.Types.SafeHaskell
 import GHC.Types.ForeignStubs
 import GHC.Types.Var.Env       ( emptyTidyEnv )
 import GHC.Types.Error         hiding ( getMessages )
+import qualified GHC.Types.Error as Error.Types
 import GHC.Types.Fixity.Env
 import GHC.Types.CostCentre
 import GHC.Types.IPE
@@ -272,14 +275,14 @@ newHscEnv dflags = do
 
 -- -----------------------------------------------------------------------------
 
-getWarnings :: Hsc WarningMessages
-getWarnings = Hsc $ \_ w -> return (w, w)
+getDiagnostics :: Hsc (Messages GhcMessage)
+getDiagnostics = Hsc $ \_ w -> return (w, w)
 
-clearWarnings :: Hsc ()
-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
+clearDiagnostics :: Hsc ()
+clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages)
 
-logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc ()
-logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
+logDiagnostics :: Messages GhcMessage -> Hsc ()
+logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w)
 
 getHscEnv :: Hsc HscEnv
 getHscEnv = Hsc $ \e w -> return (e, w)
@@ -288,18 +291,18 @@ handleWarnings :: Hsc ()
 handleWarnings = do
     dflags <- getDynFlags
     logger <- getLogger
-    w <- getWarnings
+    w <- getDiagnostics
     liftIO $ printOrThrowDiagnostics logger dflags w
-    clearWarnings
+    clearDiagnostics
 
 -- | log warning in the monad, and if there are errors then
 -- throw a SourceError exception.
 logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()
 logWarningsReportErrors (warnings,errors) = do
     dflags <- getDynFlags
-    let warns = fmap (mkParserWarn dflags) warnings
+    let warns = fmap (fmap (GhcPsMessage . PsUnknownMessage) . mkParserWarn dflags) warnings
         errs  = fmap mkParserErr errors
-    logDiagnostics warns
+    logDiagnostics (mkMessages warns)
     when (not $ isEmptyBag errs)
       $ throwErrors $ mkMessages errs
 
@@ -308,9 +311,9 @@ logWarningsReportErrors (warnings,errors) = do
 handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a
 handleWarningsThrowErrors (warnings, errors) = do
     dflags <- getDynFlags
-    let warns = fmap (mkParserWarn dflags) warnings
-        errs  = fmap mkParserErr           errors
-    logDiagnostics warns
+    let warns = fmap (fmap (GhcPsMessage . PsUnknownMessage) . mkParserWarn dflags) warnings
+        errs  = fmap (fmap (GhcPsMessage . PsUnknownMessage) . mkParserErr        ) errors
+    logDiagnostics (mkMessages warns)
     logger <- getLogger
     let (wWarns, wErrs) = partitionMessageBag warns
     liftIO $ printBagOfErrors logger dflags wWarns
@@ -332,21 +335,21 @@ handleWarningsThrowErrors (warnings, errors) = do
 --  2. If there are no error messages, but the second result indicates failure
 --     there should be warnings in the first result. That is, if the action
 --     failed, it must have been due to the warnings (i.e., @-Werror@).
-ioMsgMaybe :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc a
+ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
 ioMsgMaybe ioA = do
     (msgs, mb_r) <- liftIO ioA
     let (warns, errs) = partitionMessages msgs
-    logDiagnostics warns
+    logDiagnostics (mkMessages warns)
     case mb_r of
         Nothing -> throwErrors . mkMessages $ errs
         Just r  -> ASSERT( isEmptyBag errs ) return r
 
 -- | like ioMsgMaybe, except that we ignore error messages and return
 -- 'Nothing' instead.
-ioMsgMaybe' :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc (Maybe a)
+ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
 ioMsgMaybe' ioA = do
     (msgs, mb_r) <- liftIO $ ioA
-    logDiagnostics (getWarningMessages msgs)
+    logDiagnostics (mkMessages $ getWarningMessages msgs)
     return mb_r
 
 -- -----------------------------------------------------------------------------
@@ -356,12 +359,12 @@ hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
 hscTcRnLookupRdrName hsc_env0 rdr_name
   = runInteractiveHsc hsc_env0 $
     do { hsc_env <- getHscEnv
-       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
+       ; ioMsgMaybe $ liftTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
 
 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
   hsc_env <- getHscEnv
-  ioMsgMaybe' $ tcRnLookupName hsc_env name
+  ioMsgMaybe' $ liftTcRnMessage $ tcRnLookupName hsc_env name
       -- ignore errors: the only error we're likely to get is
       -- "name not found", and the Maybe in the return type
       -- is used to indicate that.
@@ -371,23 +374,23 @@ hscTcRnGetInfo :: HscEnv -> Name
 hscTcRnGetInfo hsc_env0 name
   = runInteractiveHsc hsc_env0 $
     do { hsc_env <- getHscEnv
-       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
+       ; ioMsgMaybe' $ liftTcRnMessage $ tcRnGetInfo hsc_env name }
 
 hscIsGHCiMonad :: HscEnv -> String -> IO Name
 hscIsGHCiMonad hsc_env name
-  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
+  = runHsc hsc_env $ ioMsgMaybe $ liftTcRnMessage $ isGHCiMonad hsc_env name
 
 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
   hsc_env <- getHscEnv
-  ioMsgMaybe $ getModuleInterface hsc_env mod
+  ioMsgMaybe $ liftTcRnMessage $ getModuleInterface hsc_env mod
 
 -- -----------------------------------------------------------------------------
 -- | Rename some import declarations
 hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
 hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
   hsc_env <- getHscEnv
-  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
+  ioMsgMaybe $ liftTcRnMessage $ tcRnImportDecls hsc_env import_decls
 
 -- -----------------------------------------------------------------------------
 -- | parse a file, returning the abstract syntax
@@ -425,8 +428,11 @@ hscParse' mod_summary
         PFailed pst ->
             handleWarningsThrowErrors (getMessages pst)
         POk pst rdr_module -> do
-            let (warns, errs) = bimap (fmap (mkParserWarn dflags)) (fmap mkParserErr) (getMessages pst)
-            logDiagnostics warns
+            let (warns, errs) =
+                  bimap (fmap (fmap (GhcPsMessage . PsUnknownMessage) . mkParserWarn dflags))
+                        (fmap (fmap (GhcPsMessage . PsUnknownMessage) . mkParserErr))
+                        (getMessages pst)
+            logDiagnostics (mkMessages warns)
             liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"
                         FormatHaskell (ppr rdr_module)
             liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"
@@ -546,7 +552,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
         keep_rn' = gopt Opt_WriteHie dflags || keep_rn
     MASSERT( isHomeModule home_unit outer_mod )
     tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
-        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
+        then ioMsgMaybe $ liftTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
         else
          do hpm <- case mb_rdr_module of
                     Just hpm -> return hpm
@@ -554,7 +560,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
             tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
             if hsc_src == HsigFile
                 then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
-                        ioMsgMaybe $
+                        ioMsgMaybe $ liftTcRnMessage $
                             tcRnMergeSignatures hsc_env hpm tc_result0 iface
                 else return tc_result0
     -- TODO are we extracting anything when we merely instantiate a signature?
@@ -573,12 +579,12 @@ tcRnModule' sum save_rn_syntax mod = do
     -- -Wmissing-safe-haskell-mode
     when (not (safeHaskellModeEnabled dflags)
           && wopt Opt_WarnMissingSafeHaskellMode dflags) $
-        logDiagnostics $ unitBag $
+        logDiagnostics $ singleMessage $ fmap (GhcTcRnMessage . TcRnUnknownMessage) $
         mkPlainMsgEnvelope dflags reason (getLoc (hpm_module mod)) $
         warnMissingSafeHaskellMode
 
     tcg_res <- {-# SCC "Typecheck-Rename" #-}
-               ioMsgMaybe $
+               ioMsgMaybe $ liftTcRnMessage $
                    tcRnModule hsc_env sum
                      save_rn_syntax mod
 
@@ -601,13 +607,13 @@ tcRnModule' sum save_rn_syntax mod = do
             case wopt Opt_WarnSafe dflags of
               True
                 | safeHaskell dflags == Sf_Safe -> return ()
-                | otherwise -> (logDiagnostics $ unitBag $
+                | otherwise -> (logDiagnostics $ singleMessage $ fmap (GhcTcRnMessage . TcRnUnknownMessage) $
                        mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnSafe)
                                           (warnSafeOnLoc dflags) $
                        errSafe tcg_res')
               False | safeHaskell dflags == Sf_Trustworthy &&
                       wopt Opt_WarnTrustworthySafe dflags ->
-                      (logDiagnostics $ unitBag $
+                      (logDiagnostics $ singleMessage $ fmap (GhcTcRnMessage . TcRnUnknownMessage) $
                        mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnTrustworthySafe)
                                           (trustworthyOnLoc dflags) $
                        errTwthySafe tcg_res')
@@ -630,8 +636,9 @@ hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
 hscDesugar' mod_location tc_result = do
     hsc_env <- getHscEnv
     r <- ioMsgMaybe $
-      {-# SCC "deSugar" #-}
-      deSugar hsc_env mod_location tc_result
+      (first (fmap GhcDsMessage) <$>
+        {-# SCC "deSugar" #-}
+        deSugar hsc_env mod_location tc_result)
 
     -- always check -Werror after desugaring, this is the last opportunity for
     -- warnings to arise before the backend.
@@ -1140,7 +1147,7 @@ hscCheckSafeImports tcg_env = do
       case safeLanguageOn dflags of
           True -> do
               -- XSafe: we nuke user written RULES
-              logDiagnostics $ warns dflags (tcg_rules tcg_env')
+              logDiagnostics $ fmap GhcTcRnMessage $ warns dflags (tcg_rules tcg_env')
               return tcg_env' { tcg_rules = [] }
           False
                 -- SafeInferred: user defined RULES, so not safe
@@ -1151,10 +1158,10 @@ hscCheckSafeImports tcg_env = do
               | otherwise
               -> return tcg_env'
 
-    warns dflags rules = listToBag $ map (warnRules dflags) rules
+    warns dflags rules = mkMessages $ listToBag $ map (warnRules dflags) rules
 
-    warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage
-    warnRules df (L loc (HsRule { rd_name = n })) =
+    warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope TcRnMessage
+    warnRules df (L loc (HsRule { rd_name = n })) = fmap TcRnUnknownMessage $
         mkPlainMsgEnvelope df WarningWithoutFlag (locA loc) $
             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
@@ -1181,36 +1188,40 @@ checkSafeImports tcg_env
 
         -- We want to use the warning state specifically for detecting if safe
         -- inference has failed, so store and clear any existing warnings.
-        oldErrs <- getWarnings
-        clearWarnings
+        oldErrs <- getDiagnostics
+        clearDiagnostics
 
         -- Check safe imports are correct
         safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
-        safeErrs <- getWarnings
-        clearWarnings
+        safeErrs <- getDiagnostics
+        clearDiagnostics
 
         -- Check non-safe imports are correct if inferring safety
         -- See the Note [Safe Haskell Inference]
         (infErrs, infPkgs) <- case (safeInferOn dflags) of
-          False -> return (emptyBag, S.empty)
+          False -> return (emptyMessages, S.empty)
           True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
-                     infErrs <- getWarnings
-                     clearWarnings
+                     infErrs <- getDiagnostics
+                     clearDiagnostics
                      return (infErrs, infPkgs)
 
         -- restore old errors
         logDiagnostics oldErrs
 
-        case (isEmptyBag safeErrs) of
+        case (isEmptyMessages safeErrs) of
           -- Failed safe check
           False ->
-            liftIO . throwIO . mkSrcErr . mkMessages $ safeErrs
+            liftIO . throwErrors $ safeErrs
 
           -- Passed safe check
           True -> do
-            let infPassed = isEmptyBag infErrs
+            let infPassed = isEmptyMessages infErrs
             tcg_env' <- case (not infPassed) of
-              True  -> markUnsafeInfer tcg_env infErrs
+              True  ->
+                let castMsg m = TcRnUnknownMessage $ DiagnosticMessage (diagnosticMessage m) (diagnosticReason m)
+                -- FIXME(adn) This is /extremely/ unfortunate. We have
+                -- to cast everything to be an 'TcRnUnknownMessage'!
+                in markUnsafeInfer tcg_env (castMsg <$> infErrs)
               False -> return tcg_env
             when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
             let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
@@ -1263,15 +1274,15 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
     dflags <- getDynFlags
     pkgs <- snd `fmap` hscCheckSafe' m l
     when (packageTrustOn dflags) $ checkPkgTrust pkgs
-    errs <- getWarnings
-    return $ isEmptyBag errs
+    errs <- getDiagnostics
+    return $ isEmptyMessages errs
 
 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
 hscGetSafe hsc_env m l = runHsc hsc_env $ do
     (self, pkgs) <- hscCheckSafe' m l
-    good         <- isEmptyBag `fmap` getWarnings
-    clearWarnings -- don't want them printed...
+    good         <- isEmptyMessages `fmap` getDiagnostics
+    clearDiagnostics -- don't want them printed...
     let pkgs' | Just p <- self = S.insert p pkgs
               | otherwise      = pkgs
     return (good, pkgs')
@@ -1319,10 +1330,10 @@ hscCheckSafe' m l = do
                                 && safeLanguageOn dflags
                                 && trust == Sf_SafeInferred
                                 then inferredImportWarn dflags
-                                else emptyBag
+                                else emptyMessages
                     -- General errors we throw but Safe errors we log
                     errs = case (safeM, safeP) of
-                        (True, True ) -> emptyBag
+                        (True, True ) -> emptyMessages
                         (True, False) -> pkgTrustErr
                         (False, _   ) -> modTrustErr
                 in do
@@ -1332,7 +1343,8 @@ hscCheckSafe' m l = do
 
                 where
                     state = hsc_units hsc_env
-                    inferredImportWarn dflags = unitBag
+                    inferredImportWarn dflags = singleMessage
+                        $ fmap (GhcTcRnMessage . TcRnUnknownMessage)
                         $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports)
                                              l (pkgQual state)
                         $ sep
@@ -1340,7 +1352,8 @@ hscCheckSafe' m l = do
                                 <> ppr (moduleName m)
                                 <> text " from explicitly Safe module"
                             ]
-                    pkgTrustErr = unitBag
+                    pkgTrustErr = singleMessage
+                      $ fmap (GhcTcRnMessage . TcRnUnknownMessage)
                       $ mkShortErrorMsgEnvelope l (pkgQual state)
                       $ sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
@@ -1348,7 +1361,8 @@ hscCheckSafe' m l = do
                                 <> (pprWithUnitState state $ ppr (moduleUnit m))
                                 <> text ") the module resides in isn't trusted."
                             ]
-                    modTrustErr = unitBag
+                    modTrustErr = singleMessage
+                      $ fmap (GhcTcRnMessage . TcRnUnknownMessage)
                       $ mkShortErrorMsgEnvelope l (pkgQual state)
                       $ sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
@@ -1414,13 +1428,13 @@ checkPkgTrust pkgs = do
 -- may call it on modules using Trustworthy or Unsafe flags so as to allow
 -- warning flags for safety to function correctly. See Note [Safe Haskell
 -- Inference].
-markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
+markUnsafeInfer :: TcGblEnv -> Messages TcRnMessage -> Hsc TcGblEnv
 markUnsafeInfer tcg_env whyUnsafe = do
     dflags <- getDynFlags
 
     let reason = WarningWithFlag Opt_WarnUnsafe
     when (wopt Opt_WarnUnsafe dflags)
-         (logDiagnostics $ unitBag $
+         (logDiagnostics $ singleMessage $ fmap (GhcTcRnMessage . TcRnUnknownMessage) $
              mkPlainMsgEnvelope dflags reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
 
     liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
@@ -1437,7 +1451,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
     whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
                          , text "Reason:"
                          , nest 4 $ (vcat $ badFlags df) $+$
-                                    (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$
+                                    (vcat $ pprMsgEnvelopeBagWithLoc (Error.Types.getMessages whyUnsafe)) $+$
                                     (vcat $ badInsts $ tcg_insts tcg_env)
                          ]
     badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer
@@ -1653,7 +1667,9 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
                $ do
                   (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
                                        $ parseCmmFile dflags cmm_mod home_unit filename
-                  return (mkMessages (fmap (mkParserWarn dflags) warns `unionBags` fmap mkParserErr errs), cmm)
+                  let msgs = unionBags (fmap (fmap (GhcPsMessage . PsUnknownMessage) . mkParserWarn dflags) warns)
+                                       (fmap (fmap (GhcPsMessage . PsUnknownMessage) . mkParserErr) errs)
+                  return (mkMessages msgs, cmm)
     liftIO $ do
         dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
 
@@ -1853,10 +1869,10 @@ hscParsedStmt :: HscEnv
                     , FixityEnv))
 hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
   -- Rename and typecheck it
-  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ liftTcRnMessage $ tcRnStmt hsc_env stmt
 
   -- Desugar it
-  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
+  ds_expr <- ioMsgMaybe $ first (fmap GhcDsMessage) <$> deSugarExpr hsc_env tc_expr
   liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
   handleWarnings
 
@@ -1900,7 +1916,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
     let interp = hscInterp hsc_env
 
     {- Rename and typecheck it -}
-    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
+    tc_gblenv <- ioMsgMaybe $ liftTcRnMessage $ tcRnDeclsi hsc_env decls
 
     {- Grab the new instances -}
     -- We grab the whole environment because of the overlapping that may have
@@ -2025,7 +2041,7 @@ hscTcExpr :: HscEnv
 hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
   hsc_env <- getHscEnv
   parsed_expr <- hscParseExpr expr
-  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
+  ioMsgMaybe $ liftTcRnMessage $ tcRnExpr hsc_env mode parsed_expr
 
 -- | Find the kind of a type, after generalisation
 hscKcType
@@ -2036,7 +2052,7 @@ hscKcType
 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
     hsc_env <- getHscEnv
     ty <- hscParseType str
-    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty
+    ioMsgMaybe $ liftTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty
 
 hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
 hscParseExpr expr = do
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 43b47df50f..87c4a0dda6 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -61,7 +61,7 @@ import GHC.Driver.Backend
 import GHC.Driver.Monad
 import GHC.Driver.Env
 import GHC.Driver.Errors
-import GHC.Driver.Errors.Types ( GhcMessage, ghcUnknownMessage )
+import GHC.Driver.Errors.Types
 import GHC.Driver.Main
 
 import GHC.Parser.Header
@@ -272,7 +272,7 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check
 warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
 warnMissingHomeModules hsc_env mod_graph =
     when (not (null missing)) $
-        logWarnings (listToBag [warn])
+        logDiagnostics warn
   where
     dflags = hsc_dflags hsc_env
     targets = map targetId (hsc_targets hsc_env)
@@ -319,7 +319,7 @@ warnMissingHomeModules hsc_env mod_graph =
           (text "Modules are not listed in command line but needed for compilation: ")
           4
           (sep (map ppr missing))
-    warn =
+    warn = singleMessage $ fmap (GhcDriverMessage . DriverUnknownMessage) $
       mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
 
 -- | Describes which modules of the module graph need to be loaded.
@@ -385,7 +385,7 @@ warnUnusedPackages = do
           = filter (\arg -> not $ any (matching state arg) loadedPackages)
                    requestedArgs
 
-    let warn =
+    let warn = singleMessage $ fmap (GhcDriverMessage . DriverUnknownMessage) $
           mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg
         msg = vcat [ text "The following packages were specified" <+>
                      text "via -package or -package-id flags,"
@@ -393,7 +393,7 @@ warnUnusedPackages = do
                    , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]
 
     when (not (null unusedArgs)) $
-      logWarnings (listToBag [warn])
+      logDiagnostics warn
 
     where
         packageArg (ExposePackage _ arg _) = Just arg
@@ -1671,7 +1671,7 @@ upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do
         case mHscMessage of
             Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)
             Nothing -> return ()
-        runHsc hsc_env $ ioMsgMaybe $ tcRnCheckUnit hsc_env $ VirtUnit iuid
+        runHsc hsc_env $ ioMsgMaybe $ liftTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid
         pure ()
 
 -- | Compile a single module.  Always produce a Linkable for it if
@@ -2214,14 +2214,14 @@ warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
 warnUnnecessarySourceImports sccs = do
   dflags <- getDynFlags
   when (wopt Opt_WarnUnusedImports dflags)
-    (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
+    (logDiagnostics (mkMessages $ listToBag (concatMap (check dflags . flattenSCC) sccs)))
   where check dflags ms =
            let mods_in_this_cycle = map ms_mod_name ms in
            [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
                              unLoc i `notElem`  mods_in_this_cycle ]
 
-        warn :: DynFlags -> Located ModuleName -> WarnMsg
-        warn dflags (L loc mod) =
+        warn :: DynFlags -> Located ModuleName -> MsgEnvelope GhcMessage
+        warn dflags (L loc mod) = fmap (GhcDriverMessage . DriverUnknownMessage) $
            mkPlainMsgEnvelope dflags WarningWithoutFlag loc
                 (text "{-# SOURCE #-} unnecessary in import of "
                  <+> quotes (ppr mod))
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 62a719eef0..7959048693 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -28,7 +28,7 @@ module GHC.Driver.Monad (
         withTimingM,
 
         -- ** Warnings
-        logWarnings, printException,
+        logDiagnostics, printException,
         WarnErrLogger, defaultWarnErrLogger
   ) where
 
@@ -37,6 +37,7 @@ import GHC.Prelude
 import GHC.Driver.Session
 import GHC.Driver.Env
 import GHC.Driver.Errors ( printOrThrowDiagnostics, printBagOfErrors )
+import GHC.Driver.Errors.Types
 
 import GHC.Utils.Monad
 import GHC.Utils.Exception
@@ -142,13 +143,13 @@ withTimingM doc force action = do
     withTiming logger dflags doc force action
 
 -- -----------------------------------------------------------------------------
--- | A monad that allows logging of warnings.
+-- | A monad that allows logging of diagnostics.
 
-logWarnings :: GhcMonad m => WarningMessages -> m ()
-logWarnings warns = do
+logDiagnostics :: GhcMonad m => Messages GhcMessage -> m ()
+logDiagnostics msgs = do
   dflags <- getSessionDynFlags
   logger <- getLogger
-  liftIO $ printOrThrowDiagnostics logger dflags warns
+  liftIO $ printOrThrowDiagnostics logger dflags msgs
 
 -- -----------------------------------------------------------------------------
 -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index a4bbc290e2..c6ebc48cdb 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -29,6 +29,7 @@ import GHC.Hs
 
 import GHC.HsToCore.Usage
 import GHC.HsToCore.Monad
+import GHC.HsToCore.Errors.Types
 import GHC.HsToCore.Expr
 import GHC.HsToCore.Binds
 import GHC.HsToCore.Foreign.Decl
@@ -82,7 +83,6 @@ import GHC.Types.Name.Set
 import GHC.Types.Name.Env
 import GHC.Types.Name.Ppr
 import GHC.Types.HpcInfo
-import GHC.Types.Error
 
 import GHC.Unit
 import GHC.Unit.Module.ModGuts
@@ -101,7 +101,7 @@ import GHC.Driver.Plugins ( LoadedPlugin(..) )
 -}
 
 -- | Main entry point to the desugarer.
-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DiagnosticMessage, Maybe ModGuts)
+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
 -- Can modify PCS by faulting in more declarations
 
 deSugar hsc_env
@@ -285,7 +285,7 @@ So we pull out the type/coercion variables (which are in dependency order),
 and Rec the rest.
 -}
 
-deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DiagnosticMessage, Maybe CoreExpr)
+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
 deSugarExpr hsc_env tc_expr = do
     let dflags = hsc_dflags hsc_env
     let logger = hsc_logger hsc_env
@@ -301,7 +301,7 @@ deSugarExpr hsc_env tc_expr = do
        Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared"
                     FormatCore (pprCoreExpr expr)
 
-    return (msgs, mb_core_expr)
+    return (DsLiftedTcRnMessage <$> msgs, mb_core_expr)
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 169c1f19b9..6b7b4c09d3 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -238,10 +238,17 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
              complete_matches = hptCompleteSigs hsc_env         -- from the home package
                                 ++ tcg_complete_matches tcg_env -- from the current module
                                 ++ eps_complete_matches eps     -- from imports
+       ; msg_var' <- liftTcRnMessages msg_var
        ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env
-                           msg_var cc_st_var complete_matches
+                           msg_var' cc_st_var complete_matches
        }
 
+liftTcRnMessages :: MonadIO m => IORef (Messages TcRnMessage) -> m (IORef (Messages DsMessage))
+liftTcRnMessages ref = liftIO $ do
+  oldContent <- readIORef ref
+  newIORef (DsLiftedTcRnMessage <$> oldContent)
+
+
 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
@@ -315,7 +322,7 @@ initTcDsForSolver thing_inside
            Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }
 
 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef (Messages TcRnMessage) -> IORef CostCentreState -> CompleteMatches
+         -> IORef (Messages DsMessage) -> IORef CostCentreState -> CompleteMatches
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
          complete_matches
diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs
index 68ee3522fa..ea3c1938cd 100644
--- a/compiler/GHC/Iface/Errors.hs
+++ b/compiler/GHC/Iface/Errors.hs
@@ -5,6 +5,7 @@ module GHC.Iface.Errors
   ( cannotFindInterface
   , cantFindInstalledErr
   , cannotFindModule
+  , cannotFindModule'
   , cantFindErr
   -- * Utility functions
   , mayShowLocations
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 6f2260dfc7..46f7a53270 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -31,10 +31,11 @@ import GHC.Builtin.Types (filterCTuple)
 import GHC.Driver.Session (DynFlags)
 import GHC.Utils.Error (diagReasonSeverity)
 
--- This is a totally uninteresting instance will will be populated in the context of #18516.
 instance Diagnostic PsMessage where
-  diagnosticMessage _ = mkDecorated []
-  diagnosticReason  _ = ErrorWithoutFlag
+  diagnosticMessage = \case
+    PsUnknownMessage m -> diagnosticMessage m
+  diagnosticReason  = \case
+    PsUnknownMessage m -> diagnosticReason m
 
 mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
 mk_parser_err span doc = MsgEnvelope
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 32e328ea74..f4d678028a 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -2,7 +2,11 @@
 module GHC.Parser.Errors.Types where
 
 import GHC.Prelude ()
+import GHC.Types.Error
 
 -- NOTE(adn): This is an opaque type where constructors will be added
 -- in the context of #18516.
+-- FIX(adn) This is temporary. We shouldn't have separate types for
+-- parsing warnings and errors.
 data PsMessage
+  = PsUnknownMessage DiagnosticMessage
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index d8c8c781da..74d983a2f3 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -51,6 +51,7 @@ import GHC.Prelude
 import GHC.Driver.Monad
 import GHC.Driver.Main
 import GHC.Driver.Env
+import GHC.Driver.Errors.Types
 import GHC.Driver.Session
 import GHC.Driver.Ppr
 
@@ -1032,7 +1033,7 @@ typeKind normalise str = withSession $ \hsc_env ->
 getInstancesForType :: GhcMonad m => Type -> m [ClsInst]
 getInstancesForType ty = withSession $ \hsc_env ->
   liftIO $ runInteractiveHsc hsc_env $
-    ioMsgMaybe $ runTcInteractive hsc_env $ do
+    ioMsgMaybe $ liftTcRnMessage $ runTcInteractive hsc_env $ do
       -- Bring class and instances from unqualified modules into scope, this fixes #16793.
       loadUnqualIfaces hsc_env (hsc_IC hsc_env)
       matches <- findMatchingInstances ty
@@ -1045,7 +1046,7 @@ parseInstanceHead str = withSession $ \hsc_env0 -> do
   (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do
     hsc_env <- getHscEnv
     ty <- hscParseType str
-    ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty
+    ioMsgMaybe $ liftTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty
 
   return ty
 
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/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 4fadae964b..86c5078b3d 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -42,6 +42,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
@@ -1438,7 +1439,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 85019be343..a629339512 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}
@@ -212,8 +213,8 @@ tcRnModule hsc_env mod_sum save_rn_syntax
     dflags  = hsc_dflags hsc_env
     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
+    err_msg = fmap TcRnUnknownMessage $ mkPlainErrorMsgEnvelope loc $
+                text "Module does not have a RealSrcSpan:" <+> ppr this_mod
 
     pair :: (Module, SrcSpan)
     pair@(this_mod,_)
@@ -2010,7 +2011,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 +2127,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 +2508,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 +2535,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 +2604,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 +2620,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 +2754,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 +2779,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 +2799,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 +2818,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 +3148,6 @@ 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 ( TcRnUnknownMessage <$> (mkPlainMsgEnvelope dflags WarningWithoutFlag noSrcSpan $
+                                               (Outputable.text unsafeText) ))
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index d4e9003b72..048433b7ba 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
 
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 98f75351a7..3cda5c5fc5 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -560,7 +560,7 @@ data TcGblEnv
                                              -- function, if this module is
                                              -- the main module.
 
-        tcg_safeInfer :: TcRef (Bool, WarningMessages),
+        tcg_safeInfer :: TcRef (Bool, Messages TcRnMessage),
         -- ^ 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.
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index a1f802b254..0637530942 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
@@ -48,6 +47,7 @@ import GHC.Unit.Module.ModDetails
 import GHC.Unit.Module.Imported
 import GHC.Unit.Module.Deps
 
+import GHC.Tc.Errors.Types
 import GHC.Tc.Gen.Export
 import GHC.Tc.Solver
 import GHC.Tc.TyCl.Utils
@@ -372,7 +372,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 +393,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 +931,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 b9991dfcdf..34a6ca2134 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -243,7 +243,7 @@ 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, emptyMessages) ;
         dfun_n_var   <- newIORef emptyOccSet ;
         type_env_var <- case hsc_type_env_var hsc_env of {
                            Just (_mod, te_var) -> return te_var ;
@@ -1980,7 +1980,7 @@ 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 :: Messages TcRnMessage -> TcM ()
 recordUnsafeInfer warns =
     getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
 
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 173a8e68cf..d249c7b88b 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