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

11 files changed, 436 insertions, 194 deletions

diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index b781685e91..30289129c4 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -31,6 +31,7 @@ import GHC.Driver.Main
 import GHC.Driver.Make
 import GHC.Driver.Env
 import GHC.Driver.Errors
+import GHC.Driver.Errors.Types
 
 import GHC.Parser
 import GHC.Parser.Header
@@ -107,7 +108,7 @@ doBackpack [src_filename] = do
     buf <- liftIO $ hGetStringBuffer src_filename
     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
     case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
-        PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
+        PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst))
         POk _ pkgname_bkp -> do
             -- OK, so we have an LHsUnit PackageName, but we want an
             -- LHsUnit HsComponentId.  So let's rename it.
@@ -808,9 +809,10 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
                          Nothing -- GHC API buffer support not supported
                          [] -- No exclusions
          case r of
-            Nothing -> throwOneError (mkPlainErrorMsgEnvelope loc
-                                     (text "module" <+> ppr modname <+> text "was not found"))
-            Just (Left err) -> throwErrors err
+            Nothing -> throwOneError $ mkPlainErrorMsgEnvelope loc $
+                                       GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $
+                                       (text "module" <+> ppr modname <+> text "was not found")
+            Just (Left err) -> throwErrors (fmap GhcDriverMessage err)
             Just (Right summary) -> return summary
 
 -- | Up until now, GHC has assumed a single compilation target per source file.
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 3fff8ab65c..219e66106b 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -50,6 +50,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
@@ -57,7 +58,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
@@ -69,7 +69,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 d1fc22314a..d672de33e6 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -4,12 +4,13 @@ module GHC.Driver.Env.Types
   , HscEnv(..)
   ) where
 
+import GHC.Driver.Errors.Types ( GhcMessage )
 import {-# SOURCE #-} GHC.Driver.Hooks
 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
@@ -25,8 +26,8 @@ import Control.Monad ( ap )
 import Control.Monad.IO.Class
 import Data.IORef
 
--- | The Hsc monad: Passing an environment and warning state
-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
+-- | The Hsc monad: Passing an environment and diagnostic state
+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 362282d1b9..7afb0f3b26 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,29 +1,25 @@
 module GHC.Driver.Errors (
     printOrThrowDiagnostics
-  , printBagOfErrors
+  , printMessages
   , handleFlagWarnings
-  , partitionMessageBag
+  , mkDriverPsHeaderMessage
   ) where
 
 import GHC.Driver.Session
+import GHC.Driver.Errors.Types
 import GHC.Data.Bag
-import GHC.Utils.Exception
-import GHC.Utils.Error ( formatBulleted, sortMsgBag, mkPlainMsgEnvelope )
-import GHC.Types.SourceError ( mkSrcErr )
 import GHC.Prelude
+import GHC.Parser.Errors ( PsError(..) )
 import GHC.Types.SrcLoc
+import GHC.Types.SourceError
 import GHC.Types.Error
+import GHC.Utils.Error
 import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )
 import GHC.Utils.Logger
 import qualified GHC.Driver.CmdLine as CmdLine
 
--- | Partitions the messages and returns a tuple which first element are the warnings, and the
--- second the errors.
-partitionMessageBag :: Diagnostic e => Bag (MsgEnvelope e) -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
-partitionMessageBag = partitionBag isWarningMessage
-
-printBagOfErrors :: Diagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
-printBagOfErrors logger dflags bag_of_errors
+printMessages :: Diagnostic a => Logger -> DynFlags -> Messages a -> IO ()
+printMessages logger dflags msgs
   = sequence_ [ let style = mkErrStyle unqual
                     ctx   = initSDocContext dflags style
                 in putLogMsg logger dflags (MCDiagnostic sev . diagnosticReason $ dia) s $
@@ -32,22 +28,35 @@ printBagOfErrors logger dflags bag_of_errors
                               errMsgDiagnostic = dia,
                               errMsgSeverity = sev,
                               errMsgContext   = unqual } <- sortMsgBag (Just dflags)
-                                                                       bag_of_errors ]
+                                                                       (getMessages msgs) ]
 
 handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()
 handleFlagWarnings logger dflags warns = do
   let -- It would be nicer if warns :: [Located SDoc], but that
       -- has circular import problems.
-      bag = listToBag [ mkPlainMsgEnvelope dflags reason loc (text warn)
+      bag = listToBag [ mkPlainMsgEnvelope dflags loc $
+                        GhcDriverMessage $
+                        DriverUnknownMessage $
+                        mkPlainDiagnostic reason $
+                        text warn
                       | CmdLine.Warn reason (L loc warn) <- warns ]
 
-  printOrThrowDiagnostics logger dflags bag
+  printOrThrowDiagnostics logger dflags (mkMessages bag)
 
 -- | 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 warns)
+printOrThrowDiagnostics :: Logger -> DynFlags -> Messages GhcMessage -> IO ()
+printOrThrowDiagnostics logger dflags msgs
+  | errorsOrFatalWarningsFound msgs
+  = throwErrors msgs
   | otherwise
-  = printBagOfErrors logger dflags warns
+  = printMessages logger dflags msgs
+
+-- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it
+-- for dealing with parse errors when the driver is doing dependency analysis.
+-- Defined here to avoid module loops between GHC.Driver.Error.Types and
+-- GHC.Driver.Error.Ppr
+mkDriverPsHeaderMessage :: PsError -> MsgEnvelope DriverMessage
+mkDriverPsHeaderMessage ps_err
+  = mkPlainErrorMsgEnvelope (errLoc ps_err) $
+    DriverPsHeaderMessage (errDesc ps_err) (errHints ps_err)
diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs
new file mode 100644
index 0000000000..06ebe0be96
--- /dev/null
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage}
+
+module GHC.Driver.Errors.Ppr where
+
+import GHC.Prelude
+
+import GHC.Types.Error
+import GHC.Driver.Errors.Types
+import GHC.Parser.Errors.Ppr
+import GHC.Tc.Errors.Ppr ()
+import GHC.HsToCore.Errors.Ppr ()
+
+instance Diagnostic GhcMessage where
+  diagnosticMessage = \case
+    GhcPsMessage m
+      -> diagnosticMessage m
+    GhcTcRnMessage m
+      -> diagnosticMessage m
+    GhcDsMessage m
+      -> diagnosticMessage m
+    GhcDriverMessage m
+      -> diagnosticMessage m
+    GhcUnknownMessage m
+      -> diagnosticMessage m
+
+  diagnosticReason = \case
+    GhcPsMessage m
+      -> diagnosticReason m
+    GhcTcRnMessage m
+      -> diagnosticReason m
+    GhcDsMessage m
+      -> diagnosticReason m
+    GhcDriverMessage m
+      -> diagnosticReason m
+    GhcUnknownMessage m
+      -> diagnosticReason m
+
+instance Diagnostic DriverMessage where
+  diagnosticMessage (DriverUnknownMessage m)  = diagnosticMessage m
+  diagnosticMessage (DriverPsHeaderMessage desc hints)
+    = mkSimpleDecorated $ pprPsError desc hints
+
+  diagnosticReason (DriverUnknownMessage m)   = diagnosticReason m
+  diagnosticReason (DriverPsHeaderMessage {}) = ErrorWithoutFlag
diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs
new file mode 100644
index 0000000000..017852fcbb
--- /dev/null
+++ b/compiler/GHC/Driver/Errors/Types.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE GADTs #-}
+
+module GHC.Driver.Errors.Types (
+    GhcMessage(..)
+  , DriverMessage(..), DriverMessages
+  , WarningMessages
+  , ErrorMessages
+  , WarnMsg
+  -- * Constructors
+  , ghcUnknownMessage
+  -- * Utility functions
+  , hoistTcRnMessage
+  , hoistDsMessage
+  , foldPsMessages
+  ) where
+
+import GHC.Prelude
+
+import Data.Typeable
+import GHC.Types.Error
+
+import GHC.Parser.Errors       ( PsErrorDesc, PsHint )
+import GHC.Parser.Errors.Types ( PsMessage )
+import GHC.Tc.Errors.Types     ( TcRnMessage )
+import GHC.HsToCore.Errors.Types ( DsMessage )
+import Data.Bifunctor
+
+-- | A collection of warning messages.
+-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity.
+type WarningMessages = Messages GhcMessage
+
+-- | A collection of error messages.
+-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevError' severity.
+type ErrorMessages   = Messages GhcMessage
+
+-- | A single warning message.
+-- /INVARIANT/: It must have 'SevWarning' severity.
+type WarnMsg         = MsgEnvelope GhcMessage
+
+
+{- Note [GhcMessage]
+~~~~~~~~~~~~~~~~~~~~
+
+We might need to report diagnostics (error and/or warnings) to the users. The
+'GhcMessage' type is the root of the diagnostic hierarchy.
+
+It's useful to have a separate type constructor for the different stages of
+the compilation pipeline. This is not just helpful for tools, as it gives a
+clear indication on where the error occurred exactly. Furthermore it increases
+the modularity amongst the different components of GHC (i.e. to avoid having
+"everything depend on everything else") and allows us to write separate
+functions that renders the different kind of messages.
+
+-}
+
+-- | The umbrella type that encompasses all the different messages that GHC
+-- might output during the different compilation stages. See
+-- Note [GhcMessage].
+data GhcMessage where
+  -- | A message from the parsing phase.
+  GhcPsMessage      :: PsMessage -> GhcMessage
+  -- | A message from typecheck/renaming phase.
+  GhcTcRnMessage    :: TcRnMessage -> GhcMessage
+  -- | A message from the desugaring (HsToCore) phase.
+  GhcDsMessage      :: DsMessage -> GhcMessage
+  -- | A message from the driver.
+  GhcDriverMessage  :: DriverMessage -> GhcMessage
+
+  -- | An \"escape\" hatch which can be used when we don't know the source of
+  -- the message or if the message is not one of the typed ones. The
+  -- 'Diagnostic' and 'Typeable' constraints ensure that if we /know/, at
+  -- pattern-matching time, the originating type, we can attempt a cast and
+  -- access the fully-structured error. This would be the case for a GHC
+  -- plugin that offers a domain-specific error type but that doesn't want to
+  -- place the burden on IDEs/application code to \"know\" it. The
+  -- 'Diagnostic' constraint ensures that worst case scenario we can still
+  -- render this into something which can be eventually converted into a
+  -- 'DecoratedSDoc'.
+  GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage
+
+-- | Creates a new 'GhcMessage' out of any diagnostic. This function is also
+-- provided to ease the integration of #18516 by allowing diagnostics to be
+-- wrapped into the general (but structured) 'GhcMessage' type, so that the
+-- conversion can happen gradually. This function should not be needed within
+-- GHC, as it would typically be used by plugin or library authors (see
+-- comment for the 'GhcUnknownMessage' type constructor)
+ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage
+ghcUnknownMessage = GhcUnknownMessage
+
+-- | Given a collection of @e@ wrapped in a 'Foldable' structure, converts it
+-- into 'Messages' via the supplied transformation function.
+foldPsMessages :: Foldable f
+               => (e -> MsgEnvelope PsMessage)
+               -> f e
+               -> Messages GhcMessage
+foldPsMessages f = foldMap (singleMessage . fmap GhcPsMessage . f)
+
+-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on
+-- the result of 'IO (Messages TcRnMessage, a)'.
+hoistTcRnMessage :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
+hoistTcRnMessage = fmap (first (fmap GhcTcRnMessage))
+
+-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on
+-- the result of 'IO (Messages DsMessage, a)'.
+hoistDsMessage :: Monad m => m (Messages DsMessage, a) -> m (Messages GhcMessage, a)
+hoistDsMessage = fmap (first (fmap GhcDsMessage))
+
+-- | A message from the driver.
+data DriverMessage
+  = DriverUnknownMessage !DiagnosticMessage
+  -- ^ Simply rewraps a generic 'DiagnosticMessage'. More
+  -- constructors will be added in the future (#18516).
+  | DriverPsHeaderMessage !PsErrorDesc ![PsHint]
+  -- ^ A parse error in parsing a Haskell file header during dependency
+  -- analysis
+
+-- | A collection of driver messages
+type DriverMessages = Messages DriverMessage
+
+-- | A message about Safe Haskell.
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index cac12cae50..c147733bb3 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -95,6 +95,7 @@ import GHC.Driver.Session
 import GHC.Driver.Backend
 import GHC.Driver.Env
 import GHC.Driver.Errors
+import GHC.Driver.Errors.Types
 import GHC.Driver.CodeOutput
 import GHC.Driver.Config
 import GHC.Driver.Hooks
@@ -144,6 +145,7 @@ 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
 
@@ -188,7 +190,8 @@ import GHC.Types.SourceError
 import GHC.Types.SafeHaskell
 import GHC.Types.ForeignStubs
 import GHC.Types.Var.Env       ( emptyTidyEnv )
-import GHC.Types.Error hiding ( getMessages )
+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
@@ -206,7 +209,6 @@ import GHC.Utils.Fingerprint ( Fingerprint )
 import GHC.Utils.Panic
 import GHC.Utils.Error
 import GHC.Utils.Outputable
-import GHC.Utils.Exception
 import GHC.Utils.Misc
 import GHC.Utils.Logger
 import GHC.Utils.TmpFs
@@ -265,14 +267,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)
@@ -281,32 +283,32 @@ 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
-        errs  = fmap mkParserErr errors
+    let warns = foldPsMessages (mkParserWarn dflags) warnings
+        errs  = foldPsMessages mkParserErr           errors
     logDiagnostics warns
-    when (not $ isEmptyBag errs) $ throwErrors errs
+    when (not $ isEmptyMessages errs) $ throwErrors errs
 
 -- | Log warnings and throw errors, assuming the messages
 -- contain at least one error (e.g. coming from PFailed)
 handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a
 handleWarningsThrowErrors (warnings, errors) = do
     dflags <- getDynFlags
-    let warns = fmap (mkParserWarn dflags) warnings
-        errs  = fmap mkParserErr           errors
+    let warns = foldPsMessages (mkParserWarn dflags) warnings
+        errs  = foldPsMessages mkParserErr           errors
     logDiagnostics warns
     logger <- getLogger
-    let (wWarns, wErrs) = partitionMessageBag warns
-    liftIO $ printBagOfErrors logger dflags wWarns
-    throwErrors (unionBags errs wErrs)
+    let (wWarns, wErrs) = partitionMessages warns
+    liftIO $ printMessages logger dflags wWarns
+    throwErrors $ errs `unionMessages` wErrs
 
 -- | Deal with errors and warnings returned by a compilation step
 --
@@ -324,21 +326,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
     case mb_r of
         Nothing -> throwErrors errs
-        Just r  -> ASSERT( isEmptyBag errs ) return r
+        Just r  -> ASSERT( isEmptyMessages 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
 
 -- -----------------------------------------------------------------------------
@@ -348,12 +350,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 $ hoistTcRnMessage $ 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' $ hoistTcRnMessage $ 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.
@@ -363,23 +365,23 @@ hscTcRnGetInfo :: HscEnv -> Name
 hscTcRnGetInfo hsc_env0 name
   = runInteractiveHsc hsc_env0 $
     do { hsc_env <- getHscEnv
-       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
+       ; ioMsgMaybe' $ hoistTcRnMessage $ 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 $ hoistTcRnMessage $ 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 $ hoistTcRnMessage $ 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 $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls
 
 -- -----------------------------------------------------------------------------
 -- | parse a file, returning the abstract syntax
@@ -417,7 +419,10 @@ hscParse' mod_summary
         PFailed pst ->
             handleWarningsThrowErrors (getMessages pst)
         POk pst rdr_module -> do
-            let (warns, errs) = bimap (fmap (mkParserWarn dflags)) (fmap mkParserErr) (getMessages pst)
+            let (warns, errs) =
+                  bimap (foldPsMessages (mkParserWarn dflags))
+                        (foldPsMessages mkParserErr)
+                        (getMessages pst)
             logDiagnostics warns
             liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"
                         FormatHaskell (ppr rdr_module)
@@ -427,7 +432,7 @@ hscParse' mod_summary
                                                    rdr_module)
             liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics"
                         FormatText (ppSourceStats False rdr_module)
-            when (not $ isEmptyBag errs) $ throwErrors errs
+            when (not $ isEmptyMessages errs) $ throwErrors errs
 
             -- To get the list of extra source files, we take the list
             -- that the parser gave us,
@@ -537,7 +542,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 $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
         else
          do hpm <- case mb_rdr_module of
                     Just hpm -> return hpm
@@ -545,7 +550,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 $ hoistTcRnMessage $
                             tcRnMergeSignatures hsc_env hpm tc_result0 iface
                 else return tc_result0
     -- TODO are we extracting anything when we merely instantiate a signature?
@@ -564,18 +569,20 @@ tcRnModule' sum save_rn_syntax mod = do
     -- -Wmissing-safe-haskell-mode
     when (not (safeHaskellModeEnabled dflags)
           && wopt Opt_WarnMissingSafeHaskellMode dflags) $
-        logDiagnostics $ unitBag $
-        mkPlainMsgEnvelope dflags reason (getLoc (hpm_module mod)) $
-        warnMissingSafeHaskellMode
+        logDiagnostics $ singleMessage $
+        mkPlainMsgEnvelope dflags (getLoc (hpm_module mod)) $
+        GhcDriverMessage $ DriverUnknownMessage $
+        mkPlainDiagnostic reason warnMissingSafeHaskellMode
 
     tcg_res <- {-# SCC "Typecheck-Rename" #-}
-               ioMsgMaybe $
+               ioMsgMaybe $ hoistTcRnMessage $
                    tcRnModule hsc_env sum
                      save_rn_syntax mod
 
     -- See Note [Safe Haskell Overlapping Instances Implementation]
     -- although this is used for more than just that failure case.
-    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
+    tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)
+    whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)
     let allSafeOK = safeInferred dflags && tcSafeOK
 
     -- end of the safe haskell line, how to respond to user?
@@ -587,20 +594,22 @@ tcRnModule' sum save_rn_syntax mod = do
       -- module (could be) safe, throw warning if needed
       else do
           tcg_res' <- hscCheckSafeImports tcg_res
-          safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
+          safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')
           when safe $
             case wopt Opt_WarnSafe dflags of
               True
                 | safeHaskell dflags == Sf_Safe -> return ()
-                | otherwise -> (logDiagnostics $ unitBag $
-                       mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnSafe)
-                                          (warnSafeOnLoc dflags) $
+                | otherwise -> (logDiagnostics $ singleMessage $
+                       mkPlainMsgEnvelope dflags (warnSafeOnLoc dflags) $
+                       GhcDriverMessage $ DriverUnknownMessage $
+                       mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) $
                        errSafe tcg_res')
               False | safeHaskell dflags == Sf_Trustworthy &&
                       wopt Opt_WarnTrustworthySafe dflags ->
-                      (logDiagnostics $ unitBag $
-                       mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnTrustworthySafe)
-                                          (trustworthyOnLoc dflags) $
+                      (logDiagnostics $ singleMessage $
+                       mkPlainMsgEnvelope dflags (trustworthyOnLoc dflags) $
+                       GhcDriverMessage $ DriverUnknownMessage $
+                       mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) $
                        errTwthySafe tcg_res')
               False -> return ()
           return tcg_res'
@@ -620,9 +629,9 @@ hscDesugar hsc_env mod_summary tc_result =
 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
+    r <- ioMsgMaybe $ hoistDsMessage $
+        {-# 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.
@@ -1177,7 +1186,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 GhcDriverMessage $ warns dflags (tcg_rules tcg_env')
               return tcg_env' { tcg_rules = [] }
           False
                 -- SafeInferred: user defined RULES, so not safe
@@ -1188,11 +1197,13 @@ 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 :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
     warnRules df (L loc (HsRule { rd_name = n })) =
-        mkPlainMsgEnvelope df WarningWithoutFlag (locA loc) $
+        mkPlainMsgEnvelope df (locA loc) $
+        DriverUnknownMessage $
+        mkPlainDiagnostic WarningWithoutFlag $
             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
 
@@ -1218,33 +1229,33 @@ 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 $ safeErrs
+          False -> 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
               False -> return tcg_env
@@ -1268,9 +1279,11 @@ checkSafeImports tcg_env
     cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
     cond' v1 v2
         | imv_is_safe v1 /= imv_is_safe v2
-        = throwOneError $ mkPlainErrorMsgEnvelope (imv_span v1)
-            (text "Module" <+> ppr (imv_name v1) <+>
-            (text $ "is imported both as a safe and unsafe import!"))
+        = throwOneError $
+            mkPlainErrorMsgEnvelope (imv_span v1) $
+            GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $
+              text "Module" <+> ppr (imv_name v1) <+>
+               (text $ "is imported both as a safe and unsafe import!")
         | otherwise
         = return v1
 
@@ -1299,15 +1312,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')
@@ -1336,9 +1349,11 @@ hscCheckSafe' m l = do
         iface <- lookup' m
         case iface of
             -- can't load iface to check trust!
-            Nothing -> throwOneError $ mkPlainErrorMsgEnvelope l
-                         $ text "Can't load the interface file for" <+> ppr m
-                           <> text ", to check that it can be safely imported"
+            Nothing -> throwOneError $
+                         mkPlainErrorMsgEnvelope l $
+                         GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $
+                           text "Can't load the interface file for" <+> ppr m
+                             <> text ", to check that it can be safely imported"
 
             -- got iface, check trust
             Just iface' ->
@@ -1355,10 +1370,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
@@ -1368,24 +1383,29 @@ hscCheckSafe' m l = do
 
                 where
                     state = hsc_units hsc_env
-                    inferredImportWarn dflags = unitBag
-                        $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports)
-                                             l (pkgQual state)
+                    inferredImportWarn dflags = singleMessage
+                        $ mkMsgEnvelope dflags l (pkgQual state)
+                        $ GhcDriverMessage $ DriverUnknownMessage
+                        $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports)
                         $ sep
                             [ text "Importing Safe-Inferred module "
                                 <> ppr (moduleName m)
                                 <> text " from explicitly Safe module"
                             ]
-                    pkgTrustErr = unitBag
-                      $ mkShortErrorMsgEnvelope l (pkgQual state)
+                    pkgTrustErr = singleMessage
+                      $ mkErrorMsgEnvelope l (pkgQual state)
+                      $ GhcDriverMessage $ DriverUnknownMessage
+                      $ mkPlainError
                       $ sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
                             , text "The package ("
                                 <> (pprWithUnitState state $ ppr (moduleUnit m))
                                 <> text ") the module resides in isn't trusted."
                             ]
-                    modTrustErr = unitBag
-                      $ mkShortErrorMsgEnvelope l (pkgQual state)
+                    modTrustErr = singleMessage
+                      $ mkErrorMsgEnvelope l (pkgQual state)
+                      $ GhcDriverMessage $ DriverUnknownMessage
+                      $ mkPlainError
                       $ sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
                             , text "The module itself isn't safe." ]
@@ -1425,20 +1445,24 @@ hscCheckSafe' m l = do
 checkPkgTrust :: Set UnitId -> Hsc ()
 checkPkgTrust pkgs = do
     hsc_env <- getHscEnv
-    let errors = S.foldr go [] pkgs
+    let errors = S.foldr go emptyBag pkgs
         state  = hsc_units hsc_env
         go pkg acc
             | unitIsTrusted $ unsafeLookupUnitId state pkg
             = acc
             | otherwise
-            = (:acc) $ mkShortErrorMsgEnvelope noSrcSpan (pkgQual state)
+            = (`consBag` acc)
+                     $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)
+                     $ GhcDriverMessage
+                     $ DriverUnknownMessage
+                     $ mkPlainError
                      $ pprWithUnitState state
                      $ text "The package ("
                         <> ppr pkg
                         <> text ") is required to be trusted but it isn't!"
-    case errors of
-        [] -> return ()
-        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
+    if isEmptyBag errors
+      then return ()
+      else liftIO $ throwErrors $ mkMessages errors
 
 -- | Set module to unsafe and (potentially) wipe trust information.
 --
@@ -1450,16 +1474,20 @@ 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 :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
 markUnsafeInfer tcg_env whyUnsafe = do
     dflags <- getDynFlags
 
     let reason = WarningWithFlag Opt_WarnUnsafe
     when (wopt Opt_WarnUnsafe dflags)
-         (logDiagnostics $ unitBag $
-             mkPlainMsgEnvelope dflags reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
-
-    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
+         (logDiagnostics $ singleMessage $
+             mkPlainMsgEnvelope dflags (warnUnsafeOnLoc dflags) $
+             GhcDriverMessage $ DriverUnknownMessage $
+             mkPlainDiagnostic reason $
+             whyUnsafe' dflags)
+
+    liftIO $ writeIORef (tcg_safe_infer tcg_env) False
+    liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages
     -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
     -- times inference may be on but we are in Trustworthy mode -- so we want
     -- to record safe-inference failed but not wipe the trust dependencies.
@@ -1473,7 +1501,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
@@ -1689,7 +1717,10 @@ 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 = foldPsMessages (mkParserWarn dflags) warns
+                             `unionMessages`
+                             foldPsMessages mkParserErr errs
+                  return (msgs, cmm)
     liftIO $ do
         dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
 
@@ -1889,10 +1920,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 $ hoistTcRnMessage $ tcRnStmt hsc_env stmt
 
   -- Desugar it
-  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
+  ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr
   liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
   handleWarnings
 
@@ -1936,7 +1967,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 $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls
 
     {- Grab the new instances -}
     -- We grab the whole environment because of the overlapping that may have
@@ -2051,6 +2082,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do
         [L _ i] -> return i
         _ -> liftIO $ throwOneError $
                  mkPlainErrorMsgEnvelope noSrcSpan $
+                 GhcPsMessage $ PsUnknownMessage $ mkPlainError $
                      text "parse error in import declaration"
 
 -- | Typecheck an expression (but don't run it)
@@ -2061,7 +2093,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 $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr
 
 -- | Find the kind of a type, after generalisation
 hscKcType
@@ -2072,15 +2104,17 @@ hscKcType
 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
     hsc_env <- getHscEnv
     ty <- hscParseType str
-    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty
+    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty
 
 hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
 hscParseExpr expr = do
   maybe_stmt <- hscParseStmt expr
   case maybe_stmt of
     Just (L _ (BodyStmt _ expr _ _)) -> return expr
-    _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan
-      (text "not an expression:" <+> quotes (text expr))
+    _ -> throwOneError $
+           mkPlainErrorMsgEnvelope noSrcSpan $
+           GhcPsMessage $ PsUnknownMessage $ mkPlainError $
+             text "not an expression:" <+> quotes (text expr)
 
 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
 hscParseStmt = hscParseThing parseStmt
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 484353ae4d..68245b42ca 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -61,16 +61,16 @@ import GHC.Driver.Backend
 import GHC.Driver.Monad
 import GHC.Driver.Env
 import GHC.Driver.Errors
+import GHC.Driver.Errors.Types
 import GHC.Driver.Main
 
 import GHC.Parser.Header
-import GHC.Parser.Errors.Ppr
 
 import GHC.Iface.Load      ( cannotFindModule )
 import GHC.IfaceToCore     ( typecheckIface )
 import GHC.Iface.Recomp    ( RecompileRequired ( MustCompile ) )
 
-import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )
+import GHC.Data.Bag        ( listToBag )
 import GHC.Data.Graph.Directed
 import GHC.Data.FastString
 import GHC.Data.Maybe      ( expectJust )
@@ -164,20 +164,20 @@ depanal :: GhcMonad m =>
         -> m ModuleGraph
 depanal excluded_mods allow_dup_roots = do
     (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots
-    if isEmptyBag errs
+    if isEmptyMessages errs
       then pure mod_graph
-      else throwErrors errs
+      else throwErrors (fmap GhcDriverMessage errs)
 
 -- | Perform dependency analysis like in 'depanal'.
 -- In case of errors, the errors and an empty module graph are returned.
 depanalE :: GhcMonad m =>     -- New for #17459
             [ModuleName]      -- ^ excluded modules
             -> Bool           -- ^ allow duplicate roots
-            -> m (ErrorMessages, ModuleGraph)
+            -> m (DriverMessages, ModuleGraph)
 depanalE excluded_mods allow_dup_roots = do
     hsc_env <- getSession
     (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots
-    if isEmptyBag errs
+    if isEmptyMessages errs
       then do
         warnMissingHomeModules hsc_env mod_graph
         setSession hsc_env { hsc_mod_graph = mod_graph }
@@ -202,7 +202,7 @@ depanalPartial
     :: GhcMonad m
     => [ModuleName]  -- ^ excluded modules
     -> Bool          -- ^ allow duplicate roots
-    -> m (ErrorMessages, ModuleGraph)
+    -> m (DriverMessages, ModuleGraph)
     -- ^ possibly empty 'Bag' of errors and a module graph.
 depanalPartial excluded_mods allow_dup_roots = do
   hsc_env <- getSession
@@ -230,7 +230,7 @@ depanalPartial excluded_mods allow_dup_roots = do
       (errs, mod_summaries) = partitionEithers mod_summariesE
       mod_graph = mkModuleGraph' $
         fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env)
-    return (unionManyBags errs, mod_graph)
+    return (unionManyMessages errs, mod_graph)
 
 -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.
 -- These are used to represent the type checking that is done after
@@ -271,7 +271,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)
@@ -318,8 +318,10 @@ warnMissingHomeModules hsc_env mod_graph =
           (text "Modules are not listed in command line but needed for compilation: ")
           4
           (sep (map ppr missing))
-    warn =
-      mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
+    warn = singleMessage $
+      mkPlainMsgEnvelope (hsc_dflags hsc_env) noSrcSpan $
+      GhcDriverMessage $ DriverUnknownMessage $
+      mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingHomeModules) msg
 
 -- | Describes which modules of the module graph need to be loaded.
 data LoadHowMuch
@@ -351,9 +353,9 @@ load how_much = do
     (errs, mod_graph) <- depanalE [] False                        -- #17459
     success <- load' how_much (Just batchMsg) mod_graph
     warnUnusedPackages
-    if isEmptyBag errs
+    if isEmptyMessages errs
       then pure success
-      else throwErrors errs
+      else throwErrors (fmap GhcDriverMessage errs)
 
 -- Note [Unused packages]
 --
@@ -384,15 +386,17 @@ warnUnusedPackages = do
           = filter (\arg -> not $ any (matching state arg) loadedPackages)
                    requestedArgs
 
-    let warn =
-          mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg
+    let warn = singleMessage $
+          mkPlainMsgEnvelope dflags noSrcSpan $
+          GhcDriverMessage $ DriverUnknownMessage $
+          mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedPackages) msg
         msg = vcat [ text "The following packages were specified" <+>
                      text "via -package or -package-id flags,"
                    , text "but were not needed for compilation:"
                    , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]
 
     when (not (null unusedArgs)) $
-      logWarnings (listToBag [warn])
+      logDiagnostics warn
 
     where
         packageArg (ExposePackage _ arg _) = Just arg
@@ -1419,7 +1423,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags
         hsc_env <- readMVar hsc_env_var
         old_hpt <- readIORef old_hpt_var
 
-        let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err)
+        let logg err = printMessages lcl_logger lcl_dflags (srcErrorMessages err)
 
         -- Limit the number of parallel compiles.
         let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)
@@ -1671,7 +1675,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 $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid
         pure ()
 
 -- | Compile a single module.  Always produce a Linkable for it if
@@ -2214,17 +2218,18 @@ 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 :: DynFlags -> Located ModuleName -> MsgEnvelope GhcMessage
         warn dflags (L loc mod) =
-           mkPlainMsgEnvelope dflags WarningWithoutFlag loc
-                (text "{-# SOURCE #-} unnecessary in import of "
-                 <+> quotes (ppr mod))
+           mkPlainMsgEnvelope dflags loc $
+           GhcDriverMessage $ DriverUnknownMessage $
+           mkPlainDiagnostic WarningWithoutFlag $
+           text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)
 
 
 -----------------------------------------------------------------------------
@@ -2250,7 +2255,7 @@ downsweep :: HscEnv
           -> Bool               -- True <=> allow multiple targets to have
                                 --          the same module name; this is
                                 --          very useful for ghc -M
-          -> IO [Either ErrorMessages ExtendedModSummary]
+          -> IO [Either DriverMessages ExtendedModSummary]
                 -- The non-error elements of the returned list all have distinct
                 -- (Modules, IsBoot) identifiers, unless the Bool is true in
                 -- which case there can be repeats
@@ -2286,7 +2291,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
         old_summary_map :: ModNodeMap ExtendedModSummary
         old_summary_map = mkNodeMap old_summaries
 
-        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)
+        getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary)
         getRootSummary Target { targetId = TargetFile file mb_phase
                               , targetAllowObjCode = obj_allowed
                               , targetContents = maybe_buf
@@ -2295,8 +2300,10 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
                 if exists || isJust maybe_buf
                     then summariseFile hsc_env old_summaries file mb_phase
                                        obj_allowed maybe_buf
-                    else return $ Left $ unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $
-                           text "can't find file:" <+> text file
+                    else return $ Left $ singleMessage $
+                           mkPlainErrorMsgEnvelope noSrcSpan $
+                           DriverUnknownMessage $ mkPlainError $
+                             text "can't find file:" <+> text file
         getRootSummary Target { targetId = TargetModule modl
                               , targetAllowObjCode = obj_allowed
                               , targetContents = maybe_buf
@@ -2316,7 +2323,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
         -- ignored, leading to confusing behaviour).
         checkDuplicates
           :: ModNodeMap
-               [Either ErrorMessages
+               [Either DriverMessages
                        ExtendedModSummary]
           -> IO ()
         checkDuplicates root_map
@@ -2329,11 +2336,11 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
 
         loop :: [GenWithIsBoot (Located ModuleName)]
                         -- Work list: process these modules
-             -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
+             -> ModNodeMap [Either DriverMessages ExtendedModSummary]
                         -- Visited set; the range is a list because
                         -- the roots can have the same module names
                         -- if allow_dup_roots is True
-             -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
+             -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
                         -- The result is the completed NodeMap
         loop [] done = return done
         loop (s : ss) done
@@ -2373,8 +2380,8 @@ enableCodeGenForTH
   -> TmpFs
   -> HomeUnit
   -> Backend
-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
+  -> ModNodeMap [Either DriverMessages ExtendedModSummary]
+  -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
 enableCodeGenForTH logger tmpfs home_unit =
   enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession
   where
@@ -2399,8 +2406,8 @@ enableCodeGenWhen
   -> TempFileLifetime
   -> TempFileLifetime
   -> Backend
-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
+  -> ModNodeMap [Either DriverMessages ExtendedModSummary]
+  -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
 enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap =
   traverse (traverse (traverse enable_code_gen)) nodemap
   where
@@ -2469,7 +2476,7 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd
 
 mkRootMap
   :: [ExtendedModSummary]
-  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
+  -> ModNodeMap [Either DriverMessages ExtendedModSummary]
 mkRootMap summaries = ModNodeMap $ Map.insertListWith
   (flip (++))
   [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]
@@ -2514,7 +2521,7 @@ summariseFile
         -> Maybe Phase                  -- start phase
         -> Bool                         -- object code allowed?
         -> Maybe (StringBuffer,UTCTime)
-        -> IO (Either ErrorMessages ExtendedModSummary)
+        -> IO (Either DriverMessages ExtendedModSummary)
 
 summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf
         -- we can use a cached summary if one is available and the
@@ -2642,7 +2649,7 @@ summariseModule
           -> Bool               -- object code allowed?
           -> Maybe (StringBuffer, UTCTime)
           -> [ModuleName]               -- Modules to exclude
-          -> IO (Maybe (Either ErrorMessages ExtendedModSummary))      -- Its new summary
+          -> IO (Maybe (Either DriverMessages ExtendedModSummary))      -- Its new summary
 
 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                 obj_allowed maybe_buf excl_mods
@@ -2730,7 +2737,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
               | otherwise = HsSrcFile
 
         when (pi_mod_name /= wanted_mod) $
-                throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $
+                throwE $ singleMessage $
+                  mkPlainErrorMsgEnvelope pi_mod_name_loc $
+                  DriverUnknownMessage $ mkPlainError $
                               text "File name does not match module name:"
                               $$ text "Saw:" <+> quotes (ppr pi_mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -2742,7 +2751,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                         | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)
                                 : homeUnitInstantiations home_unit)
                         ])
-            in throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $
+            in throwE $ singleMessage $
+                mkPlainErrorMsgEnvelope pi_mod_name_loc $
+                DriverUnknownMessage $ mkPlainError $
                 text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
                 $$ if gopt Opt_BuildingCabalPackage dflags
                     then parens (text "Try adding" <+> quotes (ppr pi_mod_name)
@@ -2845,7 +2856,7 @@ getPreprocessedImports
     -> Maybe Phase
     -> Maybe (StringBuffer, UTCTime)
     -- ^ optional source code buffer and modification time
-    -> ExceptT ErrorMessages IO PreprocessedImports
+    -> ExceptT DriverMessages IO PreprocessedImports
 getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
   (pi_local_dflags, pi_hspp_fn)
       <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
@@ -2855,7 +2866,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
           let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags
               popts = initParserOpts pi_local_dflags
           mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
-          return (first (fmap mkParserErr) mimps)
+          return (first (mkMessages . fmap mkDriverPsHeaderMessage) mimps)
   return PreprocessedImports {..}
 
 
@@ -2899,24 +2910,30 @@ withDeferredDiagnostics f = do
       (\_ -> popLogHookM >> printDeferredDiagnostics)
       (\_ -> f)
 
-noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DiagnosticMessage
+noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
 -- ToDo: we don't have a proper line number for this error
 noModError hsc_env loc wanted_mod err
-  = mkPlainErrorMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err
+  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $
+    cannotFindModule hsc_env wanted_mod err
 
-noHsFileErr :: SrcSpan -> String -> ErrorMessages
+noHsFileErr :: SrcSpan -> String -> DriverMessages
 noHsFileErr loc path
-  = unitBag $ mkPlainErrorMsgEnvelope loc $ text "Can't find" <+> text path
+  = singleMessage $ mkPlainErrorMsgEnvelope loc $
+    DriverUnknownMessage $ mkPlainError $
+    text "Can't find" <+> text path
 
-moduleNotFoundErr :: ModuleName -> ErrorMessages
+moduleNotFoundErr :: ModuleName -> DriverMessages
 moduleNotFoundErr mod
-  = unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $
+  = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan $
+    DriverUnknownMessage $ mkPlainError $
         text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
 
 multiRootsErr :: [ModSummary] -> IO ()
 multiRootsErr [] = panic "multiRootsErr"
 multiRootsErr summs@(summ1:_)
-  = throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $
+  = throwOneError $
+      mkPlainErrorMsgEnvelope noSrcSpan $
+      GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $
         text "module" <+> quotes (ppr mod) <+>
         text "is defined in multiple files:" <+>
         sep (map text files)
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index ea1bf1f501..6acc547202 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -23,6 +23,7 @@ import GHC.Driver.Session
 import GHC.Driver.Ppr
 import GHC.Utils.Misc
 import GHC.Driver.Env
+import GHC.Driver.Errors.Types
 import qualified GHC.SysTools as SysTools
 import GHC.Data.Graph.Directed ( SCC(..) )
 import GHC.Utils.Outputable
@@ -305,7 +306,9 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
         -> return Nothing
 
     fail ->
-        throwOneError $ mkPlainErrorMsgEnvelope srcloc $
+        throwOneError $
+          mkPlainErrorMsgEnvelope srcloc $
+          GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $
              cannotFindModule hsc_env imp fail
 
 -----------------------------
@@ -454,4 +457,3 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
 depStartMarker, depEndMarker :: String
 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
-
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 1a42d8402f..2fa3c51cc1 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -27,8 +27,8 @@ module GHC.Driver.Monad (
         putMsgM,
         withTimingM,
 
-        -- ** Warnings
-        logWarnings, printException,
+        -- ** Diagnostics
+        logDiagnostics, printException,
         WarnErrLogger, defaultWarnErrLogger
   ) where
 
@@ -36,7 +36,8 @@ import GHC.Prelude
 
 import GHC.Driver.Session
 import GHC.Driver.Env
-import GHC.Driver.Errors ( printOrThrowDiagnostics, printBagOfErrors )
+import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages )
+import GHC.Driver.Errors.Types
 
 import GHC.Utils.Monad
 import GHC.Utils.Exception
@@ -141,10 +142,10 @@ 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 warns = do
   dflags <- getSessionDynFlags
   logger <- getLogger
   liftIO $ printOrThrowDiagnostics logger dflags warns
@@ -240,13 +241,13 @@ instance ExceptionMonad m => GhcMonad (GhcT m) where
   setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
 
 
--- | Print the error message and all warnings.  Useful inside exception
---   handlers.  Clears warnings after printing.
+-- | Print the all diagnostics in a 'SourceError'.  Useful inside exception
+--   handlers.
 printException :: GhcMonad m => SourceError -> m ()
 printException err = do
   dflags <- getSessionDynFlags
   logger <- getLogger
-  liftIO $ printBagOfErrors logger dflags (srcErrorMessages err)
+  liftIO $ printMessages logger dflags (srcErrorMessages err)
 
 -- | A function called to log warnings and errors.
 type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()
@@ -254,4 +255,3 @@ type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()
 defaultWarnErrLogger :: WarnErrLogger
 defaultWarnErrLogger Nothing  = return ()
 defaultWarnErrLogger (Just e) = printException e
-
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 8589b81ee5..5496fe31a2 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -47,6 +47,7 @@ import GHC.Tc.Types
 import GHC.Driver.Main
 import GHC.Driver.Env hiding ( Hsc )
 import GHC.Driver.Errors
+import GHC.Driver.Errors.Types
 import GHC.Driver.Pipeline.Monad
 import GHC.Driver.Config
 import GHC.Driver.Phases
@@ -81,7 +82,6 @@ import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Settings
 
-import GHC.Data.Bag            ( unitBag )
 import GHC.Data.FastString     ( mkFastString )
 import GHC.Data.StringBuffer   ( hGetStringBuffer, hPutStringBuffer )
 import GHC.Data.Maybe          ( expectJust )
@@ -89,6 +89,7 @@ import GHC.Data.Maybe          ( expectJust )
 import GHC.Iface.Make          ( mkFullIface )
 
 import GHC.Types.Basic       ( SuccessFlag(..) )
+import GHC.Types.Error       ( singleMessage, getMessages )
 import GHC.Types.Target
 import GHC.Types.SrcLoc
 import GHC.Types.SourceFile
@@ -130,9 +131,9 @@ preprocess :: HscEnv
            -> Maybe InputFileBuffer
            -- ^ optional buffer to use instead of reading the input file
            -> Maybe Phase -- ^ starting phase
-           -> IO (Either ErrorMessages (DynFlags, FilePath))
+           -> IO (Either DriverMessages (DynFlags, FilePath))
 preprocess hsc_env input_fn mb_input_buf mb_phase =
-  handleSourceError (\err -> return (Left (srcErrorMessages err))) $
+  handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $
   MC.handle handler $
   fmap Right $ do
   MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
@@ -148,10 +149,21 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
   return (dflags, fp)
   where
     srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
-    handler (ProgramError msg) = return $ Left $ unitBag $
-        mkPlainErrorMsgEnvelope srcspan $ text msg
+    handler (ProgramError msg) =
+      return $ Left $ singleMessage $
+        mkPlainErrorMsgEnvelope srcspan $
+        DriverUnknownMessage $ mkPlainError $ text msg
     handler ex = throwGhcExceptionIO ex
 
+    to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
+    to_driver_messages msgs = case traverse to_driver_message msgs of
+      Nothing    -> pprPanic "non-driver message in preprocess"
+                             (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))
+      Just msgs' -> msgs'
+
+    to_driver_message (GhcDriverMessage msg) = Just msg
+    to_driver_message _other                 = Nothing
+
 -- ---------------------------------------------------------------------------
 
 -- | Compile
@@ -1259,7 +1271,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn
                 popts = initParserOpts dflags
             eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
             case eimps of
-              Left errs -> throwErrors (fmap mkParserErr errs)
+              Left errs -> throwErrors (foldPsMessages mkParserErr errs)
               Right (src_imps,imps,L _ mod_name) -> return
                   (Just buf, mod_name, imps, src_imps)