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

6 files changed, 34 insertions, 22 deletions

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