summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/typecheck/TcDeriv.hs44
-rw-r--r--testsuite/tests/deriving/should_compile/T10561.hs19
-rw-r--r--testsuite/tests/deriving/should_compile/T10561.stderr5
-rw-r--r--testsuite/tests/deriving/should_compile/all.T1
-rw-r--r--testsuite/tests/deriving/should_fail/T9071.stderr7
-rw-r--r--testsuite/tests/deriving/should_fail/T9071_2.stderr7
-rw-r--r--testsuite/tests/typecheck/should_fail/T9305.stderr7
7 files changed, 63 insertions, 27 deletions
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index f99f78b6ef..bbb9dc3589 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -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
diff --git a/testsuite/tests/deriving/should_compile/T10561.hs b/testsuite/tests/deriving/should_compile/T10561.hs
new file mode 100644
index 0000000000..85acc516d9
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T10561.hs
@@ -0,0 +1,19 @@
+{-# 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)
+-}
diff --git a/testsuite/tests/deriving/should_compile/T10561.stderr b/testsuite/tests/deriving/should_compile/T10561.stderr
new file mode 100644
index 0000000000..3a158ddb9a
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T10561.stderr
@@ -0,0 +1,5 @@
+
+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))
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index e16d8f5432..a01a5149b2 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -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, [''])
diff --git a/testsuite/tests/deriving/should_fail/T9071.stderr b/testsuite/tests/deriving/should_fail/T9071.stderr
index 3a09c8ecd5..c2dccbd28f 100644
--- a/testsuite/tests/deriving/should_fail/T9071.stderr
+++ b/testsuite/tests/deriving/should_fail/T9071.stderr
@@ -1,10 +1,7 @@
[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)
diff --git a/testsuite/tests/deriving/should_fail/T9071_2.stderr b/testsuite/tests/deriving/should_fail/T9071_2.stderr
index 65ba471c40..f618343a7a 100644
--- a/testsuite/tests/deriving/should_fail/T9071_2.stderr
+++ b/testsuite/tests/deriving/should_fail/T9071_2.stderr
@@ -1,8 +1,5 @@
-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)
diff --git a/testsuite/tests/typecheck/should_fail/T9305.stderr b/testsuite/tests/typecheck/should_fail/T9305.stderr
index c908a562ae..e7c761ef46 100644
--- a/testsuite/tests/typecheck/should_fail/T9305.stderr
+++ b/testsuite/tests/typecheck/should_fail/T9305.stderr
@@ -1,8 +1,5 @@
-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)
View Lorry Controller Status