Parameterise Messages over e

This commit paves the way to a richer and more structured representation
of GHC error messages, as per GHC proposal #306. More specifically
'Messages' from 'GHC.Types.Error' now gains an extra type parameter,
that we instantiate to 'ErrDoc' for now. Later, this will allow us to
replace ErrDoc with something more structure (for example messages
coming from the parser, the typechecker etc).

22 files changed, 275 insertions, 171 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index f52dc5b657..c7e7e5c826 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1474,7 +1474,7 @@ getNameToInstancesIndex :: GhcMonad m
                      -- if it is visible from at least one module in the list.
   -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load
                      -- modules for everything that is in scope unqualified.
-  -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
+  -> m (Messages ErrDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
 getNameToInstancesIndex visible_mods mods_to_load = do
   hsc_env <- getSession
   liftIO $ runTcInteractive hsc_env $
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 0cfa0d20f5..191d3b8248 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -17,9 +17,9 @@ import GHC.Types.Error
 import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )
 import qualified GHC.Driver.CmdLine as CmdLine
 
--- | Converts a list of 'WarningMessages' into 'Messages', where the second element contains only
+-- | Converts a list of 'WarningMessages' into a tuple where the second element contains only
 -- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'.
-warningsToMessages :: DynFlags -> WarningMessages -> Messages
+warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, ErrorMessages)
 warningsToMessages dflags =
   partitionBagWith $ \warn ->
     case isWarnMsgFatal dflags warn of
@@ -28,13 +28,14 @@ warningsToMessages dflags =
         Right warn{ errMsgSeverity = SevError
                   , errMsgReason = ErrReason err_reason }
 
-printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
+printBagOfErrors :: RenderableDiagnostic a => DynFlags -> Bag (ErrMsg a) -> IO ()
 printBagOfErrors dflags bag_of_errors
   = sequence_ [ let style = mkErrStyle unqual
                     ctx   = initSDocContext dflags style
-                in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc)
+                in putLogMsg dflags reason sev s
+                $ withPprStyle style (formatErrDoc ctx (renderDiagnostic doc))
               | ErrMsg { errMsgSpan      = s,
-                         errMsgDoc       = doc,
+                         errMsgDiagnostic = doc,
                          errMsgSeverity  = sev,
                          errMsgReason    = reason,
                          errMsgContext   = unqual } <- sortMsgBag (Just dflags)
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 38d55e61f2..889d808b41 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -183,6 +183,7 @@ import GHC.Types.SourceError
 import GHC.Types.SafeHaskell
 import GHC.Types.ForeignStubs
 import GHC.Types.Var.Env       ( emptyTidyEnv )
+import GHC.Types.Error
 import GHC.Types.Fixity.Env
 import GHC.Types.CostCentre
 import GHC.Types.Unique.Supply
@@ -320,9 +321,10 @@ 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, Maybe a) -> Hsc a
+ioMsgMaybe :: IO (Messages ErrDoc, Maybe a) -> Hsc a
 ioMsgMaybe ioA = do
-    ((warns,errs), mb_r) <- liftIO ioA
+    (msgs, mb_r) <- liftIO ioA
+    let (warns, errs) = partitionMessages msgs
     logWarnings warns
     case mb_r of
         Nothing -> throwErrors errs
@@ -330,10 +332,10 @@ ioMsgMaybe ioA = do
 
 -- | like ioMsgMaybe, except that we ignore error messages and return
 -- 'Nothing' instead.
-ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
+ioMsgMaybe' :: IO (Messages ErrDoc, Maybe a) -> Hsc (Maybe a)
 ioMsgMaybe' ioA = do
-    ((warns,_errs), mb_r) <- liftIO $ ioA
-    logWarnings warns
+    (msgs, mb_r) <- liftIO $ ioA
+    logWarnings (getWarningMessages msgs)
     return mb_r
 
 -- -----------------------------------------------------------------------------
@@ -1132,7 +1134,7 @@ hscCheckSafeImports tcg_env = do
 
     warns rules = listToBag $ map warnRules rules
 
-    warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg
+    warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg ErrDoc
     warnRules (L loc (HsRule { rd_name = n })) =
         mkPlainWarnMsg loc $
             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
@@ -1605,7 +1607,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
                $ do
                   (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
                                        $ parseCmmFile dflags home_unit filename
-                  return ((fmap pprWarning warns, fmap pprError errs), cmm)
+                  return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm)
     liftIO $ do
         dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
         let -- Make up a module name to give the NCG. We can't pass bottom here
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 8c460b4b5c..8588675e3c 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -2886,7 +2886,7 @@ withDeferredDiagnostics f = do
       (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)
       (\_ -> f)
 
-noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
+noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg ErrDoc
 -- ToDo: we don't have a proper line number for this error
 noModError hsc_env loc wanted_mod err
   = mkPlainErrMsg loc $ cannotFindModule hsc_env wanted_mod err
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 10f613f761..c1292c9275 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -100,7 +100,7 @@ import GHC.Driver.Plugins ( LoadedPlugin(..) )
 -}
 
 -- | Main entry point to the desugarer.
-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages ErrDoc, Maybe ModGuts)
 -- Can modify PCS by faulting in more declarations
 
 deSugar hsc_env
@@ -283,7 +283,7 @@ So we pull out the type/coercion variables (which are in dependency order),
 and Rec the rest.
 -}
 
-deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages ErrDoc, Maybe CoreExpr)
 
 deSugarExpr hsc_env tc_expr = do {
          let dflags = hsc_dflags hsc_env
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 7e52691124..a4b4652277 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -83,7 +83,6 @@ import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )
 
 import GHC.Builtin.Names
 
-import GHC.Data.Bag
 import GHC.Data.FastString
 
 import GHC.Unit.Env
@@ -104,9 +103,9 @@ import GHC.Types.Name.Ppr
 import GHC.Types.Literal ( mkLitString )
 import GHC.Types.CostCentre.State
 import GHC.Types.TyThing
+import GHC.Types.Error
 
 import GHC.Utils.Outputable
-import GHC.Utils.Error
 import GHC.Utils.Panic
 
 import Data.IORef
@@ -214,7 +213,7 @@ initDsTc thing_inside
        }
 
 -- | Run a 'DsM' action inside the 'IO' monad.
-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages ErrDoc, Maybe a)
 initDs hsc_env tcg_env thing_inside
   = do { msg_var <- newIORef emptyMessages
        ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
@@ -223,7 +222,7 @@ initDs hsc_env tcg_env thing_inside
 
 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
 mkDsEnvsFromTcGbl :: MonadIO m
-                  => HscEnv -> IORef Messages -> TcGblEnv
+                  => HscEnv -> IORef (Messages ErrDoc) -> TcGblEnv
                   -> m (DsGblEnv, DsLclEnv)
 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
@@ -240,21 +239,20 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
                            msg_var cc_st_var complete_matches
        }
 
-runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages ErrDoc, Maybe a)
 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
                               (tryM thing_inside)
        ; msgs   <- readIORef (ds_msgs ds_gbl)
        ; let final_res
-               | errorsFound dflags msgs = Nothing
-               | Right r <- res          = Just r
-               | otherwise               = panic "initDs"
+               | errorsFound msgs = Nothing
+               | Right r <- res   = Just r
+               | otherwise        = panic "initDs"
        ; return (msgs, final_res)
        }
-  where dflags = hsc_dflags hsc_env
 
 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages ErrDoc, Maybe a)
 initDsWithModGuts hsc_env guts thing_inside
   = do { cc_st_var   <- newIORef newCostCentreState
        ; msg_var <- newIORef emptyMessages
@@ -278,7 +276,7 @@ initDsWithModGuts hsc_env guts thing_inside
        ; runDs hsc_env envs thing_inside
        }
 
-initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
+initTcDsForSolver :: TcM a -> DsM (Messages ErrDoc, Maybe a)
 -- Spin up a TcM context so that we can run the constraint solver
 -- Returns any error messages generated by the constraint solver
 -- and (Just res) if no error happened; Nothing if an error happened
@@ -309,7 +307,7 @@ initTcDsForSolver thing_inside
          thing_inside }
 
 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef Messages -> IORef CostCentreState -> CompleteMatches
+         -> IORef (Messages ErrDoc) -> IORef CostCentreState -> CompleteMatches
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
          complete_matches
@@ -455,7 +453,7 @@ warnDs reason warn
        ; loc <- getSrcSpanDs
        ; let msg = makeIntoWarning reason $
                    mkWarnMsg loc (ds_unqual env) warn
-       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+       ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Emit a warning only if the correct WarnReason is set in the DynFlags
 warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
@@ -468,7 +466,7 @@ errDs err
   = do  { env <- getGblEnv
         ; loc <- getSrcSpanDs
         ; let msg = mkErrMsg loc (ds_unqual env) err
-        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
+        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Issue an error, but return the expression for (), so that we can continue
 -- reporting errors.
@@ -506,14 +504,13 @@ askNoErrsDs thing_inside
                   thing_inside
 
       -- Propagate errors
-      ; msgs@(warns, errs) <- readMutVar errs_var
-      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
+      ; msgs <- readMutVar errs_var
+      ; updMutVar (ds_msgs env) (unionMessages msgs)
 
       -- And return
       ; case mb_res of
            Left _    -> failM
-           Right res -> do { dflags <- getDynFlags
-                           ; let errs_found = errorsFound dflags msgs
+           Right res -> do { let errs_found = errorsFound msgs
                            ; return (res, not errs_found) } }
 
 mkPrintUnqualifiedDs :: DsM PrintUnqualified
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
index 251fd0af83..0ea659e471 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -48,6 +48,7 @@ import GHC.Utils.Error ( pprErrMsgBagWithLoc )
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Data.Bag
+import GHC.Types.Error
 import GHC.Types.Unique.Set
 import GHC.Types.Unique.DSet
 import GHC.Types.Unique.SDFM
@@ -679,11 +680,11 @@ tyOracle ty_st@(TySt n inert) cts
   | otherwise
   = do { evs <- traverse nameTyCt cts
        ; tracePm "tyOracle" (ppr cts $$ ppr inert)
-       ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability inert evs
+       ; (msgs, res) <- initTcDsForSolver $ tcCheckSatisfiability inert evs
        ; case res of
             -- return the new inert set and increment the sequence number n
             Just mb_new_inert -> return (TySt (n+1) <$> mb_new_inert)
-            Nothing           -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }
+            Nothing           -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc (getErrorMessages msgs)) }
 
 -- | Allocates a fresh 'EvVar' name for 'PredTy's.
 nameTyCt :: PredType -> DsM EvVar
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index aeeeb0c530..782b5faeee 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -47,7 +47,7 @@ data DsGblEnv
                                           -- constructors are in scope during
                                           -- pattern-match satisfiability checking
   , ds_unqual  :: PrintUnqualified
-  , ds_msgs    :: IORef Messages          -- Warning messages
+  , ds_msgs    :: IORef (Messages ErrDoc) -- Warning messages
   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
                                           -- possibly-imported things
   , ds_complete_matches :: CompleteMatches
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index 7374239092..930d58ddc5 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -34,13 +34,13 @@ import GHC.Unit.Module.Deps
 import GHC.Types.SrcLoc
 import GHC.Types.Unique.FM
 import GHC.Types.Avail
+import GHC.Types.Error
 import GHC.Types.FieldLabel
 import GHC.Types.Var
 import GHC.Types.Basic
 import GHC.Types.Name
 import GHC.Types.Name.Shape
 
-import GHC.Utils.Error
 import GHC.Utils.Outputable
 import GHC.Utils.Misc
 import GHC.Utils.Fingerprint
@@ -57,7 +57,7 @@ tcRnMsgMaybe do_this = do
     r <- liftIO $ do_this
     case r of
         Left errs -> do
-            addMessages (emptyBag, errs)
+            addMessages (mkMessages errs)
             failM
         Right x -> return x
 
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 98b2341cf1..671453e4c1 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -24,25 +24,25 @@ import GHC.Hs.Type (pprLHsContext)
 import GHC.Builtin.Names (allNameStrings)
 import GHC.Builtin.Types (filterCTuple)
 
-mkParserErr :: SrcSpan -> SDoc -> ErrMsg
+mkParserErr :: SrcSpan -> SDoc -> ErrMsg ErrDoc
 mkParserErr span doc = ErrMsg
    { errMsgSpan        = span
    , errMsgContext     = alwaysQualify
-   , errMsgDoc         = ErrDoc [doc] [] []
+   , errMsgDiagnostic  = ErrDoc [doc] [] []
    , errMsgSeverity    = SevError
    , errMsgReason      = NoReason
    }
 
-mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg
+mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg ErrDoc
 mkParserWarn flag span doc = ErrMsg
    { errMsgSpan        = span
    , errMsgContext     = alwaysQualify
-   , errMsgDoc         = ErrDoc [doc] [] []
+   , errMsgDiagnostic  = ErrDoc [doc] [] []
    , errMsgSeverity    = SevWarning
    , errMsgReason      = Reason flag
    }
 
-pprWarning :: PsWarning -> ErrMsg
+pprWarning :: PsWarning -> ErrMsg ErrDoc
 pprWarning = \case
    PsWarnTab loc tc
       -> mkParserWarn Opt_WarnTabs loc $
@@ -128,7 +128,7 @@ pprWarning = \case
            OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"
            OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"
 
-pprError :: PsError -> ErrMsg
+pprError :: PsError -> ErrMsg ErrDoc
 pprError err = mkParserErr (errLoc err) $ vcat
    (pp_err (errDesc err) : map pp_hint (errHints err))
 
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index 8c0a876c36..8634d8c495 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -39,7 +39,7 @@ import GHC.Hs
 import GHC.Unit.Module
 import GHC.Builtin.Names
 
-import GHC.Types.Error
+import GHC.Types.Error hiding ( getErrorMessages, getWarningMessages )
 import GHC.Types.SrcLoc
 import GHC.Types.SourceError
 import GHC.Types.SourceText
@@ -52,7 +52,7 @@ import GHC.Utils.Exception as Exception
 
 import GHC.Data.StringBuffer
 import GHC.Data.Maybe
-import GHC.Data.Bag         ( Bag, emptyBag, listToBag, unitBag, isEmptyBag )
+import GHC.Data.Bag         ( Bag, listToBag, unitBag, isEmptyBag )
 import GHC.Data.FastString
 
 import Control.Monad
@@ -348,9 +348,9 @@ unsupportedExtnError dflags loc unsup =
      suggestions = fuzzyMatch unsup supported
 
 
-optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
+optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages ErrDoc
 optionsErrorMsgs unhandled_flags flags_lines _filename
-  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
+  = mkMessages $ listToBag (map mkMsg unhandled_flags_lines)
   where unhandled_flags_lines :: [Located String]
         unhandled_flags_lines = [ L l f
                                 | f <- unhandled_flags
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index f6bb5f7d42..fcd48c3d5c 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -50,8 +50,9 @@ import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Name.Set
 import GHC.Data.Bag
-import GHC.Utils.Error  ( ErrMsg, errDoc, pprLocErrMsg )
+import GHC.Utils.Error  ( pprLocErrMsg )
 import GHC.Types.Basic
+import GHC.Types.Error
 import GHC.Core.ConLike ( ConLike(..))
 import GHC.Utils.Misc
 import GHC.Data.FastString
@@ -749,7 +750,7 @@ mkUserTypeErrorReporter ctxt
                       ; maybeReportError ctxt err
                       ; addDeferredBinding ctxt err ct }
 
-mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
+mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc)
 mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
                         $ important
                         $ pprUserTypeErrorTy
@@ -825,7 +826,7 @@ pattern match which binds some equality constraints.  If we
 find one, we report the insoluble Given.
 -}
 
-mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc))
                              -- Make error message for a group
                 -> Reporter  -- Deal with lots of constraints
 -- Group together errors from same location,
@@ -834,7 +835,7 @@ mkGroupReporter mk_err ctxt cts
   = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
 
 -- Like mkGroupReporter, but doesn't actually print error messages
-mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
+mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter
 mkSuppressReporter mk_err ctxt cts
   = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
 
@@ -852,7 +853,7 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2
              -- Reduce duplication by reporting only one error from each
              -- /starting/ location even if the end location differs
 
-reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter
 reportGroup mk_err ctxt cts =
   ASSERT( not (null cts))
   do { err <- mk_err ctxt cts
@@ -871,13 +872,13 @@ reportGroup mk_err ctxt cts =
 
 -- like reportGroup, but does not actually report messages. It still adds
 -- -fdefer-type-errors bindings, though.
-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter
+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter
 suppressGroup mk_err ctxt cts
  = do { err <- mk_err ctxt cts
       ; traceTc "Suppressing errors for" (ppr cts)
       ; mapM_ (addDeferredBinding ctxt err) cts }
 
-maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg -> TcM ()
+maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg ErrDoc -> TcM ()
 maybeReportHoleError ctxt hole err
   | isOutOfScopeHole hole
   -- Always report an error for out-of-scope variables
@@ -919,7 +920,7 @@ maybeReportHoleError ctxt hole err
        HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err
        HoleDefer -> return ()
 
-maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
+maybeReportError :: ReportErrCtxt -> ErrMsg ErrDoc -> TcM ()
 -- Report the error and/or make a deferred binding for it
 maybeReportError ctxt err
   | cec_suppress ctxt    -- Some worse error has occurred;
@@ -931,7 +932,7 @@ maybeReportError ctxt err
       TypeWarn reason -> reportWarning reason err
       TypeError       -> reportError err
 
-addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
+addDeferredBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Ct -> TcM ()
 -- See Note [Deferring coercion errors to runtime]
 addDeferredBinding ctxt err ct
   | deferringAnyBindings ctxt
@@ -954,14 +955,14 @@ addDeferredBinding ctxt err ct
   = return ()
 
 mkErrorTerm :: DynFlags -> Type  -- of the error term
-            -> ErrMsg -> EvTerm
+            -> ErrMsg ErrDoc -> EvTerm
 mkErrorTerm dflags ty err = evDelayedError ty err_fs
   where
     err_msg = pprLocErrMsg err
     err_fs  = mkFastString $ showSDoc dflags $
               err_msg $$ text "(deferred type error)"
 
-maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Hole -> TcM ()
+maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Hole -> TcM ()
 maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) })
 -- Only add bindings for holes in expressions
 -- not for holes in partial type signatures
@@ -1047,11 +1048,11 @@ pprWithArising (ct:cts)
     ppr_one ct' = hang (parens (pprType (ctPred ct')))
                      2 (pprCtLoc (ctLoc ct'))
 
-mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
+mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (ErrMsg ErrDoc)
 mkErrorMsgFromCt ctxt ct report
   = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report
 
-mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
+mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (ErrMsg ErrDoc)
 mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)
   = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
        ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing)
@@ -1152,7 +1153,7 @@ solve it.
 ************************************************************************
 -}
 
-mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)
 mkIrredErr ctxt cts
   = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
        ; let orig = ctOrigin ct1
@@ -1163,7 +1164,7 @@ mkIrredErr ctxt cts
     (ct1:_) = cts
 
 ----------------
-mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM ErrMsg
+mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (ErrMsg ErrDoc)
 mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ
                                            , hole_ty = hole_ty
                                            , hole_loc = ct_loc })
@@ -1304,7 +1305,7 @@ givenConstraintsMsg ctxt =
             2 (vcat $ map pprConstraint constraints)
 
 ----------------
-mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)
 mkIPErr ctxt cts
   = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
        ; let orig    = ctOrigin ct1
@@ -1381,11 +1382,11 @@ any more.  So we don't assert that it is.
 
 -- Don't have multiple equality errors from the same location
 -- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
-mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)
 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
 mkEqErr _ [] = panic "mkEqErr"
 
-mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc)
 mkEqErr1 ctxt ct   -- Wanted or derived;
                    -- givens handled in mkGivenErrorReporter
   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
@@ -1451,7 +1452,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
 
 mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
              -> Ct
-             -> TcType -> TcType -> TcM ErrMsg
+             -> TcType -> TcType -> TcM (ErrMsg ErrDoc)
 mkEqErr_help dflags ctxt report ct ty1 ty2
   | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1
   = mkTyVarEqErr dflags ctxt report ct tv1 ty2
@@ -1462,7 +1463,7 @@ mkEqErr_help dflags ctxt report ct ty1 ty2
 
 reportEqErr :: ReportErrCtxt -> Report
             -> Ct
-            -> TcType -> TcType -> TcM ErrMsg
+            -> TcType -> TcType -> TcM (ErrMsg ErrDoc)
 reportEqErr ctxt report ct ty1 ty2
   = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])
   where
@@ -1471,7 +1472,7 @@ reportEqErr ctxt report ct ty1 ty2
 
 mkTyVarEqErr, mkTyVarEqErr'
   :: DynFlags -> ReportErrCtxt -> Report -> Ct
-             -> TcTyVar -> TcType -> TcM ErrMsg
+             -> TcTyVar -> TcType -> TcM (ErrMsg ErrDoc)
 -- tv1 and ty2 are already tidied
 mkTyVarEqErr dflags ctxt report ct tv1 ty2
   = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
@@ -1671,7 +1672,7 @@ pp_givens givens
 -- always be another unsolved wanted around, which will ordinarily suppress
 -- this message. But this can still be printed out with -fdefer-type-errors
 -- (sigh), so we must produce a message.
-mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)
 mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report
   where
     report = important msg
@@ -2278,7 +2279,7 @@ Warn of loopy local equalities that were dropped.
 ************************************************************************
 -}
 
-mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)
 mkDictErr ctxt cts
   = ASSERT( not (null cts) )
     do { inst_envs <- tcGetInstEnvs
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 2e55974f90..e21adf31df 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -104,6 +104,7 @@ import GHC.Types.Unique
 import GHC.Types.Var.Set
 import GHC.Types.Meta
 import GHC.Types.Basic hiding( SuccessFlag(..) )
+import GHC.Types.Error
 import GHC.Types.Fixity as Hs
 import GHC.Types.Annotations
 import GHC.Types.Name
@@ -114,7 +115,6 @@ import GHC.Unit.Module
 import GHC.Unit.Module.ModIface
 import GHC.Unit.Module.Deps
 
-import GHC.Utils.Error
 import GHC.Utils.Misc
 import GHC.Utils.Panic as Panic
 import GHC.Utils.Lexeme
@@ -122,7 +122,6 @@ import GHC.Utils.Outputable
 
 import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) )
 
-import GHC.Data.Bag
 import GHC.Data.FastString
 import GHC.Data.Maybe( MaybeErr(..) )
 import qualified GHC.Data.EnumSet as EnumSet
@@ -1286,7 +1285,7 @@ runTH ty fhv = do
 -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
 runRemoteTH
   :: IServInstance
-  -> [Messages]   --  saved from nested calls to qRecover
+  -> [Messages ErrDoc]   --  saved from nested calls to qRecover
   -> TcM ()
 runRemoteTH iserv recovers = do
   THMsg msg <- liftIO $ readIServ iserv getTHMessage
@@ -1298,15 +1297,15 @@ runRemoteTH iserv recovers = do
       writeTcRef v emptyMessages
       runRemoteTH iserv (msgs : recovers)
     EndRecover caught_error -> do
-      let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of
+      let (prev_msgs, rest) = case recovers of
              [] -> panic "EndRecover"
              a : b -> (a,b)
       v <- getErrsVar
-      (warn_msgs,_) <- readTcRef v
+      warn_msgs <- getWarningMessages <$> readTcRef v
       -- keep the warnings only if there were no errors
       writeTcRef v $ if caught_error
         then prev_msgs
-        else (prev_warns `unionBags` warn_msgs, prev_errs)
+        else mkMessages warn_msgs `unionMessages` prev_msgs
       runRemoteTH iserv rest
     _other -> do
       r <- handleTHMessage msg
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index e8073d763e..746b5c71ea 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -129,6 +129,7 @@ import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Misc
 
+import GHC.Types.Error
 import GHC.Types.Name.Reader
 import GHC.Types.Fixity.Env
 import GHC.Types.Id as Id
@@ -187,7 +188,7 @@ tcRnModule :: HscEnv
            -> ModSummary
            -> Bool              -- True <=> save renamed syntax
            -> HsParsedModule
-           -> IO (Messages, Maybe TcGblEnv)
+           -> IO (Messages ErrDoc, Maybe TcGblEnv)
 
 tcRnModule hsc_env mod_sum save_rn_syntax
    parsedModule@HsParsedModule {hpm_module= L loc this_module}
@@ -201,7 +202,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax
           tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
 
   | otherwise
-  = return ((emptyBag, unitBag err_msg), Nothing)
+  = return (err_msg `addMessage` emptyMessages, Nothing)
 
   where
     hsc_src = ms_hsc_src mod_sum
@@ -1985,7 +1986,7 @@ this Note.
 *********************************************************
 -}
 
-runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages ErrDoc, Maybe a)
 -- Initialise the tcg_inst_env with instances from all home modules.
 -- This mimics the more selective call to hptInstances in tcRnImports
 runTcInteractive hsc_env thing_inside
@@ -2101,7 +2102,7 @@ We don't bother with the tcl_th_bndrs environment either.
 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
 -- values, coerced to ().
 tcRnStmt :: HscEnv -> GhciLStmt GhcPs
-         -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
+         -> IO (Messages ErrDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
 tcRnStmt hsc_env rdr_stmt
   = runTcInteractive hsc_env $ do {
 
@@ -2481,7 +2482,7 @@ getGhciStepIO = do
 
     return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
 
-isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
+isGHCiMonad :: HscEnv -> String -> IO (Messages ErrDoc, Maybe Name)
 isGHCiMonad hsc_env ty
   = runTcInteractive hsc_env $ do
         rdrEnv <- getGlobalRdrEnv
@@ -2508,7 +2509,7 @@ data TcRnExprMode = TM_Inst     -- ^ Instantiate inferred quantifiers only (:typ
 tcRnExpr :: HscEnv
          -> TcRnExprMode
          -> LHsExpr GhcPs
-         -> IO (Messages, Maybe Type)
+         -> IO (Messages ErrDoc, Maybe Type)
 tcRnExpr hsc_env mode rdr_expr
   = runTcInteractive hsc_env $
     do {
@@ -2577,7 +2578,7 @@ has a special case for application chains.
 --------------------------
 tcRnImportDecls :: HscEnv
                 -> [LImportDecl GhcPs]
-                -> IO (Messages, Maybe GlobalRdrEnv)
+                -> IO (Messages ErrDoc, Maybe GlobalRdrEnv)
 -- Find the new chunk of GlobalRdrEnv created by this list of import
 -- decls.  In contract tcRnImports *extends* the TcGblEnv.
 tcRnImportDecls hsc_env import_decls
@@ -2593,7 +2594,7 @@ tcRnType :: HscEnv
          -> ZonkFlexi
          -> Bool        -- Normalise the returned type
          -> LHsType GhcPs
-         -> IO (Messages, Maybe (Type, Kind))
+         -> IO (Messages ErrDoc, Maybe (Type, Kind))
 tcRnType hsc_env flexi normalise rdr_type
   = runTcInteractive hsc_env $
     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
@@ -2727,7 +2728,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
 
 tcRnDeclsi :: HscEnv
            -> [LHsDecl GhcPs]
-           -> IO (Messages, Maybe TcGblEnv)
+           -> IO (Messages ErrDoc, Maybe TcGblEnv)
 tcRnDeclsi hsc_env local_decls
   = runTcInteractive hsc_env $
     tcRnSrcDecls False local_decls Nothing
@@ -2752,13 +2753,13 @@ externaliseAndTidyId this_mod id
 -- a package module with an interface on disk.  If neither of these is
 -- true, then the result will be an error indicating the interface
 -- could not be found.
-getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
+getModuleInterface :: HscEnv -> Module -> IO (Messages ErrDoc, Maybe ModIface)
 getModuleInterface hsc_env mod
   = runTcInteractive hsc_env $
     loadModuleInterface (text "getModuleInterface") mod
 
 tcRnLookupRdrName :: HscEnv -> Located RdrName
-                  -> IO (Messages, Maybe [Name])
+                  -> IO (Messages ErrDoc, Maybe [Name])
 -- ^ Find all the Names that this RdrName could mean, in GHCi
 tcRnLookupRdrName hsc_env (L loc rdr_name)
   = runTcInteractive hsc_env $
@@ -2772,7 +2773,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name)
        ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))
        ; return names }
 
-tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
+tcRnLookupName :: HscEnv -> Name -> IO (Messages ErrDoc, Maybe TyThing)
 tcRnLookupName hsc_env name
   = runTcInteractive hsc_env $
     tcRnLookupName' name
@@ -2791,7 +2792,7 @@ tcRnLookupName' name = do
 
 tcRnGetInfo :: HscEnv
             -> Name
-            -> IO ( Messages
+            -> IO ( Messages ErrDoc
                   , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
 
 -- Used to implement :info in GHCi
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 2d97b84e9d..7e1f919e1f 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -60,7 +60,7 @@ import GHC.Utils.Panic
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.Basic    ( IntWithInf, intGtLimit )
-import GHC.Utils.Error    ( emptyMessages )
+import GHC.Types.Error
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
@@ -149,7 +149,7 @@ simplifyTop wanteds
 
            ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol }
 
-           ; whyUnsafe <- fst <$> TcM.readTcRef errs_var
+           ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var
            ; TcM.writeTcRef errs_var saved_msg
            ; recordUnsafeInfer whyUnsafe
            }
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 2f41bb4b14..8197220f09 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -748,7 +748,7 @@ data TcLclEnv           -- Changes as we move inside an expression
                                       -- and for tidying types
 
         tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints
-        tcl_errs :: TcRef Messages              -- Place to accumulate errors
+        tcl_errs :: TcRef (Messages ErrDoc)     -- Place to accumulate errors
     }
 
 setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 137fbaeb3a..0265abef64 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -361,7 +361,7 @@ checkUnit (VirtUnit indef) = do
 -- an @hsig@ file.)
 tcRnCheckUnit ::
     HscEnv -> Unit ->
-    IO (Messages, Maybe ())
+    IO (Messages ErrDoc, Maybe ())
 tcRnCheckUnit hsc_env uid =
    withTiming dflags
               (text "Check unit id" <+> ppr uid)
@@ -381,7 +381,7 @@ tcRnCheckUnit hsc_env uid =
 -- | Top-level driver for signature merging (run after typechecking
 -- an @hsig@ file).
 tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
-                    -> IO (Messages, Maybe TcGblEnv)
+                    -> IO (Messages ErrDoc, Maybe TcGblEnv)
 tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
   withTiming dflags
              (text "Signature merging" <+> brackets (ppr this_mod))
@@ -912,7 +912,7 @@ mergeSignatures
 -- an @hsig@ file.)
 tcRnInstantiateSignature ::
     HscEnv -> Module -> RealSrcSpan ->
-    IO (Messages, Maybe TcGblEnv)
+    IO (Messages ErrDoc, Maybe TcGblEnv)
 tcRnInstantiateSignature hsc_env this_mod real_loc =
    withTiming dflags
               (text "Signature instantiation"<+>brackets (ppr this_mod))
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 48348ce7d7..08d76b64a0 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -188,6 +188,7 @@ import GHC.Utils.Error
 import GHC.Utils.Panic
 import GHC.Utils.Misc
 
+import GHC.Types.Error
 import GHC.Types.Fixity.Env
 import GHC.Types.Name.Reader
 import GHC.Types.Name
@@ -230,7 +231,7 @@ initTc :: HscEnv
        -> Module
        -> RealSrcSpan
        -> TcM r
-       -> IO (Messages, Maybe r)
+       -> IO (Messages ErrDoc, Maybe r)
                 -- Nothing => error thrown by the thing inside
                 -- (error messages should have been printed already)
 
@@ -352,10 +353,10 @@ initTcWithGbl :: HscEnv
               -> TcGblEnv
               -> RealSrcSpan
               -> TcM r
-              -> IO (Messages, Maybe r)
+              -> IO (Messages ErrDoc, Maybe r)
 initTcWithGbl hsc_env gbl_env loc do_this
  = do { lie_var      <- newIORef emptyWC
-      ; errs_var     <- newIORef (emptyBag, emptyBag)
+      ; errs_var     <- newIORef emptyMessages
       ; usage_var    <- newIORef zeroUE
       ; let lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
@@ -392,14 +393,13 @@ initTcWithGbl hsc_env gbl_env loc do_this
         -- Collect any error messages
       ; msgs <- readIORef (tcl_errs lcl_env)
 
-      ; let { final_res | errorsFound dflags msgs = Nothing
-                        | otherwise               = maybe_res }
+      ; let { final_res | errorsFound msgs = Nothing
+                        | otherwise        = maybe_res }
 
       ; return (msgs, final_res)
       }
-  where dflags = hsc_dflags hsc_env
 
-initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
+initTcInteractive :: HscEnv -> TcM a -> IO (Messages ErrDoc, Maybe a)
 -- Initialise the type checker monad for use in GHCi
 initTcInteractive hsc_env thing_inside
   = initTc hsc_env HsSrcFile False
@@ -930,10 +930,10 @@ wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)
 
 -- Reporting errors
 
-getErrsVar :: TcRn (TcRef Messages)
+getErrsVar :: TcRn (TcRef (Messages ErrDoc))
 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 
-setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
+setErrsVar :: TcRef (Messages ErrDoc) -> TcRn a -> TcRn a
 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 
 addErr :: MsgDoc -> TcRn ()
@@ -963,7 +963,7 @@ checkErr :: Bool -> MsgDoc -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = unless ok (addErr msg)
 
-addMessages :: Messages -> TcRn ()
+addMessages :: Messages ErrDoc -> TcRn ()
 addMessages msgs1
   = do { errs_var <- getErrsVar ;
          msgs0 <- readTcRef errs_var ;
@@ -974,13 +974,13 @@ discardWarnings :: TcRn a -> TcRn a
 -- used to ignore-unused-variable warnings inside derived code
 discardWarnings thing_inside
   = do  { errs_var <- getErrsVar
-        ; (old_warns, _) <- readTcRef errs_var
+        ; old_warns <- getWarningMessages <$> readTcRef errs_var
 
         ; result <- thing_inside
 
         -- Revert warnings to old_warns
-        ; (_new_warns, new_errs) <- readTcRef errs_var
-        ; writeTcRef errs_var (old_warns, new_errs)
+        ; new_errs <- getErrorMessages <$> readTcRef errs_var
+        ; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs)
 
         ; return result }
 
@@ -992,36 +992,36 @@ discardWarnings thing_inside
 ************************************************************************
 -}
 
-mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
+mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn (ErrMsg ErrDoc)
 mkLongErrAt loc msg extra
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
          let msg' = pprWithUnitState unit_state msg in
          return $ mkLongErrMsg loc printer msg' extra }
 
-mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
+mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn (ErrMsg ErrDoc)
 mkErrDocAt loc errDoc
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
          let f = pprWithUnitState unit_state
              errDoc' = mapErrDoc f errDoc
          in
-         return $ mkErrDoc loc printer errDoc' }
+         return $ mkErr loc printer errDoc' }
 
 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
 
-reportErrors :: [ErrMsg] -> TcM ()
+reportErrors :: [ErrMsg ErrDoc] -> TcM ()
 reportErrors = mapM_ reportError
 
-reportError :: ErrMsg -> TcRn ()
+reportError :: ErrMsg ErrDoc -> TcRn ()
 reportError err
   = do { traceTc "Adding error:" (pprLocErrMsg err) ;
          errs_var <- getErrsVar ;
-         (warns, errs) <- readTcRef errs_var ;
-         writeTcRef errs_var (warns, errs `snocBag` err) }
+         msgs     <- readTcRef errs_var ;
+         writeTcRef errs_var (err `addMessage` msgs) }
 
-reportWarning :: WarnReason -> ErrMsg -> TcRn ()
+reportWarning :: WarnReason -> ErrMsg ErrDoc -> TcRn ()
 reportWarning reason err
   = do { let warn = makeIntoWarning reason err
                     -- 'err' was built by mkLongErrMsg or something like that,
@@ -1030,8 +1030,8 @@ reportWarning reason err
 
        ; traceTc "Adding warning:" (pprLocErrMsg warn)
        ; errs_var <- getErrsVar
-       ; (warns, errs) <- readTcRef errs_var
-       ; writeTcRef errs_var (warns `snocBag` warn, errs) }
+       ; (warns, errs) <- partitionMessages <$> readTcRef errs_var
+       ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) }
 
 
 -----------------------
@@ -1058,8 +1058,7 @@ ifErrsM :: TcRn r -> TcRn r -> TcRn r
 ifErrsM bale_out normal
  = do { errs_var <- getErrsVar ;
         msgs <- readTcRef errs_var ;
-        dflags <- getDynFlags ;
-        if errorsFound dflags msgs then
+        if errorsFound msgs then
            bale_out
         else
            normal }
@@ -1192,7 +1191,7 @@ capture_constraints thing_inside
        ; lie <- readTcRef lie_var
        ; return (res, lie) }
 
-capture_messages :: TcM r -> TcM (r, Messages)
+capture_messages :: TcM r -> TcM (r, Messages ErrDoc)
 -- capture_messages simply captures and returns the
 --                  errors arnd warnings generated by thing_inside
 -- Precondition: thing_inside must not throw an exception!
@@ -1228,8 +1227,7 @@ askNoErrs thing_inside
                           ; failM }
 
            Just res -> do { emitConstraints lie
-                          ; dflags <- getDynFlags
-                          ; let errs_found = errorsFound dflags msgs
+                          ; let errs_found = errorsFound msgs
                                           || insolubleWC lie
                           ; return (res, not errs_found) } }
 
@@ -1363,7 +1361,7 @@ foldAndRecoverM f acc (x:xs) =
                                 Just acc' -> foldAndRecoverM f acc' xs  }
 
 -----------------------
-tryTc :: TcRn a -> TcRn (Maybe a, Messages)
+tryTc :: TcRn a -> TcRn (Maybe a, Messages ErrDoc)
 -- (tryTc m) executes m, and returns
 --      Just r,  if m succeeds (returning r)
 --      Nothing, if m fails
@@ -1391,9 +1389,8 @@ tryTcDiscardingErrs recover thing_inside
   = do { ((mb_res, lie), msgs) <- capture_messages    $
                                   capture_constraints $
                                   tcTryM thing_inside
-        ; dflags <- getDynFlags
         ; case mb_res of
-            Just res | not (errorsFound dflags msgs)
+            Just res | not (errorsFound msgs)
                      , not (insolubleWC lie)
               -> -- 'main' succeeded with no errors
                  do { addMessages msgs  -- msgs might still have warnings
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 6737edcda4..6107f9da49 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -1,15 +1,23 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 
 module GHC.Types.Error
-   ( Messages
+   ( -- * Messages
+     Messages
    , WarningMessages
    , ErrorMessages
+   , mkMessages
+   , emptyMessages
+   , isEmptyMessages
+   , addMessage
+   , unionMessages
    , ErrMsg (..)
    , WarnMsg
    , ErrDoc (..)
    , MsgDoc
    , Severity (..)
-   , unionMessages
+   , RenderableDiagnostic (..)
    , errDoc
    , mapErrDoc
    , pprMessageBag
@@ -21,11 +29,18 @@ module GHC.Types.Error
    -- * Constructing individual errors
    , mkErrMsg
    , mkPlainErrMsg
-   , mkErrDoc
+   , mkErr
    , mkLongErrMsg
    , mkWarnMsg
    , mkPlainWarnMsg
    , mkLongWarnMsg
+   -- * Queries
+   , isErrorMessage
+   , isWarningMessage
+   , getErrorMessages
+   , getWarningMessages
+   , partitionMessages
+   , errorsFound
    )
 where
 
@@ -43,21 +58,94 @@ import GHC.Utils.Json
 
 import System.IO.Error  ( catchIOError )
 
-type Messages        = (WarningMessages, ErrorMessages)
-type WarningMessages = Bag WarnMsg
-type ErrorMessages   = Bag ErrMsg
+{-
+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). For now we rely on the 'Severity' to distinguish between a warning and an
+error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably
+shouldn't belong to an 'ErrMsg' to begin with, as it might potentially lead to the construction of
+"impossible states" (e.g. a waning with 'SevInfo', for example).
+
+'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].
+newtype Messages e = Messages (Bag (ErrMsg e))
+
+instance Functor Messages where
+  fmap f (Messages xs) = Messages (mapBag (fmap f) xs)
+
+emptyMessages :: Messages e
+emptyMessages = Messages emptyBag
+
+mkMessages :: Bag (ErrMsg e) -> Messages e
+mkMessages = Messages
+
+isEmptyMessages :: Messages e -> Bool
+isEmptyMessages (Messages msgs) = isEmptyBag msgs
+
+addMessage :: ErrMsg e -> Messages e -> Messages e
+addMessage x (Messages xs) = Messages (x `consBag` xs)
+
+-- | Joins two collections of messages together.
+unionMessages :: Messages e -> Messages e -> Messages e
+unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2)
+
+type WarningMessages = Bag (ErrMsg ErrDoc)
+type ErrorMessages   = Bag (ErrMsg ErrDoc)
+
 type MsgDoc          = SDoc
-type WarnMsg         = ErrMsg
+type WarnMsg         = ErrMsg ErrDoc
+
+{-
+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 boundaries (i.e. from the 'Driver' upwards).
 
--- | The main 'GHC' error type.
-data ErrMsg = ErrMsg
+For now (see #18516) this class is very boring as it has only one 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 TcRnMessage
+  = TcRnOutOfScope ..
+  | ..
+
+We could then define how a 'TcRnMessage' is displayed to the user. Rather than scattering pieces of
+'SDoc' around the codebase, we would write once for all:
+
+instance RenderableDiagnostic TcRnMessage where
+  renderDiagnostic = \case
+    TcRnOutOfScope .. -> ErrDoc [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 'RenderableDiagnostic' constraint.
+
+-}
+
+-- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'ErrDoc'.
+-- For more information, see Note [Rendering Messages].
+class RenderableDiagnostic a where
+  renderDiagnostic :: a -> ErrDoc
+
+-- | The main 'GHC' error type, parameterised over the /domain-specific/ message.
+data ErrMsg e = ErrMsg
    { errMsgSpan        :: SrcSpan
       -- ^ The SrcSpan is used for sorting errors into line-number order
    , errMsgContext     :: PrintUnqualified
-   , errMsgDoc         :: ErrDoc
+   , errMsgDiagnostic  :: e
    , errMsgSeverity    :: Severity
    , errMsgReason      :: WarnReason
-   }
+   } deriving Functor
 
 -- | Categorise error msgs by their importance.  This is so each section can
 -- be rendered visually distinct.  See Note [Error report] for where these come
@@ -71,9 +159,8 @@ data ErrDoc = ErrDoc {
         errDocSupplementary :: [MsgDoc]
         }
 
-unionMessages :: Messages -> Messages -> Messages
-unionMessages (warns1, errs1) (warns2, errs2) =
-  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
+instance RenderableDiagnostic ErrDoc where
+  renderDiagnostic = id
 
 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
 errDoc = ErrDoc
@@ -101,19 +188,19 @@ data Severity
     --     plus "warning:" or "error:",
     --     added by mkLocMessags
     --   o Output is intended for end users
-  deriving Show
+  deriving (Eq, Show)
 
 
 instance ToJson Severity where
   json s = JSString (show s)
 
-instance Show ErrMsg where
+instance Show (ErrMsg ErrDoc) where
     show = showErrMsg
 
 -- | Shows an 'ErrMsg'.
-showErrMsg :: ErrMsg -> String
+showErrMsg :: RenderableDiagnostic a => ErrMsg a -> String
 showErrMsg err =
-  renderWithContext defaultSDocContext (vcat (errDocImportant $ errMsgDoc err))
+  renderWithContext defaultSDocContext (vcat (errDocImportant $ renderDiagnostic $ errMsgDiagnostic err))
 
 pprMessageBag :: Bag MsgDoc -> SDoc
 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
@@ -244,7 +331,7 @@ getCaretDiagnostic severity (RealSrcSpan span _) =
                       | otherwise = ""
         caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
 
-makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
+makeIntoWarning :: WarnReason -> ErrMsg e -> ErrMsg e
 makeIntoWarning reason err = err
     { errMsgSeverity = SevWarning
     , errMsgReason = reason }
@@ -253,22 +340,23 @@ makeIntoWarning reason err = err
 -- Creating ErrMsg(s)
 --
 
-mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
+mk_err_msg
+  :: Severity -> SrcSpan -> PrintUnqualified -> e -> ErrMsg e
 mk_err_msg sev locn print_unqual err
  = ErrMsg { errMsgSpan = locn
           , errMsgContext = print_unqual
-          , errMsgDoc = err
+          , errMsgDiagnostic = err
           , errMsgSeverity = sev
           , errMsgReason = NoReason }
 
-mkErrDoc :: SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
-mkErrDoc = mk_err_msg SevError
+mkErr :: SrcSpan -> PrintUnqualified -> e -> ErrMsg e
+mkErr = mk_err_msg SevError
 
-mkLongErrMsg, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
+mkLongErrMsg, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg ErrDoc
 -- ^ A long (multi-line) error message
-mkErrMsg, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
+mkErrMsg, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg ErrDoc
 -- ^ A short (one-line) error message
-mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan ->                     MsgDoc            -> ErrMsg
+mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan ->                     MsgDoc            -> ErrMsg ErrDoc
 -- ^ Variant that doesn't care about qualified/unqualified names
 
 mkLongErrMsg   locn unqual msg extra = mk_err_msg SevError   locn unqual        (ErrDoc [msg] [] [extra])
@@ -277,3 +365,27 @@ mkPlainErrMsg  locn        msg       = mk_err_msg SevError   locn alwaysQualify
 mkLongWarnMsg  locn unqual msg extra = mk_err_msg SevWarning locn unqual        (ErrDoc [msg] [] [extra])
 mkWarnMsg      locn unqual msg       = mk_err_msg SevWarning locn unqual        (ErrDoc [msg] [] [])
 mkPlainWarnMsg locn        msg       = mk_err_msg SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
+
+--
+-- Queries
+--
+
+isErrorMessage :: ErrMsg e -> Bool
+isErrorMessage = (== SevError) . errMsgSeverity
+
+isWarningMessage :: ErrMsg e -> Bool
+isWarningMessage = not . isErrorMessage
+
+errorsFound :: Messages e -> Bool
+errorsFound (Messages msgs) = any isErrorMessage msgs
+
+getWarningMessages :: Messages e -> Bag (ErrMsg e)
+getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs
+
+getErrorMessages :: Messages e -> Bag (ErrMsg e)
+getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs
+
+-- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the
+-- second the errors.
+partitionMessages :: Messages e -> (Bag (ErrMsg e), Bag (ErrMsg e))
+partitionMessages (Messages xs) = partitionBag isWarningMessage xs
diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs
index 657178cc51..200905881a 100644
--- a/compiler/GHC/Types/SourceError.hs
+++ b/compiler/GHC/Types/SourceError.hs
@@ -27,7 +27,7 @@ srcErrorMessages (SourceError msgs) = msgs
 throwErrors :: MonadIO io => ErrorMessages -> io a
 throwErrors = liftIO . throwIO . mkSrcErr
 
-throwOneError :: MonadIO io => ErrMsg -> io a
+throwOneError :: MonadIO io => ErrMsg ErrDoc -> io a
 throwOneError = throwErrors . unitBag
 
 -- | A source error is an error that is caused by one or more errors in the
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 2e47601e8c..9ecbb1465c 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -29,7 +29,7 @@ module GHC.Utils.Error (
 
         -- ** Construction
         emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
-        mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
+        mkErrMsg, mkPlainErrMsg, mkErr, mkLongErrMsg, mkWarnMsg,
         mkPlainWarnMsg,
         mkLongWarnMsg,
 
@@ -121,15 +121,6 @@ orValid _       v = v
 -- Collecting up messages for later ordering and printing.
 
 ----------------
-emptyMessages :: Messages
-emptyMessages = (emptyBag, emptyBag)
-
-isEmptyMessages :: Messages -> Bool
-isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
-
-errorsFound :: DynFlags -> Messages -> Bool
-errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
-
 formatErrDoc :: SDocContext -> ErrDoc -> SDoc
 formatErrDoc ctx (ErrDoc important context supplementary)
   = case msgs of
@@ -140,18 +131,18 @@ formatErrDoc ctx (ErrDoc important context supplementary)
         [important, context, supplementary]
     starred = (bullet<+>) . vcat
 
-pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
+pprErrMsgBagWithLoc :: Bag (ErrMsg ErrDoc) -> [SDoc]
 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
 
-pprLocErrMsg :: ErrMsg -> SDoc
+pprLocErrMsg :: RenderableDiagnostic e => ErrMsg e -> SDoc
 pprLocErrMsg (ErrMsg { errMsgSpan      = s
-                     , errMsgDoc       = doc
+                     , errMsgDiagnostic = e
                      , errMsgSeverity  = sev
                      , errMsgContext   = unqual })
   = sdocWithContext $ \ctx ->
-    withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc)
+    withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx $ renderDiagnostic e)
 
-sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
+sortMsgBag :: Maybe DynFlags -> Bag (ErrMsg e) -> [ErrMsg e]
 sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
   where cmp
           | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
index 39da5f1292..a29dc194dd 100644
--- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -4,6 +4,7 @@ module Main where
 
 import Language.Haskell.TH (runQ)
 import GHC.Types.Basic
+import GHC.Types.Error
 import GHC.ThToHs
 import GHC.Driver.Session
 import GHC.Core.TyCo.Ppr
@@ -42,8 +43,9 @@ main = do
                        () |]
       let hs_t = fromRight (error "convertToHsType") $
                  convertToHsType Generated noSrcSpan th_t
-      ((warnings, errors), mres) <-
+      (messages, mres) <-
         tcRnType hsc_env SkolemiseFlexi True hs_t
+      let (warnings, errors) = partitionMessages messages
       case mres of
         Nothing -> do
           printBagOfErrors dflags warnings