diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index db8505c92931bc98c7342b4d6355b14064fcf4fa..02c0c098055e66ef77ba2a8366f03fac614c0722 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1060,7 +1060,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
| data_con <- tyConDataCons rep_tc,
(arg_n, arg_ty) <-
ASSERT( isVanillaDataCon data_con )
- zip [1..] $
+ zip [1..] $ -- ASSERT is precondition of dataConInstOrigArgTys
get_constrained_tys $
dataConInstOrigArgTys data_con all_rep_tc_args,
not (isUnLiftedType arg_ty) ]
@@ -1171,21 +1171,30 @@ sideConditions mtheta cls
| cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
| cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
| cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond`
- cond_std `andCond` cond_args cls)
+ cond_std `andCond`
+ cond_args cls)
| cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond`
- cond_functorOK True) -- NB: no cond_std!
+ cond_vanilla `andCond`
+ cond_functorOK True)
| cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond`
+ cond_vanilla `andCond`
cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
| cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
+ cond_vanilla `andCond`
cond_functorOK False)
- | cls_key == genClassKey = Just (cond_RepresentableOk `andCond`
- checkFlag Opt_DeriveGeneric)
- | cls_key == gen1ClassKey = Just (cond_Representable1Ok `andCond`
- checkFlag Opt_DeriveGeneric)
+ | cls_key == genClassKey = Just (checkFlag Opt_DeriveGeneric `andCond`
+ cond_vanilla `andCond`
+ cond_RepresentableOk)
+ | cls_key == gen1ClassKey = Just (checkFlag Opt_DeriveGeneric `andCond`
+ cond_vanilla `andCond`
+ cond_Representable1Ok)
| otherwise = Nothing
where
cls_key = getUnique cls
- cond_std = cond_stdOK mtheta
+ cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one,
+ -- and monotype arguments
+ cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but
+ -- allow no data cons or polytype arguments
type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc
-- first Bool is whether or not we are allowed to derive Data and Typeable
@@ -1208,13 +1217,18 @@ andCond c1 c2 tc = case c1 tc of
Nothing -> c2 tc -- c1 succeeds
Just x -> Just x -- c1 fails
-cond_stdOK :: DerivContext -> Condition
-cond_stdOK (Just _) _
+cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
+ -- if standalone, we just say "yes, go for it"
+ -> Bool -- True <=> permissive: allow higher rank
+ -- args and no data constructors
+ -> Condition
+cond_stdOK (Just _) _ _
= Nothing -- Don't check these conservative conditions for
-- standalone deriving; just generate the code
-- and let the typechecker handle the result
-cond_stdOK Nothing (_, rep_tc, _)
- | null data_cons = Just (no_cons_why rep_tc $$ suggestion)
+cond_stdOK Nothing permissive (_, rep_tc, _)
+ | null data_cons
+ , not permissive = Just (no_cons_why rep_tc $$ suggestion)
| not (null con_whys) = Just (vcat con_whys $$ suggestion)
| otherwise = Nothing
where
@@ -1224,9 +1238,12 @@ cond_stdOK Nothing (_, rep_tc, _)
check_con :: DataCon -> Maybe SDoc
check_con con
- | isVanillaDataCon con
- , all isTauTy (dataConOrigArgTys con) = Nothing
- | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
+ | not (isVanillaDataCon con)
+ = Just (badCon con (ptext (sLit "has existentials or constraints in its type")))
+ | not (permissive || all isTauTy (dataConOrigArgTys con))
+ = Just (badCon con (ptext (sLit "has a higher-rank type")))
+ | otherwise
+ = Nothing
no_cons_why :: TyCon -> SDoc
no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
@@ -1244,7 +1261,7 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
cond_args :: Class -> Condition
-- For some classes (eg Eq, Ord) we allow unlifted arg types
--- by generating specilaised code. For others (eg Data) we don't.
+-- by generating specialised code. For others (eg Data) we don't.
cond_args cls (_, tc, _)
= case bad_args of
[] -> Nothing
@@ -1342,11 +1359,16 @@ cond_functorOK allowFunctions (_, rep_tc, _)
is_bad pred = last_tv `elemVarSet` tyVarsOfType pred
data_cons = tyConDataCons rep_tc
- check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
-
- check_vanilla :: DataCon -> Maybe SDoc
- check_vanilla con | isVanillaDataCon con = Nothing
- | otherwise = Just (badCon con existential)
+ check_con con = msum (check_universal con : foldDataConArgs (ft_check con) con)
+
+ check_universal :: DataCon -> Maybe SDoc
+ check_universal con
+ | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
+ , tv `elem` dataConUnivTyVars con
+ , not (tv `elemVarSet` tyVarsOfTypes (dataConTheta con))
+ = Nothing -- See Note [Check that the type variable is truly universal]
+ | otherwise
+ = Just (badCon con existential)
ft_check :: DataCon -> FFoldType (Maybe SDoc)
ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
@@ -1358,7 +1380,7 @@ cond_functorOK allowFunctions (_, rep_tc, _)
, ft_bad_app = Just (badCon con wrong_arg)
, ft_forall = \_ x -> x }
- existential = ptext (sLit "must not have existential arguments")
+ existential = ptext (sLit "must be truly polymorphic in the last argument of the data type")
covariant = ptext (sLit "must not use the type variable in a function argument")
functions = ptext (sLit "must not contain function types")
wrong_arg = ptext (sLit "must use the type variable only as the last argument of a data type")
@@ -1420,6 +1442,28 @@ badCon :: DataCon -> SDoc -> SDoc
badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
\end{code}
+Note [Check that the type variable is truly universal]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For Functor, Foldable, Traversable, we must check that the *last argument*
+of the type constructor is used truly universally. Example
+
+ data T a b where
+ T1 :: a -> b -> T a b -- Fine! Vanilla H-98
+ T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b'
+ T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic
+ T4 :: Ord b => b -> T a b -- No! 'b' is constrained
+ T5 :: b -> T b b -- No! 'b' is constrained
+ T6 :: T a (b,b) -- No! 'b' is constrained
+
+Notice that only the first of these constructors is vanilla H-98. We only
+need to take care about the last argument (b in this case). See Trac #8678.
+Eg. for T1-T3 we can write
+
+ fmap f (T1 a b) = T1 a (f b)
+ fmap f (T2 b c) = T2 (f b) c
+ fmap f (T3 x) = T3 (f x)
+
+
Note [Superclasses of derived instance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general, a derived instance decl needs the superclasses of the derived
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index c8b203e8cc90806a2ecbf1ae81758d2847d1b3f9..581cebc9c4449054f2be6504dbe613bb7836ea88 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -1714,10 +1714,10 @@ foldDataConArgs :: FFoldType a -> DataCon -> [a]
foldDataConArgs ft con
= map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
where
- tv = last (dataConUnivTyVars con)
- -- Argument to derive for, 'a in the above description
- -- The validity checks have ensured that con is
- -- a vanilla data constructor
+ Just tv = getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
+ -- Argument to derive for, 'a in the above description
+ -- The validity and kind checks have ensured that
+ -- the Just will match and a::*
-- Make a HsLam using a fresh variable from a State monad
mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 9910d2bd4eb10c216910c4609f47be594a2138e9..dc1fbb5a9cede0448e99eeb678d67bed58601b7b 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -3803,6 +3803,13 @@ data type declaration for <literal>T</literal>,
because <literal>T</literal> is a GADT, but you <emphasis>can</emphasis> generate
the instance declaration using stand-alone deriving.
</para>
+<para>
+The down-side is that,
+if the boilerplate code fails to typecheck, you will get an error message about that
+code, which you did not write. Whereas, with a <literal>deriving</literal> clause
+the side-conditions are necessarily more conservative, but any error message
+may be more comprehensible.
+</para>
</listitem>
<listitem>
diff --git a/testsuite/tests/deriving/should_compile/T8678.hs b/testsuite/tests/deriving/should_compile/T8678.hs
new file mode 100644
index 0000000000000000000000000000000000000000..655f530b5b37a84e933ec6a5840331cfa6ca3519
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T8678.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleInstances, GADTs, KindSignatures, StandaloneDeriving #-}
+module T8678 where
+
+data {- kind -} Nat = Z | S Nat
+
+-- GADT in parameter other than the last
+data NonStandard :: Nat -> * -> * -> * where
+ Standard :: a -> NonStandard (S n) a b
+ Non :: NonStandard n a b -> b -> NonStandard (S n) a b
+
+deriving instance (Show a, Show b) => Show (NonStandard n a b)
+deriving instance Functor (NonStandard n a)
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 8620c36dc5e6bf2dd15b5f50d040c80686653fde..5d9c7337f130c34aec043ef1e96ce8a096563e24 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -44,4 +44,5 @@ test('AutoDeriveTypeable', normal, compile, [''])
test('T8138', reqlib('primitive'), compile, ['-O2'])
test('T8631', normal, compile, [''])
test('T8758', extra_clean(['T8758a.o', 'T8758a.hi']), multimod_compile, ['T8758a', '-v0'])
-test('T8851', expect_broken(8851), compile, [''])
\ No newline at end of file
+test('T8851', expect_broken(8851), compile, [''])
+test('T8678', normal, compile, [''])
diff --git a/testsuite/tests/deriving/should_fail/T3101.stderr b/testsuite/tests/deriving/should_fail/T3101.stderr
index 58069283dc7ae6ab1333e361ac954ede43333d17..7c976178c4edbe3421ff7d23f6975ca5756c2e16 100644
--- a/testsuite/tests/deriving/should_fail/T3101.stderr
+++ b/testsuite/tests/deriving/should_fail/T3101.stderr
@@ -1,6 +1,6 @@
T3101.hs:9:12:
Can't make a derived instance of ‘Show Boom’:
- Constructor ‘Boom’ must have a Haskell-98 type
+ Constructor ‘Boom’ has a higher-rank type
Possible fix: use a standalone deriving declaration instead
In the data declaration for ‘Boom’
diff --git a/testsuite/tests/generics/GenCannotDoRep0_0.stderr b/testsuite/tests/generics/GenCannotDoRep0_0.stderr
index 3537dac4d61b29f434916440347da9db989db3df..e1292b8e7eb7e04ee312512585cb66aa738e3949 100644
--- a/testsuite/tests/generics/GenCannotDoRep0_0.stderr
+++ b/testsuite/tests/generics/GenCannotDoRep0_0.stderr
@@ -4,7 +4,8 @@ GenCannotDoRep0_0.hs:6:14: Warning:
GenCannotDoRep0_0.hs:13:45:
Can't make a derived instance of ‘Generic Dynamic’:
- Dynamic must be a vanilla data constructor
+ Constructor ‘Dynamic’ has existentials or constraints in its type
+ Possible fix: use a standalone deriving declaration instead
In the data declaration for ‘Dynamic’
GenCannotDoRep0_0.hs:17:1:
diff --git a/testsuite/tests/generics/GenCannotDoRep1_0.stderr b/testsuite/tests/generics/GenCannotDoRep1_0.stderr
index e40f35961331f8006ae58dd6fb3adc289c5fcce9..7764f24662cf4e6ff4cbde28e01b4c242814289c 100644
--- a/testsuite/tests/generics/GenCannotDoRep1_0.stderr
+++ b/testsuite/tests/generics/GenCannotDoRep1_0.stderr
@@ -1,5 +1,6 @@
GenCannotDoRep1_0.hs:9:49:
Can't make a derived instance of ‘Generic1 Dynamic’:
- Dynamic must be a vanilla data constructor
+ Constructor ‘Dynamic’ has existentials or constraints in its type
+ Possible fix: use a standalone deriving declaration instead
In the data declaration for ‘Dynamic’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail086.stderr b/testsuite/tests/typecheck/should_fail/tcfail086.stderr
index 65149ef1f9ea535579a00327572378cd5f322d83..f88fde164b50c4484ba2a3a4a439d3ec0b86f961 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail086.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail086.stderr
@@ -1,6 +1,6 @@
tcfail086.hs:6:38:
Can't make a derived instance of ‘Eq Ex’:
- Constructor ‘Ex’ must have a Haskell-98 type
+ Constructor ‘Ex’ has existentials or constraints in its type
Possible fix: use a standalone deriving declaration instead
In the data declaration for ‘Ex’