Commit e737a512 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

base: MRP-refactoring of AMP instances

This refactors `(>>)`/`(*>)`/`return`/`pure` methods into normal form.

The redundant explicit `return` method definitions are dropped
altogether.

The explicit `(>>) = (*>)` definitions can't be removed yet, as
the default implementation of `(>>)` is still in terms of `(*>)`
(even though that should have been changed according to the AMP but
wasn't -- see note in GHC.Base for details why this had to be postponed)

A nofib comparision shows this refactoring to result in minor runtime
improvements (unless those are within normal measurement fluctuations):

        Program           Size    Allocs   Runtime   Elapsed  TotalMem
  -------------------------------------------------------------------------
            Min          -0.0%     -0.0%     -1.6%     -3.9%     -1.1%
            Max          -0.0%     +0.0%     +0.5%     +0.5%      0.0%
  Geometric Mean         -0.0%     -0.0%     -0.4%     -0.5%     -0.0%

Full `nofib` report at https://phabricator.haskell.org/P68

Reviewers: quchen, alanz, austin, #core_libraries_committee, bgamari

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D1316
parent 4bd58c17
......@@ -96,7 +96,7 @@ instance Monad m => Functor (WrappedMonad m) where
fmap f (WrapMonad v) = WrapMonad (liftM f v)
instance Monad m => Applicative (WrappedMonad m) where
pure = WrapMonad . return
pure = WrapMonad . pure
WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
instance MonadPlus m => Alternative (WrappedMonad m) where
......
......@@ -314,7 +314,6 @@ instance Arrow a => Applicative (ArrowMonad a) where
ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
instance ArrowApply a => Monad (ArrowMonad a) where
return x = ArrowMonad (arr (\_ -> x))
ArrowMonad m >>= f = ArrowMonad $
m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app
......
......@@ -71,13 +71,11 @@ instance Functor (ST s) where
(f r,new_s)
instance Applicative (ST s) where
pure = return
pure a = ST $ \ s -> (a,s)
(<*>) = ap
instance Monad (ST s) where
return a = ST $ \ s -> (a,s)
m >> k = m >>= \ _ -> k
fail s = error s
(ST m) >>= k
......
......@@ -213,5 +213,4 @@ instance Applicative Complex where
f :+ g <*> a :+ b = f a :+ g b
instance Monad Complex where
return a = a :+ a
a :+ b >>= f = realPart (f a) :+ imagPart (f b)
......@@ -134,7 +134,6 @@ instance Applicative (Either e) where
Right f <*> r = fmap f r
instance Monad (Either e) where
return = Right
Left l >>= _ = Left l
Right r >>= k = k r
......
......@@ -88,7 +88,6 @@ instance Applicative Identity where
(<*>) = coerce
instance Monad Identity where
return = Identity
m >>= k = k (runIdentity m)
instance MonadFix Identity where
......
......@@ -189,7 +189,6 @@ instance Applicative NonEmpty where
(<*>) = ap
instance Monad NonEmpty where
return a = a :| []
~(a :| as) >>= f = b :| (bs ++ bs')
where b :| bs = f a
bs' = as >>= toList . f
......
......@@ -82,7 +82,6 @@ instance Applicative Dual where
(<*>) = coerce
instance Monad Dual where
return = Dual
m >>= k = k (getDual m)
-- | The monoid of endomorphisms under composition.
......@@ -126,7 +125,6 @@ instance Applicative Sum where
(<*>) = coerce
instance Monad Sum where
return = Sum
m >>= k = k (getSum m)
-- | Monoid under multiplication.
......@@ -146,7 +144,6 @@ instance Applicative Product where
(<*>) = coerce
instance Monad Product where
return = Product
m >>= k = k (getProduct m)
-- $MaybeExamples
......
......@@ -90,8 +90,6 @@ instance Applicative Proxy where
{-# INLINE (<*>) #-}
instance Monad Proxy where
return _ = Proxy
{-# INLINE return #-}
_ >>= _ = Proxy
{-# INLINE (>>=) #-}
......
......@@ -332,8 +332,7 @@ instance Applicative Min where
Min f <*> Min x = Min (f x)
instance Monad Min where
return = Min
_ >> a = a
(>>) = (*>)
Min a >>= f = f a
instance MonadFix Min where
......@@ -389,8 +388,7 @@ instance Applicative Max where
Max f <*> Max x = Max (f x)
instance Monad Max where
return = Max
_ >> a = a
(>>) = (*>)
Max a >>= f = f a
instance MonadFix Max where
......@@ -476,8 +474,7 @@ instance Applicative First where
First f <*> First x = First (f x)
instance Monad First where
return = First
_ >> a = a
(>>) = (*>)
First a >>= f = f a
instance MonadFix First where
......@@ -523,8 +520,7 @@ instance Applicative Last where
Last f <*> Last x = Last (f x)
instance Monad Last where
return = Last
_ >> a = a
(>>) = (*>)
Last a >>= f = f a
instance MonadFix Last where
......@@ -584,14 +580,13 @@ instance Applicative Option where
pure a = Option (Just a)
Option a <*> Option b = Option (a <*> b)
instance Monad Option where
return = pure
Option Nothing *> _ = Option Nothing
_ *> b = b
instance Monad Option where
Option (Just a) >>= k = k a
_ >>= _ = Option Nothing
Option Nothing >> _ = Option Nothing
_ >> b = b
(>>) = (*>)
instance Alternative Option where
empty = Option Nothing
......
......@@ -196,9 +196,9 @@ instance Traversable Proxy where
{-# INLINE traverse #-}
sequenceA _ = pure Proxy
{-# INLINE sequenceA #-}
mapM _ _ = return Proxy
mapM _ _ = pure Proxy
{-# INLINE mapM #-}
sequence _ = return Proxy
sequence _ = pure Proxy
{-# INLINE sequence #-}
instance Traversable (Const m) where
......
......@@ -36,7 +36,8 @@ module Data.Version (
makeVersion
) where
import Control.Monad ( Monad(..), liftM )
import Data.Functor ( Functor(..) )
import Control.Applicative ( Applicative(..) )
import Data.Bool ( (&&) )
import Data.Char ( isDigit, isAlphaNum )
import Data.Eq
......@@ -120,9 +121,9 @@ showVersion (Version branch tags)
-- | A parser for versions in the format produced by 'showVersion'.
--
parseVersion :: ReadP Version
parseVersion = do branch <- sepBy1 (liftM read (munch1 isDigit)) (char '.')
tags <- many (char '-' >> munch1 isAlphaNum)
return Version{versionBranch=branch, versionTags=tags}
parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.')
tags <- many (char '-' *> munch1 isAlphaNum)
pure Version{versionBranch=branch, versionTags=tags}
-- | Construct tag-less 'Version'
--
......
......@@ -309,7 +309,6 @@ instance Monoid a => Applicative ((,) a) where
(u, f) <*> (v, x) = (u `mappend` v, f x)
instance Monoid a => Monad ((,) a) where
return x = (mempty, x)
(u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b)
instance Monoid a => Monoid (IO a) where
......@@ -626,7 +625,6 @@ instance Applicative ((->) a) where
(<*>) f g x = f x (g x)
instance Monad ((->) r) where
return = const
f >>= k = \ r -> k (f r) r
instance Functor ((,) a) where
......@@ -652,7 +650,6 @@ instance Monad Maybe where
(>>) = (*>)
return = Just
fail _ = Nothing
-- -----------------------------------------------------------------------------
......@@ -735,8 +732,6 @@ instance Monad [] where
xs >>= f = [y | x <- xs, y <- f x]
{-# INLINE (>>) #-}
(>>) = (*>)
{-# INLINE return #-}
return x = [x]
{-# INLINE fail #-}
fail _ = []
......@@ -1063,18 +1058,19 @@ asTypeOf = const
----------------------------------------------
instance Functor IO where
fmap f x = x >>= (return . f)
fmap f x = x >>= (pure . f)
instance Applicative IO where
pure = return
(<*>) = ap
{-# INLINE pure #-}
{-# INLINE (*>) #-}
pure = returnIO
m *> k = m >>= \ _ -> k
(<*>) = ap
instance Monad IO where
{-# INLINE return #-}
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = m >>= \ _ -> k
return = returnIO
(>>) = (*>)
(>>=) = bindIO
fail s = failIO s
......
......@@ -626,19 +626,19 @@ unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
unSTM (STM a) = a
instance Functor STM where
fmap f x = x >>= (return . f)
fmap f x = x >>= (pure . f)
instance Applicative STM where
pure = return
{-# INLINE pure #-}
{-# INLINE (*>) #-}
pure x = returnSTM x
(<*>) = ap
m *> k = thenSTM m k
instance Monad STM where
{-# INLINE return #-}
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = thenSTM m k
return x = returnSTM x
m >>= k = bindSTM m k
(>>) = (*>)
bindSTM :: STM a -> (a -> STM b) -> STM b
bindSTM (STM m) k = STM ( \s ->
......
......@@ -38,11 +38,10 @@ instance Functor NoIO where
fmap f (NoIO a) = NoIO (fmap f a)
instance Applicative NoIO where
pure = return
pure a = NoIO (pure a)
(<*>) = ap
instance Monad NoIO where
return a = NoIO (return a)
(>>=) k f = NoIO (noio k >>= noio . f)
instance GHCiSandboxIO NoIO where
......
......@@ -58,16 +58,15 @@ instance Functor (ST s) where
(# new_s, f r #) }
instance Applicative (ST s) where
pure = return
{-# INLINE pure #-}
{-# INLINE (*>) #-}
pure x = ST (\ s -> (# s, x #))
m *> k = m >>= \ _ -> k
(<*>) = ap
instance Monad (ST s) where
{-# INLINE return #-}
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
return x = ST (\ s -> (# s, x #))
m >> k = m >>= \ _ -> k
(>>) = (*>)
(ST m) >>= k
= ST (\ s ->
case (m s) of { (# new_s, r #) ->
......
......@@ -103,7 +103,7 @@ data P a
-- Monad, MonadPlus
instance Applicative P where
pure = return
pure x = Result x Fail
(<*>) = ap
instance MonadPlus P where
......@@ -111,8 +111,6 @@ instance MonadPlus P where
mplus = (<|>)
instance Monad P where
return x = Result x Fail
(Get f) >>= k = Get (\c -> f c >>= k)
(Look f) >>= k = Look (\s -> f s >>= k)
Fail >>= _ = Fail
......@@ -161,11 +159,10 @@ instance Functor ReadP where
fmap h (R f) = R (\k -> f (k . h))
instance Applicative ReadP where
pure = return
pure x = R (\k -> k x)
(<*>) = ap
instance Monad ReadP where
return x = R (\k -> k x)
fail _ = R (\_ -> Fail)
R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
......
......@@ -75,11 +75,10 @@ instance Functor ReadPrec where
fmap h (P f) = P (\n -> fmap h (f n))
instance Applicative ReadPrec where
pure = return
pure x = P (\_ -> pure x)
(<*>) = ap
instance Monad ReadPrec where
return x = P (\_ -> return x)
fail s = P (\_ -> fail s)
P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)
......
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