From cdac487bcd9928d77738f6e79ead7b9bb4bc00fd Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Fri, 7 Mar 2014 16:45:55 +0000
Subject: [PATCH] Make -XDeriveFunctor more generous about non-last arguments
(Trac #8678)
When deriving Functor, Foldable, Traversable, we need only look at the
way that the last type argument is treated. It's fine for there to
be existentials etc, provided they don't affect the last type argument.
See Note [Check that the type variable is truly universal] in TcDeriv.
---
compiler/typecheck/TcDeriv.lhs | 88 ++++++++++++++-----
compiler/typecheck/TcGenDeriv.lhs | 8 +-
docs/users_guide/glasgow_exts.xml | 7 ++
.../tests/deriving/should_compile/T8678.hs | 12 +++
testsuite/tests/deriving/should_compile/all.T | 3 +-
.../tests/deriving/should_fail/T3101.stderr | 2 +-
.../tests/generics/GenCannotDoRep0_0.stderr | 3 +-
.../tests/generics/GenCannotDoRep1_0.stderr | 3 +-
.../typecheck/should_fail/tcfail086.stderr | 2 +-
9 files changed, 97 insertions(+), 31 deletions(-)
create mode 100644 testsuite/tests/deriving/should_compile/T8678.hs
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index db8505c92931..02c0c098055e 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 c8b203e8cc90..581cebc9c444 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 9910d2bd4eb1..dc1fbb5a9ced 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 000000000000..655f530b5b37
--- /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 8620c36dc5e6..5d9c7337f130 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 58069283dc7a..7c976178c4ed 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 3537dac4d61b..e1292b8e7eb7 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 e40f35961331..7764f24662cf 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 65149ef1f9ea..f88fde164b50 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’
--
GitLab