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#")
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")
......
......@@ -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]
-----------------------------------------------------------------------
......
......@@ -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
~~~~~~
......
......@@ -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
......
......@@ -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' #-}
......
......@@ -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
......
......@@ -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
......
{-# 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
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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:
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
{-# 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