Add liftA2 to Applicative class

* Make `liftA2` a method of `Applicative`.

* Add explicit `liftA2` definitions to instances in `base`.

* Add explicit invocations in `base`.

Reviewers: ekmett, bgamari, RyanGlScott, austin, hvr

Reviewed By: RyanGlScott

Subscribers: ekmett, RyanGlScott, rwbarton, thomie

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

26 files changed, 285 insertions, 79 deletions

diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 6fe1485f7d..4570076404 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -809,11 +809,12 @@ uFloatHash_RDR  = varQual_RDR gHC_GENERICS (fsLit "uFloat#")
 uIntHash_RDR    = varQual_RDR gHC_GENERICS (fsLit "uInt#")
 uWordHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uWord#")
 
-fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
+fmap_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, foldMap_RDR,
     traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
 fmap_RDR                = varQual_RDR gHC_BASE (fsLit "fmap")
 pure_RDR                = nameRdrName pureAName
 ap_RDR                  = nameRdrName apAName
+liftA2_RDR              = varQual_RDR gHC_BASE (fsLit "liftA2")
 foldable_foldr_RDR      = varQual_RDR dATA_FOLDABLE       (fsLit "foldr")
 foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")
 traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
index 0b89ce28ea..f5ecbedfec 100644
--- a/compiler/typecheck/TcGenFunctor.hs
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -549,7 +549,8 @@ Again, Traversable is much like Functor and Foldable.
 The cases are:
 
   $(traverse 'a 'a)          =  f
-  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
+  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->
+     liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
   $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
 
 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
@@ -601,7 +602,7 @@ gen_Traversable_binds loc tycon
                lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
                return (Just lam)
              -- traverse f = \x -> case x of (a1,a2,..) ->
-             --                           (,,) <$> g1 a1 <*> g2 a2 <*> ..
+             --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..
            , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
              -- traverse f = traverse g
            , ft_forall  = \_ g -> g
@@ -609,8 +610,8 @@ gen_Traversable_binds loc tycon
            , ft_fun     = panic "function"
            , ft_bad_app = panic "in other argument" }
 
-    -- Con a1 a2 ... -> fmap (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
-    --                    <*> g2 a2 <*> ...
+    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
+    --                    (g2 a2) <*> ...
     match_for_con :: [LPat RdrName]
                   -> DataCon
                   -> [Maybe (LHsExpr RdrName)]
@@ -618,10 +619,12 @@ gen_Traversable_binds loc tycon
     match_for_con = mkSimpleConMatch2 CaseAlt $
                                              \con xs -> return (mkApCon con xs)
       where
-        -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> ..
+        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
         mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
         mkApCon con [] = nlHsApps pure_RDR [con]
-        mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
+        mkApCon con [x] = nlHsApps fmap_RDR [con,x]
+        mkApCon con (x1:x2:xs) =
+            foldl appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
           where appAp x y = nlHsApps ap_RDR [x,y]
 
 -----------------------------------------------------------------------
diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index d29914a100..36ed2b90d8 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -298,6 +298,12 @@ See ``changelog.md`` in the ``base`` package for full release notes.
   operations in ``GHC.TypeLits`` are a thin compatibility layer on top.
   Note: the ``KnownNat`` evidence is changed from an ``Integer`` to a ``Natural``.
 
+- ``liftA2`` is now a method of the ``Applicative`` class. ``Traversable``
+  deriving has been modified to use ``liftA2`` for the first two elements
+  traversed in each constructor. ``liftA2`` is not yet in the ``Prelude``,
+  and must currently be imported from ``Control.Applicative``. It is likely
+  to be added to the ``Prelude`` in the future.
+
 binary
 ~~~~~~
 
diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs
index 6398a5791a..8883818280 100644
--- a/libraries/base/Control/Applicative.hs
+++ b/libraries/base/Control/Applicative.hs
@@ -43,7 +43,7 @@ module Control.Applicative (
     Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
     -- * Utility functions
     (<$>), (<$), (<**>),
-    liftA, liftA2, liftA3,
+    liftA, liftA3,
     optional,
     ) where
 
@@ -74,6 +74,7 @@ instance Monad m => Functor (WrappedMonad m) where
 instance Monad m => Applicative (WrappedMonad m) where
     pure = WrapMonad . pure
     WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
+    liftA2 f (WrapMonad x) (WrapMonad y) = WrapMonad (liftM2 f x y)
 
 -- | @since 2.01
 instance MonadPlus m => Alternative (WrappedMonad m) where
@@ -90,7 +91,8 @@ instance Arrow a => Functor (WrappedArrow a b) where
 -- | @since 2.01
 instance Arrow a => Applicative (WrappedArrow a b) where
     pure x = WrapArrow (arr (const x))
-    WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))
+    liftA2 f (WrapArrow u) (WrapArrow v) =
+      WrapArrow (u &&& v >>> arr (uncurry f))
 
 -- | @since 2.01
 instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
@@ -109,7 +111,7 @@ newtype ZipList a = ZipList { getZipList :: [a] }
 -- | @since 2.01
 instance Applicative ZipList where
     pure x = ZipList (repeat x)
-    ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
+    liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)
 
 -- extra functions
 
diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs
index 9883def001..67d5838356 100644
--- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs
+++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs
@@ -142,6 +142,21 @@ instance Applicative (ST s) where
     -- forces the (f x, s'') pair, then they must need
     -- f or s''. To get s'', they need s'.
 
+    liftA2 f m n = ST $ \ s ->
+      let
+        {-# NOINLINE res1 #-}
+        -- See Note [Lazy ST and multithreading]
+        res1 = noDup (unST m s)
+        (x, s') = res1
+
+        {-# NOINLINE res2 #-}
+        res2 = noDup (unST n s')
+        (y, s'') = res2
+      in (f x y, s'')
+    -- We don't get to be strict in liftA2, but we clear out a
+    -- NOINLINE in comparison to the default definition, which may
+    -- help the simplifier.
+
     m *> n = ST $ \s ->
        let
          {-# NOINLINE s' #-}
diff --git a/libraries/base/Data/Bitraversable.hs b/libraries/base/Data/Bitraversable.hs
index adabc6a005..169510844d 100644
--- a/libraries/base/Data/Bitraversable.hs
+++ b/libraries/base/Data/Bitraversable.hs
@@ -144,27 +144,28 @@ bisequence = bitraverse id id
 
 -- | @since 4.10.0.0
 instance Bitraversable (,) where
-  bitraverse f g ~(a, b) = (,) <$> f a <*> g b
+  bitraverse f g ~(a, b) = liftA2 (,) (f a) (g b)
 
 -- | @since 4.10.0.0
 instance Bitraversable ((,,) x) where
-  bitraverse f g ~(x, a, b) = (,,) x <$> f a <*> g b
+  bitraverse f g ~(x, a, b) = liftA2 ((,,) x) (f a) (g b)
 
 -- | @since 4.10.0.0
 instance Bitraversable ((,,,) x y) where
-  bitraverse f g ~(x, y, a, b) = (,,,) x y <$> f a <*> g b
+  bitraverse f g ~(x, y, a, b) = liftA2 ((,,,) x y) (f a) (g b)
 
 -- | @since 4.10.0.0
 instance Bitraversable ((,,,,) x y z) where
-  bitraverse f g ~(x, y, z, a, b) = (,,,,) x y z <$> f a <*> g b
+  bitraverse f g ~(x, y, z, a, b) = liftA2 ((,,,,) x y z) (f a) (g b)
 
 -- | @since 4.10.0.0
 instance Bitraversable ((,,,,,) x y z w) where
-  bitraverse f g ~(x, y, z, w, a, b) = (,,,,,) x y z w <$> f a <*> g b
+  bitraverse f g ~(x, y, z, w, a, b) = liftA2 ((,,,,,) x y z w) (f a) (g b)
 
 -- | @since 4.10.0.0
 instance Bitraversable ((,,,,,,) x y z w v) where
-  bitraverse f g ~(x, y, z, w, v, a, b) = (,,,,,,) x y z w v <$> f a <*> g b
+  bitraverse f g ~(x, y, z, w, v, a, b) =
+    liftA2 ((,,,,,,) x y z w v) (f a) (g b)
 
 -- | @since 4.10.0.0
 instance Bitraversable Either where
diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs
index efdc1c53b7..dd3e0eca0b 100644
--- a/libraries/base/Data/Complex.hs
+++ b/libraries/base/Data/Complex.hs
@@ -36,6 +36,7 @@ module Data.Complex
 
         )  where
 
+import GHC.Base (Applicative (..))
 import GHC.Generics (Generic, Generic1)
 import GHC.Float (Floating(..))
 import Data.Data (Data)
@@ -231,6 +232,7 @@ instance Storable a => Storable (Complex a) where
 instance Applicative Complex where
   pure a = a :+ a
   f :+ g <*> a :+ b = f a :+ g b
+  liftA2 f (x :+ y) (a :+ b) = f x a :+ f y b
 
 -- | @since 4.9.0.0
 instance Monad Complex where
diff --git a/libraries/base/Data/Functor/Compose.hs b/libraries/base/Data/Functor/Compose.hs
index 901489cc18..68fbfc630a 100644
--- a/libraries/base/Data/Functor/Compose.hs
+++ b/libraries/base/Data/Functor/Compose.hs
@@ -1,7 +1,8 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Functor.Compose
@@ -24,6 +25,7 @@ module Data.Functor.Compose (
 import Data.Functor.Classes
 
 import Control.Applicative
+import Data.Coerce (coerce)
 import Data.Data (Data)
 import Data.Foldable (Foldable(foldMap))
 import Data.Traversable (Traversable(traverse))
@@ -106,9 +108,12 @@ instance (Traversable f, Traversable g) => Traversable (Compose f g) where
 -- | @since 4.9.0.0
 instance (Applicative f, Applicative g) => Applicative (Compose f g) where
     pure x = Compose (pure (pure x))
-    Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)
+    Compose f <*> Compose x = Compose (liftA2 (<*>) f x)
+    liftA2 f (Compose x) (Compose y) =
+      Compose (liftA2 (liftA2 f) x y)
 
 -- | @since 4.9.0.0
 instance (Alternative f, Applicative g) => Alternative (Compose f g) where
     empty = Compose empty
-    Compose x <|> Compose y = Compose (x <|> y)
+    (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a))
+      :: forall a . Compose f g a -> Compose f g a -> Compose f g a
diff --git a/libraries/base/Data/Functor/Const.hs b/libraries/base/Data/Functor/Const.hs
index 8f54b4204c..9199b7cf94 100644
--- a/libraries/base/Data/Functor/Const.hs
+++ b/libraries/base/Data/Functor/Const.hs
@@ -68,6 +68,7 @@ instance Functor (Const m) where
 -- | @since 2.0.1
 instance Monoid m => Applicative (Const m) where
     pure _ = Const mempty
+    liftA2 _ (Const x) (Const y) = Const (x `mappend` y)
     (<*>) = coerce (mappend :: m -> m -> m)
 -- This is pretty much the same as
 -- Const f <*> Const v = Const (f `mappend` v)
diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs
index 492ba84600..1fe127f310 100644
--- a/libraries/base/Data/Functor/Identity.hs
+++ b/libraries/base/Data/Functor/Identity.hs
@@ -107,6 +107,7 @@ instance Functor Identity where
 instance Applicative Identity where
     pure     = Identity
     (<*>)    = coerce
+    liftA2   = coerce
 
 -- | @since 4.8.0.0
 instance Monad Identity where
diff --git a/libraries/base/Data/Functor/Product.hs b/libraries/base/Data/Functor/Product.hs
index b176d4e114..7676aa5f0c 100644
--- a/libraries/base/Data/Functor/Product.hs
+++ b/libraries/base/Data/Functor/Product.hs
@@ -88,12 +88,13 @@ instance (Foldable f, Foldable g) => Foldable (Product f g) where
 
 -- | @since 4.9.0.0
 instance (Traversable f, Traversable g) => Traversable (Product f g) where
-    traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y
+    traverse f (Pair x y) = liftA2 Pair (traverse f x) (traverse f y)
 
 -- | @since 4.9.0.0
 instance (Applicative f, Applicative g) => Applicative (Product f g) where
     pure x = Pair (pure x) (pure x)
     Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)
+    liftA2 f (Pair a b) (Pair x y) = Pair (liftA2 f a x) (liftA2 f b y)
 
 -- | @since 4.9.0.0
 instance (Alternative f, Alternative g) => Alternative (Product f g) where
diff --git a/libraries/base/Data/Functor/Utils.hs b/libraries/base/Data/Functor/Utils.hs
index 79b34184c5..1bd729bcca 100644
--- a/libraries/base/Data/Functor/Utils.hs
+++ b/libraries/base/Data/Functor/Utils.hs
@@ -58,6 +58,10 @@ instance Applicative (StateL s) where
         let (s', f) = kf s
             (s'', v) = kv s'
         in (s'', f v)
+    liftA2 f (StateL kx) (StateL ky) = StateL $ \s ->
+        let (s', x) = kx s
+            (s'', y) = ky s'
+        in (s'', f x y)
 
 -- right-to-left state transformer
 newtype StateR s a = StateR { runStateR :: s -> (s, a) }
@@ -73,6 +77,10 @@ instance Applicative (StateR s) where
         let (s', v) = kv s
             (s'', f) = kf s'
         in (s'', f v)
+    liftA2 f (StateR kx) (StateR ky) = StateR $ \ s ->
+        let (s', y) = ky s
+            (s'', x) = kx s'
+        in (s'', f x y)
 
 -- See Note [Function coercion]
 (#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs
index 6eaeb36f25..2f9f868b43 100644
--- a/libraries/base/Data/List/NonEmpty.hs
+++ b/libraries/base/Data/List/NonEmpty.hs
@@ -101,8 +101,8 @@ import           Prelude             hiding (break, cycle, drop, dropWhile,
                                       unzip, zip, zipWith, (!!))
 import qualified Prelude
 
-import           Control.Applicative (Alternative, many)
-import           Control.Monad       (ap)
+import           Control.Applicative (Applicative (..), Alternative (many))
+import           Control.Monad       (ap, liftM2)
 import           Control.Monad.Fix
 import           Control.Monad.Zip   (MonadZip(..))
 import           Data.Data           (Data)
@@ -210,6 +210,7 @@ instance Functor NonEmpty where
 instance Applicative NonEmpty where
   pure a = a :| []
   (<*>) = ap
+  liftA2 = liftM2
 
 -- | @since 4.9.0.0
 instance Monad NonEmpty where
@@ -219,7 +220,7 @@ instance Monad NonEmpty where
 
 -- | @since 4.9.0.0
 instance Traversable NonEmpty where
-  traverse f ~(a :| as) = (:|) <$> f a <*> traverse f as
+  traverse f ~(a :| as) = liftA2 (:|) (f a) (traverse f as)
 
 -- | @since 4.9.0.0
 instance Foldable NonEmpty where
@@ -299,7 +300,7 @@ insert a = fromList . List.insert a . Foldable.toList
 
 -- | @'some1' x@ sequences @x@ one or more times.
 some1 :: Alternative f => f a -> f (NonEmpty a)
-some1 x = (:|) <$> x <*> many x
+some1 x = liftA2 (:|) x (many x)
 
 -- | 'scanl' is similar to 'foldl', but returns a stream of successive
 -- reduced values from the left:
diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs
index 1c3d9da208..e6bc3140b4 100644
--- a/libraries/base/Data/Semigroup.hs
+++ b/libraries/base/Data/Semigroup.hs
@@ -366,7 +366,8 @@ instance Applicative Min where
   pure = Min
   a <* _ = a
   _ *> a = a
-  Min f <*> Min x = Min (f x)
+  (<*>) = coerce
+  liftA2 = coerce
 
 -- | @since 4.9.0.0
 instance Monad Min where
@@ -428,7 +429,8 @@ instance Applicative Max where
   pure = Max
   a <* _ = a
   _ *> a = a
-  Max f <*> Max x = Max (f x)
+  (<*>) = coerce
+  liftA2 = coerce
 
 -- | @since 4.9.0.0
 instance Monad Max where
@@ -533,7 +535,8 @@ instance Applicative First where
   pure x = First x
   a <* _ = a
   _ *> a = a
-  First f <*> First x = First (f x)
+  (<*>) = coerce
+  liftA2 = coerce
 
 -- | @since 4.9.0.0
 instance Monad First where
@@ -583,7 +586,8 @@ instance Applicative Last where
   pure = Last
   a <* _ = a
   _ *> a = a
-  Last f <*> Last x = Last (f x)
+  (<*>) = coerce
+  liftA2 = coerce
 
 -- | @since 4.9.0.0
 instance Monad Last where
@@ -648,6 +652,7 @@ instance Functor Option where
 instance Applicative Option where
   pure a = Option (Just a)
   Option a <*> Option b = Option (a <*> b)
+  liftA2 f (Option x) (Option y) = Option (liftA2 f x y)
 
   Option Nothing  *>  _ = Option Nothing
   _               *>  b = b
diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs
index e525ba3231..5c2745edeb 100644
--- a/libraries/base/Data/Traversable.hs
+++ b/libraries/base/Data/Traversable.hs
@@ -235,7 +235,7 @@ instance Traversable Maybe where
 instance Traversable [] where
     {-# INLINE traverse #-} -- so that traverse can fuse
     traverse f = List.foldr cons_f (pure [])
-      where cons_f x ys = (:) <$> f x <*> ys
+      where cons_f x ys = liftA2 (:) (f x) ys
 
 -- | @since 4.7.0.0
 instance Traversable (Either a) where
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index 2863ea71ac..e07c077e84 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -331,6 +331,7 @@ instance Monoid a => Monoid (Maybe a) where
 instance Monoid a => Applicative ((,) a) where
     pure x = (mempty, x)
     (u, f) <*> (v, x) = (u `mappend` v, f x)
+    liftA2 f (u, x) (v, y) = (u `mappend` v, f x y)
 
 -- | @since 4.9.0.0
 instance Monoid a => Monad ((,) a) where
@@ -364,10 +365,16 @@ class  Functor f  where
 --
 -- * embed pure expressions ('pure'), and
 --
--- * sequence computations and combine their results ('<*>').
+-- * sequence computations and combine their results ('<*>' and 'liftA2').
 --
--- A minimal complete definition must include implementations of these
--- functions satisfying the following laws:
+-- A minimal complete definition must include implementations of 'pure'
+-- and of either '<*>' or 'liftA2'. If it defines both, then they must behave
+-- the same as their default definitions:
+--
+--      @('<*>') = 'liftA2' 'id'@
+--      @'liftA2' f x y = f '<$>' x '<*>' y@
+--
+-- Further, any definition must satisfy the following:
 --
 -- [/identity/]
 --
@@ -385,17 +392,28 @@ class  Functor f  where
 --
 --      @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
 --
+--
 -- The other methods have the following default definitions, which may
 -- be overridden with equivalent specialized implementations:
 --
---   * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@
+--   * @u '*>' v = ('id' '<$' u) '<*>' v@
 --
---   * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@
+--   * @u '<*' v = 'liftA2' 'const' u v@
 --
 -- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
 --
 --   * @'fmap' f x = 'pure' f '<*>' x@
 --
+--
+-- It may be useful to note that supposing
+--
+--      @forall x y. p (q x y) = f x . g y@
+--
+-- it follows from the above that
+--
+--      @'liftA2' p ('liftA2' q u v) = 'liftA2' f u . 'liftA2' g v@
+--
+--
 -- If @f@ is also a 'Monad', it should satisfy
 --
 --   * @'pure' = 'return'@
@@ -405,17 +423,37 @@ class  Functor f  where
 -- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
 
 class Functor f => Applicative f where
+    {-# MINIMAL pure, ((<*>) | liftA2) #-}
     -- | Lift a value.
     pure :: a -> f a
 
     -- | Sequential application.
+    --
+    -- A few functors support an implementation of '<*>' that is more
+    -- efficient than the default one.
     (<*>) :: f (a -> b) -> f a -> f b
+    (<*>) = liftA2 id
+
+    -- | Lift a binary function to actions.
+    --
+    -- Some functors support an implementation of 'liftA2' that is more
+    -- efficient than the default one. In particular, if 'fmap' is an
+    -- expensive operation, it is likely better to use 'liftA2' than to
+    -- 'fmap' over the structure and then use '<*>'.
+    liftA2 :: (a -> b -> c) -> f a -> f b -> f c
+    liftA2 f x = (<*>) (fmap f x)
 
     -- | Sequence actions, discarding the value of the first argument.
     (*>) :: f a -> f b -> f b
     a1 *> a2 = (id <$ a1) <*> a2
-    -- This is essentially the same as liftA2 (const id), but if the
-    -- Functor instance has an optimized (<$), we want to use that instead.
+    -- This is essentially the same as liftA2 (flip const), but if the
+    -- Functor instance has an optimized (<$), it may be better to use
+    -- that instead. Before liftA2 became a method, this definition
+    -- was strictly better, but now it depends on the functor. For a
+    -- functor supporting a sharing-enhancing (<$), this definition
+    -- may reduce allocation by preventing a1 from ever being fully
+    -- realized. In an implementation with a boring (<$) but an optimizing
+    -- liftA2, it would likely be better to define (*>) using liftA2.
 
     -- | Sequence actions, discarding the value of the second argument.
     (<*) :: f a -> f b -> f a
@@ -433,21 +471,14 @@ liftA f a = pure f <*> a
 -- Caution: since this may be used for `fmap`, we can't use the obvious
 -- definition of liftA = fmap.
 
--- | Lift a binary function to actions.
-liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
-liftA2 f a b = fmap f a <*> b
-
 -- | Lift a ternary function to actions.
 liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
-liftA3 f a b c = fmap f a <*> b <*> c
+liftA3 f a b c = liftA2 f a b <*> c
 
 
 {-# INLINABLE liftA #-}
 {-# SPECIALISE liftA :: (a1->r) -> IO a1 -> IO r #-}
 {-# SPECIALISE liftA :: (a1->r) -> Maybe a1 -> Maybe r #-}
-{-# INLINABLE liftA2 #-}
-{-# SPECIALISE liftA2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}
-{-# SPECIALISE liftA2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-}
 {-# INLINABLE liftA3 #-}
 {-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
 {-# SPECIALISE liftA3 :: (a1->a2->a3->r) ->
@@ -596,6 +627,8 @@ liftM f m1              = do { x1 <- m1; return (f x1) }
 --
 liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
 liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
+-- Caution: since this may be used for `liftA2`, we can't use the obvious
+-- definition of liftM2 = liftA2.
 
 -- | Promote a function to a monad, scanning the monadic arguments from
 -- left to right (cf. 'liftM2').
@@ -657,6 +690,7 @@ instance Functor ((->) r) where
 instance Applicative ((->) a) where
     pure = const
     (<*>) f g x = f x (g x)
+    liftA2 q f g x = q (f x) (g x)
 
 -- | @since 2.01
 instance Monad ((->) r) where
@@ -678,6 +712,9 @@ instance Applicative Maybe where
     Just f  <*> m       = fmap f m
     Nothing <*> _m      = Nothing
 
+    liftA2 f (Just x) (Just y) = Just (f x y)
+    liftA2 _ _ _ = Nothing
+
     Just _m1 *> m2      = m2
     Nothing  *> _m2     = Nothing
 
@@ -714,14 +751,14 @@ class Applicative f => Alternative f where
     some v = some_v
       where
         many_v = some_v <|> pure []
-        some_v = (fmap (:) v) <*> many_v
+        some_v = liftA2 (:) v many_v
 
     -- | Zero or more.
     many :: f a -> f [a]
     many v = many_v
       where
         many_v = some_v <|> pure []
-        some_v = (fmap (:) v) <*> many_v
+        some_v = liftA2 (:) v many_v
 
 
 -- | @since 2.01
@@ -765,6 +802,8 @@ instance Applicative [] where
     pure x    = [x]
     {-# INLINE (<*>) #-}
     fs <*> xs = [f x | f <- fs, x <- xs]
+    {-# INLINE liftA2 #-}
+    liftA2 f xs ys = [f x y | x <- xs, y <- ys]
     {-# INLINE (*>) #-}
     xs *> ys  = [y | _ <- xs, y <- ys]
 
@@ -1114,9 +1153,11 @@ instance  Functor IO where
 instance Applicative IO where
     {-# INLINE pure #-}
     {-# INLINE (*>) #-}
+    {-# INLINE liftA2 #-}
     pure  = returnIO
     (*>)  = thenIO
     (<*>) = ap
+    liftA2 = liftM2
 
 -- | @since 2.01
 instance  Monad IO  where
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index 200cdfec74..a9629c41bb 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -650,8 +650,10 @@ instance  Functor STM where
 instance Applicative STM where
   {-# INLINE pure #-}
   {-# INLINE (*>) #-}
+  {-# INLINE liftA2 #-}
   pure x = returnSTM x
   (<*>) = ap
+  liftA2 = liftM2
   m *> k = thenSTM m k
 
 -- | @since 4.3.0.0
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index 8e128d444f..4282b7c83b 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP                    #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
@@ -730,7 +731,7 @@ import GHC.Types
 -- Needed for instances
 import GHC.Arr     ( Ix )
 import GHC.Base    ( Alternative(..), Applicative(..), Functor(..)
-                   , Monad(..), MonadPlus(..), String )
+                   , Monad(..), MonadPlus(..), String, coerce )
 import GHC.Classes ( Eq(..), Ord(..) )
 import GHC.Enum    ( Bounded, Enum )
 import GHC.Read    ( Read(..), lex, readParen )
@@ -781,6 +782,7 @@ instance Functor U1 where
 instance Applicative U1 where
   pure _ = U1
   _ <*> _ = U1
+  liftA2 _ _ _ = U1
 
 -- | @since 4.9.0.0
 instance Alternative U1 where
@@ -800,8 +802,9 @@ newtype Par1 p = Par1 { unPar1 :: p }
 
 -- | @since 4.9.0.0
 instance Applicative Par1 where
-  pure a = Par1 a
-  Par1 f <*> Par1 x = Par1 (f x)
+  pure = Par1
+  (<*>) = coerce
+  liftA2 = coerce
 
 -- | @since 4.9.0.0
 instance Monad Par1 where
@@ -813,42 +816,33 @@ newtype Rec1 (f :: k -> *) (p :: k) = Rec1 { unRec1 :: f p }
   deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
 
 -- | @since 4.9.0.0
-instance Applicative f => Applicative (Rec1 f) where
-  pure a = Rec1 (pure a)
-  Rec1 f <*> Rec1 x = Rec1 (f <*> x)
+deriving instance Applicative f => Applicative (Rec1 f)
 
 -- | @since 4.9.0.0
-instance Alternative f => Alternative (Rec1 f) where
-  empty = Rec1 empty
-  Rec1 l <|> Rec1 r = Rec1 (l <|> r)
+deriving instance Alternative f => Alternative (Rec1 f)
 
 -- | @since 4.9.0.0
 instance Monad f => Monad (Rec1 f) where
   Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a))
 
 -- | @since 4.9.0.0
-instance MonadPlus f => MonadPlus (Rec1 f)
+deriving instance MonadPlus f => MonadPlus (Rec1 f)
 
 -- | Constants, additional parameters and recursion of kind @*@
 newtype K1 (i :: *) c (p :: k) = K1 { unK1 :: c }
   deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
 
 -- | @since 4.9.0.0
-instance Applicative f => Applicative (M1 i c f) where
-  pure a = M1 (pure a)
-  M1 f <*> M1 x = M1 (f <*> x)
+deriving instance Applicative f => Applicative (M1 i c f)
 
 -- | @since 4.9.0.0
-instance Alternative f => Alternative (M1 i c f) where
-  empty = M1 empty
-  M1 l <|> M1 r = M1 (l <|> r)
+deriving instance Alternative f => Alternative (M1 i c f)
 
 -- | @since 4.9.0.0
-instance Monad f => Monad (M1 i c f) where
-  M1 x >>= f = M1 (x >>= \a -> unM1 (f a))
+deriving instance Monad f => Monad (M1 i c f)
 
 -- | @since 4.9.0.0
-instance MonadPlus f => MonadPlus (M1 i c f)
+deriving instance MonadPlus f => MonadPlus (M1 i c f)
 
 -- | Meta-information (constructor names, etc.)
 newtype M1 (i :: *) (c :: Meta) (f :: k -> *) (p :: k) = M1 { unM1 :: f p }
@@ -868,6 +862,7 @@ data (:*:) (f :: k -> *) (g :: k -> *) (p :: k) = f p :*: g p
 instance (Applicative f, Applicative g) => Applicative (f :*: g) where
   pure a = pure a :*: pure a
   (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y)
+  liftA2 f (a :*: b) (x :*: y) = liftA2 f a x :*: liftA2 f b y
 
 -- | @since 4.9.0.0
 instance (Alternative f, Alternative g) => Alternative (f :*: g) where
@@ -893,12 +888,14 @@ newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
 -- | @since 4.9.0.0
 instance (Applicative f, Applicative g) => Applicative (f :.: g) where
   pure x = Comp1 (pure (pure x))
-  Comp1 f <*> Comp1 x = Comp1 (fmap (<*>) f <*> x)
+  Comp1 f <*> Comp1 x = Comp1 (liftA2 (<*>) f x)
+  liftA2 f (Comp1 x) (Comp1 y) = Comp1 (liftA2 (liftA2 f) x y)
 
 -- | @since 4.9.0.0
 instance (Alternative f, Applicative g) => Alternative (f :.: g) where
   empty = Comp1 empty
-  Comp1 x <|> Comp1 y = Comp1 (x <|> y)
+  (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a)) ::
+    forall a . (f :.: g) a -> (f :.: g) a -> (f :.: g) a
 
 -- | Constants of unlifted kinds
 --
diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs
index dc5c71fe68..7982d598af 100644
--- a/libraries/base/GHC/ST.hs
+++ b/libraries/base/GHC/ST.hs
@@ -65,6 +65,7 @@ instance Applicative (ST s) where
     pure x = ST (\ s -> (# s, x #))
     m *> k = m >>= \ _ -> k
     (<*>) = ap
+    liftA2 = liftM2
 
 -- | @since 2.01
 instance Monad (ST s) where
diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs
index ed30b3bda6..cc6897447e 100644
--- a/libraries/base/Text/ParserCombinators/ReadP.hs
+++ b/libraries/base/Text/ParserCombinators/ReadP.hs
@@ -171,6 +171,7 @@ instance Functor ReadP where
 instance Applicative ReadP where
     pure x = R (\k -> k x)
     (<*>) = ap
+    liftA2 = liftM2
 
 -- | @since 2.01
 instance Monad ReadP where
diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs
index 8e763ce1c2..2b30fe08ac 100644
--- a/libraries/base/Text/ParserCombinators/ReadPrec.hs
+++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs
@@ -81,6 +81,7 @@ instance Functor ReadPrec where
 instance Applicative ReadPrec where
     pure x  = P (\_ -> pure x)
     (<*>) = ap
+    liftA2 = liftM2
 
 -- | @since 2.01
 instance Monad ReadPrec where
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index ab9158d244..aa7302db0b 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -49,6 +49,13 @@
 
   * The type of `asProxyTypeOf` in `Data.Proxy` has been generalized (#12805)
 
+  * `liftA2` is now a method of the `Applicative` class. `liftA2` and
+    `<*>` each have a default implementation based on the other. Various
+    library functions have been updated to use `liftA2` where it might offer
+    some benefit. `liftA2` is not yet in the `Prelude`, and must currently be
+    imported from `Control.Applicative`. It is likely to be added to the
+    `Prelude` in the future. (#13191)
+
 ## 4.9.0.0  *May 2016*
 
   * Bundled with GHC 8.0
diff --git a/libraries/base/tests/T13191.hs b/libraries/base/tests/T13191.hs
new file mode 100644
index 0000000000..b492b608bc
--- /dev/null
+++ b/libraries/base/tests/T13191.hs
@@ -0,0 +1,71 @@
+-- To test with GHC before liftA2 was added to the Applicative
+-- class, remove the definition of liftA2 here, and import
+-- liftA2 separately from Control.Applicative.
+{-# LANGUAGE DeriveTraversable, GADTs, DataKinds,
+    DeriveFunctor, StandaloneDeriving #-}
+
+module Main where
+import Control.Applicative (Applicative (..))
+import Data.Monoid (Sum (..))
+import qualified Data.Array as A
+
+data Tree a = Leaf a a | Node (Tree a) (Tree a)
+  deriving (Functor, Foldable, Traversable)
+
+buildTree :: Int -> a -> Tree a
+buildTree 0 a = Leaf a a
+buildTree n a =
+  let subtree = buildTree (n - 1) a
+  in Node subtree subtree
+
+data Nat = Z | S Nat
+
+data Vec n a where
+  Nil :: Vec 'Z a
+  Cons :: a -> !(Vec n a) -> Vec ('S n) a
+
+deriving instance Functor (Vec n)
+deriving instance Foldable (Vec n)
+deriving instance Show a => Show (Vec n a)
+
+class Pure n where
+  pure' :: a -> Vec n a
+instance Pure 'Z where
+  pure' _ = Nil
+instance Pure n => Pure ('S n) where
+  pure' a = Cons a (pure' a)
+
+instance Pure n => Applicative (Vec n) where
+  pure = pure'
+  (<*>) = apVec
+  liftA2 = liftA2Vec
+
+apVec :: Vec n (a -> b) -> Vec n a -> Vec n b
+apVec Nil Nil = Nil
+apVec (Cons f fs) (Cons x xs) = f x `Cons` apVec fs xs
+
+liftA2Vec :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c
+liftA2Vec _ Nil Nil = Nil
+liftA2Vec f (Cons x xs) (Cons y ys) = f x y `Cons` liftA2Vec f xs ys
+
+data SomeVec a where
+  SomeVec :: Pure n => Vec n a -> SomeVec a
+
+replicateVec :: Int -> a -> SomeVec a
+replicateVec 0 _ = SomeVec Nil
+replicateVec n a =
+  case replicateVec (n - 1) a of
+    SomeVec v -> SomeVec (a `Cons` v)
+
+ones :: SomeVec Int
+ones = replicateVec 6000 (1 :: Int)
+
+theTree :: Tree ()
+theTree = buildTree 7 ()
+
+blah :: SomeVec (Tree Int)
+blah = case ones of
+         SomeVec v -> SomeVec $ traverse (const v) theTree
+
+main = case blah of
+         SomeVec v -> print $ getSum $ foldMap (foldMap Sum) v
diff --git a/libraries/base/tests/T13191.stdout b/libraries/base/tests/T13191.stdout
new file mode 100644
index 0000000000..2ede990484
--- /dev/null
+++ b/libraries/base/tests/T13191.stdout
@@ -0,0 +1 @@
+1536000
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 7ce6a81385..7125b636f8 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -198,3 +198,11 @@ test('T11555', normal, compile_and_run, [''])
 test('T12852', when(opsys('mingw32'), skip), compile_and_run, [''])
 test('lazySTexamples', normal, compile_and_run, [''])
 test('T11760', normal, compile_and_run, ['-threaded -with-rtsopts=-N2'])
+test('T13191',
+        [ stats_num_field('bytes allocated',
+                          [ (wordsize(64), 185943272, 5) ])
+        # with GHC-8.1 before liftA2 change: 325065128
+        # GHC-8.1 with custom liftA2:        185943272
+        , only_ways(['normal'])],
+      compile_and_run,
+      ['-O'])
diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr
index 7d3413a5ba..aa9bf88d37 100644
--- a/testsuite/tests/simplCore/should_compile/T8848.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8848.stderr
@@ -5,25 +5,30 @@ Rule fired: SPEC map2
 Rule fired: Class op fmap
 Rule fired: Class op fmap
 Rule fired: Class op fmap
+Rule fired: Class op liftA2
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
 Rule fired: Class op <$
 Rule fired: Class op <*>
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
 Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
+Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
+Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
+Rule fired: Class op <$
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
+Rule fired: Class op <$
 Rule fired: Class op <*>
-Rule fired: SPEC/T8848 liftA2 @ (Shape 'Z) _ _ _
 Rule fired: Class op $p1Applicative
 Rule fired: Class op $p1Applicative
 Rule fired: SPEC $cfmap @ 'Z
@@ -38,40 +43,59 @@ Rule fired: SPEC $fFunctorShape @ 'Z
 Rule fired: SPEC $cp1Applicative @ 'Z
 Rule fired: SPEC $cpure @ 'Z
 Rule fired: SPEC $c<*> @ 'Z
+Rule fired: SPEC $cliftA2 @ 'Z
 Rule fired: SPEC $c*> @ 'Z
 Rule fired: SPEC $c<* @ 'Z
 Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: Class op liftA2
 Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
+Rule fired: Class op <$
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
 Rule fired: Class op <$
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
+Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: SPEC $c<*> @ 'Z
+Rule fired: SPEC $cliftA2 @ 'Z
 Rule fired: SPEC $c*> @ 'Z
 Rule fired: SPEC $c<* @ 'Z
 Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: Class op liftA2
+Rule fired: Class op liftA2
 Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
+Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
-Rule fired: Class op <$
+Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
+Rule fired: Class op <$
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
-Rule fired: Class op fmap
+Rule fired: Class op <$
 Rule fired: Class op <*>
-Rule fired: SPEC/T8848 liftA2 @ (Shape ('S 'Z)) _ _ _
 Rule fired: SPEC $fFunctorShape @ 'Z
 Rule fired: Class op fmap
 Rule fired: Class op fmap
+Rule fired: SPEC $c<*> @ ('S 'Z)
+Rule fired: SPEC $c<*> @ ('S 'Z)