From db60084d738621b13835af2444bdf8c50013bf65 Mon Sep 17 00:00:00 2001
From: Herbert Valerio Riedel <hvr@gnu.org>
Date: Thu, 8 Oct 2015 16:34:17 +0200
Subject: base: MRP-refactoring of AMP instances

Summary:
This refactors (>>)/(*>)/return/pure methods into normalform.

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

This results in measurable runtime improvements in nofib of up
to -20% runtime (geometric mean: -7%) in my measurements.

Reviewers: quchen, austin, alanz, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1316
---
 libraries/base/Control/Applicative.hs             |  2 +-
 libraries/base/Control/Arrow.hs                   |  1 -
 libraries/base/Control/Monad/ST/Lazy/Imp.hs       |  4 +---
 libraries/base/Data/Complex.hs                    |  1 -
 libraries/base/Data/Either.hs                     |  1 -
 libraries/base/Data/Functor/Identity.hs           |  1 -
 libraries/base/Data/List/NonEmpty.hs              |  1 -
 libraries/base/Data/Monoid.hs                     |  3 ---
 libraries/base/Data/Proxy.hs                      |  2 --
 libraries/base/Data/Semigroup.hs                  | 21 ++++++++-------------
 libraries/base/Data/Traversable.hs                |  4 ++--
 libraries/base/Data/Version.hs                    |  9 +++++----
 libraries/base/GHC/Base.hs                        | 18 +++++++-----------
 libraries/base/GHC/Conc/Sync.hs                   | 12 ++++++------
 libraries/base/GHC/GHCi.hs                        |  3 +--
 libraries/base/GHC/ST.hs                          | 11 +++++------
 libraries/base/Text/ParserCombinators/ReadP.hs    |  7 ++-----
 libraries/base/Text/ParserCombinators/ReadPrec.hs |  3 +--
 18 files changed, 39 insertions(+), 65 deletions(-)

diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs
index a2f342f83f..6770234926 100644
--- a/libraries/base/Control/Applicative.hs
+++ b/libraries/base/Control/Applicative.hs
@@ -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
diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs
index 9d09544eeb..c9281569f9 100644
--- a/libraries/base/Control/Arrow.hs
+++ b/libraries/base/Control/Arrow.hs
@@ -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
 
diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs
index 55b28cfc9a..c99912e62d 100644
--- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs
+++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs
@@ -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
diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs
index 09314f163e..31550d5ac7 100644
--- a/libraries/base/Data/Complex.hs
+++ b/libraries/base/Data/Complex.hs
@@ -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)
diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs
index d727e5219d..50e95824c8 100644
--- a/libraries/base/Data/Either.hs
+++ b/libraries/base/Data/Either.hs
@@ -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
 
diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs
index 9f7ae24e66..46fb66650c 100644
--- a/libraries/base/Data/Functor/Identity.hs
+++ b/libraries/base/Data/Functor/Identity.hs
@@ -88,7 +88,6 @@ instance Applicative Identity where
     (<*>)    = coerce
 
 instance Monad Identity where
-    return   = Identity
     m >>= k  = k (runIdentity m)
 
 instance MonadFix Identity where
diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs
index 6698a0ba58..d8bad07c7b 100644
--- a/libraries/base/Data/List/NonEmpty.hs
+++ b/libraries/base/Data/List/NonEmpty.hs
@@ -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
diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs
index c5a4d8bdf9..eff3836396 100644
--- a/libraries/base/Data/Monoid.hs
+++ b/libraries/base/Data/Monoid.hs
@@ -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
diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs
index a9146214c0..2dad8e4e78 100644
--- a/libraries/base/Data/Proxy.hs
+++ b/libraries/base/Data/Proxy.hs
@@ -90,8 +90,6 @@ instance Applicative Proxy where
     {-# INLINE (<*>) #-}
 
 instance Monad Proxy where
-    return _ = Proxy
-    {-# INLINE return #-}
     _ >>= _ = Proxy
     {-# INLINE (>>=) #-}
 
diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs
index 661e513cba..f3f9f0b326 100644
--- a/libraries/base/Data/Semigroup.hs
+++ b/libraries/base/Data/Semigroup.hs
@@ -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
diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs
index 81e639cf37..9da76c6a34 100644
--- a/libraries/base/Data/Traversable.hs
+++ b/libraries/base/Data/Traversable.hs
@@ -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
diff --git a/libraries/base/Data/Version.hs b/libraries/base/Data/Version.hs
index aba8cf7f74..414b2aa859 100644
--- a/libraries/base/Data/Version.hs
+++ b/libraries/base/Data/Version.hs
@@ -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'
 --
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index 9bd6124e6a..273950b1fb 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -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
 
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index db6f841851..83934fe05a 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -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 ->
diff --git a/libraries/base/GHC/GHCi.hs b/libraries/base/GHC/GHCi.hs
index c11863520c..56874a5a12 100644
--- a/libraries/base/GHC/GHCi.hs
+++ b/libraries/base/GHC/GHCi.hs
@@ -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
diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs
index d5320522a5..46c5196c9e 100644
--- a/libraries/base/GHC/ST.hs
+++ b/libraries/base/GHC/ST.hs
@@ -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 #) ->
diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs
index 034411d6bf..bae2abc90e 100644
--- a/libraries/base/Text/ParserCombinators/ReadP.hs
+++ b/libraries/base/Text/ParserCombinators/ReadP.hs
@@ -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))
 
diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs
index 027648d9e8..02268364ca 100644
--- a/libraries/base/Text/ParserCombinators/ReadPrec.hs
+++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs
@@ -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)
 
-- 
cgit v1.2.1