Commit fa86ac7c authored by Ryan Scott's avatar Ryan Scott Committed by Ryan Scott

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
parent c5be5e2e
......@@ -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
......
{-# 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
......@@ -69,3 +69,4 @@ test('T11357', normal, compile, [''])
test('T11732a', normal, compile, [''])
test('T11732b', normal, compile, [''])
test('T11732c', normal, compile, [''])
test('T11833', normal, compile, [''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment