[commit: ghc] master: Check that an associated type mentions at least one type variable from the class (66bddbb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/66bddbb27fd9c383f85005b8c6e1961d25d7a7dd/ghc

>---------------------------------------------------------------

commit 66bddbb27fd9c383f85005b8c6e1961d25d7a7dd
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jun 9 13:28:51 2014 +0100

    Check that an associated type mentions at least one type variable from the class
    
    Fixes Trac #9167


>---------------------------------------------------------------

66bddbb27fd9c383f85005b8c6e1961d25d7a7dd
 compiler/typecheck/TcTyClsDecls.lhs                    | 18 +++++++++++-------
 testsuite/tests/indexed-types/should_fail/T2888.stderr |  5 +++++
 testsuite/tests/indexed-types/should_fail/T9167.hs     |  6 ++++++
 testsuite/tests/indexed-types/should_fail/T9167.stderr |  5 +++++
 testsuite/tests/indexed-types/should_fail/all.T        |  3 ++-
 testsuite/tests/typecheck/should_fail/tcfail116.stderr |  2 +-
 6 files changed, 30 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 94fefbb..4239530 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1620,7 +1620,7 @@ checkValidClass cls
                 -- since there is no possible ambiguity
         ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
         ; checkTc (arity == 0 || tyVarsOfType tau `intersectsVarSet` grown_tyvars)
-                  (noClassTyVarErr cls sel_id)
+                  (noClassTyVarErr cls (ptext (sLit "class method") <+> quotes (ppr sel_id)))
 
         ; case dm of
             GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
@@ -1643,8 +1643,12 @@ checkValidClass cls
                 -- type variable.  What a mess!
 
     check_at_defs (fam_tc, defs)
-      = tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $
-        mapM_ (checkValidTyFamInst mb_clsinfo fam_tc) defs
+      = do { traceTc "check-at" (ppr fam_tc $$ ppr (tyConTyVars fam_tc) $$ ppr tyvars)
+           ; checkTc (any (`elem` tyvars) (tyConTyVars fam_tc)) 
+                     (noClassTyVarErr cls (ptext (sLit "associated type") <+> quotes (ppr fam_tc)))
+                     
+           ; tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $
+             mapM_ (checkValidTyFamInst mb_clsinfo fam_tc) defs }
 
     mb_clsinfo = Just (cls, mkVarEnv [ (tv, mkTyVarTy tv) | tv <- tyvars ])
 
@@ -2067,11 +2071,11 @@ classFunDepsErr cls
   = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
           parens (ptext (sLit "Use FunctionalDependencies to allow fundeps"))]
 
-noClassTyVarErr :: Class -> Var -> SDoc
-noClassTyVarErr clas op
-  = sep [ptext (sLit "The class method") <+> quotes (ppr op),
+noClassTyVarErr :: Class -> SDoc -> SDoc
+noClassTyVarErr clas what
+  = sep [ptext (sLit "The") <+> what,
          ptext (sLit "mentions none of the type variables of the class") <+>
-                ppr clas <+> hsep (map ppr (classTyVars clas))]
+                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
 
 recSynErr :: [LTyClDecl Name] -> TcRn ()
 recSynErr syn_decls
diff --git a/testsuite/tests/indexed-types/should_fail/T2888.stderr b/testsuite/tests/indexed-types/should_fail/T2888.stderr
new file mode 100644
index 0000000..df217dd
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T2888.stderr
@@ -0,0 +1,5 @@
+
+T2888.hs:6:1:
+    The associated type ‘D’
+    mentions none of the type variables of the class ‘C w’
+    In the class declaration for ‘C’
diff --git a/testsuite/tests/indexed-types/should_fail/T9167.hs b/testsuite/tests/indexed-types/should_fail/T9167.hs
new file mode 100644
index 0000000..2d2f555
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T9167.hs
@@ -0,0 +1,6 @@
+ {-# LANGUAGE TypeFamilies #-}
+
+module T9167 where
+
+class C a where
+   type F b
diff --git a/testsuite/tests/indexed-types/should_fail/T9167.stderr b/testsuite/tests/indexed-types/should_fail/T9167.stderr
new file mode 100644
index 0000000..ec230fa
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T9167.stderr
@@ -0,0 +1,5 @@
+
+T9167.hs:5:1:
+    The associated type ‘F’
+    mentions none of the type variables of the class ‘C a’
+    In the class declaration for ‘C’
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index 003b51d..d60f15f 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -47,7 +47,7 @@ test('T2157', normal, compile_fail, [''])
 test('T2203a', normal, compile_fail, [''])
 test('T2627b', normal, compile_fail, [''])
 test('T2693', normal, compile_fail, [''])
-test('T2888', normal, compile, [''])
+test('T2888', normal, compile_fail, [''])
 test('T3092', normal, compile_fail, [''])
 test('NoMatchErr', normal, compile_fail, [''])
 test('T2677', normal, compile_fail, [''])
@@ -120,4 +120,5 @@ test('T8368', normal, compile_fail, [''])
 test('T8368a', normal, compile_fail, [''])
 test('T8518', normal, compile_fail, [''])
 test('T9036', normal, compile_fail, [''])
+test('T9167', normal, compile_fail, [''])
 
diff --git a/testsuite/tests/typecheck/should_fail/tcfail116.stderr b/testsuite/tests/typecheck/should_fail/tcfail116.stderr
index 0fdafcf..51b89ef 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail116.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail116.stderr
@@ -1,6 +1,6 @@
 
 tcfail116.hs:5:1:
     The class method ‘bug’
-    mentions none of the type variables of the class Foo a
+    mentions none of the type variables of the class ‘Foo a’
     When checking the class method: bug :: ()
     In the class declaration for ‘Foo’