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

2 files changed, 192 insertions, 108 deletions

diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index e995ad8a4b..0ec3e8756c 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -1,20 +1,21 @@
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 
 module GHC.Types.Error
    ( -- * Messages
      Messages
-   , WarningMessages
-   , ErrorMessages
    , mkMessages
    , getMessages
    , emptyMessages
    , isEmptyMessages
+   , singleMessage
    , addMessage
    , unionMessages
+   , unionManyMessages
    , MsgEnvelope (..)
-   , WarnMsg
 
    -- * Classifying Messages
 
@@ -23,23 +24,31 @@ module GHC.Types.Error
    , Diagnostic (..)
    , DiagnosticMessage (..)
    , DiagnosticReason (..)
+   , mkDiagnosticMessage
+   , mkPlainDiagnostic
+   , mkPlainError
+   , mkDecoratedDiagnostic
+   , mkDecoratedError
 
     -- * Rendering Messages
 
    , SDoc
    , DecoratedSDoc (unDecorated)
+   , mkDecorated, mkSimpleDecorated
+
    , pprMessageBag
-   , mkDecorated
    , mkLocMessage
    , mkLocMessageAnn
    , getCaretDiagnostic
    -- * Queries
    , isIntrinsicErrorMessage
+   , isExtrinsicErrorMessage
    , isWarningMessage
    , getErrorMessages
    , getWarningMessages
    , partitionMessages
    , errorsFound
+   , errorsOrFatalWarningsFound
    )
 where
 
@@ -56,46 +65,62 @@ import GHC.Data.FastString (unpackFS)
 import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
 import GHC.Utils.Json
 
+import Data.Bifunctor
+import Data.Foldable    ( fold )
+
 {-
 Note [Messages]
 ~~~~~~~~~~~~~~~
 
 We represent the 'Messages' as a single bag of warnings and errors.
 
-The reason behind that is that there is a fluid relationship between errors and warnings and we want to
-be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors
-or -XPartialTypeSignatures). More specifically, every diagnostic has a 'DiagnosticReason', but a warning
-'DiagnosticReason' might be associated with 'SevError', in the case of -Werror.
+The reason behind that is that there is a fluid relationship between errors
+and warnings and we want to be able to promote or demote errors and warnings
+based on certain flags (e.g. -Werror, -fdefer-type-errors or
+-XPartialTypeSignatures). More specifically, every diagnostic has a
+'DiagnosticReason', but a warning 'DiagnosticReason' might be associated with
+'SevError', in the case of -Werror.
 
 We rely on the 'Severity' to distinguish between a warning and an error.
 
-'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but
-in future iterations these can be either parameterised over an 'e' message type (to make type signatures
-a bit more declarative) or removed altogether.
+'WarningMessages' and 'ErrorMessages' are for now simple type aliases to
+retain backward compatibility, but in future iterations these can be either
+parameterised over an 'e' message type (to make type signatures a bit more
+declarative) or removed altogether.
 -}
 
--- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically
--- a warning or an error. See Note [Messages].
+-- | A collection of messages emitted by GHC during error reporting. A
+-- diagnostic message is typically a warning or an error. See Note [Messages].
+--
+-- /INVARIANT/: All the messages in this collection must be relevant, i.e.
+-- their 'Severity' should /not/ be 'SevIgnore'. The smart constructor
+-- 'mkMessages' will filter out any message which 'Severity' is 'SevIgnore'.
 newtype Messages e = Messages { getMessages :: Bag (MsgEnvelope e) }
-
-instance Functor Messages where
-  fmap f (Messages xs) = Messages (mapBag (fmap f) xs)
+  deriving newtype (Semigroup, Monoid)
+  deriving stock (Functor, Foldable, Traversable)
 
 emptyMessages :: Messages e
 emptyMessages = Messages emptyBag
 
 mkMessages :: Bag (MsgEnvelope e) -> Messages e
-mkMessages = Messages
+mkMessages = Messages . filterBag interesting
+  where
+    interesting :: MsgEnvelope e -> Bool
+    interesting = (/=) SevIgnore . errMsgSeverity
 
 isEmptyMessages :: Messages e -> Bool
 isEmptyMessages (Messages msgs) = isEmptyBag msgs
 
+singleMessage :: MsgEnvelope e -> Messages e
+singleMessage e = addMessage e emptyMessages
+
 {- Note [Discarding Messages]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is
-just an optimisation, as GHC would /also/ suppress any diagnostic which severity is
-'SevIgnore' before printing the message: See for example 'putLogMsg' and 'defaultLogAction'.
+Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is just
+an optimisation, as GHC would /also/ suppress any diagnostic which severity is
+'SevIgnore' before printing the message: See for example 'putLogMsg' and
+'defaultLogAction'.
 
 -}
 
@@ -110,36 +135,38 @@ addMessage x (Messages xs)
 -- See Note [Discarding Messages].
 unionMessages :: Messages e -> Messages e -> Messages e
 unionMessages (Messages msgs1) (Messages msgs2) =
-  Messages (filterBag interesting $ msgs1 `unionBags` msgs2)
-  where
-    interesting :: MsgEnvelope e -> Bool
-    interesting = (/=) SevIgnore . errMsgSeverity
+  Messages (msgs1 `unionBags` msgs2)
 
-type WarningMessages = Bag (MsgEnvelope DiagnosticMessage)
-type ErrorMessages   = Bag (MsgEnvelope DiagnosticMessage)
+-- | Joins many 'Messages's together
+unionManyMessages :: Foldable f => f (Messages e) -> Messages e
+unionManyMessages = fold
 
-type WarnMsg         = MsgEnvelope DiagnosticMessage
-
--- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]'
--- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets
--- between each elements of the list.
--- The type of decoration depends on the formatting function used, but in practice GHC uses the
--- 'formatBulleted'.
+-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the
+-- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its
+-- final form, where the typical case would be adding bullets between each
+-- elements of the list. The type of decoration depends on the formatting
+-- function used, but in practice GHC uses the 'formatBulleted'.
 newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] }
 
 -- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'.
 mkDecorated :: [SDoc] -> DecoratedSDoc
 mkDecorated = Decorated
 
+-- | Creates a new 'DecoratedSDoc' out of a single 'SDoc'
+mkSimpleDecorated :: SDoc -> DecoratedSDoc
+mkSimpleDecorated doc = Decorated [doc]
+
 {-
 Note [Rendering Messages]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 
-Turning 'Messages' into something that renders nicely for the user is one of the last steps, and it
-happens typically at the application's boundaries (i.e. from the 'Driver' upwards).
+Turning 'Messages' into something that renders nicely for the user is one of
+the last steps, and it happens typically at the application's boundaries (i.e.
+from the 'Driver' upwards).
 
-For now (see #18516) this class has few instance, but the idea is that as
-the more domain-specific types are defined, the more instances we would get. For example, given something like:
+For now (see #18516) this class has few instance, but the idea is that as the
+more domain-specific types are defined, the more instances we would get. For
+example, given something like:
 
   data TcRnDiagnostic
     = TcRnOutOfScope ..
@@ -147,36 +174,40 @@ the more domain-specific types are defined, the more instances we would get. For
 
   newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic)
 
-We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather than scattering pieces of
-'SDoc' around the codebase, we would write once for all:
+We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather
+than scattering pieces of 'SDoc' around the codebase, we would write once for
+all:
 
   instance Diagnostic TcRnDiagnostic where
     diagnosticMessage (TcRnMessage msg) = case diagMessage msg of
       TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."]
       ...
 
-This way, we can easily write generic rendering functions for errors that all they care about is the
-knowledge that a given type 'e' has a 'Diagnostic' constraint.
+This way, we can easily write generic rendering functions for errors that all
+they care about is the knowledge that a given type 'e' has a 'Diagnostic'
+constraint.
 
 -}
 
 -- | A class identifying a diagnostic.
 -- Dictionary.com defines a diagnostic as:
 --
--- \"a message output by a computer diagnosing an error in a computer program, computer system,
--- or component device\".
+-- \"a message output by a computer diagnosing an error in a computer program,
+-- computer system, or component device\".
 --
--- A 'Diagnostic' carries the /actual/ description of the message (which, in GHC's case, it can be
--- an error or a warning) and the /reason/ why such message was generated in the first place.
--- See also Note [Rendering Messages].
+-- A 'Diagnostic' carries the /actual/ description of the message (which, in
+-- GHC's case, it can be an error or a warning) and the /reason/ why such
+-- message was generated in the first place. See also Note [Rendering
+-- Messages].
 class Diagnostic a where
   diagnosticMessage :: a -> DecoratedSDoc
   diagnosticReason  :: a -> DiagnosticReason
 
--- | A generic 'Diagnostic' message, without any further classification or provenance:
--- By looking at a 'DiagnosticMessage' we don't know neither /where/ it was generated nor how to
--- intepret its payload (as it's just a structured document). All we can do is to print it out and
--- look at its 'DiagnosticReason'.
+-- | A generic 'Diagnostic' message, without any further classification or
+-- provenance: By looking at a 'DiagnosticMessage' we don't know neither
+-- /where/ it was generated nor how to intepret its payload (as it's just a
+-- structured document). All we can do is to print it out and look at its
+-- 'DiagnosticReason'.
 data DiagnosticMessage = DiagnosticMessage
   { diagMessage :: !DecoratedSDoc
   , diagReason  :: !DiagnosticReason
@@ -186,13 +217,34 @@ instance Diagnostic DiagnosticMessage where
   diagnosticMessage = diagMessage
   diagnosticReason  = diagReason
 
--- | The reason /why/ a 'Diagnostic' was emitted in the first place. Diagnostic messages
--- are born within GHC with a very precise reason, which can be completely statically-computed
--- (i.e. this is an error or a warning no matter what), or influenced by the specific state
--- of the 'DynFlags' at the moment of the creation of a new 'Diagnostic'. For example, a parsing
--- error is /always/ going to be an error, whereas a 'WarningWithoutFlag Opt_WarnUnusedImports' might turn
--- into an error due to '-Werror' or '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason'
--- together with its associated 'Severity' gives us the full picture.
+-- | Create a 'DiagnosticMessage' with a 'DiagnosticReason'
+mkDiagnosticMessage :: DecoratedSDoc -> DiagnosticReason -> DiagnosticMessage
+mkDiagnosticMessage = DiagnosticMessage
+
+mkPlainDiagnostic :: DiagnosticReason -> SDoc -> DiagnosticMessage
+mkPlainDiagnostic rea doc = DiagnosticMessage (mkSimpleDecorated doc) rea
+
+-- | Create an error 'DiagnosticMessage' holding just a single 'SDoc'
+mkPlainError :: SDoc -> DiagnosticMessage
+mkPlainError doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag
+
+-- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason'
+mkDecoratedDiagnostic :: DiagnosticReason -> [SDoc] -> DiagnosticMessage
+mkDecoratedDiagnostic rea docs = DiagnosticMessage (mkDecorated docs) rea
+
+-- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs
+mkDecoratedError :: [SDoc] -> DiagnosticMessage
+mkDecoratedError docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag
+
+-- | The reason /why/ a 'Diagnostic' was emitted in the first place.
+-- Diagnostic messages are born within GHC with a very precise reason, which
+-- can be completely statically-computed (i.e. this is an error or a warning
+-- no matter what), or influenced by the specific state of the 'DynFlags' at
+-- the moment of the creation of a new 'Diagnostic'. For example, a parsing
+-- error is /always/ going to be an error, whereas a 'WarningWithoutFlag
+-- Opt_WarnUnusedImports' might turn into an error due to '-Werror' or
+-- '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' together
+-- with its associated 'Severity' gives us the full picture.
 data DiagnosticReason
   = WarningWithoutFlag
   -- ^ Born as a warning.
@@ -211,19 +263,22 @@ instance Outputable DiagnosticReason where
 -- | An envelope for GHC's facts about a running program, parameterised over the
 -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.
 --
--- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped
--- into a 'MsgEnvelope' that carries specific information like where the error happened, etc.
--- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user.
+-- To say things differently, GHC emits /diagnostics/ about the running
+-- program, each of which is wrapped into a 'MsgEnvelope' that carries
+-- specific information like where the error happened, etc. Finally, multiple
+-- 'MsgEnvelope's are aggregated into 'Messages' that are returned to the
+-- user.
 data MsgEnvelope e = MsgEnvelope
    { errMsgSpan        :: SrcSpan
       -- ^ The SrcSpan is used for sorting errors into line-number order
    , errMsgContext     :: PrintUnqualified
    , errMsgDiagnostic  :: e
    , errMsgSeverity    :: Severity
-   } deriving Functor
+   } deriving (Functor, Foldable, Traversable)
 
--- | The class for a diagnostic message. The main purpose is to classify a message within GHC,
--- to distinguish it from a debug/dump message vs a proper diagnostic, for which we include a 'DiagnosticReason'.
+-- | The class for a diagnostic message. The main purpose is to classify a
+-- message within GHC, to distinguish it from a debug/dump message vs a proper
+-- diagnostic, for which we include a 'DiagnosticReason'.
 data MessageClass
   = MCOutput
   | MCFatal
@@ -238,33 +293,37 @@ data MessageClass
     -- No file\/line\/column stuff.
 
   | MCDiagnostic Severity DiagnosticReason
-    -- ^ Diagnostics from the compiler. This constructor
-    -- is very powerful as it allows the construction
-    -- of a 'MessageClass' with a completely arbitrary
-    -- permutation of 'Severity' and 'DiagnosticReason'. As such,
-    -- users are encouraged to use the 'mkMCDiagnostic' smart constructor instead.
-    -- Use this constructor directly only if you need to construct and manipulate diagnostic
-    -- messages directly, for example inside 'GHC.Utils.Error'. In all the other circumstances,
-    -- /especially/ when emitting compiler diagnostics, use the smart constructor.
+    -- ^ Diagnostics from the compiler. This constructor is very powerful as
+    -- it allows the construction of a 'MessageClass' with a completely
+    -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
+    -- users are encouraged to use the 'mkMCDiagnostic' smart constructor
+    -- instead. Use this constructor directly only if you need to construct
+    -- and manipulate diagnostic messages directly, for example inside
+    -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when
+    -- emitting compiler diagnostics, use the smart constructor.
   deriving (Eq, Show)
 
 {- Note [Suppressing Messages]
 
-The 'SevIgnore' constructor is used to generate messages for diagnostics which are
-meant to be suppressed and not reported to the user: the classic example are warnings
-for which the user didn't enable the corresponding 'WarningFlag', so GHC shouldn't print them.
+The 'SevIgnore' constructor is used to generate messages for diagnostics which
+are meant to be suppressed and not reported to the user: the classic example
+are warnings for which the user didn't enable the corresponding 'WarningFlag',
+so GHC shouldn't print them.
 
-A different approach would be to extend the zoo of 'mkMsgEnvelope' functions to return
-a 'Maybe (MsgEnvelope e)', so that we won't need to even create the message to begin with.
-Both approaches have been evaluated, but we settled on the "SevIgnore one" for a number of reasons:
+A different approach would be to extend the zoo of 'mkMsgEnvelope' functions
+to return a 'Maybe (MsgEnvelope e)', so that we won't need to even create the
+message to begin with. Both approaches have been evaluated, but we settled on
+the "SevIgnore one" for a number of reasons:
 
 * It's less invasive to deal with;
-* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as for those we need
-  to be able to /always/ produce a message (so that is reported at runtime);
-* It gives us more freedom: we can still decide to drop a 'SevIgnore' message at leisure, or we can
-  decide to keep it around until the last moment. Maybe in the future we would need to
-  turn a 'SevIgnore' into something else, for example to "unsuppress" diagnostics if a flag is
-  set: with this approach, we have more leeway to accommodate new features.
+* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as
+  for those we need to be able to /always/ produce a message (so that is
+  reported at runtime);
+* It gives us more freedom: we can still decide to drop a 'SevIgnore' message
+  at leisure, or we can decide to keep it around until the last moment. Maybe
+  in the future we would need to turn a 'SevIgnore' into something else, for
+  example to "unsuppress" diagnostics if a flag is set: with this approach, we
+  have more leeway to accommodate new features.
 
 -}
 
@@ -446,36 +505,49 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) =
 {- Note [Intrinsic And Extrinsic Failures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in the former category
-those diagnostics which are /essentially/ failures, and their nature can't be changed. This is
-the case for 'ErrorWithoutFlag'. We classify as /extrinsic/ all those diagnostics (like fatal warnings)
-which are born as warnings but which are still failures under particular 'DynFlags' settings. It's important
-to be aware of such logic distinction, because when we are inside the typechecker or the desugarer, we are
-interested about intrinsic errors, and to bail out as soon as we find one of them. Conversely, if we find
-an /extrinsic/ one, for example because a particular 'WarningFlag' makes a warning and error, we /don't/
-want to bail out, that's still not the right time to do so: Rather, we want to first collect all the
-diagnostics, and later classify and report them appropriately (in the driver).
-
+We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in
+the former category those diagnostics which are /essentially/ failures, and
+their nature can't be changed. This is the case for 'ErrorWithoutFlag'. We
+classify as /extrinsic/ all those diagnostics (like fatal warnings) which are
+born as warnings but which are still failures under particular 'DynFlags'
+settings. It's important to be aware of such logic distinction, because when
+we are inside the typechecker or the desugarer, we are interested about
+intrinsic errors, and to bail out as soon as we find one of them. Conversely,
+if we find an /extrinsic/ one, for example because a particular 'WarningFlag'
+makes a warning and error, we /don't/ want to bail out, that's still not the
+right time to do so: Rather, we want to first collect all the diagnostics, and
+later classify and report them appropriately (in the driver).
 -}
 
-
--- | Returns 'True' if this is, intrinsically, a failure. See Note [Intrinsic And Extrinsic Failures].
+-- | Returns 'True' if this is, intrinsically, a failure. See
+-- Note [Intrinsic And Extrinsic Failures].
 isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
 isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic
 
 isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool
 isWarningMessage = not . isIntrinsicErrorMessage
 
+-- | Are there any hard errors here? -Werror warnings are /not/ detected. If
+-- you want to check for -Werror warnings, use 'errorsOrFatalWarningsFound'.
 errorsFound :: Diagnostic e => Messages e -> Bool
 errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs
 
+-- | Returns 'True' if the envelope contains a message that will stop
+-- compilation: either an intrinsic error or a fatal (-Werror) warning
+isExtrinsicErrorMessage :: MsgEnvelope e -> Bool
+isExtrinsicErrorMessage = (==) SevError . errMsgSeverity
+
+-- | Are there any errors or -Werror warnings here?
+errorsOrFatalWarningsFound :: Messages e -> Bool
+errorsOrFatalWarningsFound (Messages msgs) = any isExtrinsicErrorMessage msgs
+
 getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
 getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs
 
 getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
 getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs
 
--- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the
--- second the errors.
-partitionMessages :: Diagnostic e => Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
-partitionMessages (Messages xs) = partitionBag isWarningMessage xs
+-- | Partitions the 'Messages' and returns a tuple which first element are the
+-- warnings, and the second the errors.
+partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e)
+partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs)
diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs
index b8a1e932e0..4979d9188b 100644
--- a/compiler/GHC/Types/SourceError.hs
+++ b/compiler/GHC/Types/SourceError.hs
@@ -10,25 +10,29 @@ module GHC.Types.SourceError
 where
 
 import GHC.Prelude
-import GHC.Data.Bag
 import GHC.Types.Error
 import GHC.Utils.Monad
 import GHC.Utils.Panic
 import GHC.Utils.Exception
+import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc)
+import GHC.Utils.Outputable
+
+import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage
+import GHC.Driver.Errors.Types
 
 import Control.Monad.Catch as MC (MonadCatch, catch)
 
-mkSrcErr :: ErrorMessages -> SourceError
+mkSrcErr :: Messages GhcMessage -> SourceError
 mkSrcErr = SourceError
 
-srcErrorMessages :: SourceError -> ErrorMessages
+srcErrorMessages :: SourceError -> Messages GhcMessage
 srcErrorMessages (SourceError msgs) = msgs
 
-throwErrors :: MonadIO io => ErrorMessages -> io a
+throwErrors :: MonadIO io => Messages GhcMessage -> io a
 throwErrors = liftIO . throwIO . mkSrcErr
 
-throwOneError :: MonadIO io => MsgEnvelope DiagnosticMessage -> io a
-throwOneError = throwErrors . unitBag
+throwOneError :: MonadIO io => MsgEnvelope GhcMessage -> io a
+throwOneError = throwErrors . singleMessage
 
 -- | A source error is an error that is caused by one or more errors in the
 -- source code.  A 'SourceError' is thrown by many functions in the
@@ -46,10 +50,18 @@ throwOneError = throwErrors . unitBag
 --
 -- See 'printExceptionAndWarnings' for more information on what to take care
 -- of when writing a custom error handler.
-newtype SourceError = SourceError ErrorMessages
+newtype SourceError = SourceError (Messages GhcMessage)
 
 instance Show SourceError where
-  show (SourceError msgs) = unlines . map show . bagToList $ msgs
+  -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics
+  -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions.
+  -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'.
+  show (SourceError msgs) =
+      renderWithContext defaultSDocContext
+    . vcat
+    . pprMsgEnvelopeBagWithLoc
+    . getMessages
+    $ msgs
 
 instance Exception SourceError