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

3 files changed, 12 insertions, 18 deletions

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