Coerce for fmapDefault and foldMapDefault

Define `fmapDefault = coerce traverse` and `foldMapDefault = coerce
traverse`.  This ensures that we won't get unnecessary allocation and
indirection when the arguments don't inline.

Fixes #13058

Reviewers: ekmett, RyanGlScott, austin, hvr, bgamari

Reviewed By: RyanGlScott

Subscribers: simonpj, RyanGlScott, thomie

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

GHC Trac Issues: #13058

2 files changed, 41 insertions, 9 deletions

diff --git a/libraries/base/Data/Bitraversable.hs b/libraries/base/Data/Bitraversable.hs
index 19d4ba264a..adabc6a005 100644
--- a/libraries/base/Data/Bitraversable.hs
+++ b/libraries/base/Data/Bitraversable.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -28,6 +29,7 @@ module Data.Bitraversable
 import Control.Applicative
 import Data.Bifunctor
 import Data.Bifoldable
+import Data.Coerce
 import Data.Functor.Identity (Identity(..))
 import Data.Functor.Utils (StateL(..), StateR(..))
 import GHC.Generics (K1(..))
@@ -217,14 +219,29 @@ bimapAccumR f g s t
 -- | A default definition of 'bimap' in terms of the 'Bitraversable'
 -- operations.
 --
+-- @'bimapDefault' f g ≡
+--     'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@
+--
 -- @since 4.10.0.0
-bimapDefault :: Bitraversable t => (a -> b) -> (c -> d) -> t a c -> t b d
-bimapDefault f g = runIdentity . bitraverse (Identity . f) (Identity . g)
+bimapDefault :: forall t a b c d . Bitraversable t
+             => (a -> b) -> (c -> d) -> t a c -> t b d
+-- See Note [Function coercion] in Data.Functor.Utils.
+bimapDefault = coerce
+  (bitraverse :: (a -> Identity b)
+              -> (c -> Identity d) -> t a c -> Identity (t b d))
+{-# INLINE bimapDefault #-}
 
 -- | A default definition of 'bifoldMap' in terms of the 'Bitraversable'
 -- operations.
 --
+-- @'bifoldMapDefault' f g ≡
+--    'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@
+--
 -- @since 4.10.0.0
-bifoldMapDefault :: (Bitraversable t, Monoid m)
+bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m)
                  => (a -> m) -> (b -> m) -> t a b -> m
-bifoldMapDefault f g = getConst . bitraverse (Const . f) (Const . g)
+-- See Note [Function coercion] in Data.Functor.Utils.
+bifoldMapDefault = coerce
+  (bitraverse :: (a -> Const m ())
+              -> (b -> Const m ()) -> t a b -> Const m (t () ()))
+{-# INLINE bifoldMapDefault #-}
diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs
index 635fcde4d9..c166db5035 100644
--- a/libraries/base/Data/Traversable.hs
+++ b/libraries/base/Data/Traversable.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE TypeOperators #-}
@@ -53,6 +54,7 @@ module Data.Traversable (
 -- It is convenient to use 'Const' here but this means we must
 -- define a few instances here which really belong in Control.Applicative
 import Control.Applicative ( Const(..), ZipList(..) )
+import Data.Coerce
 import Data.Either ( Either(..) )
 import Data.Foldable ( Foldable )
 import Data.Functor
@@ -348,11 +350,24 @@ mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s
 --   instance, provided that 'traverse' is defined. (Using
 --   `fmapDefault` with a `Traversable` instance defined only by
 --   'sequenceA' will result in infinite recursion.)
-fmapDefault :: Traversable t => (a -> b) -> t a -> t b
+--
+-- @
+-- 'fmapDefault' f ≡ 'runIdentity' . 'traverse' ('Identity' . f)
+-- @
+fmapDefault :: forall t a b . Traversable t
+            => (a -> b) -> t a -> t b
 {-# INLINE fmapDefault #-}
-fmapDefault f = runIdentity . traverse (Identity . f)
+-- See Note [Function coercion] in Data.Functor.Utils.
+fmapDefault = coerce (traverse :: (a -> Identity b) -> t a -> Identity (t b))
 
 -- | This function may be used as a value for `Data.Foldable.foldMap`
 -- in a `Foldable` instance.
-foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m
-foldMapDefault f = getConst . traverse (Const . f)
+--
+-- @
+-- 'foldMapDefault' f ≡ 'getConst' . 'traverse' ('Const' . f)
+-- @
+foldMapDefault :: forall t m a . (Traversable t, Monoid m)
+               => (a -> m) -> t a -> m
+{-# INLINE foldMapDefault #-}
+-- See Note [Function coercion] in Data.Functor.Utils.
+foldMapDefault = coerce (traverse :: (a -> Const m ()) -> t a -> Const m (t ()))