Commit a2f39da0 authored by David Feuer's avatar David Feuer Committed by David Feuer
Browse files

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
parent 54b9b064
...@@ -809,11 +809,12 @@ uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") ...@@ -809,11 +809,12 @@ uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#")
uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#")
uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#") 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 traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
pure_RDR = nameRdrName pureAName pure_RDR = nameRdrName pureAName
ap_RDR = nameRdrName apAName ap_RDR = nameRdrName apAName
liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2")
foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr")
foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap")
traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse")
......
...@@ -549,7 +549,8 @@ Again, Traversable is much like Functor and Foldable. ...@@ -549,7 +549,8 @@ Again, Traversable is much like Functor and Foldable.
The cases are: The cases are:
$(traverse 'a 'a) = f $(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 $(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 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
...@@ -601,7 +602,7 @@ gen_Traversable_binds loc tycon ...@@ -601,7 +602,7 @@ gen_Traversable_binds loc tycon
lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
return (Just lam) return (Just lam)
-- traverse f = \x -> case x of (a1,a2,..) -> -- 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 , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
-- traverse f = traverse g -- traverse f = traverse g
, ft_forall = \_ g -> g , ft_forall = \_ g -> g
...@@ -609,8 +610,8 @@ gen_Traversable_binds loc tycon ...@@ -609,8 +610,8 @@ gen_Traversable_binds loc tycon
, ft_fun = panic "function" , ft_fun = panic "function"
, ft_bad_app = panic "in other argument" } , ft_bad_app = panic "in other argument" }
-- Con a1 a2 ... -> fmap (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
-- <*> g2 a2 <*> ... -- (g2 a2) <*> ...
match_for_con :: [LPat RdrName] match_for_con :: [LPat RdrName]
-> DataCon -> DataCon
-> [Maybe (LHsExpr RdrName)] -> [Maybe (LHsExpr RdrName)]
...@@ -618,10 +619,12 @@ gen_Traversable_binds loc tycon ...@@ -618,10 +619,12 @@ gen_Traversable_binds loc tycon
match_for_con = mkSimpleConMatch2 CaseAlt $ match_for_con = mkSimpleConMatch2 CaseAlt $
\con xs -> return (mkApCon con xs) \con xs -> return (mkApCon con xs)
where 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 :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
mkApCon con [] = nlHsApps pure_RDR [con] 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] where appAp x y = nlHsApps ap_RDR [x,y]
----------------------------------------------------------------------- -----------------------------------------------------------------------
......
...@@ -298,6 +298,12 @@ See ``changelog.md`` in the ``base`` package for full release notes. ...@@ -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. operations in ``GHC.TypeLits`` are a thin compatibility layer on top.
Note: the ``KnownNat`` evidence is changed from an ``Integer`` to a ``Natural``. 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 binary
~~~~~~ ~~~~~~
......
...@@ -43,7 +43,7 @@ module Control.Applicative ( ...@@ -43,7 +43,7 @@ module Control.Applicative (
Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..), Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
-- * Utility functions -- * Utility functions
(<$>), (<$), (<**>), (<$>), (<$), (<**>),
liftA, liftA2, liftA3, liftA, liftA3,
optional, optional,
) where ) where
...@@ -74,6 +74,7 @@ instance Monad m => Functor (WrappedMonad m) where ...@@ -74,6 +74,7 @@ instance Monad m => Functor (WrappedMonad m) where
instance Monad m => Applicative (WrappedMonad m) where instance Monad m => Applicative (WrappedMonad m) where
pure = WrapMonad . pure pure = WrapMonad . pure
WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
liftA2 f (WrapMonad x) (WrapMonad y) = WrapMonad (liftM2 f x y)
-- | @since 2.01 -- | @since 2.01
instance MonadPlus m => Alternative (WrappedMonad m) where instance MonadPlus m => Alternative (WrappedMonad m) where
...@@ -90,7 +91,8 @@ instance Arrow a => Functor (WrappedArrow a b) where ...@@ -90,7 +91,8 @@ instance Arrow a => Functor (WrappedArrow a b) where
-- | @since 2.01 -- | @since 2.01
instance Arrow a => Applicative (WrappedArrow a b) where instance Arrow a => Applicative (WrappedArrow a b) where
pure x = WrapArrow (arr (const x)) 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 -- | @since 2.01
instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
...@@ -109,7 +111,7 @@ newtype ZipList a = ZipList { getZipList :: [a] } ...@@ -109,7 +111,7 @@ newtype ZipList a = ZipList { getZipList :: [a] }
-- | @since 2.01 -- | @since 2.01
instance Applicative ZipList where instance Applicative ZipList where
pure x = ZipList (repeat x) 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 -- extra functions
......
...@@ -142,6 +142,21 @@ instance Applicative (ST s) where ...@@ -142,6 +142,21 @@ instance Applicative (ST s) where
-- forces the (f x, s'') pair, then they must need -- forces the (f x, s'') pair, then they must need
-- f or s''. To get s'', they need s'. -- 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 -> m *> n = ST $ \s ->
let let
{-# NOINLINE s' #-} {-# NOINLINE s' #-}
......
...@@ -144,27 +144,28 @@ bisequence = bitraverse id id ...@@ -144,27 +144,28 @@ bisequence = bitraverse id id
-- | @since 4.10.0.0 -- | @since 4.10.0.0
instance Bitraversable (,) where 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 -- | @since 4.10.0.0
instance Bitraversable ((,,) x) where 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 -- | @since 4.10.0.0
instance Bitraversable ((,,,) x y) where 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 -- | @since 4.10.0.0
instance Bitraversable ((,,,,) x y z) where 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 -- | @since 4.10.0.0
instance Bitraversable ((,,,,,) x y z w) where 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 -- | @since 4.10.0.0
instance Bitraversable ((,,,,,,) x y z w v) where 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 -- | @since 4.10.0.0
instance Bitraversable Either where instance Bitraversable Either where
......
...@@ -36,6 +36,7 @@ module Data.Complex ...@@ -36,6 +36,7 @@ module Data.Complex
) where ) where
import GHC.Base (Applicative (..))
import GHC.Generics (Generic, Generic1) import GHC.Generics (Generic, Generic1)
import GHC.Float (Floating(..)) import GHC.Float (Floating(..))
import Data.Data (Data) import Data.Data (Data)
...@@ -231,6 +232,7 @@ instance Storable a => Storable (Complex a) where ...@@ -231,6 +232,7 @@ instance Storable a => Storable (Complex a) where
instance Applicative Complex where instance Applicative Complex where
pure a = a :+ a pure a = a :+ a
f :+ g <*> a :+ b = f a :+ g b 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 -- | @since 4.9.0.0
instance Monad Complex where instance Monad Complex where
......
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-} {-# LANGUAGE Trustworthy #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Data.Functor.Compose -- Module : Data.Functor.Compose
...@@ -24,6 +25,7 @@ module Data.Functor.Compose ( ...@@ -24,6 +25,7 @@ module Data.Functor.Compose (
import Data.Functor.Classes import Data.Functor.Classes
import Control.Applicative import Control.Applicative
import Data.Coerce (coerce)
import Data.Data (Data) import Data.Data (Data)
import Data.Foldable (Foldable(foldMap)) import Data.Foldable (Foldable(foldMap))
import Data.Traversable (Traversable(traverse)) import Data.Traversable (Traversable(traverse))
...@@ -106,9 +108,12 @@ instance (Traversable f, Traversable g) => Traversable (Compose f g) where ...@@ -106,9 +108,12 @@ instance (Traversable f, Traversable g) => Traversable (Compose f g) where
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance (Applicative f, Applicative g) => Applicative (Compose f g) where instance (Applicative f, Applicative g) => Applicative (Compose f g) where
pure x = Compose (pure (pure x)) 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 -- | @since 4.9.0.0
instance (Alternative f, Applicative g) => Alternative (Compose f g) where instance (Alternative f, Applicative g) => Alternative (Compose f g) where
empty = Compose empty 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
...@@ -68,6 +68,7 @@ instance Functor (Const m) where ...@@ -68,6 +68,7 @@ instance Functor (Const m) where
-- | @since 2.0.1 -- | @since 2.0.1
instance Monoid m => Applicative (Const m) where instance Monoid m => Applicative (Const m) where
pure _ = Const mempty pure _ = Const mempty
liftA2 _ (Const x) (Const y) = Const (x `mappend` y)
(<*>) = coerce (mappend :: m -> m -> m) (<*>) = coerce (mappend :: m -> m -> m)
-- This is pretty much the same as -- This is pretty much the same as
-- Const f <*> Const v = Const (f `mappend` v) -- Const f <*> Const v = Const (f `mappend` v)
......
...@@ -107,6 +107,7 @@ instance Functor Identity where ...@@ -107,6 +107,7 @@ instance Functor Identity where
instance Applicative Identity where instance Applicative Identity where
pure = Identity pure = Identity
(<*>) = coerce (<*>) = coerce
liftA2 = coerce
-- | @since 4.8.0.0 -- | @since 4.8.0.0
instance Monad Identity where instance Monad Identity where
......
...@@ -88,12 +88,13 @@ instance (Foldable f, Foldable g) => Foldable (Product f g) where ...@@ -88,12 +88,13 @@ instance (Foldable f, Foldable g) => Foldable (Product f g) where
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance (Traversable f, Traversable g) => Traversable (Product f g) where 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 -- | @since 4.9.0.0
instance (Applicative f, Applicative g) => Applicative (Product f g) where instance (Applicative f, Applicative g) => Applicative (Product f g) where
pure x = Pair (pure x) (pure x) pure x = Pair (pure x) (pure x)
Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) 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 -- | @since 4.9.0.0
instance (Alternative f, Alternative g) => Alternative (Product f g) where instance (Alternative f, Alternative g) => Alternative (Product f g) where
......
...@@ -58,6 +58,10 @@ instance Applicative (StateL s) where ...@@ -58,6 +58,10 @@ instance Applicative (StateL s) where
let (s', f) = kf s let (s', f) = kf s
(s'', v) = kv s' (s'', v) = kv s'
in (s'', f v) 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 -- right-to-left state transformer
newtype StateR s a = StateR { runStateR :: s -> (s, a) } newtype StateR s a = StateR { runStateR :: s -> (s, a) }
...@@ -73,6 +77,10 @@ instance Applicative (StateR s) where ...@@ -73,6 +77,10 @@ instance Applicative (StateR s) where
let (s', v) = kv s let (s', v) = kv s
(s'', f) = kf s' (s'', f) = kf s'
in (s'', f v) 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] -- See Note [Function coercion]
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) (#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
......
...@@ -101,8 +101,8 @@ import Prelude hiding (break, cycle, drop, dropWhile, ...@@ -101,8 +101,8 @@ import Prelude hiding (break, cycle, drop, dropWhile,
unzip, zip, zipWith, (!!)) unzip, zip, zipWith, (!!))
import qualified Prelude import qualified Prelude
import Control.Applicative (Alternative, many) import Control.Applicative (Applicative (..), Alternative (many))
import Control.Monad (ap) import Control.Monad (ap, liftM2)
import Control.Monad.Fix import Control.Monad.Fix
import Control.Monad.Zip (MonadZip(..)) import Control.Monad.Zip (MonadZip(..))
import Data.Data (Data) import Data.Data (Data)
...@@ -210,6 +210,7 @@ instance Functor NonEmpty where ...@@ -210,6 +210,7 @@ instance Functor NonEmpty where
instance Applicative NonEmpty where instance Applicative NonEmpty where
pure a = a :| [] pure a = a :| []
(<*>) = ap (<*>) = ap
liftA2 = liftM2
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance Monad NonEmpty where instance Monad NonEmpty where
...@@ -219,7 +220,7 @@ instance Monad NonEmpty where ...@@ -219,7 +220,7 @@ instance Monad NonEmpty where
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance Traversable NonEmpty where 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 -- | @since 4.9.0.0
instance Foldable NonEmpty where instance Foldable NonEmpty where
...@@ -299,7 +300,7 @@ insert a = fromList . List.insert a . Foldable.toList ...@@ -299,7 +300,7 @@ insert a = fromList . List.insert a . Foldable.toList
-- | @'some1' x@ sequences @x@ one or more times. -- | @'some1' x@ sequences @x@ one or more times.
some1 :: Alternative f => f a -> f (NonEmpty a) 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 -- | 'scanl' is similar to 'foldl', but returns a stream of successive
-- reduced values from the left: -- reduced values from the left:
......
...@@ -366,7 +366,8 @@ instance Applicative Min where ...@@ -366,7 +366,8 @@ instance Applicative Min where
pure = Min pure = Min
a <* _ = a a <* _ = a
_ *> a = a _ *> a = a
Min f <*> Min x = Min (f x) (<*>) = coerce
liftA2 = coerce
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance Monad Min where instance Monad Min where
...@@ -428,7 +429,8 @@ instance Applicative Max where ...@@ -428,7 +429,8 @@ instance Applicative Max where
pure = Max pure = Max
a <* _ = a a <* _ = a
_ *> a = a _ *> a = a
Max f <*> Max x = Max (f x) (<*>) = coerce
liftA2 = coerce
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance Monad Max where instance Monad Max where
...@@ -533,7 +535,8 @@ instance Applicative First where ...@@ -533,7 +535,8 @@ instance Applicative First where
pure x = First x pure x = First x
a <* _ = a a <* _ = a
_ *> a = a _ *> a = a
First f <*> First x = First (f x) (<*>) = coerce
liftA2 = coerce
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance Monad First where instance Monad First where
...@@ -583,7 +586,8 @@ instance Applicative Last where ...@@ -583,7 +586,8 @@ instance Applicative Last where
pure = Last pure = Last
a <* _ = a a <* _ = a
_ *> a = a _ *> a = a
Last f <*> Last x = Last (f x) (<*>) = coerce
liftA2 = coerce
-- | @since 4.9.0.0 -- | @since 4.9.0.0
instance Monad Last where instance Monad Last where
...@@ -648,6 +652,7 @@ instance Functor Option where ...@@ -648,6 +652,7 @@ instance Functor Option where
instance Applicative Option where instance Applicative Option where
pure a = Option (Just a) pure a = Option (Just a)
Option a <*> Option b = Option (a <*> b) Option a <*> Option b = Option (a <*> b)
liftA2 f (Option x) (Option y) = Option (liftA2 f x y)
Option Nothing *> _ = Option Nothing Option Nothing *> _ = Option Nothing
_ *> b = b _ *> b = b
......
...@@ -235,7 +235,7 @@ instance Traversable Maybe where ...@@ -235,7 +235,7 @@ instance Traversable Maybe where
instance Traversable [] where instance Traversable [] where
{-# INLINE traverse #-} -- so that traverse can fuse {-# INLINE traverse #-} -- so that traverse can fuse
traverse f = List.foldr cons_f (pure []) 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 -- | @since 4.7.0.0
instance Traversable (Either a) where instance Traversable (Either a) where
......
...@@ -331,6 +331,7 @@ instance Monoid a => Monoid (Maybe a) where ...@@ -331,6 +331,7 @@ instance Monoid a => Monoid (Maybe a) where
instance Monoid a => Applicative ((,) a) where instance Monoid a => Applicative ((,) a) where
pure x = (mempty, x) pure x = (mempty, x)
(u, f) <*> (v, x) = (u `mappend` v, f 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 -- | @since 4.9.0.0
instance Monoid a => Monad ((,) a) where instance Monoid a => Monad ((,) a) where
...@@ -364,10 +365,16 @@ class Functor f where ...@@ -364,10 +365,16 @@ class Functor f where
-- --
-- * embed pure expressions ('pure'), and -- * 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 -- A minimal complete definition must include implementations of 'pure'
-- functions satisfying the following laws: -- 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/] -- [/identity/]
-- --
...@@ -385,17 +392,28 @@ class Functor f where ...@@ -385,17 +392,28 @@ class Functor f where
-- --
-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@ -- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
-- --
--
-- The other methods have the following default definitions, which may -- The other methods have the following default definitions, which may
-- be overridden with equivalent specialized implementations: -- be overridden with equivalent specialized implementations: