Compute Severity of diagnostics at birth

This commit further expand on the design for #18516 by getting rid of
the `defaultReasonSeverity` in favour of a function called
`diagReasonSeverity` which correctly takes the `DynFlags` as input. The
idea is to compute the `Severity` and the `DiagnosticReason` of each
message "at birth", without doing any later re-classifications, which
are potentially error prone, as the `DynFlags` might evolve during the
course of the program.

In preparation for a proper refactoring, now `pprWarning` from the
Parser.Ppr module has been renamed to `mkParserWarn`, which now takes a
`DynFlags` as input.

We also get rid of the reclassification we were performing inside `printOrThrowWarnings`.

Last but not least, this commit removes the need for reclassify inside GHC.Tc.Errors,
and also simplifies the implementation of `maybeReportError`.

Update Haddock submodule

29 files changed, 465 insertions, 452 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index f77ab69532..4ba5e9b68a 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -907,8 +907,8 @@ checkNewInteractiveDynFlags logger dflags0 = do
   -- We currently don't support use of StaticPointers in expressions entered on
   -- the REPL. See #12356.
   if xopt LangExt.StaticPointers dflags0
-  then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag
-            [mkPlainMsgEnvelope Session.WarningWithoutFlag interactiveSrcSpan
+  then do liftIO $ printOrThrowDiagnostics logger dflags0 $ listToBag
+            [mkPlainMsgEnvelope dflags0 Session.WarningWithoutFlag interactiveSrcSpan
              $ text "StaticPointers is not supported in GHCi interactive expressions."]
           return $ xopt_unset dflags0 LangExt.StaticPointers
   else return dflags0
@@ -1605,7 +1605,7 @@ getTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream (initParserOpts dflags) source startLoc of
     POk _ ts    -> return ts
-    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
+    PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
 
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
@@ -1616,7 +1616,7 @@ getRichTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream (initParserOpts dflags) source startLoc of
     POk _ ts    -> return $ addSourceToTokens startLoc source ts
-    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
+    PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
 
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
@@ -1796,11 +1796,11 @@ parser str dflags filename =
 
      PFailed pst ->
          let (warns,errs) = getMessages pst in
-         (fmap pprWarning warns, Left (fmap pprError errs))
+         (fmap (mkParserWarn dflags) warns, Left (fmap mkParserErr errs))
 
      POk pst rdr_module ->
          let (warns,_) = getMessages pst in
-         (fmap pprWarning warns, Right rdr_module)
+         (fmap (mkParserWarn dflags) warns, Right rdr_module)
 
 -- -----------------------------------------------------------------------------
 -- | Find the package environment (if one exists)
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 116e26b3d1..3438f372fc 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -2774,7 +2774,7 @@ addMsg is_error env msgs msg
                           , isGoodSrcSpan span ] of
                []    -> noSrcSpan
                (s:_) -> s
-   mk_msg msg = mkLocMessage (mkMCDiagnostic WarningWithoutFlag) msg_span
+   mk_msg msg = mkLocMessage (mkMCDiagnostic (le_dynflags env) WarningWithoutFlag) msg_span
                              (msg $$ context)
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 8b1b94b14f..3c6ff07a65 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -64,6 +64,7 @@ import GHC.Types.Name.Env
 import GHC.Types.SrcLoc
 import GHC.Types.Error
 
+import GHC.Utils.Error ( errorDiagnostic )
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger )
 import GHC.Utils.Monad
@@ -820,7 +821,7 @@ errorMsgS = errorMsg . text
 
 -- | Output an error to the screen. Does not cause the compiler to die.
 errorMsg :: SDoc -> CoreM ()
-errorMsg = msg (mkMCDiagnostic ErrorWithoutFlag)
+errorMsg doc = msg errorDiagnostic doc
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
 fatalErrorMsgS :: String -> CoreM ()
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 5caae8bf77..8efebd0cd5 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -55,6 +55,7 @@ import GHC.Types.Var.Env
 import GHC.Types.Id
 import GHC.Types.Error
 
+import GHC.Utils.Error ( mkMCDiagnostic )
 import GHC.Utils.Monad    ( foldlM )
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
@@ -809,7 +810,7 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn
   where
     allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
     doWarn reason =
-      msg (mkMCDiagnostic reason)
+      msg (mkMCDiagnostic dflags reason)
         (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
                 2 (vcat [ text "when specialising" <+> quotes (ppr caller)
                         | caller <- callers])
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 4789af6fe7..5c45858570 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -107,7 +107,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 pprError (getErrorMessages pst))
+        PFailed pst -> throwErrors (fmap 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.
@@ -802,8 +802,8 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
                          Nothing -- GHC API buffer support not supported
                          [] -- No exclusions
          case r of
-            Nothing -> throwOneError (mkPlainMsgEnvelope ErrorWithoutFlag
-                                        loc (text "module" <+> ppr modname <+> text "was not found"))
+            Nothing -> throwOneError (mkPlainErrorMsgEnvelope loc
+                                     (text "module" <+> ppr modname <+> text "was not found"))
             Just (Left err) -> throwErrors err
             Just (Right summary) -> return summary
 
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 6e843d2ea4..3fff8ab65c 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -30,7 +30,7 @@ import GHC.Prelude
 
 import GHC.Driver.Ppr
 import GHC.Driver.Session
-import GHC.Driver.Errors ( printOrThrowWarnings )
+import GHC.Driver.Errors ( printOrThrowDiagnostics )
 
 import GHC.Runtime.Context
 import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
@@ -70,7 +70,7 @@ import Data.IORef
 runHsc :: HscEnv -> Hsc a -> IO a
 runHsc hsc_env (Hsc hsc) = do
     (a, w) <- hsc hsc_env emptyBag
-    printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w
+    printOrThrowDiagnostics (hsc_logger hsc_env) (hsc_dflags hsc_env) w
     return a
 
 -- | Switches in the DynFlags and Plugins from the InteractiveContext
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 9127e7d094..b6fdee5c9b 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,5 +1,5 @@
 module GHC.Driver.Errors (
-    printOrThrowWarnings
+    printOrThrowDiagnostics
   , printBagOfErrors
   , handleFlagWarnings
   , partitionMessageBag
@@ -8,7 +8,7 @@ module GHC.Driver.Errors (
 import GHC.Driver.Session
 import GHC.Data.Bag
 import GHC.Utils.Exception
-import GHC.Utils.Error ( formatBulleted, sortMsgBag )
+import GHC.Utils.Error ( formatBulleted, sortMsgBag, mkPlainMsgEnvelope )
 import GHC.Types.SourceError ( mkSrcErr )
 import GHC.Prelude
 import GHC.Types.SrcLoc
@@ -40,10 +40,10 @@ handleFlagWarnings logger dflags warns = do
 
       -- It would be nicer if warns :: [Located SDoc], but that
       -- has circular import problems.
-      bag = listToBag [ mkPlainMsgEnvelope WarningWithoutFlag loc (text warn)
+      bag = listToBag [ mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text warn)
                       | CmdLine.Warn _ (L loc warn) <- warns' ]
 
-  printOrThrowWarnings logger dflags bag
+  printOrThrowDiagnostics logger dflags bag
 
 -- Given a warn reason, check to see if it's associated -W opt is enabled
 shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
@@ -54,40 +54,11 @@ shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag
 shouldPrintWarning _ _
   = True
 
--- | Given a bag of warnings, turn them into an exception if
--- -Werror is enabled, or print them out otherwise.
-printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
-printOrThrowWarnings logger dflags warns = do
-  let (make_error, warns') =
-        mapAccumBagL
-          (\make_err warn ->
-            case warn_msg_severity dflags warn of
-              SevWarning ->
-                (make_err, warn)
-              SevError ->
-                (True, set_severity SevError warn))
-          False warns
-  if make_error
-    then throwIO (mkSrcErr warns')
-    else printBagOfErrors logger dflags warns
-
-  where
-
-    -- | Sets the 'Severity' of the input 'WarnMsg' according to the 'DynFlags'.
-    warn_msg_severity :: DynFlags -> WarnMsg -> Severity
-    warn_msg_severity dflags msg =
-      case diagnosticReason (errMsgDiagnostic msg) of
-        ErrorWithoutFlag   -> SevError
-        WarningWithoutFlag ->
-          if gopt Opt_WarnIsError dflags
-            then SevError
-            else SevWarning
-        WarningWithFlag wflag ->
-          if wopt_fatal wflag dflags
-            then SevError
-            else SevWarning
-
-    -- | Adjust the 'Severity' of the input 'WarnMsg'.
-    set_severity :: Severity -> WarnMsg -> MsgEnvelope DiagnosticMessage
-    set_severity newSeverity msg = msg { errMsgSeverity = newSeverity }
-
+-- | 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)
+  | otherwise
+  = printBagOfErrors logger dflags warns
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 0c67d05d3a..07f1e7acda 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -281,15 +281,16 @@ handleWarnings = do
     dflags <- getDynFlags
     logger <- getLogger
     w <- getWarnings
-    liftIO $ printOrThrowWarnings logger dflags w
+    liftIO $ printOrThrowDiagnostics logger dflags w
     clearWarnings
 
 -- | 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
-    let warns = fmap pprWarning warnings
-        errs  = fmap pprError   errors
+    dflags <- getDynFlags
+    let warns = fmap (mkParserWarn dflags) warnings
+        errs  = fmap mkParserErr errors
     logDiagnostics warns
     when (not $ isEmptyBag errs) $ throwErrors errs
 
@@ -297,10 +298,10 @@ logWarningsReportErrors (warnings,errors) = do
 -- contain at least one error (e.g. coming from PFailed)
 handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a
 handleWarningsThrowErrors (warnings, errors) = do
-    let warns = fmap pprWarning warnings
-        errs  = fmap pprError   errors
-    logDiagnostics warns
     dflags <- getDynFlags
+    let warns = fmap (mkParserWarn dflags) warnings
+        errs  = fmap mkParserErr           errors
+    logDiagnostics warns
     logger <- getLogger
     let (wWarns, wErrs) = partitionMessageBag warns
     liftIO $ printBagOfErrors logger dflags wWarns
@@ -415,7 +416,7 @@ hscParse' mod_summary
         PFailed pst ->
             handleWarningsThrowErrors (getMessages pst)
         POk pst rdr_module -> do
-            let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)
+            let (warns, errs) = bimap (fmap (mkParserWarn dflags)) (fmap mkParserErr) (getMessages pst)
             logDiagnostics warns
             liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"
                         FormatHaskell (ppr rdr_module)
@@ -563,7 +564,7 @@ tcRnModule' sum save_rn_syntax mod = do
     when (not (safeHaskellModeEnabled dflags)
           && wopt Opt_WarnMissingSafeHaskellMode dflags) $
         logDiagnostics $ unitBag $
-        mkPlainMsgEnvelope reason (getLoc (hpm_module mod)) $
+        mkPlainMsgEnvelope dflags reason (getLoc (hpm_module mod)) $
         warnMissingSafeHaskellMode
 
     tcg_res <- {-# SCC "Typecheck-Rename" #-}
@@ -591,13 +592,13 @@ tcRnModule' sum save_rn_syntax mod = do
               True
                 | safeHaskell dflags == Sf_Safe -> return ()
                 | otherwise -> (logDiagnostics $ unitBag $
-                       mkPlainMsgEnvelope (WarningWithFlag Opt_WarnSafe)
+                       mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnSafe)
                                           (warnSafeOnLoc dflags) $
                        errSafe tcg_res')
               False | safeHaskell dflags == Sf_Trustworthy &&
                       wopt Opt_WarnTrustworthySafe dflags ->
                       (logDiagnostics $ unitBag $
-                       mkPlainMsgEnvelope (WarningWithFlag Opt_WarnTrustworthySafe)
+                       mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnTrustworthySafe)
                                           (trustworthyOnLoc dflags) $
                        errTwthySafe tcg_res')
               False -> return ()
@@ -1127,22 +1128,22 @@ hscCheckSafeImports tcg_env = do
       case safeLanguageOn dflags of
           True -> do
               -- XSafe: we nuke user written RULES
-              logDiagnostics $ warns (tcg_rules tcg_env')
+              logDiagnostics $ warns dflags (tcg_rules tcg_env')
               return tcg_env' { tcg_rules = [] }
           False
                 -- SafeInferred: user defined RULES, so not safe
               | safeInferOn dflags && not (null $ tcg_rules tcg_env')
-              -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env')
+              -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
 
                 -- Trustworthy OR SafeInferred: with no RULES
               | otherwise
               -> return tcg_env'
 
-    warns rules = listToBag $ map warnRules rules
+    warns dflags rules = listToBag $ map (warnRules dflags) rules
 
-    warnRules :: LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage
-    warnRules (L loc (HsRule { rd_name = n })) =
-        mkPlainMsgEnvelope WarningWithoutFlag (locA loc) $
+    warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage
+    warnRules df (L loc (HsRule { rd_name = n })) =
+        mkPlainMsgEnvelope df WarningWithoutFlag (locA loc) $
             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
 
@@ -1218,9 +1219,9 @@ checkSafeImports tcg_env
     cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
     cond' v1 v2
         | imv_is_safe v1 /= imv_is_safe v2
-        = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag (imv_span v1)
-              (text "Module" <+> ppr (imv_name v1) <+>
-              (text $ "is imported both as a safe and unsafe import!"))
+        = throwOneError $ mkPlainErrorMsgEnvelope (imv_span v1)
+            (text "Module" <+> ppr (imv_name v1) <+>
+            (text $ "is imported both as a safe and unsafe import!"))
         | otherwise
         = return v1
 
@@ -1286,7 +1287,7 @@ hscCheckSafe' m l = do
         iface <- lookup' m
         case iface of
             -- can't load iface to check trust!
-            Nothing -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag l
+            Nothing -> throwOneError $ mkPlainErrorMsgEnvelope l
                          $ text "Can't load the interface file for" <+> ppr m
                            <> text ", to check that it can be safely imported"
 
@@ -1304,7 +1305,7 @@ hscCheckSafe' m l = do
                     warns = if wopt Opt_WarnInferredSafeImports dflags
                                 && safeLanguageOn dflags
                                 && trust == Sf_SafeInferred
-                                then inferredImportWarn
+                                then inferredImportWarn dflags
                                 else emptyBag
                     -- General errors we throw but Safe errors we log
                     errs = case (safeM, safeP) of
@@ -1318,23 +1319,25 @@ hscCheckSafe' m l = do
 
                 where
                     state = hsc_units hsc_env
-                    inferredImportWarn = unitBag
-                        $ mkShortMsgEnvelope (WarningWithFlag Opt_WarnInferredSafeImports)
+                    inferredImportWarn dflags = unitBag
+                        $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports)
                                              l (pkgQual state)
                         $ sep
                             [ text "Importing Safe-Inferred module "
                                 <> ppr (moduleName m)
                                 <> text " from explicitly Safe module"
                             ]
-                    pkgTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $
-                        sep [ ppr (moduleName m)
+                    pkgTrustErr = unitBag
+                      $ mkShortErrorMsgEnvelope l (pkgQual state)
+                      $ 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 $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $
-                        sep [ ppr (moduleName m)
+                    modTrustErr = unitBag
+                      $ mkShortErrorMsgEnvelope l (pkgQual state)
+                      $ sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
                             , text "The module itself isn't safe." ]
 
@@ -1379,7 +1382,7 @@ checkPkgTrust pkgs = do
             | unitIsTrusted $ unsafeLookupUnitId state pkg
             = acc
             | otherwise
-            = (:acc) $ mkShortMsgEnvelope ErrorWithoutFlag noSrcSpan (pkgQual state)
+            = (:acc) $ mkShortErrorMsgEnvelope noSrcSpan (pkgQual state)
                      $ pprWithUnitState state
                      $ text "The package ("
                         <> ppr pkg
@@ -1405,7 +1408,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
     let reason = WarningWithFlag Opt_WarnUnsafe
     when (wopt Opt_WarnUnsafe dflags)
          (logDiagnostics $ unitBag $
-             mkPlainMsgEnvelope reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
+             mkPlainMsgEnvelope dflags reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
 
     liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
     -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
@@ -1637,7 +1640,7 @@ 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 pprWarning warns `unionBags` fmap pprError errs), cmm)
+                  return (mkMessages (fmap (mkParserWarn dflags) warns `unionBags` fmap mkParserErr errs), cmm)
     liftIO $ do
         dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
 
@@ -1998,7 +2001,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do
     case is of
         [L _ i] -> return i
         _ -> liftIO $ throwOneError $
-                 mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $
+                 mkPlainErrorMsgEnvelope noSrcSpan $
                      text "parse error in import declaration"
 
 -- | Typecheck an expression (but don't run it)
@@ -2027,7 +2030,7 @@ hscParseExpr expr = do
   maybe_stmt <- hscParseStmt expr
   case maybe_stmt of
     Just (L _ (BodyStmt _ expr _ _)) -> return expr
-    _ -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan
+    _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan
       (text "not an expression:" <+> quotes (text expr))
 
 hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 4036208954..b677f63681 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -319,7 +319,7 @@ warnMissingHomeModules hsc_env mod_graph =
           4
           (sep (map ppr missing))
     warn =
-      mkPlainMsgEnvelope (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
+      mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
 
 -- | Describes which modules of the module graph need to be loaded.
 data LoadHowMuch
@@ -385,7 +385,7 @@ warnUnusedPackages = do
                    requestedArgs
 
     let warn =
-          mkPlainMsgEnvelope (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg
+          mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg
         msg = vcat [ text "The following packages were specified" <+>
                      text "via -package or -package-id flags,"
                    , text "but were not needed for compilation:"
@@ -2214,15 +2214,15 @@ warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
 warnUnnecessarySourceImports sccs = do
   dflags <- getDynFlags
   when (wopt Opt_WarnUnusedImports dflags)
-    (logWarnings (listToBag (concatMap (check . flattenSCC) sccs)))
-  where check ms =
+    (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
+  where check dflags ms =
            let mods_in_this_cycle = map ms_mod_name ms in
-           [ warn i | m <- ms, i <- ms_home_srcimps m,
-                      unLoc i `notElem`  mods_in_this_cycle ]
+           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
+                             unLoc i `notElem`  mods_in_this_cycle ]
 
-        warn :: Located ModuleName -> WarnMsg
-        warn (L loc mod) =
-           mkPlainMsgEnvelope WarningWithoutFlag loc
+        warn :: DynFlags -> Located ModuleName -> WarnMsg
+        warn dflags (L loc mod) =
+           mkPlainMsgEnvelope dflags WarningWithoutFlag loc
                 (text "{-# SOURCE #-} unnecessary in import of "
                  <+> quotes (ppr mod))
 
@@ -2295,7 +2295,7 @@ 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 $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $
+                    else return $ Left $ unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $
                            text "can't find file:" <+> text file
         getRootSummary Target { targetId = TargetModule modl
                               , targetAllowObjCode = obj_allowed
@@ -2730,7 +2730,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
               | otherwise = HsSrcFile
 
         when (pi_mod_name /= wanted_mod) $
-                throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $
+                throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $
                               text "File name does not match module name:"
                               $$ text "Saw:" <+> quotes (ppr pi_mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -2742,7 +2742,7 @@ 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 $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $
+            in throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $
                 text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
                 $$ if gopt Opt_BuildingCabalPackage dflags
                     then parens (text "Try adding" <+> quotes (ppr pi_mod_name)
@@ -2855,7 +2855,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 pprError) mimps)
+          return (first (fmap mkParserErr) mimps)
   return PreprocessedImports {..}
 
 
@@ -2902,21 +2902,21 @@ withDeferredDiagnostics f = do
 noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DiagnosticMessage
 -- ToDo: we don't have a proper line number for this error
 noModError hsc_env loc wanted_mod err
-  = mkPlainMsgEnvelope ErrorWithoutFlag loc $ cannotFindModule hsc_env wanted_mod err
+  = mkPlainErrorMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err
 
 noHsFileErr :: SrcSpan -> String -> ErrorMessages
 noHsFileErr loc path
-  = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc $ text "Can't find" <+> text path
+  = unitBag $ mkPlainErrorMsgEnvelope loc $ text "Can't find" <+> text path
 
 moduleNotFoundErr :: ModuleName -> ErrorMessages
 moduleNotFoundErr mod
-  = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $
+  = unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $
         text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
 
 multiRootsErr :: [ModSummary] -> IO ()
 multiRootsErr [] = panic "multiRootsErr"
 multiRootsErr summs@(summ1:_)
-  = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $
+  = throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $
         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 9324755d3d..ea1bf1f501 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -305,7 +305,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
         -> return Nothing
 
     fail ->
-        throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag srcloc $
+        throwOneError $ mkPlainErrorMsgEnvelope srcloc $
              cannotFindModule hsc_env imp fail
 
 -----------------------------
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 39ccdc7c21..1a42d8402f 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -36,7 +36,7 @@ import GHC.Prelude
 
 import GHC.Driver.Session
 import GHC.Driver.Env
-import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors )
+import GHC.Driver.Errors ( printOrThrowDiagnostics, printBagOfErrors )
 
 import GHC.Utils.Monad
 import GHC.Utils.Exception
@@ -147,7 +147,7 @@ logWarnings :: GhcMonad m => WarningMessages -> m ()
 logWarnings warns = do
   dflags <- getSessionDynFlags
   logger <- getLogger
-  liftIO $ printOrThrowWarnings logger dflags warns
+  liftIO $ printOrThrowDiagnostics logger dflags warns
 
 -- -----------------------------------------------------------------------------
 -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 514c3c9701..e79d1ecab9 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -151,7 +151,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
   where
     srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
     handler (ProgramError msg) = return $ Left $ unitBag $
-        mkPlainMsgEnvelope ErrorWithoutFlag srcspan $ text msg
+        mkPlainErrorMsgEnvelope srcspan $ text msg
     handler ex = throwGhcExceptionIO ex
 
 -- ---------------------------------------------------------------------------
@@ -1255,7 +1255,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 pprError errs)
+              Left errs -> throwErrors (fmap mkParserErr errs)
               Right (src_imps,imps,L _ mod_name) -> return
                   (Just buf, mod_name, imps, src_imps)
 
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index f5be46006a..a16f70cded 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -105,9 +105,9 @@ import GHC.Types.CostCentre.State
 import GHC.Types.TyThing
 import GHC.Types.Error
 
+import GHC.Utils.Error
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
-import GHC.Utils.Error
 
 import Data.IORef
 
@@ -460,7 +460,8 @@ diagnosticDs :: DiagnosticReason -> SDoc -> DsM ()
 diagnosticDs reason warn
   = do { env <- getGblEnv
        ; loc <- getSrcSpanDs
-       ; let msg = mkShortMsgEnvelope reason loc (ds_unqual env) warn
+       ; dflags <- getDynFlags
+       ; let msg = mkShortMsgEnvelope dflags reason loc (ds_unqual env) warn
        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags
@@ -473,7 +474,7 @@ errDs :: SDoc -> DsM ()
 errDs err
   = do  { env <- getGblEnv
         ; loc <- getSrcSpanDs
-        ; let msg = mkShortMsgEnvelope ErrorWithoutFlag loc (ds_unqual env) err
+        ; let msg = mkShortErrorMsgEnvelope loc (ds_unqual env) err
         ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Issue an error, but return the expression for (), so that we can continue
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index beb7aadbbb..f4e8b449f5 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -43,6 +43,7 @@ import GHC.Types.Name.Shape
 
 import GHC.Utils.Outputable
 import GHC.Utils.Misc
+import GHC.Utils.Error
 import GHC.Utils.Fingerprint
 import GHC.Utils.Panic
 
@@ -76,7 +77,7 @@ failWithRn doc = do
     errs_var <- fmap sh_if_errs getGblEnv
     errs <- readTcRef errs_var
     -- TODO: maybe associate this with a source location?
-    writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan doc)
+    writeTcRef errs_var (errs `snocBag` mkPlainErrorMsgEnvelope noSrcSpan doc)
     failM
 
 -- | What we have is a generalized ModIface, which corresponds to
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index 86fff45160..735f6ceb16 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -1433,7 +1433,7 @@ load_dyn interp hsc_env crash_early dll = do
         else
           when (wopt Opt_WarnMissedExtraSharedLib dflags)
             $ putLogMsg logger dflags
-                (mkMCDiagnostic $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
+                (mkMCDiagnostic dflags $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
                   noSrcSpan $ withPprStyle defaultUserStyle (note err)
   where
     dflags = hsc_dflags hsc_env
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index c0c09d6173..7b9f2e64a0 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -3,8 +3,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module GHC.Parser.Errors.Ppr
-   ( pprWarning
-   , pprError
+   ( mkParserWarn
+   , mkParserErr
    )
 where
 
@@ -24,27 +24,32 @@ import GHC.Hs.Expr (prependQualified,HsExpr(..))
 import GHC.Hs.Type (pprLHsContext)
 import GHC.Builtin.Names (allNameStrings)
 import GHC.Builtin.Types (filterCTuple)
+import GHC.Driver.Session (DynFlags)
+import GHC.Utils.Error (diagReasonSeverity)
 
-mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
-mkParserErr span doc = MsgEnvelope
+mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
+mk_parser_err span doc = MsgEnvelope
    { errMsgSpan        = span
    , errMsgContext     = alwaysQualify
    , errMsgDiagnostic  = DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag
    , errMsgSeverity    = SevError
    }
 
-mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
-mkParserWarn flag span doc = MsgEnvelope
+mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
+mk_parser_warn df flag span doc = MsgEnvelope
    { errMsgSpan        = span
    , errMsgContext     = alwaysQualify
-   , errMsgDiagnostic  = DiagnosticMessage (mkDecorated [doc]) (WarningWithFlag flag)
-   , errMsgSeverity    = SevWarning
+   , errMsgDiagnostic  = DiagnosticMessage (mkDecorated [doc]) reason
+   , errMsgSeverity    = diagReasonSeverity df reason
    }
+  where
+    reason :: DiagnosticReason
+    reason = WarningWithFlag flag
 
-pprWarning :: PsWarning -> MsgEnvelope DiagnosticMessage
-pprWarning = \case
+mkParserWarn :: DynFlags -> PsWarning -> MsgEnvelope DiagnosticMessage
+mkParserWarn df = \case
    PsWarnTab loc tc
-      -> mkParserWarn Opt_WarnTabs loc $
+      -> mk_parser_warn df Opt_WarnTabs loc $
           text "Tab character found here"
             <> (if tc == 1
                 then text ""
@@ -53,7 +58,7 @@ pprWarning = \case
             $+$ text "Please use spaces instead."
 
    PsWarnTransitionalLayout loc reason
-      -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $
+      -> mk_parser_warn df Opt_WarnAlternativeLayoutRuleTransitional loc $
             text "transitional layout will not be accepted in the future:"
             $$ text (case reason of
                TransLayout_Where -> "`where' clause at the same depth as implicit layout block"
@@ -61,20 +66,20 @@ pprWarning = \case
             )
 
    PsWarnUnrecognisedPragma loc
-      -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $
+      -> mk_parser_warn df Opt_WarnUnrecognisedPragmas loc $
             text "Unrecognised pragma"
 
    PsWarnHaddockInvalidPos loc
-      -> mkParserWarn Opt_WarnInvalidHaddock loc $
+      -> mk_parser_warn df Opt_WarnInvalidHaddock loc $
             text "A Haddock comment cannot appear in this position and will be ignored."
 
    PsWarnHaddockIgnoreMulti loc
-      -> mkParserWarn Opt_WarnInvalidHaddock loc $
+      -> mk_parser_warn df Opt_WarnInvalidHaddock loc $
             text "Multiple Haddock comments for a single entity are not allowed." $$
             text "The extraneous comment will be ignored."
 
    PsWarnStarBinder loc
-      -> mkParserWarn Opt_WarnStarBinder loc $
+      -> mk_parser_warn df Opt_WarnStarBinder loc $
             text "Found binding occurrence of" <+> quotes (text "*")
             <+> text "yet StarIsType is enabled."
          $$ text "NB. To use (or export) this operator in"
@@ -82,7 +87,7 @@ pprWarning = \case
          $$ text "    including the definition module, you must qualify it."
 
    PsWarnStarIsType loc
-      -> mkParserWarn Opt_WarnStarIsType loc $
+      -> mk_parser_warn df Opt_WarnStarIsType loc $
              text "Using" <+> quotes (text "*")
              <+> text "(or its Unicode variant) to mean"
              <+> quotes (text "Data.Kind.Type")
@@ -92,7 +97,7 @@ pprWarning = \case
            <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
 
    PsWarnImportPreQualified loc
-      -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $
+      -> mk_parser_warn df Opt_WarnPrepositiveQualifiedModule loc $
             text "Found" <+> quotes (text "qualified")
              <+> text "in prepositive position"
          $$ text "Suggested fix: place " <+> quotes (text "qualified")
@@ -100,7 +105,7 @@ pprWarning = \case
          $$ text "To allow this, enable language extension 'ImportQualifiedPost'"
 
    PsWarnOperatorWhitespaceExtConflict loc sym
-      -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $
+      -> mk_parser_warn df Opt_WarnOperatorWhitespaceExtConflict loc $
          let mk_prefix_msg operator_symbol extension_name syntax_meaning =
                   text "The prefix use of a" <+> quotes (text operator_symbol)
                     <+> text "would denote" <+> text syntax_meaning
@@ -115,7 +120,7 @@ pprWarning = \case
 
 
    PsWarnOperatorWhitespace loc sym occ_type
-      -> mkParserWarn Opt_WarnOperatorWhitespace loc $
+      -> mk_parser_warn df Opt_WarnOperatorWhitespace loc $
          let mk_msg occ_type_str =
                   text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)
                     <+> text "might be repurposed as special syntax"
@@ -127,8 +132,8 @@ pprWarning = \case
            OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"
            OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"
 
-pprError :: PsError -> MsgEnvelope DiagnosticMessage
-pprError err = mkParserErr (errLoc err) $ vcat
+mkParserErr :: PsError -> MsgEnvelope DiagnosticMessage
+mkParserErr err = mk_parser_err (errLoc err) $ vcat
    (pp_err (errDesc err) : map pp_hint (errHints err))
 
 pp_err :: PsErrorDesc -> SDoc
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index a80620eed4..c45cae45ca 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -48,6 +48,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Monad
+import GHC.Utils.Error
 import GHC.Utils.Exception as Exception
 
 import GHC.Data.StringBuffer
@@ -90,7 +91,7 @@ getImports popts implicit_prelude buf filename source_filename = do
       -- don't log warnings: they'll be reported when we parse the file
       -- for real.  See #2500.
       if not (isEmptyBag errs)
-        then throwIO $ mkSrcErr (fmap pprError errs)
+        then throwIO $ mkSrcErr (fmap mkParserErr errs)
         else
           let   hsmod = unLoc rdr_module
                 mb_mod = hsmodName hsmod
@@ -314,7 +315,7 @@ checkProcessArgsResult flags
   = when (notNull flags) $
       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
     where mkMsg (L loc flag)
-              = mkPlainMsgEnvelope ErrorWithoutFlag loc $
+              = mkPlainErrorMsgEnvelope loc $
                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
                    text flag)
 
@@ -358,7 +359,7 @@ optionsErrorMsgs unhandled_flags flags_lines _filename
                                 , L l f' <- flags_lines
                                 , f == f' ]
         mkMsg (L flagSpan flag) =
-            mkPlainMsgEnvelope ErrorWithoutFlag flagSpan $
+            mkPlainErrorMsgEnvelope flagSpan $
                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
 
 optionsParseError :: String -> SrcSpan -> a     -- #15053
@@ -371,4 +372,4 @@ optionsParseError str loc =
 
 throwErr :: SrcSpan -> SDoc -> a                -- #15053
 throwErr loc doc =
-  throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc doc
+  throw $ mkSrcErr $ unitBag $ mkPlainErrorMsgEnvelope loc doc
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 412d221794..abdc5e8328 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -75,7 +75,7 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
 
 lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
   = {-# SCC "StgLint" #-}
-    case initL this_mod unarised opts top_level_binds (lint_binds binds) of
+    case initL dflags this_mod unarised opts top_level_binds (lint_binds binds) of
       Nothing  ->
         return ()
       Just msg -> do
@@ -247,6 +247,7 @@ The Lint monad
 newtype LintM a = LintM
     { unLintM :: Module
               -> LintFlags
+              -> DynFlags
               -> StgPprOpts        -- Pretty-printing options
               -> [LintLocInfo]     -- Locations
               -> IdSet             -- Local vars in scope
@@ -281,16 +282,16 @@ pp_binders bs
     pp_binder b
       = hsep [ppr b, dcolon, ppr (idType b)]
 
-initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
-initL this_mod unarised opts locals (LintM m) = do
-  let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag
+initL :: DynFlags -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
+initL dflags this_mod unarised opts locals (LintM m) = do
+  let (_, errs) = m this_mod (LintFlags unarised) dflags opts [] locals emptyBag
   if isEmptyBag errs then
       Nothing
   else
       Just (vcat (punctuate blankLine (bagToList errs)))
 
 instance Applicative LintM where
-      pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs)
+      pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
       (<*>) = ap
       (*>)  = thenL_
 
@@ -299,14 +300,14 @@ instance Monad LintM where
     (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \mod lf opts loc scope errs
-  -> case unLintM m mod lf opts loc scope errs of
-      (r, errs') -> unLintM (k r) mod lf opts loc scope errs'
+thenL m k = LintM $ \mod lf dflags opts loc scope errs
+  -> case unLintM m mod lf dflags opts loc scope errs of
+      (r, errs') -> unLintM (k r) mod lf dflags opts loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \mod lf opts loc scope errs
-  -> case unLintM m mod lf opts loc scope errs of
-      (_, errs') -> unLintM k mod lf opts loc scope errs'
+thenL_ m k = LintM $ \mod lf dflags opts loc scope errs
+  -> case unLintM m mod lf dflags opts loc scope errs of
+      (_, errs') -> unLintM k mod lf dflags opts loc scope errs'
 
 checkL :: Bool -> SDoc -> LintM ()
 checkL True  _   = return ()
@@ -351,37 +352,37 @@ checkPostUnariseId id =
       is_sum <|> is_tuple <|> is_void
 
 addErrL :: SDoc -> LintM ()
-addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
 
-addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
-addErr errs_so_far msg locs
+addErr :: DynFlags -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
+addErr dflags errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
-                     in  mkLocMessage (Err.mkMCDiagnostic WarningWithoutFlag)
+                     in  mkLocMessage (Err.mkMCDiagnostic dflags WarningWithoutFlag)
                                       l (hdr $$ msg)
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \mod lf opts loc scope errs
-   -> unLintM m mod lf opts (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \mod lf dflags opts loc scope errs
+   -> unLintM m mod lf dflags opts (extra_loc:loc) scope errs
 
 addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \mod lf opts loc scope errs
+addInScopeVars ids m = LintM $ \mod lf dflags opts loc scope errs
  -> let
         new_set = mkVarSet ids
-    in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs
+    in unLintM m mod lf dflags opts loc (scope `unionVarSet` new_set) errs
 
 getLintFlags :: LintM LintFlags
-getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs)
+getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
 
 getStgPprOpts :: LintM StgPprOpts
-getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs)
+getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
 
 checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \mod _lf _opts loc scope errs
+checkInScope id = LintM $ \mod _lf dflags _opts loc scope errs
  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
-        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
+        ((), addErr dflags errs (hsep [ppr id, dcolon, ppr (idType id),
                                 text "is out of scope"]) loc)
     else
         ((), errs)
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index c9cd24cf89..522c50f354 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ b/compiler/GHC/SysTools/Process.hs
@@ -310,7 +310,7 @@ builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do
           logInfo logger dflags $ withPprStyle defaultUserStyle msg
           log_loop chan t
         BuildError loc msg -> do
-          putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) (mkSrcSpan loc loc)
+          putLogMsg logger dflags errorDiagnostic (mkSrcSpan loc loc)
               $ withPprStyle defaultUserStyle msg
           log_loop chan t
         EOF ->
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 23cad15976..abb58cd58b 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -66,9 +66,10 @@ import GHC.Data.Maybe
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Utils.FV ( fvVarList, unionFV )
 
-import Control.Monad    ( when, unless )
+import Control.Monad    ( unless,  when )
 import Data.Foldable    ( toList )
 import Data.List        ( partition, mapAccumL, sortBy, unfoldr )
+import Data.Traversable ( for )
 
 import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )
 
@@ -758,24 +759,21 @@ machinery, in cases where it is definitely going to be a no-op.
 
 mkUserTypeErrorReporter :: Reporter
 mkUserTypeErrorReporter ctxt
-  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct
-                      ; maybeReportError ctxt err
+  = mapM_ $ \ct -> do { let err = mkUserTypeError ct
+                      ; maybeReportError ctxt ct err
                       ; addDeferredBinding ctxt err ct }
 
-mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)
-mkUserTypeError ctxt ct = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct
-                        $ important
-                        $ pprUserTypeErrorTy
-                        $ case getUserTypeErrorMsg ct of
-                            Just msg -> msg
-                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
-
+mkUserTypeError :: Ct -> Report
+mkUserTypeError ct = important
+                   $ pprUserTypeErrorTy
+                   $ case getUserTypeErrorMsg ct of
+                       Just msg -> msg
+                       Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
 
 mkGivenErrorReporter :: Reporter
 -- See Note [Given errors]
 mkGivenErrorReporter ctxt cts
   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
-       ; dflags <- getDynFlags
        ; let (implic:_) = cec_encl ctxt
                  -- Always non-empty when mkGivenErrorReporter is called
              ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
@@ -788,7 +786,9 @@ mkGivenErrorReporter ctxt cts
              report = important inaccessible_msg `mappend`
                       mk_relevant_bindings binds_msg
 
-       ; err <- mkEqErr_help (WarningWithFlag Opt_WarnInaccessibleCode) dflags ctxt report ct' ty1 ty2
+       ; report <- mkEqErr_help ctxt report ct' ty1 ty2
+       ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt
+                              (ctLocEnv (ctLoc ct')) report
 
        ; traceTc "mkGivenErrorReporter" (ppr ct)
        ; reportDiagnostic err }
@@ -838,7 +838,7 @@ pattern match which binds some equality constraints.  If we
 find one, we report the insoluble Given.
 -}
 
-mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage))
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report)
                              -- Make error message for a group
                 -> Reporter  -- Deal with lots of constraints
 -- Group together errors from same location,
@@ -847,7 +847,8 @@ 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 (MsgEnvelope DiagnosticMessage)) -> Reporter
+mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report)
+                   -> Reporter
 mkSuppressReporter mk_err ctxt cts
   = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
 
@@ -865,15 +866,15 @@ 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 (MsgEnvelope DiagnosticMessage)) -> Reporter
-reportGroup mk_err ctxt cts =
-  ASSERT( not (null cts))
+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter
+reportGroup mk_err ctxt cts
+  | ct1 : _ <- cts =
   do { err <- mk_err ctxt cts
      ; traceTc "About to maybeReportErr" $
        vcat [ text "Constraint:"             <+> ppr cts
             , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)
             , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
-     ; maybeReportError ctxt err
+     ; maybeReportError ctxt ct1 err
          -- But see Note [Always warn with -fdefer-type-errors]
      ; traceTc "reportGroup" (ppr cts)
      ; mapM_ (addDeferredBinding ctxt err) cts }
@@ -881,51 +882,34 @@ reportGroup mk_err ctxt cts =
          -- Redundant if we are going to abort compilation,
          -- but that's hard to know for sure, and if we don't
          -- abort, we need bindings for all (e.g. #12156)
+  | otherwise = panic "empty reportGroup"
 
 -- like reportGroup, but does not actually report messages. It still adds
 -- -fdefer-type-errors bindings, though.
-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter
+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter
 suppressGroup mk_err ctxt cts
  = do { err <- mk_err ctxt cts
       ; traceTc "Suppressing errors for" (ppr cts)
       ; mapM_ (addDeferredBinding ctxt err) cts }
 
-maybeReportError :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> TcM ()
--- Report the error and/or make a deferred binding for it
-maybeReportError ctxt msg
-  | cec_suppress ctxt    -- Some worse error has occurred;
-  = return ()            -- so suppress this error/warning
-
+maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM ()
+maybeReportError ctxt ct report
   | Just reason <- cec_defer_type_errors ctxt
-  = reportDiagnostic (reclassify reason msg)
+  = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic
+    do msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report
+       reportDiagnostic msg
+
   | otherwise
-  = return ()
-  where
-    -- Reclassifies a 'DiagnosticMessage', by explicitly setting its 'Severity' and
-    -- 'DiagnosticReason'. This function has to be considered unsafe and local to this
-    -- module, and it's a temporary stop-gap in the context of #18516. In particular,
-    -- diagnostic messages should have both their 'DiagnosticReason' and 'Severity' computed
-    -- \"at birth\": the former is statically computer, the latter is computed using the
-    -- 'DynFlags' in scope at the time of construction. However, due to the intricacies of
-    -- the current error-deferring logic, we are not always able to enforce this invariant
-    -- and we rather have to change one or the other /a posteriori/.
-    reclassify :: DiagnosticReason
-               -> MsgEnvelope DiagnosticMessage
-               -> MsgEnvelope DiagnosticMessage
-    reclassify rea msg =
-      let set_reason   r m = m { errMsgDiagnostic = (errMsgDiagnostic m) { diagReason = r } }
-          set_severity s m = m { errMsgSeverity = s }
-      in set_severity (defaultReasonSeverity rea) . set_reason rea $ msg
-
-addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> Ct -> TcM ()
+  = return ()  -- nothing to report
+
+addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM ()
 -- See Note [Deferring coercion errors to runtime]
 addDeferredBinding ctxt err ct
   | deferringAnyBindings ctxt
   , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
     -- Only add deferred bindings for Wanted constraints
-  = do { dflags <- getDynFlags
-       ; let err_tm       = mkErrorTerm dflags pred err
-             ev_binds_var = cec_binds ctxt
+  = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err
+       ; let ev_binds_var = cec_binds ctxt
 
        ; case dest of
            EvVarDest evar
@@ -939,13 +923,17 @@ addDeferredBinding ctxt err ct
   | otherwise   -- Do not set any evidence for Given/Derived
   = return ()
 
-mkErrorTerm :: DynFlags -> Type  -- of the error term
-            -> MsgEnvelope DiagnosticMessage -> EvTerm
-mkErrorTerm dflags ty err = evDelayedError ty err_fs
-  where
-    err_msg = pprLocMsgEnvelope err
-    err_fs  = mkFastString $ showSDoc dflags $
-              err_msg $$ text "(deferred type error)"
+mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type  -- of the error term
+            -> Report -> TcM EvTerm
+mkErrorTerm ctxt ct_loc ty report
+  = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report
+         -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"
+       ; dflags <- getDynFlags
+       ; let err_msg = pprLocMsgEnvelope msg
+             err_fs  = mkFastString $ showSDoc dflags $
+                       err_msg $$ text "(deferred type error)"
+
+       ; return $ evDelayedError ty err_fs }
 
 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
 -- Use the first reporter in the list whose predicate says True
@@ -1015,10 +1003,6 @@ pprWithArising (ct:cts)
     ppr_one ct' = hang (parens (pprType (ctPred ct')))
                      2 (pprCtLoc (ctLoc ct'))
 
-mkErrorMsgFromCt :: DiagnosticReason -> ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DiagnosticMessage)
-mkErrorMsgFromCt rea ctxt ct report
-  = mkErrorReport rea ctxt (ctLocEnv (ctLoc ct)) report
-
 mkErrorReport :: DiagnosticReason
               -> ReportErrCtxt
               -> TcLclEnv
@@ -1033,6 +1017,17 @@ mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs)
                            (vcat $ relevant_bindings ++ valid_subs)
        }
 
+-- This version does not include the context
+mkErrorReportNC :: DiagnosticReason
+                -> TcLclEnv
+                -> Report
+                -> TcM (MsgEnvelope DiagnosticMessage)
+mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs)
+  = mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc tcl_env) Nothing)
+                      (vcat important)
+                      O.empty
+                      (vcat $ relevant_bindings ++ valid_subs)
+
 type UserGiven = Implication
 
 getUserGivens :: ReportErrCtxt -> [UserGiven]
@@ -1051,12 +1046,9 @@ would get errors without -fdefer-type-errors, but if we suppress any of
 them you might get a runtime error that wasn't warned about at compile
 time.
 
-This is an easy design choice to change; just flip the order of the
-first two equations for maybeReportError
-
 To be consistent, we should also report multiple warnings from a single
 location in mkGroupReporter, when -fdefer-type-errors is on.  But that
-is perhaps a bit *over*-consistent! Again, an easy choice to change.
+is perhaps a bit *over*-consistent!
 
 With #10283, you can now opt out of deferred type error warnings.
 
@@ -1127,13 +1119,12 @@ solve it.
 ************************************************************************
 -}
 
-mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report
 mkIrredErr ctxt cts
   = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
        ; let orig = ctOrigin ct1
              msg  = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
-       ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $
-         msg `mappend` mk_relevant_bindings binds_msg }
+       ; return $ msg `mappend` mk_relevant_bindings binds_msg }
   where
     (ct1:_) = cts
 
@@ -1183,14 +1174,15 @@ mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ
        ; imp_info <- getImports
        ; curr_mod <- getModule
        ; hpt <- getHpt
-       ; let mk_err rea = do
-               mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc lcl_env) Nothing)
-                                 out_of_scope_msg O.empty
-                                 (unknownNameSuggestions dflags hpt curr_mod rdr_env
-                                 (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))
-
-       ; maybeAddDeferredBindings ctxt hole mk_err
-       ; whenNotDeferring (cec_out_of_scope_holes ctxt) mk_err
+       ; let err = important out_of_scope_msg `mappend`
+                   (mk_relevant_bindings $
+                     unknownNameSuggestions dflags hpt curr_mod rdr_env
+                       (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))
+
+       ; maybeAddDeferredBindings ctxt hole err
+       ; for (cec_out_of_scope_holes ctxt) $ \ rea ->
+           mkErrorReportNC rea lcl_env err
+           -- Use NC variant: the context is generally not helpful here
        }
   where
     herald | isDataOcc occ = text "Data constructor not in scope:"
@@ -1223,18 +1215,15 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
                             then validHoleFits ctxt tidy_simples hole
                             else return (ctxt, empty)
 
-       ; let mk_err rea =
-               mkErrorReport rea ctxt lcl_env $
-                             important hole_msg `mappend`
-                             mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`
-                             valid_hole_fits sub_msg
+       ; let err = important hole_msg `mappend`
+                   mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`
+                   valid_hole_fits sub_msg
 
-       ; maybeAddDeferredBindings ctxt hole mk_err
+       ; maybeAddDeferredBindings ctxt hole err
 
        ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt
                    | otherwise          = cec_type_holes ctxt
-       ; whenNotDeferring holes mk_err
-
+       ; for holes $ \ rea -> mkErrorReport rea ctxt lcl_env err
        }
 
   where
@@ -1293,10 +1282,6 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
            quotes (ppr tv) <+> text "is a coercion variable"
 
 
--- | Similar in spirit to 'whenIsJust', but the action returns a value of type @Maybe b@.
-whenNotDeferring :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b)
-whenNotDeferring = flip traverse
-
 {- Note [Adding deferred bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -1313,18 +1298,16 @@ so that the correct 'Severity' can be computed out of that later on.
 -- See Note [Adding deferred bindings].
 maybeAddDeferredBindings :: ReportErrCtxt
                          -> Hole
-                         -> (DiagnosticReason -> TcM (MsgEnvelope DiagnosticMessage))
+                         -> Report
                          -> TcM ()
-maybeAddDeferredBindings ctxt hole mk_err = do
+maybeAddDeferredBindings ctxt hole report = do
   case hole_sort hole of
     ExprHole (HER ref ref_ty _) -> do
       -- Only add bindings for holes in expressions
       -- not for holes in partial type signatures
       -- cf. addDeferredBinding
       when (deferringAnyBindings ctxt) $ do
-        dflags <- getDynFlags
-        err    <- mk_err ErrorWithoutFlag
-        let err_tm = mkErrorTerm dflags ref_ty err
+        err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report
           -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.
           -- See Note [Holes] in GHC.Tc.Types.Constraint
         writeMutVar ref err_tm
@@ -1365,7 +1348,7 @@ givenConstraintsMsg ctxt =
             2 (vcat $ map pprConstraint constraints)
 
 ----------------
-mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report
 mkIPErr ctxt cts
   = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
        ; let orig    = ctOrigin ct1
@@ -1378,8 +1361,7 @@ mkIPErr ctxt cts
                  | otherwise
                  = couldNotDeduce givens (preds, orig)
 
-       ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $
-         msg `mappend` mk_relevant_bindings binds_msg }
+       ; return $ msg `mappend` mk_relevant_bindings binds_msg }
   where
     (ct1:_) = cts
 
@@ -1442,11 +1424,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 (MsgEnvelope DiagnosticMessage)
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report
 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
 mkEqErr _ [] = panic "mkEqErr"
 
-mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)
+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report
 mkEqErr1 ctxt ct   -- Wanted or derived;
                    -- givens handled in mkGivenErrorReporter
   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
@@ -1455,11 +1437,10 @@ mkEqErr1 ctxt ct   -- Wanted or derived;
        ; let coercible_msg = case ctEqRel ct of
                NomEq  -> empty
                ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
-       ; dflags <- getDynFlags
        ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
        ; let report = mconcat [ important coercible_msg
                               , mk_relevant_bindings binds_msg]
-       ; mkEqErr_help ErrorWithoutFlag dflags ctxt report ct ty1 ty2 }
+       ; mkEqErr_help ctxt report ct ty1 ty2 }
   where
     (ty1, ty2) = getEqPredTys (ctPred ct)
 
@@ -1510,77 +1491,78 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
       | otherwise
       = False
 
-mkEqErr_help :: DiagnosticReason -> DynFlags -> ReportErrCtxt -> Report
+mkEqErr_help :: ReportErrCtxt -> Report
              -> Ct
-             -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
-mkEqErr_help rea dflags ctxt report ct ty1 ty2
+             -> TcType -> TcType -> TcM Report
+mkEqErr_help ctxt report ct ty1 ty2
   | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1
-  = mkTyVarEqErr rea dflags ctxt report ct tv1 ty2
+  = mkTyVarEqErr ctxt report ct tv1 ty2
   | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
-  = mkTyVarEqErr rea dflags ctxt report ct tv2 ty1
+  = mkTyVarEqErr ctxt report ct tv2 ty1
   | otherwise
-  = reportEqErr rea ctxt report ct ty1 ty2
+  = return $ reportEqErr ctxt report ct ty1 ty2
 
-reportEqErr :: DiagnosticReason -> ReportErrCtxt -> Report
+reportEqErr :: ReportErrCtxt -> Report
             -> Ct
-            -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
-reportEqErr rea ctxt report ct ty1 ty2
-  = mkErrorMsgFromCt rea ctxt ct (mconcat [misMatch, report, eqInfo])
+            -> TcType -> TcType -> Report
+reportEqErr ctxt report ct ty1 ty2
+  = mconcat [misMatch, report, eqInfo]
   where
     misMatch = misMatchOrCND False ctxt ct ty1 ty2
     eqInfo   = mkEqInfoMsg ct ty1 ty2
 
-mkTyVarEqErr, mkTyVarEqErr'
-  :: DiagnosticReason
-  -> DynFlags -> ReportErrCtxt -> Report -> Ct
-  -> TcTyVar -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
+mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct
+             -> TcTyVar -> TcType -> TcM Report
 -- tv1 and ty2 are already tidied
-mkTyVarEqErr reason dflags ctxt report ct tv1 ty2
+mkTyVarEqErr ctxt report ct tv1 ty2
   = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
-       ; mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 }
+       ; dflags <- getDynFlags
+       ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 }
 
-mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
+mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct
+              -> TcTyVar -> TcType -> Report
+mkTyVarEqErr' dflags ctxt report ct tv1 ty2
   | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have
                        -- swapped in Solver.Canonical.canEqTyVarHomo
     || isTyVarTyVar tv1 && not (isTyVarTy ty2)
     || ctEqRel ct == ReprEq
      -- The cases below don't really apply to ReprEq (except occurs check)
-  = mkErrorMsgFromCt reason ctxt ct $ mconcat
-        [ headline_msg
-        , extraTyVarEqInfo ctxt tv1 ty2
-        , suggestAddSig ctxt ty1 ty2
-        , report
-        ]
+  = mconcat [ headline_msg
+            , extraTyVarEqInfo ctxt tv1 ty2
+            , suggestAddSig ctxt ty1 ty2
+            , report
+            ]
 
   | CTE_Occurs <- occ_check_expand
     -- We report an "occurs check" even for  a ~ F t a, where F is a type
     -- function; it's not insoluble (because in principle F could reduce)
     -- but we have certainly been unable to solve it
     -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical
-  = do { let extra2   = mkEqInfoMsg ct ty1 ty2
-
-             interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
-                                  filter isTyVar $
-                                  fvVarList $
-                                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
-             extra3 = mk_relevant_bindings $
-                      ppWhen (not (null interesting_tyvars)) $
-                      hang (text "Type variable kinds:") 2 $
-                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
-                                interesting_tyvars)
-
-             tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
-       ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $
-         mconcat [headline_msg, extra2, extra3, report] }
+  = let extra2   = mkEqInfoMsg ct ty1 ty2
+
+        interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
+                             filter isTyVar $
+                             fvVarList $
+                             tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
+        extra3 = mk_relevant_bindings $
+                 ppWhen (not (null interesting_tyvars)) $
+                 hang (text "Type variable kinds:") 2 $
+                 vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
+                           interesting_tyvars)
+
+        tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+    in
+    mconcat [headline_msg, extra2, extra3, report]
 
   | CTE_Bad <- occ_check_expand
-  = do { let msg = vcat [ text "Cannot instantiate unification variable"
-                          <+> quotes (ppr tv1)
-                        , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]
+  = let msg = vcat [ text "Cannot instantiate unification variable"
+                     <+> quotes (ppr tv1)
+                   , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]
+    in
        -- Unlike the other reports, this discards the old 'report_important'
        -- instead of augmenting it.  This is because the details are not likely
        -- to be helpful since this is just an unimplemented feature.
-       ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat [ headline_msg, important msg, report ] }
+    mconcat [ headline_msg, important msg, report ]
 
   -- If the immediately-enclosing implication has 'tv' a skolem, and
   -- we know by now its an InferSkol kind of skolem, then presumably
@@ -1589,35 +1571,35 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
   | (implic:_) <- cec_encl ctxt
   , Implic { ic_skols = skols } <- implic
   , tv1 `elem` skols
-  = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat
-        [ misMatchMsg ctxt ct ty1 ty2
-        , extraTyVarEqInfo ctxt tv1 ty2
-        , report
-        ]
+  = mconcat [ misMatchMsg ctxt ct ty1 ty2
+            , extraTyVarEqInfo ctxt tv1 ty2
+            , report
+            ]
 
   -- Check for skolem escape
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
   , Implic { ic_skols = skols, ic_info = skol_info } <- implic
   , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
   , not (null esc_skols)
-  = do { let msg = misMatchMsg ctxt ct ty1 ty2
-             esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
-                             <+> pprQuotedList esc_skols
-                           , text "would escape" <+>
-                             if isSingleton esc_skols then text "its scope"
-                                                      else text "their scope" ]
-             tv_extra = important $
-                        vcat [ nest 2 $ esc_doc
-                             , sep [ (if isSingleton esc_skols
-                                      then text "This (rigid, skolem)" <+>
-                                           what <+> text "variable is"
-                                      else text "These (rigid, skolem)" <+>
-                                           what <+> text "variables are")
-                               <+> text "bound by"
-                             , nest 2 $ ppr skol_info
-                             , nest 2 $ text "at" <+>
-                               ppr (tcl_loc (ic_env implic)) ] ]
-       ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct (mconcat [msg, tv_extra, report]) }
+  = let msg = misMatchMsg ctxt ct ty1 ty2
+        esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
+                        <+> pprQuotedList esc_skols
+                      , text "would escape" <+>
+                        if isSingleton esc_skols then text "its scope"
+                                                 else text "their scope" ]
+        tv_extra = important $
+                   vcat [ nest 2 $ esc_doc
+                        , sep [ (if isSingleton esc_skols
+                                 then text "This (rigid, skolem)" <+>
+                                      what <+> text "variable is"
+                                 else text "These (rigid, skolem)" <+>
+                                      what <+> text "variables are")
+                          <+> text "bound by"
+                        , nest 2 $ ppr skol_info
+                        , nest 2 $ text "at" <+>
+                          ppr (tcl_loc (ic_env implic)) ] ]
+    in
+    mconcat [msg, tv_extra, report]
 
   -- Nastiest case: attempt to unify an untouchable variable
   -- So tv is a meta tyvar (or started that way before we
@@ -1628,21 +1610,21 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
   , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
   = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
            , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]
-    do { let msg = misMatchMsg ctxt ct ty1 ty2
-             tclvl_extra = important $
-                  nest 2 $
-                  sep [ quotes (ppr tv1) <+> text "is untouchable"
-                      , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
-                      , nest 2 $ text "bound by" <+> ppr skol_info
-                      , nest 2 $ text "at" <+>
-                        ppr (tcl_loc (ic_env implic)) ]
-             tv_extra = extraTyVarEqInfo ctxt tv1 ty2
-             add_sig  = suggestAddSig ctxt ty1 ty2
-       ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat
-            [msg, tclvl_extra, tv_extra, add_sig, report] }
+    let msg         = misMatchMsg ctxt ct ty1 ty2
+        tclvl_extra = important $
+             nest 2 $
+             sep [ quotes (ppr tv1) <+> text "is untouchable"
+                 , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
+                 , nest 2 $ text "bound by" <+> ppr skol_info
+                 , nest 2 $ text "at" <+>
+                   ppr (tcl_loc (ic_env implic)) ]
+        tv_extra = extraTyVarEqInfo ctxt tv1 ty2
+        add_sig  = suggestAddSig ctxt ty1 ty2
+    in
+    mconcat [msg, tclvl_extra, tv_extra, add_sig, report]
 
   | otherwise
-  = reportEqErr ErrorWithoutFlag ctxt report ct (mkTyVarTy tv1) ty2
+  = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2
         -- This *can* happen (#6123, and test T2627b)
         -- Consider an ambiguous top-level constraint (a ~ F a)
         -- Not an occurs check, because F is a type function.
@@ -1733,10 +1715,9 @@ 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 (MsgEnvelope DiagnosticMessage)
-mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct report
+mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report
+mkBlockedEqErr _ (ct:_) = return $ important msg
   where
-    report = important msg
     msg = vcat [ hang (text "Cannot use equality for substitution:")
                    2 (ppr (ctPred ct))
                , text "Doing so would be ill-kinded." ]
@@ -2340,12 +2321,11 @@ Warn of loopy local equalities that were dropped.
 ************************************************************************
 -}
 
-mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report
 mkDictErr ctxt cts
   = ASSERT( not (null cts) )
     do { inst_envs <- tcGetInstEnvs
-       ; let (ct1:_) = cts  -- ct1 just for its location
-             min_cts = elim_superclasses cts
+       ; let min_cts = elim_superclasses cts
              lookups = map (lookup_cls_inst inst_envs) min_cts
              (no_inst_cts, overlap_cts) = partition is_no_inst lookups
 
@@ -2354,8 +2334,8 @@ mkDictErr ctxt cts
        -- But we report only one of them (hence 'head') because they all
        -- have the same source-location origin, to try avoid a cascade
        -- of error from one location
-       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
-       ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 (important err) }
+       ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
+       ; return $ important err }
   where
     no_givens = null (getUserGivens ctxt)
 
@@ -2377,20 +2357,20 @@ mkDictErr ctxt cts
     elim_superclasses cts = mkMinimalBySCs ctPred cts
 
 mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
-            -> TcM (ReportErrCtxt, SDoc)
+            -> TcM SDoc
 -- Report an overlap error if this class constraint results
 -- from an overlap (returning Left clas), otherwise return (Right pred)
 mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))
   | null matches  -- No matches but perhaps several unifiers
-  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+  = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct
        ; candidate_insts <- get_candidate_instances
-       ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }
+       ; return (cannot_resolve_msg ct candidate_insts binds_msg) }
 
   | null unsafe_overlapped   -- Some matches => overlap errors
-  = return (ctxt, overlap_msg)
+  = return overlap_msg
 
   | otherwise
-  = return (ctxt, safe_haskell_msg)
+  = return safe_haskell_msg
   where
     orig          = ctOrigin ct
     pred          = ctPred ct
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 8833abe03d..0883ba1c8b 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -212,7 +212,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax
     dflags  = hsc_dflags hsc_env
     logger  = hsc_logger hsc_env
     home_unit = hsc_home_unit hsc_env
-    err_msg = mkPlainMsgEnvelope ErrorWithoutFlag loc $
+    err_msg = mkPlainErrorMsgEnvelope loc $
               text "Module does not have a RealSrcSpan:" <+> ppr this_mod
 
     pair :: (Module, SrcSpan)
@@ -3148,5 +3148,5 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
   recordUnsafeInfer pluginUnsafe
   where
     unsafeText = "Use of plugins makes the module unsafe"
-    pluginUnsafe = unitBag ( mkPlainMsgEnvelope WarningWithoutFlag noSrcSpan
+    pluginUnsafe = unitBag ( mkPlainMsgEnvelope dflags WarningWithoutFlag noSrcSpan
                                    (Outputable.text unsafeText) )
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 6fb31e2d7d..a8f6cbbc19 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1033,8 +1033,9 @@ mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage)
 mkLongErrAt loc msg extra
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
+         dflags <- getDynFlags ;
          let msg' = pprWithUnitState unit_state msg in
-         return $ mkLongMsgEnvelope ErrorWithoutFlag loc printer msg' extra }
+         return $ mkLongMsgEnvelope dflags ErrorWithoutFlag loc printer msg' extra }
 
 mkDecoratedSDocAt :: DiagnosticReason
                   -> SrcSpan
@@ -1048,11 +1049,12 @@ mkDecoratedSDocAt :: DiagnosticReason
 mkDecoratedSDocAt reason loc important context extra
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
+         dflags <- getDynFlags ;
          let f = pprWithUnitState unit_state
              errDoc  = [important, context, extra]
              errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason
          in
-         return $ mkMsgEnvelope (defaultReasonSeverity reason) loc printer errDoc' }
+         return $ mkMsgEnvelope dflags loc printer errDoc' }
 
 addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()
 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic
@@ -1558,7 +1560,8 @@ add_diagnostic reason msg extra_info
 add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn ()
 add_diagnostic_at reason loc msg extra_info
   = do { printer <- getPrintUnqualified ;
-         let { dia = mkLongMsgEnvelope reason
+         dflags  <- getDynFlags ;
+         let { dia = mkLongMsgEnvelope dflags reason
                                        loc printer
                                        msg extra_info } ;
          reportDiagnostic dia }
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 7edf599c9f..48cb9eaedd 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -19,7 +19,6 @@ module GHC.Types.Error
 
    , MessageClass (..)
    , Severity (..)
-   , mkMCDiagnostic
    , Diagnostic (..)
    , DiagnosticMessage (..)
    , DiagnosticReason (..)
@@ -33,14 +32,8 @@ module GHC.Types.Error
    , mkLocMessage
    , mkLocMessageAnn
    , getCaretDiagnostic
-   -- * Constructing individual diagnostic messages
-   , mkMsgEnvelope
-   , mkPlainMsgEnvelope
-   , mkLongMsgEnvelope
-   , mkShortMsgEnvelope
-   , defaultReasonSeverity
    -- * Queries
-   , isErrorMessage
+   , isIntrinsicErrorMessage
    , isWarningMessage
    , getErrorMessages
    , getWarningMessages
@@ -193,9 +186,9 @@ data DiagnosticReason
 
 instance Outputable DiagnosticReason where
   ppr = \case
-    WarningWithoutFlag              -> text "WarningWithoutFlag"
-    WarningWithFlag wf              -> text ("WarningWithFlag " ++ show wf)
-    ErrorWithoutFlag                -> text "ErrorWithoutFlag"
+    WarningWithoutFlag  -> text "WarningWithoutFlag"
+    WarningWithFlag wf  -> text ("WarningWithFlag " ++ show wf)
+    ErrorWithoutFlag    -> text "ErrorWithoutFlag"
 
 -- | An envelope for GHC's facts about a running program, parameterised over the
 -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.
@@ -237,11 +230,6 @@ data MessageClass
     -- /especially/ when emitting compiler diagnostics, use the smart constructor.
   deriving (Eq, Show)
 
--- | Make a 'MessageClass' for a given 'DiagnosticReason', without consulting the 'DynFlags'.
--- This will not respect -Werror or warning suppression and so is probably wrong
--- for any warning.
-mkMCDiagnostic :: DiagnosticReason -> MessageClass
-mkMCDiagnostic reason = MCDiagnostic (defaultReasonSeverity reason) reason
 
 -- | Used to describe warnings and errors
 --   o The message has a file\/line\/column heading,
@@ -325,14 +313,6 @@ mkLocMessageAnn ann msg_class locn msg
         MCFatal                         -> text "fatal:"
         _                               -> empty
 
--- | Computes a severity from a reason in the absence of DynFlags. This will likely
--- be wrong in the presence of -Werror. It will be removed in the context of #18516.
-defaultReasonSeverity :: DiagnosticReason -> Severity
-defaultReasonSeverity = \case
-  WarningWithoutFlag    -> SevWarning
-  WarningWithFlag _flag -> SevWarning
-  ErrorWithoutFlag      -> SevError
-
 getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
 getMessageClassColour (MCDiagnostic SevError _reason)   = Col.sError
 getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning
@@ -416,76 +396,40 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) =
         caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
 
 --
--- Creating MsgEnvelope(s)
+-- Queries
 --
 
-mkMsgEnvelope
-  :: Diagnostic e
-  => Severity
-  -> SrcSpan
-  -> PrintUnqualified
-  -> e
-  -> MsgEnvelope e
-mkMsgEnvelope sev locn print_unqual err
- = MsgEnvelope { errMsgSpan = locn
-               , errMsgContext = print_unqual
-               , errMsgDiagnostic = err
-               , errMsgSeverity = sev
-               }
-
--- | A long (multi-line) diagnostic message.
--- The 'Severity' will be calculated out of the 'DiagnosticReason', and will likely be
--- incorrect in the presence of '-Werror'.
-mkLongMsgEnvelope :: DiagnosticReason
-                  -> SrcSpan
-                  -> PrintUnqualified
-                  -> SDoc
-                  -> SDoc
-                  -> MsgEnvelope DiagnosticMessage
-mkLongMsgEnvelope rea locn unqual msg extra =
-  mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings
-                locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea)
-
--- | A short (one-line) diagnostic message.
--- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
-mkShortMsgEnvelope :: DiagnosticReason
-                   -> SrcSpan
-                   -> PrintUnqualified
-                   -> SDoc
-                   -> MsgEnvelope DiagnosticMessage
-mkShortMsgEnvelope rea locn unqual msg =
-  mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings
-                locn unqual (DiagnosticMessage (mkDecorated [msg]) rea)
-
--- | Variant that doesn't care about qualified/unqualified names.
--- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
-mkPlainMsgEnvelope :: DiagnosticReason
-                   -> SrcSpan
-                   -> SDoc
-                   -> MsgEnvelope DiagnosticMessage
-mkPlainMsgEnvelope rea locn msg =
-  mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings
-                locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea)
+{- 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).
+
+-}
 
---
--- Queries
---
 
-isErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
-isErrorMessage MsgEnvelope { errMsgSeverity = SevError } = True
-isErrorMessage _ = False
+-- | 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 . isErrorMessage
+isWarningMessage = not . isIntrinsicErrorMessage
 
 errorsFound :: Diagnostic e => Messages e -> Bool
-errorsFound (Messages msgs) = any isErrorMessage msgs
+errorsFound (Messages msgs) = any isIntrinsicErrorMessage 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 isErrorMessage xs
+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.
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index aba5e64357..2ee1763ebb 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -31,8 +31,9 @@ module GHC.Utils.Error (
 
         -- ** Construction
         emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,
-        mkMsgEnvelope, mkPlainMsgEnvelope, mkLongMsgEnvelope,
-        mkMCDiagnostic,
+        mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
+        mkShortMsgEnvelope, mkShortErrorMsgEnvelope, mkLongMsgEnvelope,
+        mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,
 
         -- * Utilities
         doIfSet, doIfSet_dyn,
@@ -80,6 +81,106 @@ import Control.Monad.Catch as MC (handle)
 import GHC.Conc         ( getAllocationCounter )
 import System.CPUTime
 
+-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
+-- the 'DynFlags'. This function /has/ to be called when a diagnostic is constructed,
+-- i.e. with a 'DynFlags' \"snapshot\" taken as close as possible to where a
+-- particular diagnostic message is built, otherwise the computed 'Severity' might
+-- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
+diagReasonSeverity :: DynFlags -> DiagnosticReason -> Severity
+diagReasonSeverity dflags (WarningWithFlag wflag) | wopt_fatal wflag dflags     = SevError
+                                                  | otherwise                   = SevWarning
+diagReasonSeverity dflags WarningWithoutFlag      | gopt Opt_WarnIsError dflags = SevError
+                                                  | otherwise                   = SevWarning
+diagReasonSeverity _      ErrorWithoutFlag                                      = SevError
+
+
+
+--
+-- Creating MsgEnvelope(s)
+--
+
+mk_msg_envelope
+  :: Diagnostic e
+  => Severity
+  -> SrcSpan
+  -> PrintUnqualified
+  -> e
+  -> MsgEnvelope e
+mk_msg_envelope severity locn print_unqual err
+ = MsgEnvelope { errMsgSpan = locn
+               , errMsgContext = print_unqual
+               , errMsgDiagnostic = err
+               , errMsgSeverity = severity
+               }
+
+mkMsgEnvelope
+  :: Diagnostic e
+  => DynFlags
+  -> SrcSpan
+  -> PrintUnqualified
+  -> e
+  -> MsgEnvelope e
+mkMsgEnvelope dflags locn print_unqual err
+ = mk_msg_envelope (diagReasonSeverity dflags (diagnosticReason err)) locn print_unqual err
+
+-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the 'DynFlags'.
+mkMCDiagnostic :: DynFlags -> DiagnosticReason -> MessageClass
+mkMCDiagnostic dflags reason = MCDiagnostic (diagReasonSeverity dflags reason) reason
+
+-- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
+-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'.
+errorDiagnostic :: MessageClass
+errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag
+
+-- | A long (multi-line) diagnostic message.
+-- The 'Severity' will be calculated out of the 'DiagnosticReason', and will likely be
+-- incorrect in the presence of '-Werror'.
+mkLongMsgEnvelope :: DynFlags
+                  -> DiagnosticReason
+                  -> SrcSpan
+                  -> PrintUnqualified
+                  -> SDoc
+                  -> SDoc
+                  -> MsgEnvelope DiagnosticMessage
+mkLongMsgEnvelope dflags rea locn unqual msg extra =
+  mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea)
+
+-- | A short (one-line) diagnostic message.
+-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
+mkShortMsgEnvelope :: DynFlags
+                   -> DiagnosticReason
+                   -> SrcSpan
+                   -> PrintUnqualified
+                   -> SDoc
+                   -> MsgEnvelope DiagnosticMessage
+mkShortMsgEnvelope dflags rea locn unqual msg =
+  mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg]) rea)
+
+mkShortErrorMsgEnvelope :: SrcSpan
+                        -> PrintUnqualified
+                        -> SDoc
+                        -> MsgEnvelope DiagnosticMessage
+mkShortErrorMsgEnvelope locn unqual msg =
+  mk_msg_envelope SevError locn unqual (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag)
+
+-- | Variant that doesn't care about qualified/unqualified names.
+-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
+mkPlainMsgEnvelope :: DynFlags
+                   -> DiagnosticReason
+                   -> SrcSpan
+                   -> SDoc
+                   -> MsgEnvelope DiagnosticMessage
+mkPlainMsgEnvelope dflags rea locn msg =
+  mkMsgEnvelope dflags locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea)
+
+-- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we
+-- are constructing a diagnostic with a 'ErrorWithoutFlag' reason.
+mkPlainErrorMsgEnvelope :: SrcSpan
+                        -> SDoc
+                        -> MsgEnvelope DiagnosticMessage
+mkPlainErrorMsgEnvelope locn msg =
+  mk_msg_envelope SevError locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag)
+
 -------------------------
 data Validity
   = IsValid            -- ^ Everything is fine
@@ -171,12 +272,12 @@ ifVerbose dflags val act
 
 errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
 errorMsg logger dflags msg
-   = putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) noSrcSpan $
+   = putLogMsg logger dflags errorDiagnostic noSrcSpan $
      withPprStyle defaultErrStyle msg
 
 warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
 warningMsg logger dflags msg
-   = putLogMsg logger dflags (mkMCDiagnostic WarningWithoutFlag) noSrcSpan $
+   = putLogMsg logger dflags (mkMCDiagnostic dflags WarningWithoutFlag) noSrcSpan $
      withPprStyle defaultErrStyle msg
 
 fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index cc4dcf7f9b..496c4dc6a0 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -117,8 +117,8 @@ compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do
     -- parse the cmm file and output any warnings or errors
     let fake_mod = mkHomeModule (hsc_home_unit hscEnv) (mkModuleName "fake")
     (warnings, errors, parsedCmm) <- parseCmmFile dflags fake_mod (hsc_home_unit hscEnv) cmmFile
-    let warningMsgs = fmap pprWarning warnings
-        errorMsgs   = fmap pprError errors
+    let warningMsgs = fmap (mkParserWarn dflags') warnings
+        errorMsgs   = fmap mkParserErr errors
 
     -- print parser errors or warnings
     mapM_ (printBagOfErrors logger dflags) [warningMsgs, errorMsgs]
diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr
index ce90de4c72..4a4fb3779c 100644
--- a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr
+++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr
@@ -5,7 +5,7 @@
 SH_Overlap7.hs:2:16: error: [-Wunsafe, -Werror=unsafe]
     ‘SH_Overlap7’ has been inferred as unsafe!
     Reason:
-        SH_Overlap7.hs:15:8: warning:
+        SH_Overlap7.hs:15:8:
             • Unsafe overlapping instances for C [Int]
                 arising from a use of ‘f’
               The matching instance is:
diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs
index eccf3f2612..f1437869ee 100644
--- a/utils/check-exact/Parsers.hs
+++ b/utils/check-exact/Parsers.hs
@@ -87,7 +87,7 @@ parseWith :: GHC.DynFlags
           -> ParseResult w
 parseWith dflags fileName parser s =
   case runParser parser dflags fileName s of
-    GHC.PFailed pst                     -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+    GHC.PFailed pst                     -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
     GHC.POk _ pmod -> Right pmod
 
 
@@ -101,7 +101,7 @@ parseWithECP dflags fileName parser s =
     -- case runParser ff dflags fileName s of
     -- case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of
     case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of
-      GHC.PFailed pst                     -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+      GHC.PFailed pst                     -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
       GHC.POk _ pmod -> Right pmod
 
 -- ---------------------------------------------------------------------
@@ -192,7 +192,7 @@ parseModuleFromStringInternal :: Parser GHC.ParsedSource
 parseModuleFromStringInternal dflags fileName str =
   let (str1, lp) = stripLinePragmas str
       res        = case runParser GHC.parseModule dflags fileName str1 of
-        GHC.PFailed pst     -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+        GHC.PFailed pst     -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
         GHC.POk     _  pmod -> Right (lp, dflags, pmod)
   in  postParseTransform res
 
@@ -263,7 +263,7 @@ parseModuleEpAnnsWithCppInternal cppOptions dflags file = do
         return (contents1,lp,dflags)
   return $
     case parseFile dflags' file fileContents of
-      GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+      GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
       GHC.POk _ pmod  ->
         Right $ (injectedComments, dflags', pmod)
 
diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs
index 761029adb2..904e76938e 100644
--- a/utils/check-exact/Preprocess.hs
+++ b/utils/check-exact/Preprocess.hs
@@ -277,7 +277,7 @@ parseError pst = do
      let
        -- (warns,errs) = GHC.getMessages pst dflags
      -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
-     GHC.throwErrors (fmap GHC.pprError (GHC.getErrorMessages pst))
+     GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst))
 
 -- ---------------------------------------------------------------------
 
diff --git a/utils/haddock b/utils/haddock
-Subproject c623c7d2df417caac4b72b747ef5262d86ee776
+Subproject eebc74dc08987fdd9b1c289be38207af9b0334c