[commit: ghc] ghc-8.0: Make validDerivPred ignore non-visible arguments to a class type constructor (9cf69d3)

[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/9cf69d33102aeae925c59d0ccc43a983f1c93081/ghc

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

commit 9cf69d33102aeae925c59d0ccc43a983f1c93081
Author: RyanGlScott <ryan.gl.scott at gmail.com>
Date:   Mon May 2 12:38:04 2016 -0400

    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
    
    (cherry picked from commit fa86ac7c14b67f27017d795811265c3a9750024b)


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

9cf69d33102aeae925c59d0ccc43a983f1c93081
 compiler/typecheck/TcValidity.hs                  | 22 ++++++++++++++++------
 testsuite/tests/deriving/should_compile/T11833.hs |  9 +++++++++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 3 files changed, 26 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 359e643..b3bc558 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -1136,6 +1136,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 ...
@@ -1156,19 +1165,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'
 
 {-
 ************************************************************************
@@ -1866,7 +1876,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 0000000..75d2a2d
--- /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 cfbb977..07242ec 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, [''])