[commit: ghc] master: Fix super-class cycle check (f13de71)
git at git.haskell.org
git at git.haskell.org
Wed Dec 23 10:13:21 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/f13de71b4684ab7702de3ad01eb212d81f7c4a5d/ghc
>---------------------------------------------------------------
commit f13de71b4684ab7702de3ad01eb212d81f7c4a5d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Dec 23 10:11:11 2015 +0000
Fix super-class cycle check
Fixes Trac #11278
>---------------------------------------------------------------
f13de71b4684ab7702de3ad01eb212d81f7c4a5d
compiler/prelude/TysWiredIn.hs | 1 +
compiler/typecheck/TcTyDecls.hs | 40 ++++++++++++++++++++++++-------------
compiler/typecheck/TcType.hs | 5 ++++-
testsuite/tests/polykinds/T11278.hs | 6 ++++++
testsuite/tests/polykinds/all.T | 2 +-
5 files changed, 38 insertions(+), 16 deletions(-)
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 368a56f..c26521d 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -517,6 +517,7 @@ cTupleTyConNameSet :: NameSet
cTupleTyConNameSet = mkNameSet cTupleTyConNames
isCTupleTyConName :: Name -> Bool
+-- Use Type.isCTupleClass where possible
isCTupleTyConName n
= ASSERT2( isExternalName n, ppr n )
nameModule n == gHC_CLASSES
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 8c80519..51d6fc7 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -189,7 +189,8 @@ checkClassCycles :: Class -> Maybe SDoc
-- Nothing <=> ok
-- Just err <=> possible cycle error
checkClassCycles cls
- = do { (definite_cycle, err) <- go emptyNameSet cls
+ = do { (definite_cycle, err) <- go (unitNameSet (getName cls))
+ cls (mkTyVarTys (classTyVars cls))
; let herald | definite_cycle = ptext (sLit "Superclass cycle for")
| otherwise = ptext (sLit "Potential superclass cycle for")
; return (vcat [ herald <+> quotes (ppr cls)
@@ -197,42 +198,53 @@ checkClassCycles cls
where
hint = ptext (sLit "Use UndecidableSuperClasses to accept this")
- go :: NameSet -> Class -> Maybe (Bool, SDoc)
- go so_far cls = firstJusts $
- map (go_pred (so_far `extendNameSet` getName cls)) $
- classSCTheta cls
+ -- Expand superclasses starting with (C a b), complaining
+ -- if you find the same class a second time, or a type function
+ -- or predicate headed by a type variable
+ --
+ -- NB: this code duplicates TcType.transSuperClasses, but
+ -- with more error message generation clobber
+ -- Make sure the two stay in sync.
+ go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+ go so_far cls tys = firstJusts $
+ map (go_pred so_far) $
+ immSuperClasses cls tys
go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)
-- Nothing <=> ok
-- Just (True, err) <=> definite cycle
-- Just (False, err) <=> possible cycle
go_pred so_far pred -- NB: tcSplitTyConApp looks through synonyms
- | Just (tc, _) <- tcSplitTyConApp_maybe pred
- = go_tc so_far pred tc
+ | Just (tc, tys) <- tcSplitTyConApp_maybe pred
+ = go_tc so_far pred tc tys
| hasTyVarHead pred
= Just (False, hang (ptext (sLit "one of whose superclass constraints is headed by a type variable:"))
2 (quotes (ppr pred)))
| otherwise
= Nothing
- go_tc :: NameSet -> PredType -> TyCon -> Maybe (Bool, SDoc)
- go_tc so_far pred tc
+ go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
+ go_tc so_far pred tc tys
| isFamilyTyCon tc
= Just (False, hang (ptext (sLit "one of whose superclass constraints is headed by a type family:"))
2 (quotes (ppr pred)))
| Just cls <- tyConClass_maybe tc
- = go_cls so_far cls
+ = go_cls so_far cls tys
| otherwise -- Equality predicate, for example
= Nothing
- go_cls :: NameSet -> Class -> Maybe (Bool, SDoc)
- go_cls so_far cls
- | getName cls `elemNameSet` so_far
+ go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+ go_cls so_far cls tys
+ | cls_nm `elemNameSet` so_far
= Just (True, ptext (sLit "one of whose superclasses is") <+> quotes (ppr cls))
+ | isCTupleClass cls
+ = go so_far cls tys
| otherwise
- = do { (b,err) <- go so_far cls
+ = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys
; return (b, ptext (sLit "one of whose superclasses is") <+> quotes (ppr cls)
$$ err) }
+ where
+ cls_nm = getName cls
{-
************************************************************************
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index bbd7bc2..82431c3 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -1616,7 +1616,10 @@ Notice that
(Eq a, (Ord a, Ix a))
And this is try of any class that we can statically guarantee
as non-recursive (in some sense). For now, we just make a special
- case for tuples
+ case for tuples. Somthing better would be cool.
+
+See also TcTyDecls.checkClassCycles.
+
************************************************************************
* *
diff --git a/testsuite/tests/polykinds/T11278.hs b/testsuite/tests/polykinds/T11278.hs
new file mode 100644
index 0000000..25c43cd
--- /dev/null
+++ b/testsuite/tests/polykinds/T11278.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE ConstraintKinds #-}
+
+module A where
+
+type K a = (Show a, Read a)
+class K a => C a where
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index fd7b216..6387d17 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/testsuite/tests/polykinds/all.T
@@ -129,4 +129,4 @@ test('SigTvKinds2', expect_broken(11203), compile_fail, [''])
test('T9017', normal, compile_fail, [''])
test('T11249', normal, compile, [''])
test('T11248', normal, compile, [''])
-
+test('T11278', normal, compile, [''])
More information about the ghc-commits
mailing list