From bb3fdb4eb3a9cdf644e4f117e1e9916a6b4d7f79 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Wed, 2 Jul 2014 12:47:11 -0500
Subject: [PATCH] Fix yet another bug in 'deriving' for polykinded classes
(Trac #7269)
This patch makes the code a bit simpler if anything.
(cherry picked from commit b1436f55da2b0e005ac09be6651a2c4d934027ec)
---
compiler/typecheck/TcDeriv.lhs | 28 ++++++----------
compiler/typecheck/TcHsType.lhs | 32 +++++++++++--------
testsuite/tests/deriving/should_compile/all.T | 1 +
.../tests/deriving/should_fail/T7959.stderr | 2 +-
.../deriving/should_fail/drvfail005.stderr | 4 +--
.../deriving/should_fail/drvfail009.stderr | 6 ++--
6 files changed, 34 insertions(+), 39 deletions(-)
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 09218dbeeb15..30c57d19861c 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -657,8 +657,9 @@ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance
-- The deriving clause of a data or newtype declaration
deriveTyData tvs tc tc_args (L loc deriv_pred)
= setSrcSpan loc $ -- Use the location of the 'deriving' item
- do { (deriv_tvs, cls, cls_tys) <- tcExtendTyVarEnv tvs $
- tcHsDeriv deriv_pred
+ do { (deriv_tvs, cls, cls_tys, cls_arg_kind)
+ <- tcExtendTyVarEnv tvs $
+ tcHsDeriv deriv_pred
-- Deriving preds may (now) mention
-- the type variables for the type constructor, hence tcExtendTyVarenv
-- The "deriv_pred" is a LHsType to take account of the fact that for
@@ -673,11 +674,7 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
-- Given data T a b c = ... deriving( C d ),
-- we want to drop type variables from T so that (C d (T a)) is well-kinded
- ; let cls_tyvars = classTyVars cls
- ; checkTc (not (null cls_tyvars)) derivingNullaryErr
-
- ; let cls_arg_kind = tyVarKind (last cls_tyvars)
- (arg_kinds, _) = splitKindFunTys cls_arg_kind
+ let (arg_kinds, _) = splitKindFunTys cls_arg_kind
n_args_to_drop = length arg_kinds
n_args_to_keep = tyConArity tc - n_args_to_drop
args_to_drop = drop n_args_to_keep tc_args
@@ -689,9 +686,9 @@ deriveTyData tvs tc tc_args (L loc deriv_pred)
-- to the types. See Note [Unify kinds in deriving]
-- We are assuming the tycon tyvars and the class tyvars are distinct
mb_match = tcUnifyTy inst_ty_kind cls_arg_kind
- Just kind_subst = mb_match
+ Just kind_subst = mb_match
(univ_kvs, univ_tvs) = partition isKindVar $ varSetElems $
- mkVarSet deriv_tvs `unionVarSet`
+ mkVarSet deriv_tvs `unionVarSet`
tyVarsOfTypes tc_args_to_keep
univ_kvs' = filter (`notElemTvSubst` kind_subst) univ_kvs
(subst', univ_tvs') = mapAccumL substTyVarBndr kind_subst univ_tvs
@@ -1506,7 +1503,8 @@ mkNewTypeEqn :: DynFlags -> [Var] -> Class
mkNewTypeEqn dflags tvs
cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
- | might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls)
+ | ASSERT( length cls_tys + 1 == classArity cls )
+ might_derive_via_coercible && (newtype_deriving || std_class_via_coercible cls)
= do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
dfun_name <- new_dfun_name cls tycon
loc <- getSrcSpanM
@@ -1633,15 +1631,10 @@ mkNewTypeEqn dflags tvs
-- See Note [Determining whether newtype-deriving is appropriate]
might_derive_via_coercible
= not (non_coercible_class cls)
- && arity_ok
&& eta_ok
&& ats_ok
-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
- arity_ok = length cls_tys + 1 == classArity cls
- -- Well kinded; eg not: newtype T ... deriving( ST )
- -- because ST needs *2* type params
-
-- Check that eta reduction is OK
eta_ok = nt_eta_arity <= length rep_tc_args
-- The newtype can be eta-reduced to match the number
@@ -1657,13 +1650,10 @@ mkNewTypeEqn dflags tvs
-- so for 'data' instance decls
cant_derive_err
- = vcat [ ppUnless arity_ok arity_msg
- , ppUnless eta_ok eta_msg
+ = vcat [ ppUnless eta_ok eta_msg
, ppUnless ats_ok ats_msg ]
- arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
ats_msg = ptext (sLit "the class has associated types")
-
\end{code}
Note [Recursive newtypes]
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index eed906898b7d..e4a34d966dc4 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -207,18 +207,22 @@ tc_inst_head hs_ty
= tc_hs_type hs_ty ekConstraint
-----------------
-tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type])
--- Like tcHsSigTypeNC, but for the ...deriving( ty ) clause
-tcHsDeriv hs_ty
- = do { kind <- newMetaKindVar
- ; ty <- tcCheckHsTypeAndGen hs_ty kind
- -- Funny newtype deriving form
- -- forall a. C [a]
- -- where C has arity 2. Hence any-kinded result
- ; ty <- zonkSigType ty
+tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type], Kind)
+-- Like tcHsSigTypeNC, but for the ...deriving( C t1 ty2 ) clause
+-- Returns the C, [ty1, ty2, and the kind of C's *next* argument
+-- E.g. class C (a::*) (b::k->k)
+-- data T a b = ... deriving( C Int )
+-- returns ([k], C, [k, Int], k->k)
+-- Also checks that (C ty1 ty2 arg) :: Constraint
+-- if arg has a suitable kind
+tcHsDeriv hs_ty
+ = do { arg_kind <- newMetaKindVar
+ ; ty <- tcCheckHsTypeAndGen hs_ty (mkArrowKind arg_kind constraintKind)
+ ; ty <- zonkSigType ty
+ ; arg_kind <- zonkSigType arg_kind
; let (tvs, pred) = splitForAllTys ty
; case getClassPredTys_maybe pred of
- Just (cls, tys) -> return (tvs, cls, tys)
+ Just (cls, tys) -> return (tvs, cls, tys, arg_kind)
Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) }
-- Used for 'VECTORISE [SCALAR] instance' declarations
@@ -724,17 +728,17 @@ mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2
zonkSigType :: TcType -> TcM TcType
-- Zonk the result of type-checking a user-written type signature
--- It may have kind varaibles in it, but no meta type variables
+-- It may have kind variables in it, but no meta type variables
-- Because of knot-typing (see Note [Zonking inside the knot])
--- it may need to establish the Type invariants;
+-- it may need to establish the Type invariants;
-- hence the use of mkTyConApp and mkAppTy
zonkSigType ty
= go ty
where
go (TyConApp tc tys) = do tys' <- mapM go tys
return (mkTyConApp tc tys')
- -- Key point: establish Type invariants!
- -- See Note [Zonking inside the knot]
+ -- Key point: establish Type invariants!
+ -- See Note [Zonking inside the knot]
go (LitTy n) = return (LitTy n)
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index f8ab42e66d45..e69208b30264 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -47,3 +47,4 @@ test('T8758', extra_clean(['T8758a.o', 'T8758a.hi']), multimod_compile, ['T8758a
test('T8865', normal, compile, [''])
test('T8893', normal, compile, [''])
test('T8963', normal, compile, [''])
+test('T7269', normal, compile, [''])
diff --git a/testsuite/tests/deriving/should_fail/T7959.stderr b/testsuite/tests/deriving/should_fail/T7959.stderr
index dde9ee003410..5ca93a7fe325 100644
--- a/testsuite/tests/deriving/should_fail/T7959.stderr
+++ b/testsuite/tests/deriving/should_fail/T7959.stderr
@@ -4,5 +4,5 @@ T7959.hs:5:1:
In the stand-alone deriving instance for ‘A’
T7959.hs:6:17:
- Cannot derive instances for nullary classes
+ Expected kind ‘k0 -> Constraint’, but ‘A’ has kind ‘Constraint’
In the data declaration for ‘B’
diff --git a/testsuite/tests/deriving/should_fail/drvfail005.stderr b/testsuite/tests/deriving/should_fail/drvfail005.stderr
index b5a2de8d01ae..1546a37d0795 100644
--- a/testsuite/tests/deriving/should_fail/drvfail005.stderr
+++ b/testsuite/tests/deriving/should_fail/drvfail005.stderr
@@ -1,5 +1,5 @@
drvfail005.hs:4:13:
- Can't make a derived instance of ‘Show a (Test a)’:
- ‘Show a’ is not a class
+ Expected kind ‘k0 -> Constraint’,
+ but ‘Show a’ has kind ‘Constraint’
In the data declaration for ‘Test’
diff --git a/testsuite/tests/deriving/should_fail/drvfail009.stderr b/testsuite/tests/deriving/should_fail/drvfail009.stderr
index fcc5b4c30562..b9dd90c75876 100644
--- a/testsuite/tests/deriving/should_fail/drvfail009.stderr
+++ b/testsuite/tests/deriving/should_fail/drvfail009.stderr
@@ -1,8 +1,8 @@
drvfail009.hs:10:31:
- Can't make a derived instance of ‘C T1’
- (even with cunning newtype deriving):
- ‘C’ does not have arity 1
+ Expecting one more argument to ‘C’
+ Expected kind ‘* -> Constraint’,
+ but ‘C’ has kind ‘* -> * -> Constraint’
In the newtype declaration for ‘T1’
drvfail009.hs:13:31:
--
GitLab