Commit b1436f55 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix yet another bug in 'deriving' for polykinded classes (Trac #7269)

This patch makes the code a bit simpler if anything.
parent 864759cb
......@@ -705,8 +705,9 @@ deriveTyData :: Bool -- False <=> data/newtype
-- I.e. not standalone deriving
deriveTyData is_instance 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
......@@ -720,12 +721,8 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
else
do { -- 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
-- we want to drop type variables from T so that (C d (T a)) is well-kinded
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
......@@ -737,9 +734,9 @@ deriveTyData is_instance 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
......@@ -1565,7 +1562,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
......@@ -1692,15 +1690,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
......@@ -1716,13 +1709,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]
......
......@@ -208,18 +208,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
......@@ -725,17 +729,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)
......
......@@ -49,3 +49,4 @@ test('T8865', normal, compile, [''])
test('T8893', normal, compile, [''])
test('T8950', expect_broken(8950), compile, [''])
test('T8963', normal, compile, [''])
test('T7269', normal, compile, [''])
......@@ -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’
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’
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:
......
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