Make validDerivPred ignore non-visible arguments to a class type constructor

Summary:
GHC choked when trying to derive the following:

```
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
module Example where

class Category (cat :: k -> k -> *) where
  catId   :: cat a a
  catComp :: cat b c -> cat a b -> cat a c

newtype T (c :: * -> * -> *) a b = MkT (c a b) deriving Category
```

Unlike in #8865, where we were deriving `Category` for a concrete type like
`Either`, in the above example we are attempting to derive an instance of the
form:

```
instance Category * c => Category (T * c) where ...
```

(using `-fprint-explicit-kinds` syntax). But `validDerivPred` is checking if
`sizePred (Category * c)` equals the number of free type variables in
`Category * c`. But note that `sizePred` counts both type variables //and//
type constructors, and `*` is a type constructor! So `validDerivPred`
erroneously rejects the above instance.

The fix is to make `validDerivPred` ignore non-visible arguments to the class
type constructor (e.g., ignore `*` is `Category * c`) by using
`filterOutInvisibleTypes`.

Fixes #11833.

Test Plan: ./validate

Reviewers: goldfire, hvr, simonpj, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2112

GHC Trac Issues: #11833

3 files changed, 26 insertions, 6 deletions

diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 0833243b19..d9f43d39c3 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -1178,6 +1178,15 @@ It checks for three things
     So if they are the same, there must be no constructors.  But there
     might be applications thus (f (g x)).
 
+    Note that tys only includes the visible arguments of the class type
+    constructor. Including the non-vivisble arguments can cause the following,
+    perfectly valid instance to be rejected:
+       class Category (cat :: k -> k -> *) where ...
+       newtype T (c :: * -> * -> *) a b = MkT (c a b)
+       instance Category c => Category (T c) where ...
+    since the first argument to Category is a non-visible *, which sizeTypes
+    would count as a constructor! See Trac #11833.
+
   * Also check for a bizarre corner case, when the derived instance decl
     would look like
        instance C a b => D (T a) where ...
@@ -1198,19 +1207,20 @@ validDerivPred :: TyVarSet -> PredType -> Bool
 -- See Note [Valid 'deriving' predicate]
 validDerivPred tv_set pred
   = case classifyPredType pred of
-       ClassPred cls _ -> cls `hasKey` typeableClassKey
+       ClassPred cls tys -> cls `hasKey` typeableClassKey
                 -- Typeable constraints are bigger than they appear due
                 -- to kind polymorphism, but that's OK
-                       || check_tys
+                       || check_tys cls tys
        EqPred {}       -> False  -- reject equality constraints
        _               -> True   -- Non-class predicates are ok
   where
-    check_tys = hasNoDups fvs
+    check_tys cls tys
+              = hasNoDups fvs
                    -- use sizePred to ignore implicit args
                 && sizePred pred == fromIntegral (length fvs)
                 && all (`elemVarSet` tv_set) fvs
-
-    fvs = fvType pred
+      where tys' = filterOutInvisibleTypes (classTyCon cls) tys
+            fvs  = fvTypes tys'
 
 {-
 ************************************************************************
@@ -1937,7 +1947,7 @@ sizePred ty = goClass ty
 
     go (ClassPred cls tys')
       | isTerminatingClass cls = 0
-      | otherwise              = sizeTypes tys'
+      | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')
     go (EqPred {})        = 0
     go (IrredPred ty)     = sizeType ty
 
diff --git a/testsuite/tests/deriving/should_compile/T11833.hs b/testsuite/tests/deriving/should_compile/T11833.hs
new file mode 100644
index 0000000000..75d2a2d255
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T11833.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PolyKinds #-}
+module T11833 where
+
+class Category (cat :: k -> k -> *) where
+  catId   :: cat a a
+  catComp :: cat b c -> cat a b -> cat a c
+
+newtype T (c :: * -> * -> *) a b = MkT (c a b) deriving Category
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index cfbb977abe..07242ec694 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -69,3 +69,4 @@ test('T11357', normal, compile, [''])
 test('T11732a', normal, compile, [''])
 test('T11732b', normal, compile, [''])
 test('T11732c', normal, compile, [''])
+test('T11833', normal, compile, [''])