diagnostics: Allow configuration at runtime (setup)wip/diagnostics-context

Ticket #21722

20 files changed, 76 insertions, 51 deletions

diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index baaa551588..efe45b2f6d 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) s $
@@ -30,7 +31,7 @@ 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)
@@ -56,7 +57,7 @@ printOrThrowDiagnostics logger opts msgs
   | errorsOrFatalWarningsFound msgs
   = throwErrors msgs
   | otherwise
-  = printMessages logger opts msgs
+  = printMessages logger () 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 8fe416196b..53fcc8e6ab 100644
--- a/compiler/GHC/Driver/Errors/Ppr.hs
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage}
 
 module GHC.Driver.Errors.Ppr where
@@ -34,17 +35,19 @@ suggestInstantiatedWith pi_mod_name insts =
 
 
 instance Diagnostic GhcMessage where
-  diagnosticMessage = \case
+  type DiagnosticOpts GhcMessage = ()
+  defaultDiagnosticOpts = ()
+  diagnosticMessage _ = \case
     GhcPsMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
     GhcTcRnMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
     GhcDsMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
     GhcDriverMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
     GhcUnknownMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
 
   diagnosticReason = \case
     GhcPsMessage m
@@ -71,11 +74,13 @@ instance Diagnostic GhcMessage where
       -> diagnosticHints m
 
 instance Diagnostic DriverMessage where
-  diagnosticMessage = \case
+  type DiagnosticOpts DriverMessage = ()
+  defaultDiagnosticOpts = ()
+  diagnosticMessage _ = \case
     DriverUnknownMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
     DriverPsHeaderMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () 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 015ae5e375..5f87c8e94a 100644
--- a/compiler/GHC/Driver/Errors/Types.hs
+++ b/compiler/GHC/Driver/Errors/Types.hs
@@ -83,7 +83,7 @@ data GhcMessage where
   -- 'Diagnostic' constraint ensures that worst case scenario we can still
   -- render this into something which can be eventually converted into a
   -- 'DecoratedSDoc'.
-  GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage
+  GhcUnknownMessage :: forall a. (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => a -> GhcMessage
 
 -- | Creates a new 'GhcMessage' out of any diagnostic. This function is also
 -- provided to ease the integration of #18516 by allowing diagnostics to be
@@ -91,7 +91,7 @@ data GhcMessage where
 -- 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 ~ (), Diagnostic a, Typeable a) => a -> GhcMessage
 ghcUnknownMessage = GhcUnknownMessage
 
 -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on
@@ -110,7 +110,7 @@ type DriverMessages = Messages DriverMessage
 -- | A message from the driver.
 data DriverMessage where
   -- | Simply wraps a generic 'Diagnostic' message @a@.
-  DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage
+  DriverUnknownMessage :: (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => a -> DriverMessage
   -- | A parse error in parsing a Haskell file header during dependency
   -- analysis
   DriverPsHeaderMessage :: !PsMessage -> DriverMessage
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 7db9b62331..982666f490 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -381,7 +381,7 @@ handleWarningsThrowErrors (warnings, errors) = do
     logDiagnostics (GhcPsMessage <$> warnings)
     logger <- getLogger
     let (wWarns, wErrs) = partitionMessages warnings
-    liftIO $ printMessages logger diag_opts wWarns
+    liftIO $ printMessages logger () diag_opts wWarns
     throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs
 
 -- | Deal with errors and warnings returned by a compilation step
@@ -1580,7 +1580,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
     whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
                          , text "Reason:"
                          , nest 4 $ (vcat $ badFlags df) $+$
-                                    (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$
+                                    (vcat $ pprMsgEnvelopeBagWithLoc undefined (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 efaefd84f5..21f8226f31 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -2267,7 +2267,7 @@ 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)
+  let logg err = printMessages lcl_logger () (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 bfe7e0feb8..a620dc0d70 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -247,7 +247,7 @@ printException err = do
   dflags <- getDynFlags
   logger <- getLogger
   let !diag_opts = initDiagOpts dflags
-  liftIO $ printMessages logger diag_opts (srcErrorMessages err)
+  liftIO $ printMessages logger () 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 e988979df2..b40549e701 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -161,7 +161,7 @@ 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))
+                             (vcat $ pprMsgEnvelopeBagWithLoc undefined (getMessages msgs))
       Just msgs' -> msgs'
 
     to_driver_message = \case
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index 9695eee60c..62f40ded88 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage
 
 module GHC.HsToCore.Errors.Ppr where
@@ -20,9 +22,11 @@ import GHC.HsToCore.Pmc.Ppr
 
 
 instance Diagnostic DsMessage where
-  diagnosticMessage = \case
+  type DiagnosticOpts DsMessage = ()
+  defaultDiagnosticOpts = ()
+  diagnosticMessage _ = \case
     DsUnknownMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () 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 d178eecfed..ae415697fd 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module GHC.HsToCore.Errors.Types where
 
@@ -27,7 +28,7 @@ type MaxPmCheckModels = Int
 -- | Diagnostics messages emitted during desugaring.
 data DsMessage
   -- | Simply wraps a generic 'Diagnostic' message.
-  = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a
+  = forall a. (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => DsUnknownMessage a
 
     {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is
         emitted if an enumeration is empty.
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 9211b52fd7..28fd9f0870 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 $ pprMsgEnvelopeBagWithLoc undefined (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 d108673e9c..c0a6e3687e 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage
 
@@ -33,9 +34,11 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 
 
 instance Diagnostic PsMessage where
-  diagnosticMessage = \case
+  type DiagnosticOpts PsMessage = ()
+  defaultDiagnosticOpts = ()
+  diagnosticMessage _ = \case
     PsUnknownMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
 
     PsHeaderMessage m
       -> psHeaderMessageDiagnostic m
@@ -499,7 +502,7 @@ instance Diagnostic PsMessage where
             ]
     PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."]
 
-  diagnosticReason  = \case
+  diagnosticReason = \case
     PsUnknownMessage m                            -> diagnosticReason m
     PsHeaderMessage  m                            -> psHeaderMessageReason m
     PsWarnBidirectionalFormatChars{}              -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters
@@ -616,7 +619,7 @@ instance Diagnostic PsMessage where
     PsErrIllegalGadtRecordMultiplicity{}          -> ErrorWithoutFlag
     PsErrInvalidCApiImport {}                     -> 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 7f40c73635..25ed28268b 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module GHC.Parser.Errors.Types where
 
@@ -68,7 +69,7 @@ data PsMessage
         arbitrary messages to be embedded. The typical use case would be GHC plugins
         willing to emit custom diagnostics.
     -}
-   forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a
+   forall a. (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => PsUnknownMessage a
 
     {-| A group of parser messages emitted in 'GHC.Parser.Header'.
         See Note [Messages from GHC.Parser.Header].
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 8ca2d2c6da..0f19f57058 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1105,7 +1105,7 @@ mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_sup
                   (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 undefined msg
              err_str = showSDoc dflags $
                        err_msg $$ text "(deferred type error)"
 
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 87f482a290..5eca678ddb 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
 
@@ -92,13 +93,15 @@ import GHC.Types.Name.Env
 
 
 instance Diagnostic TcRnMessage where
-  diagnosticMessage = \case
+  type DiagnosticOpts TcRnMessage = ()
+  defaultDiagnosticOpts = ()
+  diagnosticMessage m = \case
     TcRnUnknownMessage m
-      -> diagnosticMessage m
+      -> diagnosticMessage () m
     TcRnMessageWithInfo unit_state msg_with_info
       -> case msg_with_info of
            TcRnMessageDetailed err_info suppress_ctx msg
-             -> messageWithInfoDiagnosticMessage unit_state err_info suppress_ctx (diagnosticMessage msg)
+             -> messageWithInfoDiagnosticMessage unit_state err_info suppress_ctx (diagnosticMessage m msg)
     TcRnSolverReport msgs _ _
       -> mkDecorated $
            map pprSolverReportWithCtxt msgs
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index b257c97fc0..dd708aee18 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -175,7 +175,7 @@ data TcRnMessage where
   {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins
       to provide custom diagnostic messages originated during typechecking/renaming.
   -}
-  TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage
+  TcRnUnknownMessage :: (DiagnosticOpts a ~ (), Diagnostic a, Typeable a) => a -> TcRnMessage
 
   {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed
       to be provided in order to qualify a diagnostic and where it was originated (and why).
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 4c6279a6d9..cc152a86b8 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1224,7 +1224,7 @@ runMeta' show_code ppr_hs run_and_convert expr
         -- cases.
         ; logger <- getLogger
         ; diag_opts <- initDiagOpts <$> getDynFlags
-        ; liftIO $ printMessages logger diag_opts ds_msgs
+        ; liftIO $ printMessages logger () 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 efe30fca02..b7eef860bb 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1137,7 +1137,7 @@ reportDiagnostics = mapM_ reportDiagnostic
 
 reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
 reportDiagnostic msg
-  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;
+  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope undefined msg) ;
          errs_var <- getErrsVar ;
          msgs     <- readTcRef errs_var ;
          writeTcRef errs_var (msg `addMessage` msgs) }
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index aab0bbf0e8..0d7395ea1c 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
@@ -235,13 +238,15 @@ constraint.
 -- message was generated in the first place. See also Note [Rendering
 -- Messages].
 class Diagnostic a where
-  diagnosticMessage :: a -> DecoratedSDoc
+  type DiagnosticOpts a
+  defaultDiagnosticOpts :: DiagnosticOpts a
+  diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc
   diagnosticReason  :: a -> DiagnosticReason
   diagnosticHints   :: a -> [GhcHint]
 
-pprDiagnostic :: Diagnostic e => e -> SDoc
+pprDiagnostic :: forall e . Diagnostic e => e -> SDoc
 pprDiagnostic e = vcat [ ppr (diagnosticReason e)
-                       , nest 2 (vcat (unDecorated (diagnosticMessage e))) ]
+                       , nest 2 (vcat (unDecorated (diagnosticMessage (defaultDiagnosticOpts @e) e))) ]
 
 -- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.
 data DiagnosticHint = DiagnosticHint !SDoc
@@ -261,7 +266,9 @@ data DiagnosticMessage = DiagnosticMessage
   }
 
 instance Diagnostic DiagnosticMessage where
-  diagnosticMessage = diagMessage
+  type DiagnosticOpts DiagnosticMessage = ()
+  defaultDiagnosticOpts = ()
+  diagnosticMessage _ = diagMessage
   diagnosticReason  = diagReason
   diagnosticHints   = diagHints
 
@@ -420,7 +427,7 @@ instance Show (MsgEnvelope DiagnosticMessage) where
 -- | Shows an 'MsgEnvelope'.
 showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String
 showMsgEnvelope err =
-  renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err))
+  renderWithContext defaultSDocContext (vcat (unDecorated . (diagnosticMessage undefined) $ 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..02d03e3a67 100644
--- a/compiler/GHC/Types/SourceError.hs
+++ b/compiler/GHC/Types/SourceError.hs
@@ -59,7 +59,7 @@ instance Show SourceError where
   show (SourceError msgs) =
       renderWithContext defaultSDocContext
     . vcat
-    . pprMsgEnvelopeBagWithLoc
+    . pprMsgEnvelopeBagWithLoc undefined
     . getMessages
     $ msgs
 
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 8c044c5af9..58514066c4 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -228,20 +228,20 @@ 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
+pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc
+pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan      = s
                                , errMsgDiagnostic = e
                                , errMsgSeverity  = sev
                                , errMsgContext   = unqual })
   = sdocWithContext $ \ctx ->
     withErrStyle unqual $
-      mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e)
+      mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage opts e)
 
 sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
 sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList