Allow configuration of error message printing

This MR implements the idea of #21731 that the printing of a diagnostic
method should be configurable at the printing time.

The interface of the `Diagnostic` class is modified from:

```
class Diagnostic a where
  diagnosticMessage :: a -> DecoratedSDoc
  diagnosticReason  :: a -> DiagnosticReason
  diagnosticHints   :: a -> [GhcHint]
```

to

```
class Diagnostic a where
  type DiagnosticOpts a
  defaultDiagnosticOpts :: DiagnosticOpts a
  diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc
  diagnosticReason  :: a -> DiagnosticReason
  diagnosticHints   :: a -> [GhcHint]
```

and so each `Diagnostic` can implement their own configuration record
which can then be supplied by a client in order to dictate how to print
out the error message.

At the moment this only allows us to implement #21722 nicely but in
future it is more natural to separate the configuration of how much
information we put into an error message and how much we decide to print
out of it.

Updates Haddock submodule

32 files changed, 247 insertions, 122 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 1711e1c802..26f870a5bc 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -929,7 +929,8 @@ checkNewDynFlags logger dflags = do
   -- See Note [DynFlags consistency]
   let (dflags', warnings) = makeDynFlagsConsistent dflags
   let diag_opts = initDiagOpts dflags
-  liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)
+      print_config = initPrintConfig dflags
+  liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings)
   return dflags'
 
 checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
@@ -939,7 +940,8 @@ checkNewInteractiveDynFlags logger dflags0 = do
   if xopt LangExt.StaticPointers dflags0
   then do
     let diag_opts = initDiagOpts dflags0
-    liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage
+        print_config = initPrintConfig dflags0
+    liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ singleMessage
       $ fmap GhcDriverMessage
       $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported
     return $ xopt_unset dflags0 LangExt.StaticPointers
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index e961b3a242..93422e4161 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -106,8 +106,9 @@ doBackpack [src_filename] = do
                         -- Not doing so caused #20396.
     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
     liftIO $ checkProcessArgsResult unhandled_flags
-    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns)
-    liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns
+    let print_config = initPrintConfig dflags
+    liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns)
+    liftIO $ handleFlagWarnings logger print_config (initDiagOpts dflags) warns
     -- TODO: Preprocessing not implemented
 
     buf <- liftIO $ hGetStringBuffer src_filename
diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs
index 00fa9695c3..e8bf0f5926 100644
--- a/compiler/GHC/Driver/Config/Diagnostic.hs
+++ b/compiler/GHC/Driver/Config/Diagnostic.hs
@@ -1,5 +1,13 @@
+{-# LANGUAGE TypeApplications #-}
+-- | Functions for initialising error message printing configuration from the
+-- GHC session flags.
 module GHC.Driver.Config.Diagnostic
   ( initDiagOpts
+  , initPrintConfig
+  , initPsMessageOpts
+  , initDsMessageOpts
+  , initTcMessageOpts
+  , initDriverMessageOpts
   )
 where
 
@@ -8,7 +16,15 @@ import GHC.Driver.Session
 
 import GHC.Utils.Outputable
 import GHC.Utils.Error (DiagOpts (..))
+import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..))
+import GHC.Driver.Errors.Ppr ()
+import GHC.Tc.Errors.Types
+import GHC.HsToCore.Errors.Types
+import GHC.Types.Error
 
+-- | Initialise the general configuration for printing diagnostic messages
+-- For example, this configuration controls things like whether warnings are
+-- treated like errors.
 initDiagOpts :: DynFlags -> DiagOpts
 initDiagOpts dflags = DiagOpts
   { diag_warning_flags       = warningFlags dflags
@@ -19,3 +35,23 @@ initDiagOpts dflags = DiagOpts
   , diag_ppr_ctx             = initSDocContext dflags defaultErrStyle
   }
 
+-- | Initialise the configuration for printing specific diagnostic messages
+initPrintConfig :: DynFlags -> DiagnosticOpts GhcMessage
+initPrintConfig dflags =
+  GhcMessageOpts { psMessageOpts = initPsMessageOpts dflags
+                 , tcMessageOpts = initTcMessageOpts dflags
+                 , dsMessageOpts = initDsMessageOpts dflags
+                 , driverMessageOpts= initDriverMessageOpts dflags }
+
+initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage
+initPsMessageOpts _ = NoDiagnosticOpts
+
+initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage
+initTcMessageOpts _ = NoDiagnosticOpts
+
+initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage
+initDsMessageOpts _ = NoDiagnosticOpts
+
+initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage
+initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags)
+
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index f6b7f415a0..edca007608 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -46,7 +46,7 @@ import GHC.Driver.Session
 import GHC.Driver.Errors ( printOrThrowDiagnostics )
 import GHC.Driver.Errors.Types ( GhcMessage )
 import GHC.Driver.Config.Logger (initLogFlags)
-import GHC.Driver.Config.Diagnostic (initDiagOpts)
+import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig)
 import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
 
 import GHC.Runtime.Context
@@ -95,7 +95,8 @@ runHsc hsc_env (Hsc hsc) = do
     (a, w) <- hsc hsc_env emptyMessages
     let dflags = hsc_dflags hsc_env
     let !diag_opts = initDiagOpts dflags
-    printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w
+        !print_config = initPrintConfig dflags
+    printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w
     return a
 
 runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 5467f2ad14..024820202d 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 module GHC.Driver.Errors (
     printOrThrowDiagnostics
   , printMessages
@@ -16,8 +17,8 @@ import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle,
 import GHC.Utils.Logger
 import qualified GHC.Driver.CmdLine as CmdLine
 
-printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
-printMessages logger opts msgs
+printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
+printMessages logger msg_opts opts msgs
   = sequence_ [ let style = mkErrStyle unqual
                     ctx   = (diag_ppr_ctx opts) { sdocStyle = style }
                 in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $
@@ -30,15 +31,15 @@ printMessages logger opts msgs
   where
     messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc
     messageWithHints ctx e =
-      let main_msg = formatBulleted ctx $ diagnosticMessage e
+      let main_msg = formatBulleted ctx $ diagnosticMessage msg_opts e
           in case diagnosticHints e of
                []  -> main_msg
                [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)
                hs  -> main_msg $$ hang (text "Suggested fixes:") 2
                                        (formatBulleted ctx . mkDecorated . map ppr $ hs)
 
-handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO ()
-handleFlagWarnings logger opts warns = do
+handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO ()
+handleFlagWarnings logger print_config opts warns = do
   let -- It would be nicer if warns :: [Located SDoc], but that
       -- has circular import problems.
       bag = listToBag [ mkPlainMsgEnvelope opts loc $
@@ -48,16 +49,16 @@ handleFlagWarnings logger opts warns = do
                         mkPlainDiagnostic reason noHints $ text warn
                       | CmdLine.Warn reason (L loc warn) <- warns ]
 
-  printOrThrowDiagnostics logger opts (mkMessages bag)
+  printOrThrowDiagnostics logger print_config opts (mkMessages bag)
 
 -- | Given a bag of diagnostics, turn them into an exception if
 -- any has 'SevError', or print them out otherwise.
-printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO ()
-printOrThrowDiagnostics logger opts msgs
+printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
+printOrThrowDiagnostics logger print_config opts msgs
   | errorsOrFatalWarningsFound msgs
   = throwErrors msgs
   | otherwise
-  = printMessages logger opts msgs
+  = printMessages logger print_config opts msgs
 
 -- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it
 -- for dealing with parse errors when the driver is doing dependency analysis.
diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs
index 8f0ffa4a4d..69e3c28740 100644
--- a/compiler/GHC/Driver/Errors/Ppr.hs
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage}
 
 module GHC.Driver.Errors.Ppr (
@@ -26,6 +28,8 @@ import GHC.Types.SrcLoc
 import Data.Version
 
 import Language.Haskell.Syntax.Decls (RuleDecl(..))
+import GHC.Tc.Errors.Types (TcRnMessage)
+import GHC.HsToCore.Errors.Types (DsMessage)
 
 --
 -- Suggestions
@@ -36,19 +40,23 @@ suggestInstantiatedWith :: ModuleName -> GenInstantiations UnitId -> [Instantiat
 suggestInstantiatedWith pi_mod_name insts =
   [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ]
 
-
 instance Diagnostic GhcMessage where
-  diagnosticMessage = \case
+  type DiagnosticOpts GhcMessage = GhcMessageOpts
+  defaultDiagnosticOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage)
+                                         (defaultDiagnosticOpts @TcRnMessage)
+                                         (defaultDiagnosticOpts @DsMessage)
+                                         (defaultDiagnosticOpts @DriverMessage)
+  diagnosticMessage opts = \case
     GhcPsMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage (psMessageOpts opts) m
     GhcTcRnMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage (tcMessageOpts opts) m
     GhcDsMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage (dsMessageOpts opts) m
     GhcDriverMessage m
-      -> diagnosticMessage m
-    GhcUnknownMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage (driverMessageOpts opts) m
+    GhcUnknownMessage (UnknownDiagnostic @e m)
+      -> diagnosticMessage (defaultDiagnosticOpts @e) m
 
   diagnosticReason = \case
     GhcPsMessage m
@@ -77,11 +85,13 @@ instance Diagnostic GhcMessage where
   diagnosticCode = constructorCode
 
 instance Diagnostic DriverMessage where
-  diagnosticMessage = \case
-    DriverUnknownMessage m
-      -> diagnosticMessage m
+  type DiagnosticOpts DriverMessage = DriverMessageOpts
+  defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage)
+  diagnosticMessage opts = \case
+    DriverUnknownMessage (UnknownDiagnostic @e m)
+      -> diagnosticMessage (defaultDiagnosticOpts @e) m
     DriverPsHeaderMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage (psDiagnosticOpts opts) m
     DriverMissingHomeModules missing buildingCabalPackage
       -> let msg | buildingCabalPackage == YesBuildingCabalPackage
                  = hang
diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs
index 988f533205..cb7625ca09 100644
--- a/compiler/GHC/Driver/Errors/Types.hs
+++ b/compiler/GHC/Driver/Errors/Types.hs
@@ -4,7 +4,10 @@
 
 module GHC.Driver.Errors.Types (
     GhcMessage(..)
-  , DriverMessage(..), DriverMessages, PsMessage(PsHeaderMessage)
+  , GhcMessageOpts(..)
+  , DriverMessage(..)
+  , DriverMessageOpts(..)
+  , DriverMessages, PsMessage(PsHeaderMessage)
   , BuildingCabalPackage(..)
   , WarningMessages
   , ErrorMessages
@@ -91,13 +94,20 @@ data GhcMessage where
 
   deriving Generic
 
+
+data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage
+                                     , tcMessageOpts :: DiagnosticOpts TcRnMessage
+                                     , dsMessageOpts :: DiagnosticOpts DsMessage
+                                     , driverMessageOpts :: DiagnosticOpts DriverMessage
+                                     }
+
 -- | Creates a new 'GhcMessage' out of any diagnostic. This function is also
 -- provided to ease the integration of #18516 by allowing diagnostics to be
 -- wrapped into the general (but structured) 'GhcMessage' type, so that the
 -- conversion can happen gradually. This function should not be needed within
 -- GHC, as it would typically be used by plugin or library authors (see
 -- comment for the 'GhcUnknownMessage' type constructor)
-ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage
+ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage
 ghcUnknownMessage = GhcUnknownMessage . UnknownDiagnostic
 
 -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on
@@ -117,6 +127,7 @@ type DriverMessages = Messages DriverMessage
 data DriverMessage where
   -- | Simply wraps a generic 'Diagnostic' message @a@.
   DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage
+
   -- | A parse error in parsing a Haskell file header during dependency
   -- analysis
   DriverPsHeaderMessage :: !PsMessage -> DriverMessage
@@ -359,6 +370,9 @@ data DriverMessage where
 
 deriving instance Generic DriverMessage
 
+data DriverMessageOpts =
+  DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage }
+
 -- | Pass to a 'DriverMessage' the information whether or not the
 -- '-fbuilding-cabal-package' flag is set.
 data BuildingCabalPackage
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index a16156143a..ab305d1ed5 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -fprof-auto-top #-}
 
@@ -381,9 +382,10 @@ getHscEnv = Hsc $ \e w -> return (e, w)
 handleWarnings :: Hsc ()
 handleWarnings = do
     diag_opts <- initDiagOpts <$> getDynFlags
+    print_config <- initPrintConfig <$> getDynFlags
     logger <- getLogger
     w <- getDiagnostics
-    liftIO $ printOrThrowDiagnostics logger diag_opts w
+    liftIO $ printOrThrowDiagnostics logger print_config diag_opts w
     clearDiagnostics
 
 -- | log warning in the monad, and if there are errors then
@@ -401,7 +403,7 @@ handleWarningsThrowErrors (warnings, errors) = do
     logDiagnostics (GhcPsMessage <$> warnings)
     logger <- getLogger
     let (wWarns, wErrs) = partitionMessages warnings
-    liftIO $ printMessages logger diag_opts wWarns
+    liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns
     throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs
 
 -- | Deal with errors and warnings returned by a compilation step
@@ -1067,6 +1069,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h
   let bcknd  = backend dflags
       hsc_src = ms_hsc_src summary
       diag_opts = initDiagOpts dflags
+      print_config = initPrintConfig dflags
 
   -- Desugar, if appropriate
   --
@@ -1081,7 +1084,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h
 
   -- Report the warnings from both typechecking and desugar together
   w <- getDiagnostics
-  liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w)
+  liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w)
   clearDiagnostics
 
   -- Simplify, if appropriate, and (whether we simplified or not) generate an
@@ -1657,7 +1660,7 @@ checkPkgTrust pkgs = do
 -- may call it on modules using Trustworthy or Unsafe flags so as to allow
 -- warning flags for safety to function correctly. See Note [Safe Haskell
 -- Inference].
-markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
+markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
 markUnsafeInfer tcg_env whyUnsafe = do
     dflags <- getDynFlags
 
@@ -1686,7 +1689,9 @@ markUnsafeInfer tcg_env whyUnsafe = do
     whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
                          , text "Reason:"
                          , nest 4 $ (vcat $ badFlags df) $+$
-                                    (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$
+                                    -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these
+                                    -- unsafety error messages in an unstructured manner.
+                                    (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$
                                     (vcat $ badInsts $ tcg_insts tcg_env)
                          ]
     badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 8f8f644cdb..68a925f901 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -2407,7 +2408,8 @@ wrapAction :: HscEnv -> IO a -> IO (Maybe a)
 wrapAction hsc_env k = do
   let lcl_logger = hsc_logger hsc_env
       lcl_dynflags = hsc_dflags hsc_env
-  let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)
+      print_config = initPrintConfig lcl_dynflags
+  let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (srcErrorMessages err)
   -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle
   -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`
   -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 3c2fbbac34..1ad0f4fac9 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -147,7 +147,8 @@ logDiagnostics warns = do
   dflags <- getSessionDynFlags
   logger <- getLogger
   let !diag_opts = initDiagOpts dflags
-  liftIO $ printOrThrowDiagnostics logger diag_opts warns
+      !print_config = initPrintConfig dflags
+  liftIO $ printOrThrowDiagnostics logger print_config diag_opts warns
 
 -- -----------------------------------------------------------------------------
 -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
@@ -224,7 +225,8 @@ printException err = do
   dflags <- getDynFlags
   logger <- getLogger
   let !diag_opts = initDiagOpts dflags
-  liftIO $ printMessages logger diag_opts (srcErrorMessages err)
+      !print_config = initPrintConfig dflags
+  liftIO $ printMessages logger print_config diag_opts (srcErrorMessages err)
 
 -- | A function called to log warnings and errors.
 type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m ()
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 8588dfdda8..246b00393a 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeApplications #-}
 
 -----------------------------------------------------------------------------
 --
@@ -162,7 +163,8 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
     to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
     to_driver_messages msgs = case traverse to_driver_message msgs of
       Nothing    -> pprPanic "non-driver message in preprocess"
-                             (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))
+                             -- MP: Default config is fine here as it's just in a panic.
+                             (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs))
       Just msgs' -> msgs'
 
     to_driver_message = \case
@@ -690,8 +692,9 @@ preprocessPipeline pipe_env hsc_env input_fn = do
             -- Reparse with original hsc_env so that we don't get duplicated options
             use (T_FileArgs hsc_env pp_fn)
 
-  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))
-  liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)
+  let print_config = initPrintConfig dflags3
+  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))
+  liftIO (handleFlagWarnings (hsc_logger hsc_env) print_config (initDiagOpts dflags3) warns3)
   return (dflags3, pp_fn)
 
 
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index 092a690b25..4566460a0e 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
-
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage
 
 module GHC.HsToCore.Errors.Ppr where
@@ -23,9 +25,11 @@ import GHC.HsToCore.Pmc.Ppr
 
 
 instance Diagnostic DsMessage where
-  diagnosticMessage = \case
-    DsUnknownMessage m
-      -> diagnosticMessage m
+  type DiagnosticOpts DsMessage = NoDiagnosticOpts
+  defaultDiagnosticOpts = NoDiagnosticOpts
+  diagnosticMessage _ = \case
+    DsUnknownMessage (UnknownDiagnostic @e m)
+      -> diagnosticMessage (defaultDiagnosticOpts @e) m
     DsEmptyEnumeration
       -> mkSimpleDecorated $ text "Enumeration is empty"
     DsIdentitiesFound conv_fn type_of_conv
@@ -235,7 +239,7 @@ instance Diagnostic DsMessage where
     DsRuleMightInlineFirst{}                    -> WarningWithFlag Opt_WarnInlineRuleShadowing
     DsAnotherRuleMightFireFirst{}               -> WarningWithFlag Opt_WarnInlineRuleShadowing
 
-  diagnosticHints  = \case
+  diagnosticHints = \case
     DsUnknownMessage m          -> diagnosticHints m
     DsEmptyEnumeration          -> noHints
     DsIdentitiesFound{}         -> noHints
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index 028a02544d..8f6586fb45 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module GHC.HsToCore.Errors.Types where
 
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 9bd53fa341..8a0b600a66 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -317,7 +317,7 @@ initTcDsForSolver thing_inside
          thing_inside
        ; case mb_ret of
            Just ret -> pure ret
-           Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }
+           Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
 
 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> IORef (Messages DsMessage) -> IORef CostCentreState
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index b515d89541..f2f8bfd769 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -5,6 +5,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage
 
@@ -36,9 +38,11 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 
 
 instance Diagnostic PsMessage where
-  diagnosticMessage = \case
-    PsUnknownMessage m
-      -> diagnosticMessage m
+  type DiagnosticOpts PsMessage = NoDiagnosticOpts
+  defaultDiagnosticOpts = NoDiagnosticOpts
+  diagnosticMessage _ = \case
+    PsUnknownMessage (UnknownDiagnostic @e m)
+      -> diagnosticMessage (defaultDiagnosticOpts @e) m
 
     PsHeaderMessage m
       -> psHeaderMessageDiagnostic m
@@ -509,7 +513,7 @@ instance Diagnostic PsMessage where
           , nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]
       , text "In the newtype declaration for" <+> quotes (ppr tycon) ]
 
-  diagnosticReason  = \case
+  diagnosticReason = \case
     PsUnknownMessage m                            -> diagnosticReason m
     PsHeaderMessage  m                            -> psHeaderMessageReason m
     PsWarnBidirectionalFormatChars{}              -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters
@@ -627,7 +631,7 @@ instance Diagnostic PsMessage where
     PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag
     PsErrMultipleConForNewtype {}                 -> ErrorWithoutFlag
 
-  diagnosticHints  = \case
+  diagnosticHints = \case
     PsUnknownMessage m                            -> diagnosticHints m
     PsHeaderMessage  m                            -> psHeaderMessageHints m
     PsWarnBidirectionalFormatChars{}              -> noHints
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 1b16911700..19851babd1 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module GHC.Parser.Errors.Types where
 
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 0eb7706434..7734a135f5 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1108,7 +1108,7 @@ mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msg = important, sr_supp
                   (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp
          -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"
        ; dflags <- getDynFlags
-       ; let err_msg = pprLocMsgEnvelope msg
+       ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg
              err_str = showSDoc dflags $
                        err_msg $$ text "(deferred type error)"
 
@@ -1174,9 +1174,12 @@ mkErrorReport tcl_env msg mb_ctxt supplementary
              ErrInfo
                (fromMaybe empty mb_context)
                (vcat $ map (pprSolverReportSupplementary hfdc) supplementary)
+       ; let detailed_msg = mkDetailedMessage err_info msg
        ; mkTcRnMessage
            (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)
-           (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) }
+           (TcRnMessageWithInfo unit_state $ detailed_msg) }
+
+
 
 -- | Pretty-print supplementary information, to add to an error report.
 pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 8dae970dee..993b62a7ea 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
 
@@ -95,15 +96,16 @@ import Data.Ord ( comparing )
 import Data.Bifunctor
 import GHC.Types.Name.Env
 
-
 instance Diagnostic TcRnMessage where
-  diagnosticMessage = \case
-    TcRnUnknownMessage m
-      -> diagnosticMessage m
+  type DiagnosticOpts TcRnMessage = NoDiagnosticOpts
+  defaultDiagnosticOpts = NoDiagnosticOpts
+  diagnosticMessage opts = \case
+    TcRnUnknownMessage (UnknownDiagnostic @e m)
+      -> diagnosticMessage (defaultDiagnosticOpts @e) m
     TcRnMessageWithInfo unit_state msg_with_info
       -> case msg_with_info of
            TcRnMessageDetailed err_info msg
-             -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg)
+             -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage opts msg)
     TcRnSolverReport msg _ _
       -> mkSimpleDecorated $ pprSolverReportWithCtxt msg
     TcRnRedundantConstraints redundants (info, show_info)
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 854ebd3bf6..d0d40366d9 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -182,12 +182,13 @@ data TcRnMessageDetailed
                         !TcRnMessage
   deriving Generic
 
-mkTcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage
+mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts)
+                     => a -> TcRnMessage
 mkTcRnUnknownMessage diag = TcRnUnknownMessage (UnknownDiagnostic diag)
 
 -- | An error which might arise during typechecking/renaming.
 data TcRnMessage where
-  {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins
+  {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins
       to provide custom diagnostic messages originated during typechecking/renaming.
   -}
   TcRnUnknownMessage :: UnknownDiagnostic -> TcRnMessage
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 6341aecf8d..b01c7ccb5d 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -1099,9 +1099,8 @@ tc_infer_id id_name
         hint_msg = vcat $ map ppr hints
         import_err_msg = vcat $ map ppr import_errs
         info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
-        msg = TcRnMessageWithInfo unit_state
-            $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False)
-      failWithTc msg
+      failWithTc $ TcRnMessageWithInfo unit_state (
+              mkDetailedMessage info (TcRnIncorrectNameSpace nm False))
 
     get_suggestions ns = do
        let occ = mkOccNameFS ns (occNameFS (occName id_name))
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index e7a45a5be9..f4490244f8 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1219,7 +1219,8 @@ runMeta' show_code ppr_hs run_and_convert expr
         -- cases.
         ; logger <- getLogger
         ; diag_opts <- initDiagOpts <$> getDynFlags
-        ; liftIO $ printMessages logger diag_opts ds_msgs
+        ; print_config <- initDsMessageOpts <$> getDynFlags
+        ; liftIO $ printMessages logger print_config diag_opts ds_msgs
 
         ; ds_expr <- case mb_ds_expr of
             Nothing      -> failM   -- Case (a) from Note [Errors in desugaring a splice]
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 346b1f4273..8319212147 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -70,7 +70,7 @@ module GHC.Tc.Utils.Monad(
   addErrAt, addErrs,
   checkErr,
   addMessages,
-  discardWarnings,
+  discardWarnings, mkDetailedMessage,
 
   -- * Usage environment
   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
@@ -1068,7 +1068,12 @@ addErrAt :: SrcSpan -> TcRnMessage -> TcRn ()
 addErrAt loc msg = do { ctxt <- getErrCtxt
                       ; tidy_env <- tcInitTidyEnv
                       ; err_info <- mkErrInfo tidy_env ctxt
-                      ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
+                      ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg
+                      ; add_long_err_at loc detailed_msg }
+
+mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed
+mkDetailedMessage err_info msg =
+  TcRnMessageDetailed err_info msg
 
 addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
 addErrs msgs = mapM_ add msgs
@@ -1132,7 +1137,7 @@ reportDiagnostics = mapM_ reportDiagnostic
 
 reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
 reportDiagnostic msg
-  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;
+  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ;
          errs_var <- getErrsVar ;
          msgs     <- readTcRef errs_var ;
          writeTcRef errs_var (msg `addMessage` msgs) }
@@ -1601,7 +1606,8 @@ addDiagnosticTcM (env0, msg)
  = do { ctxt <- getErrCtxt
       ; extra <- mkErrInfo env0 ctxt
       ; let err_info = ErrInfo extra Outputable.empty
-      ; add_diagnostic (TcRnMessageDetailed err_info msg) }
+            detailed_msg = mkDetailedMessage err_info msg
+      ; add_diagnostic detailed_msg }
 
 -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'
 -- given some additional context about the diagnostic.
@@ -1623,14 +1629,14 @@ addTcRnDiagnostic msg = do
 -- | Display a diagnostic for the current source location, taken from
 -- the 'TcRn' monad.
 addDiagnostic :: TcRnMessage -> TcRn ()
-addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg)
+addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg)
 
 -- | Display a diagnostic for a given source location.
 addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
 addDiagnosticAt loc msg = do
   unit_state <- hsc_units <$> getTopEnv
-  let dia = TcRnMessageDetailed no_err_info msg
-  mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic
+  let detailed_msg = mkDetailedMessage no_err_info msg
+  mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic
 
 -- | Display a diagnostic, with an optional flag, for the current source
 -- location.
@@ -1652,7 +1658,7 @@ add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan
             -> TcM ()
 add_err_tcm tidy_env msg loc ctxt
  = do { err_info <- mkErrInfo tidy_env ctxt ;
-        add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
+        add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) }
 
 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
 -- Tidy the error info, trimming excessive contexts
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 3c8ff8b4bb..3bc7937df0 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -4,6 +4,9 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
 
 module GHC.Types.Error
    ( -- * Messages
@@ -32,6 +35,8 @@ module GHC.Types.Error
    , mkDecoratedDiagnostic
    , mkDecoratedError
 
+   , NoDiagnosticOpts(..)
+
    -- * Hints and refactoring actions
    , GhcHint (..)
    , AvailableBindings(..)
@@ -211,11 +216,16 @@ mapDecoratedSDoc f (Decorated s1) =
 -- GHC's case, it can be an error or a warning) and the /reason/ why such
 -- message was generated in the first place.
 class Diagnostic a where
+
+  -- | Type of configuration options for the diagnostic.
+  type DiagnosticOpts a
+  defaultDiagnosticOpts :: DiagnosticOpts a
+
   -- | Extract the error message text from a 'Diagnostic'.
-  diagnosticMessage :: a -> DecoratedSDoc
+  diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc
 
   -- | Extract the reason for this diagnostic. For warnings,
-  -- a 'DiagnosticReason' includes the warning flag
+  -- a 'DiagnosticReason' includes the warning flag.
   diagnosticReason  :: a -> DiagnosticReason
 
   -- | Extract any hints a user might use to repair their
@@ -238,17 +248,25 @@ class Diagnostic a where
 
 -- | An existential wrapper around an unknown diagnostic.
 data UnknownDiagnostic where
-  UnknownDiagnostic :: (Typeable diag, Diagnostic diag) => diag -> UnknownDiagnostic
+  UnknownDiagnostic :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a)
+                    => a -> UnknownDiagnostic
 
 instance Diagnostic UnknownDiagnostic where
-  diagnosticMessage (UnknownDiagnostic diag) = diagnosticMessage diag
-  diagnosticReason  (UnknownDiagnostic diag) = diagnosticReason  diag
-  diagnosticHints   (UnknownDiagnostic diag) = diagnosticHints   diag
-  diagnosticCode    (UnknownDiagnostic diag) = diagnosticCode    diag
-
-pprDiagnostic :: Diagnostic e => e -> SDoc
+  type DiagnosticOpts UnknownDiagnostic = NoDiagnosticOpts
+  defaultDiagnosticOpts = NoDiagnosticOpts
+  diagnosticMessage _ (UnknownDiagnostic diag) = diagnosticMessage NoDiagnosticOpts diag
+  diagnosticReason    (UnknownDiagnostic diag) = diagnosticReason  diag
+  diagnosticHints     (UnknownDiagnostic diag) = diagnosticHints   diag
+  diagnosticCode      (UnknownDiagnostic diag) = diagnosticCode    diag
+
+-- A fallback 'DiagnosticOpts' which can be used when there are no options
+-- for a particular diagnostic.
+data NoDiagnosticOpts = NoDiagnosticOpts
+
+pprDiagnostic :: forall e . Diagnostic e => e -> SDoc
 pprDiagnostic e = vcat [ ppr (diagnosticReason e)
-                       , nest 2 (vcat (unDecorated (diagnosticMessage e))) ]
+                       , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ]
+  where opts = defaultDiagnosticOpts @e
 
 -- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.
 data DiagnosticHint = DiagnosticHint !SDoc
@@ -268,7 +286,9 @@ data DiagnosticMessage = DiagnosticMessage
   }
 
 instance Diagnostic DiagnosticMessage where
-  diagnosticMessage = diagMessage
+  type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts
+  defaultDiagnosticOpts = NoDiagnosticOpts
+  diagnosticMessage _ = diagMessage
   diagnosticReason  = diagReason
   diagnosticHints   = diagHints
   diagnosticCode _  = Nothing
@@ -429,10 +449,10 @@ instance ToJson MessageClass where
 instance Show (MsgEnvelope DiagnosticMessage) where
     show = showMsgEnvelope
 
--- | Shows an 'MsgEnvelope'.
-showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String
+-- | Shows an 'MsgEnvelope'. Only use this for debugging.
+showMsgEnvelope :: forall a . Diagnostic a => MsgEnvelope a -> String
 showMsgEnvelope err =
-  renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err))
+  renderWithContext defaultSDocContext (vcat (unDecorated . (diagnosticMessage (defaultDiagnosticOpts @a)) $ errMsgDiagnostic err))
 
 pprMessageBag :: Bag SDoc -> SDoc
 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs
index 4979d9188b..5ce389fd4e 100644
--- a/compiler/GHC/Types/SourceError.hs
+++ b/compiler/GHC/Types/SourceError.hs
@@ -14,7 +14,7 @@ import GHC.Types.Error
 import GHC.Utils.Monad
 import GHC.Utils.Panic
 import GHC.Utils.Exception
-import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc)
+import GHC.Utils.Error (pprMsgEnvelopeBagWithLocDefault)
 import GHC.Utils.Outputable
 
 import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage
@@ -59,7 +59,7 @@ instance Show SourceError where
   show (SourceError msgs) =
       renderWithContext defaultSDocContext
     . vcat
-    . pprMsgEnvelopeBagWithLoc
+    . pprMsgEnvelopeBagWithLocDefault
     . getMessages
     $ msgs
 
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index d696ddd2be..def40ea728 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor   #-}
 {-# LANGUAGE RankNTypes      #-}
 {-# LANGUAGE ViewPatterns    #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-
 (c) The AQUA Project, Glasgow University, 1994-1998
@@ -25,9 +26,9 @@ module GHC.Utils.Error (
         errorsFound, isEmptyMessages,
 
         -- ** Formatting
-        pprMessageBag, pprMsgEnvelopeBagWithLoc,
+        pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault,
         pprMessages,
-        pprLocMsgEnvelope,
+        pprLocMsgEnvelope, pprLocMsgEnvelopeDefault,
         formatBulleted,
 
         -- ** Construction
@@ -228,14 +229,22 @@ formatBulleted ctx (unDecorated -> docs)
     msgs    = filter (not . Outputable.isEmpty ctx) docs
     starred = (bullet<+>)
 
-pprMessages :: Diagnostic e => Messages e -> SDoc
-pprMessages = vcat . pprMsgEnvelopeBagWithLoc . getMessages
+pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc
+pprMessages e = vcat . pprMsgEnvelopeBagWithLoc e . getMessages
 
-pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
-pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ]
+pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
+pprMsgEnvelopeBagWithLoc e bag = [ pprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ]
 
-pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc
-pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s
+-- | Print the messages with the suitable default configuration, usually not what you want but sometimes you don't really
+-- care about what the configuration is (for example, if the message is in a panic).
+pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
+pprMsgEnvelopeBagWithLocDefault bag = [ pprLocMsgEnvelopeDefault item | item <- sortMsgBag Nothing bag ]
+
+pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc
+pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e)
+
+pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
+pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan      = s
                                , errMsgDiagnostic = e
                                , errMsgSeverity  = sev
                                , errMsgContext   = unqual })
@@ -244,7 +253,7 @@ pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s
       mkLocMessage
         (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e))
         s
-        (formatBulleted ctx $ diagnosticMessage e)
+        (formatBulleted ctx $ diagnosticMessage opts e)
 
 sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
 sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 6cbf4dffb9..4efb35f35e 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -3136,7 +3136,7 @@ newDynFlags interactive_only minus_opts = do
       idflags0 <- GHC.getInteractiveDynFlags
       (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts
 
-      liftIO $ handleFlagWarnings logger (initDiagOpts idflags1) warns
+      liftIO $ handleFlagWarnings logger (initPrintConfig idflags1) (initDiagOpts idflags1) warns
       when (not $ null leftovers)
            (throwGhcException . CmdLineError
             $ "Some flags have not been recognized: "
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 16075284c0..ae862a7014 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -247,7 +247,7 @@ main' postLoadMode units dflags0 args flagWarnings = do
   handleSourceError (\e -> do
        GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
-         liftIO $ handleFlagWarnings logger4 (initDiagOpts dflags4) flagWarnings'
+         liftIO $ handleFlagWarnings logger4 (initPrintConfig dflags4) (initDiagOpts dflags4) flagWarnings'
 
   liftIO $ showBanner postLoadMode dflags4
 
@@ -779,7 +779,7 @@ initMulti unitArgsFiles  = do
     handleSourceError (\e -> do
        GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
-         liftIO $ handleFlagWarnings logger (initDiagOpts dflags2) warns
+         liftIO $ handleFlagWarnings logger (initPrintConfig dflags2) (initDiagOpts dflags2) warns
 
     let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)
         dflags4 = offsetDynFlags dflags3
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
index 8e89a63cc6..32bad7c8e0 100644
--- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -51,7 +51,8 @@ main = do
       case mres of
         Nothing -> do
           let diag_opts = initDiagOpts dflags
-          printMessages logger diag_opts warnings
-          printMessages logger diag_opts errors
+              print_config = initTcMessageOpts dflags
+          printMessages logger print_config diag_opts warnings
+          printMessages logger print_config diag_opts errors
         Just (t, _) -> do
           putStrLn $ showSDoc dflags (debugPprType t)
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index 0238b5d03c..f3294bfd35 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -140,7 +140,8 @@ compileCmmForRegAllocStats logger home_unit dflags cmmFile ncgImplF us = do
 
     -- print parser errors or warnings
     let !diag_opts = initDiagOpts dflags
-    mapM_ (printMessages logger diag_opts) [warnings, errors]
+        !print_config = initPsMessageOpts dflags
+    mapM_ (printMessages logger print_config diag_opts) [warnings, errors]
 
     let initTopSRT = emptySRT thisMod
     cmmGroup <- fmap snd $ cmmPipeline logger cmm_config initTopSRT $ fst $ fromJust parsedCmm
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 8023549c22..87921ac3e8 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -358,7 +358,7 @@ showErrorMessages :: Messages GhcMessage -> String
 showErrorMessages msgs =
   renderWithContext defaultSDocContext
     $ vcat
-    $ pprMsgEnvelopeBagWithLoc
+    $ pprMsgEnvelopeBagWithLocDefault
     $ getMessages
     $ msgs
 
diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs
index b238b2baa7..756dc18984 100644
--- a/utils/check-exact/Preprocess.hs
+++ b/utils/check-exact/Preprocess.hs
@@ -17,7 +17,6 @@ module Preprocess
 import qualified GHC            as GHC hiding (parseModule)
 
 import qualified Control.Monad.IO.Class as GHC
-import qualified GHC.Data.Bag          as GHC
 import qualified GHC.Data.FastString   as GHC
 import qualified GHC.Data.StringBuffer as GHC
 import qualified GHC.Driver.Config.Parser as GHC
@@ -28,16 +27,17 @@ import qualified GHC.Driver.Pipeline   as GHC
 import qualified GHC.Fingerprint.Type  as GHC
 import qualified GHC.Parser.Lexer      as GHC
 import qualified GHC.Settings          as GHC
-import qualified GHC.Types.Error       as GHC (getErrorMessages, DiagnosticMessage(..))
+import qualified GHC.Types.Error       as GHC
 import qualified GHC.Types.SourceError as GHC
 import qualified GHC.Types.SourceFile  as GHC
 import qualified GHC.Types.SrcLoc      as GHC
 import qualified GHC.Utils.Error       as GHC
 import qualified GHC.Utils.Fingerprint as GHC
+import qualified GHC.Utils.Outputable  as GHC
 import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc)
 import GHC.Data.FastString (mkFastString)
 
-import Data.List (isPrefixOf, intercalate)
+import Data.List (isPrefixOf)
 import Data.Maybe
 import Types
 import Utils
@@ -218,25 +218,19 @@ getPreprocessedSrcDirectPrim cppOptions src_fn = do
       new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs }
   r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile))
   case r of
-    Left err -> error $ showErrorMessages $ fmap GHC.GhcDriverMessage err
+    Left err -> error $ showErrorMessages err
     Right (dflags', hspp_fn) -> do
       buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn
       txt <- GHC.liftIO $ readFileGhc hspp_fn
       return (txt, buf, dflags')
 
-showErrorMessages :: GHC.ErrorMessages -> String
-showErrorMessages msgs = intercalate "\n"
-    $ map (show @(GHC.MsgEnvelope GHC.DiagnosticMessage) . fmap toDiagnosticMessage)
-    $ GHC.bagToList
-    $ GHC.getErrorMessages msgs
-
--- | Show Error Messages relies on show instance for MsgEnvelope DiagnosticMessage
--- We convert a known Diagnostic into this generic version
-toDiagnosticMessage :: GHC.Diagnostic e => e -> GHC.DiagnosticMessage
-toDiagnosticMessage msg = GHC.DiagnosticMessage { diagMessage = GHC.diagnosticMessage msg
-                                                , diagReason  = GHC.diagnosticReason  msg
-                                                , diagHints   = GHC.diagnosticHints   msg
-                                                }
+showErrorMessages :: GHC.Messages GHC.DriverMessage -> String
+showErrorMessages msgs =
+  GHC.renderWithContext GHC.defaultSDocContext
+    $ GHC.vcat
+    $ GHC.pprMsgEnvelopeBagWithLocDefault
+    $ GHC.getMessages
+    $ msgs
 
 injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags
 injectCppOptions CppOptions{..} dflags =
diff --git a/utils/haddock b/utils/haddock
-Subproject e5b41a9f92de608f3605ef54da5709074e189ad
+Subproject 57b7493ba60bc4f4cf6b57b900b0c46fe8d8666