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.

2 files changed, 95 insertions, 10 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"
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 4e9d233a67..dfaf43df5b 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -3,6 +3,7 @@
 module GHC.Tc.Errors.Types (
   -- * Main types
     TcRnMessage(..)
+  , TcRnMessageDetailed(..)
   , ErrInfo(..)
   , LevityCheckProvenance(..)
   ) where
@@ -15,10 +16,61 @@ import GHC.Unit.Types (Module)
 import GHC.Utils.Outputable
 import Data.Typeable
 import GHC.Core.Type (Type, Var)
+import GHC.Unit.State (UnitState)
+
+{-
+Note [Migrating TcM Messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+As part of #18516, we are slowly migrating the diagnostic messages emitted
+and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted
+some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions
+that accepted 3 SDocs an input: one for the important part of the message,
+one for the context and one for any supplementary information. Consider the following:
+
+    • Couldn't match expected type ‘Int’ with actual type ‘Char’
+    • In the expression: x4
+      In a stmt of a 'do' block: return (x2, x4)
+      In the expression:
+
+Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match"
+as the important part, "In the expression" as the context and "In a stmt..In the expression"
+as the supplementary, with the context and supplementary usually smashed together so that
+the final message would be composed only by two SDoc (which would then be bulletted like in
+the example).
+
+In order for us to smooth out the migration to the new diagnostic infrastructure, we
+introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose
+of bridging the two worlds together without breaking the external API or the existing
+format of messages reported by GHC.
+
+Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden
+diagnostic API inside Tc.Utils.Monad, enabling further refactorings.
+
+In the future, once the conversion will be complete and we will successfully eradicate
+any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and
+existence of these two types, which for now remain a "necessary evil".
+
+-}
+
 
 -- The majority of TcRn messages come with extra context about the error,
--- and this newtype captures it.
-newtype ErrInfo = ErrInfo { getErrInfo :: SDoc }
+-- and this newtype captures it. See Note [Migrating TcM messages].
+data ErrInfo = ErrInfo {
+    errInfoContext :: !SDoc
+    -- ^ Extra context associated to the error.
+  , errInfoSupplementary :: !SDoc
+    -- ^ Extra supplementary info associated to the error.
+  }
+
+
+-- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside
+-- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing
+-- any extra info needed to correctly pretty-print this diagnostic later on.
+data TcRnMessageDetailed
+  = TcRnMessageDetailed !ErrInfo
+                        -- ^ Extra info associated with the message
+                        !TcRnMessage
 
 -- | An error which might arise during typechecking/renaming.
 data TcRnMessage where
@@ -27,6 +79,18 @@ data TcRnMessage where
   -}
   TcRnUnknownMessage :: (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).
+      It carries an extra 'UnitState' which can be used to pretty-print some names
+      and it wraps a 'TcRnMessageDetailed', which includes any extra context associated
+      with this diagnostic.
+  -}
+  TcRnMessageWithInfo :: !UnitState
+                      -- ^ The 'UnitState' will allow us to pretty-print
+                      -- some diagnostics with more detail.
+                      -> !TcRnMessageDetailed
+                      -> TcRnMessage
+
   {-| A levity polymorphism check happening during TcRn.
   -}
   TcLevityPolyInType :: !Type
@@ -34,7 +98,6 @@ data TcRnMessage where
                      -> !ErrInfo -- Extra info accumulated in the TcM monad
                      -> TcRnMessage
 
-
   {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when
       a Template Haskell quote implicitly uses 'lift'.