DeriveFoldable for data types with existential constraints (#10447)

Reviewers: dolio, shachaf, ekmett, austin, #core_libraries_committee,
simonpj, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie, bgamari

Differential Revision: https://phabricator.haskell.org/D1031

GHC Trac Issues: #10447

compiler/typecheck/TcDeriv.hs

@@ -1219,13 +1219,15 @@ sideConditions mtheta cls
                                            cond_args cls)
   | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
                                            cond_vanilla `andCond`
-                                           cond_functorOK True)
+                                           cond_functorOK True False)
   | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
                                            cond_vanilla `andCond`
-                                           cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
+                                           cond_functorOK False True)
+                                           -- Functor/Fold/Trav works ok
+                                           -- for rank-n types
   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
                                            cond_vanilla `andCond`
-                                           cond_functorOK False)
+                                           cond_functorOK False False)
   | cls_key == genClassKey         = Just (checkFlag Opt_DeriveGeneric `andCond`
                                            cond_vanilla `andCond`
                                            cond_RepresentableOk)
@@ -1346,14 +1348,14 @@ cond_isProduct (_, rep_tc, _)
 functorLikeClassKeys :: [Unique]
 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
 
-cond_functorOK :: Bool -> Condition
+cond_functorOK :: Bool -> Bool -> Condition
 -- OK for Functor/Foldable/Traversable class
 -- Currently: (a) at least one argument
 --            (b) don't use argument contravariantly
 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 --            (d) optionally: don't use function types
 --            (e) no "stupid context" on data type
-cond_functorOK allowFunctions (_, rep_tc, _)
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _)
   | null tc_tvs
   = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
               <+> ptext (sLit "must have some type parameters"))
@@ -1375,6 +1377,9 @@ cond_functorOK allowFunctions (_, rep_tc, _)
 
     check_universal :: DataCon -> Validity
     check_universal con
+      | allowExQuantifiedLastTyVar
+      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
+                -- in TcGenDeriv
       | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
       , tv `elem` dataConUnivTyVars con
       , not (tv `elemVarSet` tyVarsOfTypes (dataConTheta con))
@@ -1442,7 +1447,7 @@ badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
 {-
 Note [Check that the type variable is truly universal]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For Functor, Foldable, Traversable, we must check that the *last argument*
+For Functor and Traversable instances, we must check that the *last argument*
 of the type constructor is used truly universally quantified.  Example
 
    data T a b where
@@ -1461,6 +1466,20 @@ Eg. for T1-T3 we can write
      fmap f (T2 b c) = T2 (f b) c
      fmap f (T3 x)   = T3 (f x)
 
+We need not perform these checks for Foldable instances, however, since
+functions in Foldable can only consume existentially quantified type variables,
+rather than produce them (as is the case in Functor and Traversable functions.)
+As a result, T can have a derived Foldable instance:
+
+    foldr f z (T1 a b) = f b z
+    foldr f z (T2 b c) = f b z
+    foldr f z (T3 x)   = f x z
+    foldr f z (T4 x)   = f x z
+    foldr f z (T5 x)   = f x z
+    foldr _ z T6       = z
+
+See Note [DeriveFoldable with ExistentialQuantification] in TcGenDeriv.
+
 
 Note [Superclasses of derived instance]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/typecheck/TcGenDeriv.hs

@@ -1673,12 +1673,20 @@ deepSubtypesContaining tv
 foldDataConArgs :: FFoldType a -> DataCon -> [a]
 -- Fold over the arguments of the datacon
 foldDataConArgs ft con
-  = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
+  = map foldArg (dataConOrigArgTys con)
   where
-    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::*
+    foldArg
+      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
+             Just tv -> functorLikeTraverse tv ft
+             Nothing -> const (ft_triv ft)
+    -- If we are deriving Foldable for a GADT, there is a chance that the last
+    -- type variable in the data type isn't actually a type variable at all.
+    -- (for example, this can happen if the last type variable is refined to
+    -- be a concrete type such as Int). If the last type variable is refined
+    -- to be a specific type, then getTyVar_maybe will return Nothing.
+    -- See Note [DeriveFoldable with ExistentialQuantification]
+    --
+    -- The kind checks have ensured the last type parameter is of kind *.
 
 -- Make a HsLam using a fresh variable from a State monad
 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
@@ -1747,6 +1755,24 @@ The cases are:
 
 Note that the arguments to the real foldr function are the wrong way around,
 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
+
+Foldable instances differ from Functor and Traversable instances in that
+Foldable instances can be derived for data types in which the last type
+variable is existentially quantified. In particular, if the last type variable
+is refined to a more specific type in a GADT:
+
+  data GADT a where
+      G :: a ~ Int => a -> G Int
+
+then the deriving machinery does not attempt to check that the type a contains
+Int, since it is not syntactically equal to a type variable. That is, the
+derived Foldable instance for GADT is:
+
+  instance Foldable GADT where
+      foldr _ z (GADT _) = z
+
+See Note [DeriveFoldable with ExistentialQuantification].
+
 -}
 
 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
@@ -2305,4 +2331,80 @@ OccName we generate for the new binding.
 In the past we used mkDerivedRdrName name occ_fun, which made an original name
 But:  (a) that does not work well for standalone-deriving either
       (b) an unqualified name is just fine, provided it can't clash with user code
+
+Note [DeriveFoldable with ExistentialQuantification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Functor and Traversable instances can only be derived for data types whose
+last type parameter is truly universally polymorphic. For example:
+
+  data T a b where
+    T1 ::                 b   -> T a b   -- YES, b is unconstrained
+    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
+    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
+    T4 ::                 Int -> T a Int -- NO, this is just like T3
+    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
+                                         -- though a is existential
+    T6 ::                 Int -> T Int b -- YES, b is unconstrained
+
+For Foldable instances, however, we can completely lift the constraint that
+the last type parameter be truly universally polymorphic. This means that T
+(as defined above) can have a derived Foldable instance:
+
+  instance Foldable (T a) where
+    foldr f z (T1 b)   = f b z
+    foldr f z (T2 b)   = f b z
+    foldr f z (T3 b)   = f b z
+    foldr f z (T4 b)   = z
+    foldr f z (T5 a b) = f b z
+    foldr f z (T6 a)   = z
+
+    foldMap f (T1 b)   = f b
+    foldMap f (T2 b)   = f b
+    foldMap f (T3 b)   = f b
+    foldMap f (T4 b)   = mempty
+    foldMap f (T5 a b) = f b
+    foldMap f (T6 a)   = mempty
+
+In a Foldable instance, it is safe to fold over an occurrence of the last type
+parameter that is not truly universally polymorphic. However, there is a bit
+of subtlety in determining what is actually an occurrence of a type parameter.
+T3 and T4, as defined above, provide one example:
+
+  data T a b where
+    ...
+    T3 :: b ~ Int => b   -> T a b
+    T4 ::            Int -> T a Int
+    ...
+
+  instance Foldable (T a) where
+    ...
+    foldr f z (T3 b) = f b z
+    foldr f z (T4 b) = z
+    ...
+    foldMap f (T3 b) = f b
+    foldMap f (T4 b) = mempty
+    ...
+
+Notice that the argument of T3 is folded over, whereas the argument of T4 is
+not. This is because we only fold over constructor arguments that
+syntactically mention the universally quantified type parameter of that
+particular data constructor. See foldDataConArgs for how this is implemented.
+
+As another example, consider the following data type. The argument of each
+constructor has the same type as the last type parameter:
+
+  data E a where
+    E1 :: (a ~ Int) => a   -> E a
+    E2 ::              Int -> E Int
+    E3 :: (a ~ Int) => a   -> E Int
+    E4 :: (a ~ Int) => Int -> E a
+
+Only E1's argument is an occurrence of a universally quantified type variable
+that is syntactically equivalent to the last type parameter, so only E1's
+argument will be be folded over in a derived Foldable instance.
+
+See Trac #10447 for the original discussion on this feature. Also see
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
+for a more in-depth explanation.
+
 -}

docs/users_guide/glasgow_exts.xml

@@ -4019,7 +4019,7 @@ as described in <xref linkend="generic-programming"/>.
 
 <listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of
 the class <literal>Functor</literal>,
-defined in <literal>GHC.Base</literal>.
+defined in <literal>GHC.Base</literal>. See <xref linkend="deriving-functor"/>.
 </para></listitem>
 
 <listitem><para> With <option>-XDeriveDataTypeable</option>, you can derive instances of
@@ -4030,7 +4030,7 @@ deriving <literal>Typeable</literal>.
 
 <listitem><para> With <option>-XDeriveFoldable</option>, you can derive instances of
 the class <literal>Foldable</literal>,
-defined in <literal>Data.Foldable</literal>.
+defined in <literal>Data.Foldable</literal>. See <xref linkend="deriving-foldable"/>.
 </para></listitem>
 
 <listitem><para> With <option>-XDeriveTraversable</option>, you can derive instances of
@@ -4040,6 +4040,7 @@ instance dictates the instances of <literal>Functor</literal> and
 <literal>Foldable</literal>, you'll probably want to derive them too, so
 <option>-XDeriveTraversable</option> implies
 <option>-XDeriveFunctor</option> and <option>-XDeriveFoldable</option>.
+See <xref linkend="deriving-traversable"/>.
 </para></listitem>
 </itemizedlist>
 You can also use a standalone deriving declaration instead
@@ -4051,6 +4052,260 @@ can be mentioned in the <literal>deriving</literal> clause.
 </para>
 </sect2>
 
+<sect2 id="deriving-functor">
+<title>Deriving <literal>Functor</literal> instances</title>
+
+<para>With <option>-XDeriveFunctor</option>, one can derive
+<literal>Functor</literal> instances for data types of kind
+<literal>* -> *</literal>. For example, this declaration:
+
+<programlisting>
+data Example a = Ex a Char (Example a) (Example Char)
+  deriving Functor
+</programlisting>
+
+would generate the following instance:
+
+<programlisting>
+instance Functor Example where
+  fmap f (Ex a1 a2 a3 a4) = Ex (f a1) a2 (fmap f a3) a4
+</programlisting>
+</para>
+
+<para>The basic algorithm for <option>-XDeriveFunctor</option> walks the
+arguments of each constructor of a data type, applying a mapping function
+depending on the type of each argument. Suppose we are deriving
+<literal>Functor</literal> for a data type whose last type parameter is
+<literal>a</literal>. Then we write the derivation of <literal>fmap</literal>
+code over the type variable <literal>a</literal> for type
+<literal>b</literal> as <literal>$(fmap 'a 'b)</literal>.
+
+<itemizedlist>
+<listitem><para>If the argument's type is <literal>a</literal>, then
+map over it.
+
+<programlisting>
+$(fmap 'a 'a) = f
+</programlisting>
+</para></listitem>
+
+<listitem><para>If the argument's type does not mention <literal>a</literal>,
+then do nothing to it.
+
+<programlisting>
+$(fmap 'a 'b) = \x -> x -- when b does not contain a
+</programlisting>
+</para></listitem>
+
+<listitem><para>If the argument has a tuple type, generate map code for each
+of its arguments.
+
+<programlisting>
+$(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
+</programlisting>
+</para></listitem>
+
+<listitem><para>If the argument's type is a data type that mentions
+<literal>a</literal>, apply <literal>fmap</literal> to it with the generated
+map code for the data type's last type parameter.
+
+<programlisting>
+$(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
+</programlisting>
+</para></listitem>
+
+<listitem><para>If the argument has a function type, apply generated
+<literal>$(fmap)</literal> code to the result type, and apply generated
+<literal>$(cofmap)</literal> code to the argument type.
+
+<programlisting>
+$(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
+</programlisting>
+
+<literal>$(cofmap)</literal> is needed because the type parameter
+<literal>a</literal> can occur in a contravariant position, which means we
+need to derive a function like:
+
+<programlisting>
+cofmap :: (a -> b) -> f b -> f a
+</programlisting>
+
+This is pretty much the same as <literal>$(fmap)</literal>, only without the
+<literal>$(cofmap 'a 'a)</literal> case:
+
+<programlisting>
+$(cofmap 'a 'b)         = \x -> x     -- when b does not contain a
+$(cofmap 'a 'a)         = error "type variable in contravariant position"
+$(cofmap 'a '(b1,b2))   = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
+$(cofmap 'a '[b])       = map $(cofmap 'a 'b)
+$(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
+$(cofmap 'a '(b -> c))  = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
+</programlisting>
+
+For more information on contravariance, see
+<ulink url="https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#Covariantandcontravariantpositions">
+this wiki page</ulink>.
+</para></listitem>
+</itemizedlist>
+</para>
+
+<para>A data type can have a derived <literal>Functor</literal> instance if:
+
+<itemizedlist>
+<listitem><para>It has at least one type parameter.
+</para></listitem>
+
+<listitem><para>It does not use the last type parameter contravariantly.
+</para></listitem>
+
+<listitem><para>It does not use the last type parameter in the "wrong place"
+in any of the argument data types. For example, in:
+
+<programlisting>
+data Right a = Right [a] (Either Int a)
+</programlisting>
+
+the type parameter <literal>a</literal> is only ever used as the last type
+argument in <literal>[]</literal> and <literal>Either</literal>, so both
+<literal>[a]</literal> and <literal>Either Int a</literal> can be
+<literal>fmap</literal>ped. However, in:
+
+<programlisting>
+data Wrong a = Wrong (Either a a)
+</programlisting>
+
+the type variable <literal>a</literal> appears in a position other than the
+last, so trying to <literal>fmap</literal> an <literal>Either a a</literal>
+value would not typecheck in a <literal>Functor</literal> instance.
+
+Note that there are two exceptions to this rule: tuple and function types, as
+described above.
+</para></listitem>
+
+<listitem><para>Its last type variable cannot be used in a
+<option>-XDatatypeContexts</option> constraint.
+</para></listitem>
+
+<listitem><para>Its last type variable cannot be used in an
+<option>-XExistentialQuantification</option> or <option>-XGADTs</option>
+constraint.
+</para></listitem>
+</itemizedlist>
+
+</para>
+</sect2>
+
+<sect2 id="deriving-foldable">
+<title>Deriving <literal>Foldable</literal> instances</title>
+
+<para>With <option>-XDeriveFoldable</option>, one can derive
+<literal>Foldable</literal> instances for data types of kind
+<literal>* -> *</literal>. For example, this declaration:
+
+<programlisting>
+data Example a = Ex a Char (Example a) (Example Char)
+  deriving Functor
+</programlisting>
+
+would generate the following instance:
+
+<programlisting>
+instance Foldable Example where
+  foldr f z (Ex a1 a2 a3 a4) = f a1 (foldr f z a3)
+  foldMap f (Ex a1 a2 a3 a4) = mappend (f a1)
+                                       (mappend mempty
+                                                (mappend (foldMap f a3)
+                                                         mempty))
+</programlisting>
+
+The algorithm for <option>-XDeriveFoldable</option> is very similar to that of
+<option>-XDeriveFunctor</option>, except that <literal>Foldable</literal>
+instances are not possible for function types. The cases are:
+
+<programlisting>
+$(foldr 'a 'b)         = \x z -> z -- when b does not contain a
+$(foldr 'a 'a)         = f
+$(foldr 'a '(b1,b2))   = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
+$(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
+</programlisting>
+
+Another difference between <option>-XDeriveFoldable</option> and
+<option>-XDeriveFunctor</option> is that <option>-XDeriveFoldable</option>
+instances can be derived for data types with existential constraints. For
+example, the following data type:
+
+<programlisting>
+data E a where
+    E1 :: (a ~ Int) =&gt; a   -> E a
+    E2 ::              Int -> E Int
+    E3 :: (a ~ Int) =&gt; a   -> E Int
+    E4 :: (a ~ Int) =&gt; Int -> E a
+
+deriving instance Foldable E
+</programlisting>
+
+would have the following <literal>Foldable</literal> instance:
+
+<programlisting>
+instance Foldable E where
+    foldr f z (E1 e) = f e z
+    foldr f z (E2 e) = z
+    foldr f z (E3 e) = z
+    foldr f z (E4 e) = z
+
+    foldMap f (E1 e) = f e
+    foldMap f (E2 e) = mempty
+    foldMap f (E3 e) = mempty
+    foldMap f (E4 e) = mempty
+</programlisting>
+
+Notice that only the argument in <literal>E1</literal> is folded over. This is
+because we only fold over constructor arguments (1) whose types are
+syntactically equivalent to the last type parameter and (2) when the last type
+parameter is not refined to a specific type. Only <literal>E1</literal>
+satisfies both of these criteria. For more information, see
+<ulink url="https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor">
+this wiki page</ulink>.
+</para>
+</sect2>
+
+<sect2 id="deriving-traversable">
+<title>Deriving <literal>Traversable</literal> instances</title>
+
+<para>With <option>-XDeriveTraversable</option>, one can derive
+<literal>Traversable</literal> instances for data types of kind
+<literal>* -> *</literal>. For example, this declaration:
+
+<programlisting>
+data Example a = Ex a Char (Example a) (Example Char)
+  deriving Functor
+</programlisting>
+
+would generate the following instance:
+
+<programlisting>
+instance Foldable Example where
+  traverse f (Ex a1 a2 a3 a4)
+    = fmap Ex (f a)
+        &lt;*&gt; pure a2
+        &lt;*&gt; traverse f a3
+        &lt;*&gt; pure a4
+</programlisting>
+
+The algorithm for <option>-XDeriveTraversable</option> is very similar to that
+of <option>-XDeriveTraversable</option>, except that
+<literal>Traversable</literal> instances are not possible for function types.
+The cases are:
+
+<programlisting>
+1812   $(traverse 'a 'b)         = pure -- when b does not contain a
+1813   $(traverse 'a 'a)         = f
+1814   $(traverse 'a '(b1,b2))   = \x -> case x of (x1,x2) -> fmap (,) $(traverse 'a 'b1) x1 &lt;*&gt; $(traverse 'a 'b2) x2
+1815   $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
+</programlisting>
+</para>
+</sect2>
+
 <sect2 id="deriving-typeable">
 <title>Deriving <literal>Typeable</literal> instances</title>
 

testsuite/tests/deriving/should_run/T10447.hs

+{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving #-}
+module Main where
+
+class (a ~ Int) => Foo a
+instance Foo Int
+
+data A a where
+  A1 :: Ord a            => a        -> A a
+  A2 ::                     Int      -> A Int
+  A3 :: b ~ Int          => b        -> A Int
+  A4 :: a ~ Int          => Int      -> A a
+  A5 :: a ~ Int          => a        -> A a
+  A6 :: (a ~ b, b ~ Int) => Int -> b -> A a
+  A7 :: Foo a            => Int -> a -> A a
+
+deriving instance Foldable A
+
+data HK f a where
+  HK1 :: f a -> HK f (f a)
+  HK2 :: f a -> HK f a
+
+deriving instance Foldable f => Foldable (HK f)
+
+one :: Int
+one = 1
+
+main :: IO ()
+main = do
+  mapM_ (print . foldr (+) one)
+    [ A1 one
+    , A2 one
+    , A3 one
+    , A4 one
+    , A5 one
+    , A6 one one
+    , A7 one one
+    ]
+  mapM_ (print . foldr mappend Nothing)
+    [ HK1 (Just "Hello")
+    , HK2 (Just (Just "World"))
+    ]

testsuite/tests/deriving/should_run/T10447.stdout

+2
+1
+1
+1
+2
+1
+2
+Nothing
+Just "World"

testsuite/tests/deriving/should_run/all.T

@@ -39,3 +39,4 @@ test('T7931', normal, compile_and_run, [''])
 test('T9576', exit_code(1), compile_and_run, [''])
 test('T9830', extra_clean(['T9830a.hi', 'T9830a.o']), multimod_compile_and_run, ['T9830','-v0'])
 test('T10104', normal, compile_and_run, [''])
+test('T10447', normal, compile_and_run, [''])