summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs16
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs13
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs24
-rw-r--r--compiler/GHC/Types/Error/Codes.hs1
-rw-r--r--testsuite/tests/backpack/should_fail/bkpfail29.stderr2
-rw-r--r--testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr2
-rw-r--r--testsuite/tests/module/mod27.stderr2
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)
View Lorry Controller Status