[commit: ghc] ghc-8.0: Adjust error check for class method types (aab9241)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/aab92412cf4cb77d988d36fb013018695c271ccd/ghc

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

commit aab92412cf4cb77d988d36fb013018695c271ccd
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Apr 15 11:49:23 2016 +0100

    Adjust error check for class method types
    
    Fixes Trac #11793.  Nothing deep here.
    
    (cherry picked from commit e24b3b1eeba91bd5b127261652b48eae2d4751b1)


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

aab92412cf4cb77d988d36fb013018695c271ccd
 compiler/typecheck/TcTyClsDecls.hs                 | 23 +++++++++++++++++++---
 testsuite/tests/typecheck/should_compile/T11793.hs |  8 ++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 3 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index f7c03dd..63a6330 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -2380,9 +2380,12 @@ checkValidClass cls
           (_,theta2,_)    = tcSplitSigmaTy tau1
 
           check_constraint :: TcPredType -> TcM ()
-          check_constraint pred
-            = when (tyCoVarsOfType pred `subVarSet` cls_tv_set)
+          check_constraint pred -- See Note [Class method constraints]
+            = when (not (isEmptyVarSet pred_tvs) &&
+                    pred_tvs `subVarSet` cls_tv_set)
                    (addErrTc (badMethPred sel_id pred))
+            where
+              pred_tvs = tyCoVarsOfType pred
 
     check_at (ATI fam_tc m_dflt_rhs)
       = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)
@@ -2421,7 +2424,21 @@ checkFamFlag tc_name
     err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))
                  2 (text "Use TypeFamilies to allow indexed type families")
 
-{-
+{- Note [Class method constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Haskell 2010 is supposed to reject
+  class C a where
+    op :: Eq a => a -> a
+where the method type costrains only the class variable(s).  (The extension
+-XConstrainedClassMethods switches off this check.)  But regardless
+we should not reject
+  class C a where
+    op :: (?x::Int) => a -> a
+as pointed out in Trac #11793. So the test here rejects the program if
+  * -XConstrainedClassMethods is off
+  * the tyvars of the constraint are non-empty
+  * all the tyvars are class tyvars, none are locally quantified
+
 Note [Abort when superclass cycle is detected]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We must avoid doing the ambiguity check for the methods (in
diff --git a/testsuite/tests/typecheck/should_compile/T11793.hs b/testsuite/tests/typecheck/should_compile/T11793.hs
new file mode 100644
index 0000000..f42a623
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11793.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ImplicitParams #-}
+
+module T11793 where
+
+class C a where
+  op :: (?x::Int) => a -> a
+
+-- Should be OK even without ConstrainedClassMethods
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index c03773a..f6c9d2e 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -510,3 +510,4 @@ test('T11699', normal, compile, [''])
 test('T11512', normal, compile, [''])
 test('T11754', normal, compile, [''])
 test('T11811', normal, compile, [''])
+test('T11793', normal, compile, [''])