Make Applicative a superclass of Monad

Summary:
This includes pretty much all the changes needed to make `Applicative`
a superclass of `Monad` finally. There's mostly reshuffling in the
interests of avoid orphans and boot files, but luckily we can resolve
all of them, pretty much. The only catch was that
Alternative/MonadPlus also had to go into Prelude to avoid this.

As a result, we must update the hsc2hs and haddock submodules.

Signed-off-by: Austin Seipp <austin@well-typed.com>

Test Plan: Build things, they might not explode horribly.

Reviewers: hvr, simonmar

Subscribers: simonmar

Differential Revision: https://phabricator.haskell.org/D13

4 files changed, 69 insertions, 285 deletions

diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs
index 81ce513a58..41049c6a9f 100644
--- a/libraries/base/Control/Applicative.hs
+++ b/libraries/base/Control/Applicative.hs
@@ -48,191 +48,15 @@ module Control.Applicative (
 
 import Prelude hiding (id,(.))
 
+import GHC.Base (liftA, liftA2, liftA3, (<**>))
 import Control.Category
 import Control.Arrow
-import Control.Monad (liftM, ap, MonadPlus(..))
-import Control.Monad.ST.Safe (ST)
-import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)
+import Control.Monad (liftM, ap, MonadPlus(..), Alternative(..))
 import Data.Functor ((<$>), (<$))
-import Data.Monoid (Monoid(..), First(..), Last(..))
-import Data.Proxy
+import Data.Monoid (Monoid(..))
 
-import Text.ParserCombinators.ReadP (ReadP)
-import Text.ParserCombinators.ReadPrec (ReadPrec)
-
-import GHC.Conc (STM, retry, orElse)
 import GHC.Generics
 
-infixl 3 <|>
-infixl 4 <*>, <*, *>, <**>
-
--- | A functor with application, providing operations to
---
--- * embed pure expressions ('pure'), and
---
--- * sequence computations and combine their results ('<*>').
---
--- A minimal complete definition must include implementations of these
--- functions satisfying the following laws:
---
--- [/identity/]
---
---      @'pure' 'id' '<*>' v = v@
---
--- [/composition/]
---
---      @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
---
--- [/homomorphism/]
---
---      @'pure' f '<*>' 'pure' x = 'pure' (f x)@
---
--- [/interchange/]
---
---      @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
---
--- The other methods have the following default definitions, which may
--- be overridden with equivalent specialized implementations:
---
---   * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@
---
---   * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@
---
--- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
---
---   * @'fmap' f x = 'pure' f '<*>' x@
---
--- If @f@ is also a 'Monad', it should satisfy
---
---   * @'pure' = 'return'@
---
---   * @('<*>') = 'ap'@
---
--- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
-
-class Functor f => Applicative f where
-    -- | Lift a value.
-    pure :: a -> f a
-
-    -- | Sequential application.
-    (<*>) :: f (a -> b) -> f a -> f b
-
-    -- | Sequence actions, discarding the value of the first argument.
-    (*>) :: f a -> f b -> f b
-    (*>) = liftA2 (const id)
-
-    -- | Sequence actions, discarding the value of the second argument.
-    (<*) :: f a -> f b -> f a
-    (<*) = liftA2 const
-
--- | A monoid on applicative functors.
---
--- Minimal complete definition: 'empty' and '<|>'.
---
--- If defined, 'some' and 'many' should be the least solutions
--- of the equations:
---
--- * @some v = (:) '<$>' v '<*>' many v@
---
--- * @many v = some v '<|>' 'pure' []@
-class Applicative f => Alternative f where
-    -- | The identity of '<|>'
-    empty :: f a
-    -- | An associative binary operation
-    (<|>) :: f a -> f a -> f a
-
-    -- | One or more.
-    some :: f a -> f [a]
-    some v = some_v
-      where
-        many_v = some_v <|> pure []
-        some_v = (:) <$> v <*> many_v
-
-    -- | Zero or more.
-    many :: f a -> f [a]
-    many v = many_v
-      where
-        many_v = some_v <|> pure []
-        some_v = (:) <$> v <*> many_v
-
--- instances for Prelude types
-
-instance Applicative Maybe where
-    pure = return
-    (<*>) = ap
-
-instance Alternative Maybe where
-    empty = Nothing
-    Nothing <|> r = r
-    l       <|> _ = l
-
-instance Applicative [] where
-    pure = return
-    (<*>) = ap
-
-instance Alternative [] where
-    empty = []
-    (<|>) = (++)
-
-instance Applicative IO where
-    pure = return
-    (<*>) = ap
-
-instance Applicative (ST s) where
-    pure = return
-    (<*>) = ap
-
-instance Applicative (Lazy.ST s) where
-    pure = return
-    (<*>) = ap
-
-instance Applicative STM where
-    pure = return
-    (<*>) = ap
-
-instance Alternative STM where
-    empty = retry
-    (<|>) = orElse
-
-instance Applicative ((->) a) where
-    pure = const
-    (<*>) f g x = f x (g x)
-
-instance Monoid a => Applicative ((,) a) where
-    pure x = (mempty, x)
-    (u, f) <*> (v, x) = (u `mappend` v, f x)
-
-instance Applicative (Either e) where
-    pure          = Right
-    Left  e <*> _ = Left e
-    Right f <*> r = fmap f r
-
-instance Applicative ReadP where
-    pure = return
-    (<*>) = ap
-
-instance Alternative ReadP where
-    empty = mzero
-    (<|>) = mplus
-
-instance Applicative ReadPrec where
-    pure = return
-    (<*>) = ap
-
-instance Alternative ReadPrec where
-    empty = mzero
-    (<|>) = mplus
-
-instance Arrow a => Applicative (ArrowMonad a) where
-   pure x = ArrowMonad (arr (const x))
-   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
-
-instance ArrowPlus a => Alternative (ArrowMonad a) where
-   empty = ArrowMonad zeroArrow
-   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
-
--- new instances
-
 newtype Const a b = Const { getConst :: a }
                   deriving (Generic, Generic1)
 
@@ -281,15 +105,6 @@ instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
     empty = WrapArrow zeroArrow
     WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)
 
--- Added in base-4.8.0.0
-instance Applicative First where
-        pure x = First (Just x)
-        First x <*> First y = First (x <*> y)
-
-instance Applicative Last where
-        pure x = Last (Just x)
-        Last x <*> Last y = Last (x <*> y)
-
 -- | Lists, but with an 'Applicative' functor based on zipping, so that
 --
 -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@
@@ -304,31 +119,8 @@ instance Applicative ZipList where
     pure x = ZipList (repeat x)
     ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
 
-instance Applicative Proxy where
-    pure _ = Proxy
-    {-# INLINE pure #-}
-    _ <*> _ = Proxy
-    {-# INLINE (<*>) #-}
-
 -- extra functions
 
--- | A variant of '<*>' with the arguments reversed.
-(<**>) :: Applicative f => f a -> f (a -> b) -> f b
-(<**>) = liftA2 (flip ($))
-
--- | Lift a function to actions.
--- 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
-
--- | Lift a binary function to actions.
-liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
-liftA2 f a b = 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 = f <$> a <*> b <*> c
-
 -- | One or none.
 optional :: Alternative f => f a -> f (Maybe a)
 optional v = Just <$> v <|> pure Nothing
diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs
index b723dd4722..f6067a01c3 100644
--- a/libraries/base/Control/Arrow.hs
+++ b/libraries/base/Control/Arrow.hs
@@ -304,11 +304,19 @@ newtype ArrowMonad a b = ArrowMonad (a () b)
 instance Arrow a => Functor (ArrowMonad a) where
     fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f
 
+instance Arrow a => Applicative (ArrowMonad a) where
+   pure x = ArrowMonad (arr (const x))
+   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
 
+instance ArrowPlus a => Alternative (ArrowMonad a) where
+   empty = ArrowMonad zeroArrow
+   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
+
 instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where
    mzero = ArrowMonad zeroArrow
    ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y)
diff --git a/libraries/base/Control/Monad.hs b/libraries/base/Control/Monad.hs
index 4a8060f87c..bfadd7ce1a 100644
--- a/libraries/base/Control/Monad.hs
+++ b/libraries/base/Control/Monad.hs
@@ -6,7 +6,7 @@
 -- Module      :  Control.Monad
 -- Copyright   :  (c) The University of Glasgow 2001
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
--- 
+--
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  provisional
 -- Portability :  portable
@@ -20,11 +20,8 @@ module Control.Monad
 
       Functor(fmap)
     , Monad((>>=), (>>), return, fail)
-
-    , MonadPlus (
-          mzero
-        , mplus
-        )
+    , Alternative(empty, (<|>), some, many)
+    , MonadPlus(mzero, mplus)
     -- * Functions
 
     -- ** Naming conventions
@@ -85,6 +82,7 @@ import GHC.List
 import GHC.Base
 
 infixr 1 =<<
+infixl 3 <|>
 
 -- -----------------------------------------------------------------------------
 -- Prelude monad functions
@@ -104,7 +102,7 @@ sequence ms = foldr k (return []) ms
 
 -- | Evaluate each action in the sequence from left to right,
 -- and ignore the results.
-sequence_        :: Monad m => [m a] -> m () 
+sequence_        :: Monad m => [m a] -> m ()
 {-# INLINE sequence_ #-}
 sequence_ ms     =  foldr (>>) (return ()) ms
 
@@ -119,18 +117,64 @@ mapM_           :: Monad m => (a -> m b) -> [a] -> m ()
 mapM_ f as      =  sequence_ (map f as)
 
 -- -----------------------------------------------------------------------------
+-- The Alternative class definition
+
+-- | A monoid on applicative functors.
+--
+-- Minimal complete definition: 'empty' and '<|>'.
+--
+-- If defined, 'some' and 'many' should be the least solutions
+-- of the equations:
+--
+-- * @some v = (:) '<$>' v '<*>' many v@
+--
+-- * @many v = some v '<|>' 'pure' []@
+class Applicative f => Alternative f where
+    -- | The identity of '<|>'
+    empty :: f a
+    -- | An associative binary operation
+    (<|>) :: f a -> f a -> f a
+
+    -- | One or more.
+    some :: f a -> f [a]
+    some v = some_v
+      where
+        many_v = some_v <|> pure []
+        some_v = (fmap (:) v) <*> many_v
+
+    -- | Zero or more.
+    many :: f a -> f [a]
+    many v = many_v
+      where
+        many_v = some_v <|> pure []
+        some_v = (fmap (:) v) <*> many_v
+
+instance Alternative Maybe where
+    empty = Nothing
+    Nothing <|> r = r
+    l       <|> _ = l
+
+instance Alternative [] where
+    empty = []
+    (<|>) = (++)
+
+
+-- -----------------------------------------------------------------------------
 -- The MonadPlus class definition
 
 -- | Monads that also support choice and failure.
-class Monad m => MonadPlus m where
+class (Alternative m, Monad m) => MonadPlus m where
    -- | the identity of 'mplus'.  It should also satisfy the equations
    --
    -- > mzero >>= f  =  mzero
    -- > v >> mzero   =  mzero
    --
-   mzero :: m a 
+   mzero :: m a
+   mzero = empty
+
    -- | an associative operation
    mplus :: m a -> m a -> m a
+   mplus = (<|>)
 
 instance MonadPlus [] where
    mzero = []
@@ -200,12 +244,6 @@ void = fmap (const ())
 -- -----------------------------------------------------------------------------
 -- Other monad functions
 
--- | The 'join' function is the conventional monad join operator. It is used to
--- remove one level of monadic structure, projecting its bound argument into the
--- outer level.
-join              :: (Monad m) => m (m a) -> m a
-join x            =  x >>= id
-
 -- | The 'mapAndUnzipM' function maps its first argument over a list, returning
 -- the result as a pair of lists. This function is mainly used with complicated
 -- data structures or a state-transforming monad.
@@ -293,64 +331,6 @@ unless            :: (Monad m) => Bool -> m () -> m ()
 {-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-}
 unless p s        =  if p then return () else s
 
--- | Promote a function to a monad.
-liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r
-liftM f m1              = do { x1 <- m1; return (f x1) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right.  For example,
---
--- >    liftM2 (+) [0,1] [0,2] = [0,2,1,3]
--- >    liftM2 (+) (Just 1) Nothing = Nothing
---
-liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
-liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM3  :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
-liftM3 f m1 m2 m3       = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM4  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
-liftM4 f m1 m2 m3 m4    = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM5  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
-liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
-
-{-# INLINEABLE liftM #-}
-{-# SPECIALISE liftM :: (a1->r) -> IO a1 -> IO r #-}
-{-# SPECIALISE liftM :: (a1->r) -> Maybe a1 -> Maybe r #-}
-{-# INLINEABLE liftM2 #-}
-{-# SPECIALISE liftM2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}
-{-# SPECIALISE liftM2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-}
-{-# INLINEABLE liftM3 #-}
-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}
-{-# INLINEABLE liftM4 #-}
-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO r #-}
-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe r #-}
-{-# INLINEABLE liftM5 #-}
-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO a5 -> IO r #-}
-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe a5 -> Maybe r #-}
-
-{- | In many situations, the 'liftM' operations can be replaced by uses of
-'ap', which promotes function application. 
-
->       return f `ap` x1 `ap` ... `ap` xn
-
-is equivalent to 
-
->       liftMn f x1 x2 ... xn
-
--}
-
-ap                :: (Monad m) => m (a -> b) -> m a -> m b
-ap                =  liftM2 id
-
 infixl 4 <$!>
 
 -- | Strict version of 'Data.Functor.<$>'.
diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs
index 19e8974807..3fdd541047 100644
--- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs
+++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs
@@ -66,12 +66,16 @@ data State s = S# (State# s)
 
 instance Functor (ST s) where
     fmap f m = ST $ \ s ->
-      let 
+      let
        ST m_a = m
        (r,new_s) = m_a s
       in
       (f r,new_s)
 
+instance Applicative (ST s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (ST s) where
 
         return a = ST $ \ s -> (a,s)