[Git][ghc/ghc][master] Add structured error messages for GHC.Tc.TyCl.Utils
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Apr 8 02:29:44 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00
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 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Types/Error/Codes.hs
- testsuite/tests/backpack/should_fail/bkpfail29.stderr
- testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
- testsuite/tests/module/mod27.stderr
Changes:
=====================================
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
=====================================
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)]
=====================================
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 =
=====================================
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
=====================================
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
=====================================
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
=====================================
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 it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a788f0ad465cf49673b187c5feeae80b738ce54
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a788f0ad465cf49673b187c5feeae80b738ce54
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230407/dc2e318d/attachment-0001.html>
More information about the ghc-commits
mailing list