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

6 files changed, 67 insertions, 44 deletions

diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs
index 401d69b0f4..d1a1efd298 100644
--- a/compiler/basicTypes/UniqSupply.lhs
+++ b/compiler/basicTypes/UniqSupply.lhs
@@ -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)
diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index e5561b2fc0..ca14688583 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -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_
diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs
index d6157b3d69..cc87343fc2 100644
--- a/libraries/base/Control/Applicative.hs
+++ b/libraries/base/Control/Applicative.hs
@@ -1,6 +1,8 @@
 {-# 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)
diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs
index d99ad01e27..495a6b25b8 100644
--- a/libraries/base/GHC/Base.lhs
+++ b/libraries/base/GHC/Base.lhs
@@ -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.
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 368753a437..f6f52d737d 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -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,[''])
 
diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr
index dad6b17652..6dcc1bb425 100644
--- a/testsuite/tests/simplCore/should_compile/T8848.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8848.stderr
@@ -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