Add structured error messages for GHC.Tc.TyCl.Utils

Tracking ticket: #20117

MR: !10251

This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.

7 files changed, 42 insertions, 18 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 2d056a31b1..f4024fe68f 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1716,6 +1716,18 @@ instance Diagnostic TcRnMessage where
       -> mkSimpleDecorated $
            text "Illegal" <+> (text $ levelString typeOrKind) <> colon <+> quotes (ppr thing)
 
+    TcRnTypeSynonymCycle decl_or_tcs
+      -> mkSimpleDecorated $
+           sep [ text "Cycle in type synonym declarations:"
+               , nest 2 (vcat (map ppr_decl decl_or_tcs)) ]
+      where
+        ppr_decl = \case
+          Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
+          Left tc ->
+            let n = tyConName tc
+            in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc)
+                   <+> text "from external module"
+
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -2286,6 +2298,8 @@ instance Diagnostic TcRnMessage where
       -> WarningWithFlag Opt_WarnUnusedForalls
     TcRnDataKindsError{}
       -> ErrorWithoutFlag
+    TcRnTypeSynonymCycle{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -2883,6 +2897,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnDataKindsError{}
       -> [suggestExtension LangExt.DataKinds]
+    TcRnTypeSynonymCycle{}
+      -> noHints
 
   diagnosticCode = constructorCode
 
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 14ff1ff6b7..7817715537 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -108,6 +108,7 @@ module GHC.Tc.Errors.Types (
   , TyFamsDisabledReason(..)
   , HsTypeOrSigType(..)
   , HsTyVarBndrExistentialFlag(..)
+  , TySynCycleTyCons
   ) where
 
 import GHC.Prelude
@@ -3787,6 +3788,15 @@ data TcRnMessage where
     -> HsExpr GhcPs -- ^ Section
     -> TcRnMessage
 
+  {-| TcRnTypeSynonymCycle is an error indicating that a cycle between type
+    synonyms has occurred.
+
+    Test cases:
+      mod27, ghc-e-fail2, bkpfail29
+  -}
+  TcRnTypeSynonymCycle :: !TySynCycleTyCons -- ^ The tycons involved in the cycle
+                       -> TcRnMessage
+
   deriving Generic
 
 -- | Things forbidden in @type data@ declarations.
@@ -5192,3 +5202,6 @@ data HsTyVarBndrExistentialFlag = forall flag. OutputableBndrFlag flag 'Renamed
 
 instance Outputable HsTyVarBndrExistentialFlag where
   ppr (HsTyVarBndrExistentialFlag hsTyVarBndr) = ppr hsTyVarBndr
+
+type TySynCycleTyCons =
+  [Either TyCon (LTyClDecl GhcRn)]
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index e052cb7633..8e7b3b8c39 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -65,7 +65,6 @@ import GHC.Data.FastString
 import GHC.Unit.Module
 
 import GHC.Types.Basic
-import GHC.Types.Error
 import GHC.Types.FieldLabel
 import GHC.Types.SrcLoc
 import GHC.Types.SourceFile
@@ -168,7 +167,7 @@ synonymTyConsOfType ty
 -- track of the TyCons which are known to be acyclic, or
 -- a failure message reporting that a cycle was found.
 newtype SynCycleM a = SynCycleM {
-    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
+    runSynCycleM :: SynCycleState -> Either (SrcSpan, TySynCycleTyCons) (a, SynCycleState) }
     deriving (Functor)
 
 -- TODO: TyConSet is implemented as IntMap over uniques.
@@ -188,8 +187,8 @@ instance Monad SynCycleM where
                 runSynCycleM (f x) state'
             Left err -> Left err
 
-failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
-failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
+failSynCycleM :: SrcSpan -> TySynCycleTyCons -> SynCycleM ()
+failSynCycleM loc seen_tcs = SynCycleM $ \_ -> Left (loc, seen_tcs)
 
 -- | Test if a 'Name' is acyclic, short-circuiting if we've
 -- seen it already.
@@ -209,7 +208,7 @@ checkTyConIsAcyclic tc m = SynCycleM $ \s ->
 checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
 checkSynCycles this_uid tcs tyclds =
     case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of
-        Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
+        Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnTypeSynonymCycle err)
         Right _  -> return ()
   where
     -- Try our best to print the LTyClDecl for locally defined things
@@ -226,9 +225,7 @@ checkSynCycles this_uid tcs tyclds =
     go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
     go' so_far seen_tcs tc
         | tc `elemTyConSet` so_far
-            = failSynCycleM (getSrcSpan (head seen_tcs)) $
-                  sep [ text "Cycle in type synonym declarations:"
-                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]
+            = failSynCycleM (getSrcSpan (head seen_tcs)) (lookup_decl <$> seen_tcs)
         -- Optimization: we don't allow cycles through external packages,
         -- so once we find a non-local name we are guaranteed to not
         -- have a cycle.
@@ -245,13 +242,10 @@ checkSynCycles this_uid tcs tyclds =
       where
         n = tyConName tc
         mod = nameModule n
-        ppr_decl tc =
-          case lookupNameEnv lcl_decls n of
-            Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
-            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n
-                       <+> text "from external module"
-         where
-          n = tyConName tc
+        lookup_decl tc =
+          case lookupNameEnv lcl_decls (tyConName tc) of
+            Just decl -> Right decl
+            Nothing -> Left tc
 
     go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
     go_ty so_far seen_tcs ty =
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 8f02023fc9..2aeffa87f5 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -578,6 +578,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnRoleAnnotationsDisabled"                   = 17779
   GhcDiagnosticCode "TcRnIncoherentRoles"                           = 18273
   GhcDiagnosticCode "TcRnTyFamNameMismatch"                         = 88221
+  GhcDiagnosticCode "TcRnTypeSynonymCycle"                          = 97522
 
   -- TcRnBadFieldAnnotation/BadFieldAnnotationReason
   GhcDiagnosticCode "LazyFieldsDisabled"                            = 81601
diff --git a/testsuite/tests/backpack/should_fail/bkpfail29.stderr b/testsuite/tests/backpack/should_fail/bkpfail29.stderr
index dc4f64768a..dc5a006ed4 100644
--- a/testsuite/tests/backpack/should_fail/bkpfail29.stderr
+++ b/testsuite/tests/backpack/should_fail/bkpfail29.stderr
@@ -5,7 +5,7 @@
 [3 of 3] Processing r
   [1 of 4] Compiling A[sig]           ( r/A.hsig, nothing )
 
-bkpfail29.bkp:8:9: error:
+bkpfail29.bkp:8:9: error: [GHC-97522]
     • Cycle in type synonym declarations:
         bkpfail29.bkp:8:9-18: S from external module
         bkpfail29.bkp:7:9-14: T from external module
diff --git a/testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr b/testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
index 858139c117..49668b081c 100644
--- a/testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
+++ b/testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
@@ -1,5 +1,5 @@
 
-<interactive>:0:1: error:
+<interactive>:0:1: error: [GHC-97522]
     Cycle in type synonym declarations:
       <interactive>:0:1-10: type A = A
 1
diff --git a/testsuite/tests/module/mod27.stderr b/testsuite/tests/module/mod27.stderr
index d2c333ffbf..5b3fdacbd4 100644
--- a/testsuite/tests/module/mod27.stderr
+++ b/testsuite/tests/module/mod27.stderr
@@ -1,5 +1,5 @@
 
-mod27.hs:3:1: error:
+mod27.hs:3:1: error: [GHC-97522]
     Cycle in type synonym declarations:
       mod27.hs:3:1-18: type T1 = (Int, T2)
       mod27.hs:4:1-18: type T2 = (Int, T1)