Commit a82956df authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Remove superfluous code when deriving Foldable/Traversable

Currently, `-XDeriveFoldable` and `-XDeriveTraversable` generate
unnecessary `mempty` and `pure` expressions when it traverses of an
argument of a constructor whose type does not mention the last type
parameter. Not only is this inefficient, but it prevents `Traversable`
from being derivable for datatypes with unlifted arguments (see
Trac #11174).

The solution to this problem is to adopt a slight change to the
algorithms for `-XDeriveFoldable` and `-XDeriveTraversable`, which is
described in [this wiki
page](https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFu
nctor#Proposal:alternativestrategyforderivingFoldableandTraversable).
The wiki page also describes why we don't apply the same changes to the
algorithm for `-XDeriveFunctor`.

This is techincally a breaking change for users of `-XDeriveFoldable`
and `-XDeriveTraversable`, since if someone was using a law-breaking
`Monoid` instance with a derived `Foldable` instance (i.e., one where `x
<> mempty` does not equal `x`) or a law-breaking `Applicative` instance
with a derived `Traversable` instance, then the new generated code could
result in different behavior. I suspect the number of scenarios like
this is very small, and the onus really should be on those users to fix
up their `Monoid`/`Applicative` instances.

Fixes #11174.

Test Plan: ./validate

Reviewers: hvr, simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

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

GHC Trac Issues: #11174
parent 67d22261
This diff is collapsed.
...@@ -14,7 +14,7 @@ module Util ( ...@@ -14,7 +14,7 @@ module Util (
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith, zipWithAndUnzip, zipLazy, stretchZipWith, zipWithAndUnzip,
filterByList, partitionByList, filterByList, filterByLists, partitionByList,
unzipWith, unzipWith,
...@@ -331,6 +331,23 @@ filterByList (True:bs) (x:xs) = x : filterByList bs xs ...@@ -331,6 +331,23 @@ filterByList (True:bs) (x:xs) = x : filterByList bs xs
filterByList (False:bs) (_:xs) = filterByList bs xs filterByList (False:bs) (_:xs) = filterByList bs xs
filterByList _ _ = [] filterByList _ _ = []
-- | 'filterByLists' takes a list of Bools and two lists as input, and
-- outputs a new list consisting of elements from the last two input lists. For
-- each Bool in the list, if it is 'True', then it takes an element from the
-- former list. If it is 'False', it takes an element from the latter list.
-- The elements taken correspond to the index of the Bool in its list.
-- For example:
--
-- @
-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"
-- @
--
-- This function does not check whether the lists have equal length.
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys
filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys
filterByLists _ _ _ = []
-- | 'partitionByList' takes a list of Bools and a list of some elements and -- | 'partitionByList' takes a list of Bools and a list of some elements and
-- partitions the list according to the list of Bools. Elements corresponding -- partitions the list according to the list of Bools. Elements corresponding
-- to 'True' go to the left; elements corresponding to 'False' go to the right. -- to 'True' go to the left; elements corresponding to 'False' go to the right.
......
...@@ -192,7 +192,10 @@ Language ...@@ -192,7 +192,10 @@ Language
In previous versions of GHC, this required a workaround via an In previous versions of GHC, this required a workaround via an
explicit export list in ``Bar``. explicit export list in ``Bar``.
- :ghc-flag:`-XDeriveFoldable` and :ghc-flag:`-XDeriveTraversable` now
generate code without superfluous ``mempty`` or ``pure`` expressions. As a
result, :ghc-flag:`-XDeriveTraversable` now works on datatypes that contain
arguments which have unlifted types.
Compiler Compiler
~~~~~~~~ ~~~~~~~~
......
...@@ -3515,8 +3515,11 @@ would generate the following instance:: ...@@ -3515,8 +3515,11 @@ would generate the following instance::
The algorithm for :ghc-flag:`-XDeriveFoldable` is adapted from the :ghc-flag:`-XDeriveFunctor` The algorithm for :ghc-flag:`-XDeriveFoldable` is adapted from the :ghc-flag:`-XDeriveFunctor`
algorithm, but it generates definitions for ``foldMap`` and ``foldr`` instead algorithm, but it generates definitions for ``foldMap`` and ``foldr`` instead
of ``fmap``. Here are the differences between the generated code in each of ``fmap``. In addition, :ghc-flag:`-XDeriveFoldable` filters out all
extension: constructor arguments on the RHS expression whose types do not mention the last
type parameter, since those arguments do not need to be folded over.
Here are the differences between the generated code in each extension:
#. When a bare type variable ``a`` is encountered, :ghc-flag:`-XDeriveFunctor` would #. When a bare type variable ``a`` is encountered, :ghc-flag:`-XDeriveFunctor` would
generate ``f a`` for an ``fmap`` definition. :ghc-flag:`-XDeriveFoldable` would generate ``f a`` for an ``fmap`` definition. :ghc-flag:`-XDeriveFoldable` would
...@@ -3527,10 +3530,6 @@ extension: ...@@ -3527,10 +3530,6 @@ extension:
``fmap`` on it. Similarly, :ghc-flag:`-XDeriveFoldable` would recursively call ``fmap`` on it. Similarly, :ghc-flag:`-XDeriveFoldable` would recursively call
``foldr`` and ``foldMap``. ``foldr`` and ``foldMap``.
#. When a type that does not mention ``a`` is encountered, :ghc-flag:`-XDeriveFunctor`
leaves it alone. On the other hand, :ghc-flag:`-XDeriveFoldable` would generate
``z`` (the state value) for ``foldr`` and ``mempty`` for ``foldMap``.
#. :ghc-flag:`-XDeriveFunctor` puts everything back together again at the end by #. :ghc-flag:`-XDeriveFunctor` puts everything back together again at the end by
invoking the constructor. :ghc-flag:`-XDeriveFoldable`, however, builds up a value invoking the constructor. :ghc-flag:`-XDeriveFoldable`, however, builds up a value
of some type. For ``foldr``, this is accomplished by chaining applications of some type. For ``foldr``, this is accomplished by chaining applications
...@@ -3596,12 +3595,15 @@ would generate the following ``Traversable`` instance:: ...@@ -3596,12 +3595,15 @@ would generate the following ``Traversable`` instance::
instance Traversable Example where instance Traversable Example where
traverse f (Ex a1 a2 a3 a4) traverse f (Ex a1 a2 a3 a4)
= fmap Ex (f a1) <*> traverse f a3 = fmap (\b1 b3 -> Ex b1 a2 b3 a4) (f a1) <*> traverse f a3
The algorithm for :ghc-flag:`-XDeriveTraversable` is adapted from the The algorithm for :ghc-flag:`-XDeriveTraversable` is adapted from the
:ghc-flag:`-XDeriveFunctor` algorithm, but it generates a definition for ``traverse`` :ghc-flag:`-XDeriveFunctor` algorithm, but it generates a definition for ``traverse``
instead of ``fmap``. Here are the differences between the generated code in instead of ``fmap``. In addition, :ghc-flag:`-XDeriveTraversable` filters out
each extension: all constructor arguments on the RHS expression whose types do not mention the
last type parameter, since those arguments do not produce any effects in a
traversal. Here are the differences between the generated code in each
extension:
#. When a bare type variable ``a`` is encountered, both :ghc-flag:`-XDeriveFunctor` and #. When a bare type variable ``a`` is encountered, both :ghc-flag:`-XDeriveFunctor` and
:ghc-flag:`-XDeriveTraversable` would generate ``f a`` for an ``fmap`` and :ghc-flag:`-XDeriveTraversable` would generate ``f a`` for an ``fmap`` and
...@@ -3612,10 +3614,6 @@ each extension: ...@@ -3612,10 +3614,6 @@ each extension:
``fmap`` on it. Similarly, :ghc-flag:`-XDeriveTraversable` would recursively call ``fmap`` on it. Similarly, :ghc-flag:`-XDeriveTraversable` would recursively call
``traverse``. ``traverse``.
#. When a type that does not mention ``a`` is encountered, :ghc-flag:`-XDeriveFunctor`
leaves it alone. On the other hand, :ghc-flag:`-XDeriveTraversable` would call
``pure`` on the value of that type.
#. :ghc-flag:`-XDeriveFunctor` puts everything back together again at the end by #. :ghc-flag:`-XDeriveFunctor` puts everything back together again at the end by
invoking the constructor. :ghc-flag:`-XDeriveTraversable` does something similar, invoking the constructor. :ghc-flag:`-XDeriveTraversable` does something similar,
but it works in an ``Applicative`` context by chaining everything together but it works in an ``Applicative`` context by chaining everything together
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE MagicHash #-}
module T11174 where
import GHC.Prim (Int#)
data IntHash a = IntHash Int#
deriving (Functor, Foldable, Traversable)
data IntHashFun a = IntHashFun ((a -> Int#) -> a)
deriving Functor
data IntHashTuple a = IntHashTuple Int# a (a, Int, IntHashTuple (a, Int))
deriving (Functor, Foldable, Traversable)
...@@ -61,5 +61,6 @@ test('T10524', normal, compile, ['']) ...@@ -61,5 +61,6 @@ test('T10524', normal, compile, [''])
test('T11148', normal, run_command, test('T11148', normal, run_command,
['$MAKE -s --no-print-directory T11148']) ['$MAKE -s --no-print-directory T11148'])
test('T9968', normal, compile, ['']) test('T9968', normal, compile, [''])
test('T11174', normal, compile, [''])
test('T11416', normal, compile, ['']) test('T11416', normal, compile, [''])
test('T11396', normal, compile, ['']) test('T11396', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment