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

2 files changed, 59 insertions, 38 deletions

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.