Make -XDeriveFunctor more generous about non-last arguments (Trac #8678)
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 7 Mar 2014 16:45:55 +0000 (16:45 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 7 Mar 2014 16:51:37 +0000 (16:51 +0000)
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
compiler/typecheck/TcGenDeriv.lhs
docs/users_guide/glasgow_exts.xml
testsuite/tests/deriving/should_compile/T8678.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/all.T
testsuite/tests/deriving/should_fail/T3101.stderr
testsuite/tests/generics/GenCannotDoRep0_0.stderr
testsuite/tests/generics/GenCannotDoRep1_0.stderr
testsuite/tests/typecheck/should_fail/tcfail086.stderr

index db8505c..02c0c09 100644 (file)
@@ -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
index c8b203e..581cebc 100644 (file)
@@ -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)
index 9910d2b..dc1fbb5 100644 (file)
@@ -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 (file)
index 0000000..655f530
--- /dev/null
@@ -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)
index 8620c36..5d9c733 100644 (file)
@@ -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, [''])
index 5806928..7c97617 100644 (file)
@@ -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’
index 3537dac..e1292b8 100644 (file)
@@ -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:
index e40f359..7764f24 100644 (file)
@@ -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’
index 65149ef..f88fde1 100644 (file)
@@ -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’