Commit 9a348640 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve kind-checking for 'deriving' clauses

The main payload is in 'mk_functor_like_constraints' in
TcDeriv.inferConstraints.

This is moving towards a fix for Trac #10561
parent 4d1316a5
......@@ -1029,7 +1029,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
| cls `hasKey` gen1ClassKey -- Gen1 needs Functor
= ASSERT(length rep_tc_tvs > 0) -- See Note [Getting base classes]
do { functorClass <- tcLookupClass functorClassName
; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) }
; return (con_arg_constraints (get_gen1_constraints functorClass)) }
| otherwise -- The others are a bit more complicated
= ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
......@@ -1038,17 +1038,19 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
++ sc_constraints
++ arg_constraints) }
where
arg_constraints = con_arg_constraints cls get_std_constrained_tys
arg_constraints = con_arg_constraints get_std_constrained_tys
-- Constraints arising from the arguments of each constructor
con_arg_constraints cls' get_constrained_tys
= [ mkPredOrigin (DerivOriginDC data_con arg_n) (mkClassPred cls' [inner_ty])
con_arg_constraints :: (CtOrigin -> Type -> [PredOrigin]) -> [PredOrigin]
con_arg_constraints get_arg_constraints
= [ pred
| data_con <- tyConDataCons rep_tc
, (arg_n, arg_ty) <- ASSERT( isVanillaDataCon data_con )
zip [1..] $ -- ASSERT is precondition of dataConInstOrigArgTys
dataConInstOrigArgTys data_con all_rep_tc_args
, not (isUnLiftedType arg_ty)
, inner_ty <- get_constrained_tys arg_ty ]
, let orig = DerivOriginDC data_con arg_n
, pred <- get_arg_constraints orig arg_ty ]
-- No constraints for unlifted types
-- See Note [Deriving and unboxed types]
......@@ -1059,19 +1061,37 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
-- (b) The rep_tc_args will be one short
is_functor_like = getUnique cls `elem` functorLikeClassKeys
|| onlyOneAndTypeConstr inst_tys
onlyOneAndTypeConstr [inst_ty] =
typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind
onlyOneAndTypeConstr [inst_ty] = typeKind inst_ty `tcEqKind` a2a_kind
onlyOneAndTypeConstr _ = False
get_std_constrained_tys :: Type -> [Type]
get_std_constrained_tys ty
| is_functor_like = deepSubtypesContaining last_tv ty
| otherwise = [ty]
a2a_kind = mkArrowKind liftedTypeKind liftedTypeKind
get_gen1_constraints functor_cls orig ty
= mk_functor_like_constraints orig functor_cls $
get_gen1_constrained_tys last_tv ty
get_std_constrained_tys :: CtOrigin -> Type -> [PredOrigin]
get_std_constrained_tys orig ty
| is_functor_like = mk_functor_like_constraints orig cls $
deepSubtypesContaining last_tv ty
| otherwise = [mkPredOrigin orig (mkClassPred cls [ty])]
mk_functor_like_constraints :: CtOrigin -> Class -> [Type] -> [PredOrigin]
-- 'cls' is Functor or Traversable etc
-- For each type, generate two constraints: (cls ty, kind(ty) ~ (*->*))
-- The second constraint checks that the first is well-kinded.
-- Lacking that, as Trac #10561 showed, we can just generate an
-- ill-kinded instance.
mk_functor_like_constraints orig cls tys
= [ mkPredOrigin orig pred
| ty <- tys
, pred <- [ mkClassPred cls [ty]
, mkEqPred (typeKind ty) a2a_kind] ]
rep_tc_tvs = tyConTyVars rep_tc
last_tv = last rep_tc_tvs
all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
= rep_tc_args ++ [mkTyVarTy last_tv]
= rep_tc_args ++ [mkTyVarTy last_tv]
| otherwise = rep_tc_args
-- Constraints arising from superclasses
......
{-# LANGUAGE PolyKinds, DeriveFunctor, RankNTypes #-}
module T10561 where
-- Ultimately this should "Just Work",
-- but in GHC 7.10 it gave a Lint failure
-- For now (HEAD, Jun 2015) it gives a kind error message,
-- which is better than a crash
newtype Compose f g a = Compose (f (g a)) deriving Functor
{-
instance forall (f_ant :: k_ans -> *)
(g_anu :: * -> k_ans).
(Functor f_ant, Functor g_anu) =>
Functor (Compose f_ant g_anu) where
fmap f_anv (T10561.Compose a1_anw)
= Compose (fmap (fmap f_anv) a1_anw)
-}
T10561.hs:10:52: error:
Couldn't match kind ‘k’ with ‘*’
arising from the first field of ‘Compose’ (type ‘f (g a)’)
When deriving the instance for (Functor (Compose f g))
......@@ -53,4 +53,5 @@ test('T9069', normal, compile, [''])
test('T9359', normal, compile, [''])
test('T4896', normal, compile, [''])
test('T7947', extra_clean(['T7947a.o', 'T7947a.hi', 'T7947b.o', 'T7947b.hi']), multimod_compile, ['T7947', '-v0'])
test('T10561', normal, compile_fail, [''])
[1 of 2] Compiling T9071a ( T9071a.hs, T9071a.o )
[2 of 2] Compiling T9071 ( T9071.hs, T9071.o )
T9071.hs:7:37:
No instance for (Functor Mu)
T9071.hs:7:37: error:
Couldn't match kind ‘* -> *’ with ‘*’
arising from the first field of ‘F’ (type ‘Mu (K a)’)
Possible fix:
use a standalone 'deriving instance' declaration,
so you can specify the instance context yourself
When deriving the instance for (Functor F)
T9071_2.hs:7:40:
No instance for (Functor K1)
T9071_2.hs:7:40: error:
Couldn't match kind ‘* -> *’ with ‘*’
arising from the first field of ‘F1’ (type ‘Mu (K1 a)’)
Possible fix:
use a standalone 'deriving instance' declaration,
so you can specify the instance context yourself
When deriving the instance for (Functor F1)
T9305.hs:8:48:
No instance for (Functor F)
T9305.hs:8:48: error:
Couldn't match kind ‘* -> *’ with ‘*’
arising from the first field of ‘EventF’ (type ‘F (Event a)’)
Possible fix:
use a standalone 'deriving instance' declaration,
so you can specify the instance context yourself
When deriving the instance for (Functor EventF)
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