Try to simplify zoo of functions in `Tc.Utils.Monad`

This commit tries to untangle the zoo of diagnostic-related functions
in `Tc.Utils.Monad` so that we can have the interfaces mentions only
`TcRnMessage`s while we push the creation of these messages upstream.

It also ports TcRnMessage diagnostics to use the new API, in particular
this commit switch to use TcRnMessage in the external interfaces
of the diagnostic functions, and port the old SDoc to be wrapped
into TcRnUnknownMessage.

1 files changed, 29 insertions, 7 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 578c182a7d..837672c4d1 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
+{-# LANGUAGE RecordWildCards #-}
 
 module GHC.Tc.Errors.Ppr (
     formatLevPolyErr
@@ -16,18 +17,24 @@ import GHC.Types.Var.Env (emptyTidyEnv)
 import GHC.Driver.Flags
 import GHC.Hs
 import GHC.Utils.Outputable
+import GHC.Unit.State (pprWithUnitState, UnitState)
+
 
 instance Diagnostic TcRnMessage where
   diagnosticMessage = \case
     TcRnUnknownMessage m
       -> diagnosticMessage m
-    TcLevityPolyInType ty prov (ErrInfo extra)
-      -> mkDecorated [pprLevityPolyInType ty prov, extra]
-    TcRnImplicitLift id_or_name errInfo
-      -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+>
-                      text "is implicitly lifted in the TH quotation"
-                     , getErrInfo errInfo
-                     ]
+    TcLevityPolyInType ty prov (ErrInfo extra supplementary)
+      -> mkDecorated [pprLevityPolyInType ty prov, extra, supplementary]
+    TcRnMessageWithInfo unit_state msg_with_info
+      -> case msg_with_info of
+           TcRnMessageDetailed err_info msg
+             -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg)
+    TcRnImplicitLift id_or_name ErrInfo{..}
+      -> mkDecorated $
+           ( text "The variable" <+> quotes (ppr id_or_name) <+>
+             text "is implicitly lifted in the TH quotation"
+           ) : [errInfoContext, errInfoSupplementary]
     TcRnUnusedPatternBinds bind
       -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]
     TcRnDodgyImports name
@@ -48,6 +55,9 @@ instance Diagnostic TcRnMessage where
       -> diagnosticReason m
     TcLevityPolyInType{}
       -> ErrorWithoutFlag
+    TcRnMessageWithInfo _ msg_with_info
+      -> case msg_with_info of
+           TcRnMessageDetailed _ m -> diagnosticReason m
     TcRnImplicitLift{}
       -> WarningWithFlag Opt_WarnImplicitLift
     TcRnUnusedPatternBinds{}
@@ -68,6 +78,9 @@ instance Diagnostic TcRnMessage where
       -> diagnosticHints m
     TcLevityPolyInType{}
       -> noHints
+    TcRnMessageWithInfo _ msg_with_info
+      -> case msg_with_info of
+           TcRnMessageDetailed _ m -> diagnosticHints m
     TcRnImplicitLift{}
       -> noHints
     TcRnUnusedPatternBinds{}
@@ -83,6 +96,15 @@ instance Diagnostic TcRnMessage where
     TcRnModMissingRealSrcSpan{}
       -> noHints
 
+messageWithInfoDiagnosticMessage :: UnitState
+                                 -> ErrInfo
+                                 -> DecoratedSDoc
+                                 -> DecoratedSDoc
+messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important =
+  let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary]
+      in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc`
+         mkDecorated err_info'
+
 dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
 dodgy_msg kind tc ie
   = sep [ text "The" <+> kind <+> text "item"