Commit abba3812 authored by David Feuer's avatar David Feuer Committed by Herbert Valerio Riedel

Improve Applicative definitions

Generally clean up things relating to Applicative and Monad in `GHC.Base`
and `Control.Applicative` to make `Applicative` feel like a bit more of a
first-class citizen rather than just playing second fiddle to `Monad`. Use
`coerce` and GND to improve performance and clarity.

Change the default definition of `(*>)` to use `(<$)`, in case the
`Functor` instance optimizes that.

Moreover, some manually written instances are made into compiler-derived
instances.

Finally, this also adds a few AMP-related laws to the `Applicative` docstring.

NOTE: These changes result in a 13% decrease in allocation for T9020

Reviewed By: ekmett, hvr

Differential Revision: https://phabricator.haskell.org/D432
parent f4ead30b
......@@ -125,6 +125,7 @@ instance Applicative UniqSM where
(USM f) <*> (USM x) = USM $ \us -> case f us of
(# ff, us' #) -> case x us' of
(# xx, us'' #) -> (# ff xx, us'' #)
(*>) = thenUs_
-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
......
......@@ -103,8 +103,9 @@ instance Functor SimplM where
fmap = liftM
instance Applicative SimplM where
pure = return
pure = returnSmpl
(<*>) = ap
(*>) = thenSmpl_
instance Monad SimplM where
(>>) = thenSmpl_
......
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
-----------------------------------------------------------------------------
......@@ -63,7 +65,7 @@ import GHC.Read (Read)
import GHC.Show (Show)
newtype Const a b = Const { getConst :: a }
deriving (Generic, Generic1)
deriving (Generic, Generic1, Monoid)
instance Foldable (Const m) where
foldMap _ _ = mempty
......@@ -71,17 +73,17 @@ instance Foldable (Const m) where
instance Functor (Const m) where
fmap _ (Const v) = Const v
-- Added in base-4.7.0.0
instance Monoid a => Monoid (Const a b) where
mempty = Const mempty
mappend (Const a) (Const b) = Const (mappend a b)
instance Monoid m => Applicative (Const m) where
pure _ = Const mempty
Const f <*> Const v = Const (f `mappend` v)
(<*>) = coerce (mappend :: m -> m -> m)
-- This is pretty much the same as
-- Const f <*> Const v = Const (f `mappend` v)
-- but guarantees that mappend for Const a b will have the same arity
-- as the one for a; it won't create a closure to raise the arity
-- to 2.
newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
deriving (Generic, Generic1)
deriving (Generic, Generic1, Monad)
instance Monad m => Functor (WrappedMonad m) where
fmap f (WrapMonad v) = WrapMonad (liftM f v)
......@@ -90,11 +92,6 @@ instance Monad m => Applicative (WrappedMonad m) where
pure = WrapMonad . return
WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
-- Added in base-4.7.0.0 (GHC Trac #8218)
instance Monad m => Monad (WrappedMonad m) where
return = WrapMonad . return
a >>= f = WrapMonad (unwrapMonad a >>= unwrapMonad . f)
instance MonadPlus m => Alternative (WrappedMonad m) where
empty = WrapMonad mzero
WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)
......@@ -118,10 +115,7 @@ instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@
--
newtype ZipList a = ZipList { getZipList :: [a] }
deriving (Show, Eq, Ord, Read, Generic, Generic1)
instance Functor ZipList where
fmap f (ZipList xs) = ZipList (map f xs)
deriving (Show, Eq, Ord, Read, Functor, Generic, Generic1)
instance Applicative ZipList where
pure x = ZipList (repeat x)
......
......@@ -391,7 +391,9 @@ class Functor f => Applicative f where
-- | Sequence actions, discarding the value of the first argument.
(*>) :: f a -> f b -> f b
(*>) = liftA2 (const id)
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.
-- | Sequence actions, discarding the value of the second argument.
(<*) :: f a -> f b -> f a
......@@ -405,14 +407,28 @@ class Functor f => Applicative f where
-- This function may be used as a value for `fmap` in a `Functor` instance.
liftA :: Applicative f => (a -> b) -> f a -> f b
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
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 = fmap f a <*> b <*> c
{-# INLINEABLE liftA #-}
{-# SPECIALISE liftA :: (a1->r) -> IO a1 -> IO r #-}
{-# SPECIALISE liftA :: (a1->r) -> Maybe a1 -> Maybe r #-}
{-# INLINEABLE liftA2 #-}
{-# SPECIALISE liftA2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}
{-# SPECIALISE liftA2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-}
{-# INLINEABLE liftA3 #-}
{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
{-# SPECIALISE liftA3 :: (a1->a2->a3->r) ->
Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}
-- | The 'join' function is the conventional monad join operator. It
-- is used to remove one level of monadic structure, projecting its
......@@ -429,13 +445,21 @@ monadic expressions.
Instances of 'Monad' should satisfy the following laws:
> return a >>= k == k a
> m >>= return == m
> m >>= (\x -> k x >>= h) == (m >>= k) >>= h
* @'return' a '>>=' k = k a@
* @m '>>=' 'return' = m@
* @m '>>=' (\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@
Furthermore, the 'Monad' and 'Applicative' operations should relate as follows:
* @'pure' = 'return'@
* @('<*>') = 'ap'@
The above laws imply that
Instances of both 'Monad' and 'Functor' should additionally satisfy the law:
* @'fmap' f xs = xs '>>=' 'return' . f@,
* @('>>') = ('*>')
> fmap f xs == xs >>= return . f
and that 'pure' and ('<*>') satisfy the applicative functor laws.
The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
defined in the "Prelude" satisfy these laws.
......@@ -569,7 +593,12 @@ is equivalent to
-}
ap :: (Monad m) => m (a -> b) -> m a -> m b
ap = liftM2 id
ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
-- Since many Applicative instances define (<*>) = ap, we
-- cannot define ap = (<*>)
{-# INLINEABLE ap #-}
{-# SPECIALISE ap :: IO (a -> b) -> IO a -> IO b #-}
{-# SPECIALISE ap :: Maybe (a -> b) -> Maybe a -> Maybe b #-}
-- instances for Prelude types
......@@ -593,15 +622,19 @@ instance Functor Maybe where
fmap f (Just a) = Just (f a)
instance Applicative Maybe where
pure = return
(<*>) = ap
pure = Just
Just f <*> m = fmap f m
Nothing <*> _m = Nothing
Just _m1 *> m2 = m2
Nothing *> _m2 = Nothing
instance Monad Maybe where
(Just x) >>= k = k x
Nothing >>= _ = Nothing
(Just _) >> k = k
Nothing >> _ = Nothing
(>>) = (*>)
return = Just
fail _ = Nothing
......@@ -662,11 +695,7 @@ class (Alternative m, Monad m) => MonadPlus m where
mplus :: m a -> m a -> m a
mplus = (<|>)
instance MonadPlus Maybe where
mzero = Nothing
Nothing `mplus` ys = ys
xs `mplus` _ys = xs
instance MonadPlus Maybe
\end{code}
......@@ -694,9 +723,7 @@ instance Alternative [] where
empty = []
(<|>) = (++)
instance MonadPlus [] where
mzero = []
mplus = (++)
instance MonadPlus []
\end{code}
A few list functions that appear here because they are used here.
......
......@@ -496,10 +496,11 @@ test('T9020',
[(wordsize(32), 343005716, 10),
# Original: 381360728
# 2014-07-31: 343005716 (Windows) (general round of updates)
(wordsize(64), 785871680, 10)])
(wordsize(64), 680162056, 10)])
# prev: 795469104
# 2014-07-17: 728263536 (general round of updates)
# 2014-09-10: 785871680 post-AMP-cleanup
# 2014-11-03: 680162056 Further Applicative and Monad adjustments
],
compile,[''])
......
......@@ -11,18 +11,17 @@ Rule fired: Class op $p1Applicative
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: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)
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 fmap
Rule fired: Class op <$
Rule fired: Class op <*>
Rule fired: Class op $p1Applicative
Rule fired: Class op fmap
......
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