Make Applicative a superclass of Monadwip/amp

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

24 files changed, 382 insertions, 355 deletions

diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs
index d9e1762a2f..e1bba86382 100644
--- a/compiler/utils/Maybes.lhs
+++ b/compiler/utils/Maybes.lhs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 %
 % (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -17,7 +18,9 @@ module Maybes (
 
         MaybeT(..)
     ) where
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative
+#endif
 import Control.Monad
 import Data.Maybe
 
diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs
index 47cdee0789..2353a8177d 100644
--- a/compiler/utils/Stream.hs
+++ b/compiler/utils/Stream.hs
@@ -12,7 +12,10 @@ module Stream (
     Stream.map, Stream.mapM, Stream.mapAccumL
   ) where
 import Control.Monad
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative
+#endif
+
 
 -- |
 -- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence
diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs
index 4e77479e15..0e31c8e954 100644
--- a/libraries/base/Control/Applicative.hs
+++ b/libraries/base/Control/Applicative.hs
@@ -48,191 +48,14 @@ 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(..))
-import Data.Proxy
-
-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)
 
@@ -295,31 +118,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 19c9a87bde..1f00b1994a 100644
--- a/libraries/base/Control/Monad.hs
+++ b/libraries/base/Control/Monad.hs
@@ -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
@@ -82,6 +79,7 @@ import GHC.List
 import GHC.Base
 
 infixr 1 =<<
+infixl 3 <|>
 
 -- -----------------------------------------------------------------------------
 -- Prelude monad functions
@@ -101,7 +99,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
 
@@ -116,18 +114,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 = []
@@ -197,12 +241,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.
diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs
index 19e8974807..d6ce22aad5 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
+    (<*>) = liftA2 id
+
 instance Monad (ST s) where
 
         return a = ST $ \ s -> (a,s)
diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs
index cf45e79456..5b3b5e2e70 100644
--- a/libraries/base/Data/Either.hs
+++ b/libraries/base/Data/Either.hs
@@ -56,6 +56,11 @@ instance Functor (Either a) where
     fmap _ (Left x) = Left x
     fmap f (Right y) = Right (f y)
 
+instance Applicative (Either e) where
+    pure          = Right
+    Left  e <*> _ = Left e
+    Right f <*> r = fmap f r
+
 instance Monad (Either e) where
     return = Right
     Left  l >>= _ = Left l
diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs
index fe2a0abc1e..991a25cb12 100644
--- a/libraries/base/Data/Maybe.hs
+++ b/libraries/base/Data/Maybe.hs
@@ -49,10 +49,26 @@ import GHC.Base
 data  Maybe a  =  Nothing | Just a
   deriving (Eq, Ord)
 
+-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
+-- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
+-- turned into a monoid simply by adjoining an element @e@ not in @S@
+-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since
+-- there is no \"Semigroup\" typeclass providing just 'mappend', we
+-- use 'Monoid' instead.
+instance Monoid a => Monoid (Maybe a) where
+  mempty = Nothing
+  Nothing `mappend` m = m
+  m `mappend` Nothing = m
+  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
+
 instance  Functor Maybe  where
     fmap _ Nothing       = Nothing
     fmap f (Just a)      = Just (f a)
 
+instance Applicative Maybe where
+    pure = return
+    (<*>) = liftA2 id
+
 instance  Monad Maybe  where
     (Just x) >>= k      = k x
     Nothing  >>= _      = Nothing
diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs
index b71176b19c..4bd1839559 100644
--- a/libraries/base/Data/Monoid.hs
+++ b/libraries/base/Data/Monoid.hs
@@ -46,7 +46,6 @@ import GHC.Read
 import GHC.Show
 import GHC.Generics
 import Data.Maybe
-import Data.Proxy
 
 {-
 -- just for testing
@@ -54,42 +53,6 @@ import Data.Maybe
 import Test.QuickCheck
 -- -}
 
--- ---------------------------------------------------------------------------
--- | The class of monoids (types with an associative binary operation that
--- has an identity).  Instances should satisfy the following laws:
---
---  * @mappend mempty x = x@
---
---  * @mappend x mempty = x@
---
---  * @mappend x (mappend y z) = mappend (mappend x y) z@
---
---  * @mconcat = 'foldr' mappend mempty@
---
--- The method names refer to the monoid of lists under concatenation,
--- but there are many other instances.
---
--- Minimal complete definition: 'mempty' and 'mappend'.
---
--- Some types can be viewed as a monoid in more than one way,
--- e.g. both addition and multiplication on numbers.
--- In such cases we often define @newtype@s and make those instances
--- of 'Monoid', e.g. 'Sum' and 'Product'.
-
-class Monoid a where
-        mempty  :: a
-        -- ^ Identity of 'mappend'
-        mappend :: a -> a -> a
-        -- ^ An associative operation
-        mconcat :: [a] -> a
-
-        -- ^ Fold a list using the monoid.
-        -- For most types, the default definition for 'mconcat' will be
-        -- used, but the function is included in the class definition so
-        -- that an optimized version can be provided for specific types.
-
-        mconcat = foldr mappend mempty
-
 infixr 6 <>
 
 -- | An infix synonym for 'mappend'.
@@ -101,55 +64,6 @@ infixr 6 <>
 
 -- Monoid instances.
 
-instance Monoid [a] where
-        mempty  = []
-        mappend = (++)
-
-instance Monoid b => Monoid (a -> b) where
-        mempty _ = mempty
-        mappend f g x = f x `mappend` g x
-
-instance Monoid () where
-        -- Should it be strict?
-        mempty        = ()
-        _ `mappend` _ = ()
-        mconcat _     = ()
-
-instance (Monoid a, Monoid b) => Monoid (a,b) where
-        mempty = (mempty, mempty)
-        (a1,b1) `mappend` (a2,b2) =
-                (a1 `mappend` a2, b1 `mappend` b2)
-
-instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
-        mempty = (mempty, mempty, mempty)
-        (a1,b1,c1) `mappend` (a2,b2,c2) =
-                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
-
-instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
-        mempty = (mempty, mempty, mempty, mempty)
-        (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
-                (a1 `mappend` a2, b1 `mappend` b2,
-                 c1 `mappend` c2, d1 `mappend` d2)
-
-instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
-                Monoid (a,b,c,d,e) where
-        mempty = (mempty, mempty, mempty, mempty, mempty)
-        (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
-                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
-                 d1 `mappend` d2, e1 `mappend` e2)
-
--- lexicographical ordering
-instance Monoid Ordering where
-        mempty         = EQ
-        LT `mappend` _ = LT
-        EQ `mappend` y = y
-        GT `mappend` _ = GT
-
-instance Monoid (Proxy s) where
-    mempty = Proxy
-    mappend _ _ = Proxy
-    mconcat _ = Proxy
-
 -- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.
 newtype Dual a = Dual { getDual :: a }
         deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)
@@ -229,18 +143,6 @@ instance Num a => Monoid (Product a) where
 --      Just (combine key value oldValue))
 -- @
 
--- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
--- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
--- turned into a monoid simply by adjoining an element @e@ not in @S@
--- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since
--- there is no \"Semigroup\" typeclass providing just 'mappend', we
--- use 'Monoid' instead.
-instance Monoid a => Monoid (Maybe a) where
-  mempty = Nothing
-  Nothing `mappend` m = m
-  m `mappend` Nothing = m
-  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
-
 
 -- | Maybe monoid returning the leftmost non-Nothing value.
 newtype First a = First { getFirst :: Maybe a }
@@ -251,6 +153,7 @@ instance Monoid (First a) where
         r@(First (Just _)) `mappend` _ = r
         First Nothing `mappend` r = r
 
+
 -- | Maybe monoid returning the rightmost non-Nothing value.
 newtype Last a = Last { getLast :: Maybe a }
         deriving (Eq, Ord, Read, Show, Generic, Generic1)
diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs
index ab89066cfa..38a43b0b0f 100644
--- a/libraries/base/Data/Proxy.hs
+++ b/libraries/base/Data/Proxy.hs
@@ -69,10 +69,21 @@ instance Bounded (Proxy s) where
     minBound = Proxy
     maxBound = Proxy
 
+instance Monoid (Proxy s) where
+    mempty = Proxy
+    mappend _ _ = Proxy
+    mconcat _ = Proxy
+
 instance Functor Proxy where
     fmap _ _ = Proxy
     {-# INLINE fmap #-}
 
+instance Applicative Proxy where
+    pure _ = Proxy
+    {-# INLINE pure #-}
+    _ <*> _ = Proxy
+    {-# INLINE (<*>) #-}
+
 instance Monad Proxy where
     return _ = Proxy
     {-# INLINE return #-}
diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs
index 1c8e144b7f..6d0c4b12d5 100644
--- a/libraries/base/GHC/Base.lhs
+++ b/libraries/base/GHC/Base.lhs
@@ -129,6 +129,8 @@ infixl 4  <$
 infixl 1  >>, >>=
 infixr 0  $
 
+infixl 4 <*>, <*, *>, <**>
+
 default ()              -- Double isn't available yet
 \end{code}
 
@@ -159,10 +161,102 @@ foldr = error "urk"
 -}
 \end{code}
 
+%*********************************************************
+%*                                                      *
+\subsection{Monoids}
+%*                                                      *
+%*********************************************************
+\begin{code}
+
+-- ---------------------------------------------------------------------------
+-- | The class of monoids (types with an associative binary operation that
+-- has an identity).  Instances should satisfy the following laws:
+--
+--  * @mappend mempty x = x@
+--
+--  * @mappend x mempty = x@
+--
+--  * @mappend x (mappend y z) = mappend (mappend x y) z@
+--
+--  * @mconcat = 'foldr' mappend mempty@
+--
+-- The method names refer to the monoid of lists under concatenation,
+-- but there are many other instances.
+--
+-- Minimal complete definition: 'mempty' and 'mappend'.
+--
+-- Some types can be viewed as a monoid in more than one way,
+-- e.g. both addition and multiplication on numbers.
+-- In such cases we often define @newtype@s and make those instances
+-- of 'Monoid', e.g. 'Sum' and 'Product'.
+
+class Monoid a where
+        mempty  :: a
+        -- ^ Identity of 'mappend'
+        mappend :: a -> a -> a
+        -- ^ An associative operation
+        mconcat :: [a] -> a
+
+        -- ^ Fold a list using the monoid.
+        -- For most types, the default definition for 'mconcat' will be
+        -- used, but the function is included in the class definition so
+        -- that an optimized version can be provided for specific types.
+
+        mconcat = foldr mappend mempty
+
+instance Monoid [a] where
+        mempty  = []
+        mappend = (++)
+
+instance Monoid b => Monoid (a -> b) where
+        mempty _ = mempty
+        mappend f g x = f x `mappend` g x
+
+instance Monoid () where
+        -- Should it be strict?
+        mempty        = ()
+        _ `mappend` _ = ()
+        mconcat _     = ()
+
+instance (Monoid a, Monoid b) => Monoid (a,b) where
+        mempty = (mempty, mempty)
+        (a1,b1) `mappend` (a2,b2) =
+                (a1 `mappend` a2, b1 `mappend` b2)
+
+instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
+        mempty = (mempty, mempty, mempty)
+        (a1,b1,c1) `mappend` (a2,b2,c2) =
+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
+        mempty = (mempty, mempty, mempty, mempty)
+        (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
+                (a1 `mappend` a2, b1 `mappend` b2,
+                 c1 `mappend` c2, d1 `mappend` d2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
+                Monoid (a,b,c,d,e) where
+        mempty = (mempty, mempty, mempty, mempty, mempty)
+        (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
+                 d1 `mappend` d2, e1 `mappend` e2)
+
+-- lexicographical ordering
+instance Monoid Ordering where
+        mempty         = EQ
+        LT `mappend` _ = LT
+        EQ `mappend` y = y
+        GT `mappend` _ = GT
+
+instance Monoid a => Applicative ((,) a) where
+    pure x = (mempty, x)
+    (u, f) <*> (v, x) = (u `mappend` v, f x)
+\end{code}
+
 
 %*********************************************************
 %*                                                      *
-\subsection{Monadic classes @Functor@, @Monad@ }
+\subsection{Monadic classes @Functor@, @Applicative@, @Monad@ }
 %*                                                      *
 %*********************************************************
 
@@ -186,6 +280,82 @@ class  Functor f  where
     (<$)        :: a -> f b -> f a
     (<$)        =  fmap . const
 
+-- | 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 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 = (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
+
 {- | The 'Monad' class defines the basic operations over a /monad/,
 a concept from a branch of mathematics known as /category theory/.
 From the perspective of a Haskell programmer, however, it is best to
@@ -209,37 +379,52 @@ The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
 defined in the "Prelude" satisfy these laws.
 -}
 
-class  Monad m  where
+class Applicative m => Monad m  where
     -- | Sequentially compose two actions, passing any value produced
     -- by the first as an argument to the second.
     (>>=)       :: forall a b. m a -> (a -> m b) -> m b
+    m >>= f = join (fmap f m)
+
     -- | Sequentially compose two actions, discarding any value produced
     -- by the first, like sequencing operators (such as the semicolon)
     -- in imperative languages.
     (>>)        :: forall a b. m a -> m b -> m b
+    (>>) = (*>)
+    {-# INLINE (>>) #-}
+
+    join :: m (m a) -> m a
+    join m = m >>= id
+
         -- Explicit for-alls so that we know what order to
         -- give type arguments when desugaring
 
     -- | Inject a value into the monadic type.
     return      :: a -> m a
+    return = pure
+
     -- | Fail with a message.  This operation is not part of the
     -- mathematical definition of a monad, but is invoked on pattern-match
     -- failure in a @do@ expression.
     fail        :: String -> m a
-
-    {-# INLINE (>>) #-}
-    m >> k      = m >>= \_ -> k
     fail s      = error s
 
+
+-- instances for Prelude types
+
 instance Functor ((->) r) where
     fmap = (.)
 
+instance Applicative ((->) a) where
+    pure = const
+    (<*>) f g x = f x (g x)
+
 instance Monad ((->) r) where
     return = const
     f >>= k = \ r -> k (f r) r
 
 instance Functor ((,) a) where
     fmap f (x,y) = (x, f y)
+
 \end{code}
 
 
@@ -253,6 +438,10 @@ instance Functor ((,) a) where
 instance Functor [] where
     fmap = map
 
+instance Applicative [] where
+    pure = return
+    (<*>) = liftA2 id
+
 instance  Monad []  where
     m >>= k             = foldr ((++) . k) [] m
     m >> k              = foldr ((++) . (\ _ -> k)) [] m
@@ -601,6 +790,10 @@ asTypeOf                =  const
 instance  Functor IO where
    fmap f x = x >>= (return . f)
 
+instance Applicative IO where
+    pure = return
+    (<*>) = liftA2 id
+
 instance  Monad IO  where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
diff --git a/libraries/base/GHC/Conc/Sync.lhs b/libraries/base/GHC/Conc/Sync.lhs
index ebb7226d09..6a14b4d6af 100644
--- a/libraries/base/GHC/Conc/Sync.lhs
+++ b/libraries/base/GHC/Conc/Sync.lhs
@@ -548,6 +548,10 @@ unSTM (STM a) = a
 instance  Functor STM where
    fmap f x = x >>= (return . f)
 
+instance Applicative STM where
+  pure = return
+  (<*>) = liftA2 id
+
 instance  Monad STM  where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
@@ -571,9 +575,13 @@ thenSTM (STM m) k = STM ( \s ->
 returnSTM :: a -> STM a
 returnSTM x = STM (\s -> (# s, x #))
 
+instance Alternative STM where
+  empty = retry
+  (<|>) = orElse
+
 instance MonadPlus STM where
-  mzero = retry
-  mplus = orElse
+  mzero = empty
+  mplus = (<|>)
 
 -- | Unsafely performs IO in the STM monad.  Beware: this is a highly
 -- dangerous thing to do.
diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs
index 30dbd77f5b..3626387669 100644
--- a/libraries/base/GHC/Event/Array.hs
+++ b/libraries/base/GHC/Event/Array.hs
@@ -24,7 +24,7 @@ module GHC.Event.Array
     , useAsPtr
     ) where
 
-import Control.Monad hiding (forM_)
+import Control.Monad hiding (forM_, empty)
 import Data.Bits ((.|.), shiftR)
 import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
 import Data.Maybe
diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc
index b808b21e96..298f450096 100644
--- a/libraries/base/GHC/Event/EPoll.hsc
+++ b/libraries/base/GHC/Event/EPoll.hsc
@@ -41,7 +41,6 @@ available = False
 import Control.Monad (when)
 import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
 import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
 import Data.Word (Word32)
 import Foreign.C.Error (eNOENT, getErrno, throwErrno,
                         throwErrnoIfMinus1, throwErrnoIfMinus1_)
diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs
index a4c2e10d32..fcd7886a20 100644
--- a/libraries/base/GHC/Event/Internal.hs
+++ b/libraries/base/GHC/Event/Internal.hs
@@ -25,7 +25,6 @@ module GHC.Event.Internal
 import Data.Bits ((.|.), (.&.))
 import Data.List (foldl', intercalate)
 import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
 import Foreign.C.Error (eINTR, getErrno, throwErrno)
 import System.Posix.Types (Fd)
 import GHC.Base
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index d55d5b1193..53788137ac 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -56,7 +56,6 @@ import Data.Bits ((.&.))
 import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                    writeIORef)
 import Data.Maybe (Maybe(..), maybe)
-import Data.Monoid (mappend, mconcat, mempty)
 import GHC.Arr (Array, (!), listArray)
 import GHC.Base
 import GHC.Conc.Signal (runHandlers)
diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc
index bb0b6e570b..4a27fcc3f4 100644
--- a/libraries/base/GHC/Event/Poll.hsc
+++ b/libraries/base/GHC/Event/Poll.hsc
@@ -28,7 +28,6 @@ import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
 import Control.Monad ((=<<), liftM, liftM2, unless)
 import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
 import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
 import Data.Word
 import Foreign.C.Types (CInt(..), CShort(..))
 import Foreign.Ptr (Ptr)
diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs
index f94f06148a..a3734fc473 100644
--- a/libraries/base/GHC/Event/TimerManager.hs
+++ b/libraries/base/GHC/Event/TimerManager.hs
@@ -42,7 +42,6 @@ import Control.Monad ((=<<), liftM, sequence_, when)
 import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                    writeIORef)
 import Data.Maybe (Maybe(..))
-import Data.Monoid (mempty)
 import GHC.Base
 import GHC.Conc.Signal (runHandlers)
 import GHC.Num (Num(..))
diff --git a/libraries/base/GHC/GHCi.hs b/libraries/base/GHC/GHCi.hs
index f66d540574..8436837c88 100644
--- a/libraries/base/GHC/GHCi.hs
+++ b/libraries/base/GHC/GHCi.hs
@@ -21,7 +21,7 @@ module GHC.GHCi {-# WARNING "This is an unstable interface." #-} (
         GHCiSandboxIO(..), NoIO()
     ) where
 
-import GHC.Base (IO(), Monad, (>>=), return, id, (.))
+import GHC.Base (IO(), Monad, Functor(fmap), Applicative(..), (>>=), liftA2, return, id, (.))
 
 -- | A monad that can execute GHCi statements by lifting them out of
 -- m into the IO monad. (e.g state monads)
@@ -34,6 +34,13 @@ instance GHCiSandboxIO IO where
 -- | A monad that doesn't allow any IO.
 newtype NoIO a = NoIO { noio :: IO a }
 
+instance Functor NoIO where
+  fmap f (NoIO a) = NoIO (fmap f a)
+
+instance Applicative NoIO where
+  pure  = return
+  (<*>) = liftA2 id
+
 instance Monad NoIO where
     return a  = NoIO (return a)
     (>>=) k f = NoIO (noio k >>= noio . f)
diff --git a/libraries/base/GHC/ST.lhs b/libraries/base/GHC/ST.lhs
index 5da8b0afed..8c7b4a6eee 100644
--- a/libraries/base/GHC/ST.lhs
+++ b/libraries/base/GHC/ST.lhs
@@ -65,6 +65,10 @@ instance Functor (ST s) where
       case (m s) of { (# new_s, r #) ->
       (# new_s, f r #) }
 
+instance Applicative (ST s) where
+    pure = return
+    (<*>) = liftA2 id
+
 instance Monad (ST s) where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs
index 6be784603c..4a7cda8a7f 100644
--- a/libraries/base/Prelude.hs
+++ b/libraries/base/Prelude.hs
@@ -67,8 +67,9 @@ module Prelude (
     fromIntegral, realToFrac,
 
     -- ** Monads and functors
-    Monad((>>=), (>>), return, fail),
     Functor(fmap),
+    Applicative(pure, (<*>), (*>), (<*)),
+    Monad((>>=), (>>), return, fail),
     mapM, mapM_, sequence, sequence_, (=<<),
 
     -- ** Miscellaneous functions
diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs
index a0e6e22062..e42e882bff 100644
--- a/libraries/base/Text/ParserCombinators/ReadP.hs
+++ b/libraries/base/Text/ParserCombinators/ReadP.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -60,18 +61,18 @@ module Text.ParserCombinators.ReadP
   chainl1,
   chainr1,
   manyTill,
-  
+
   -- * Running a parser
   ReadS,
   readP_to_S,
   readS_to_P,
-  
+
   -- * Properties
   -- $properties
   )
  where
 
-import Control.Monad( MonadPlus(..), sequence, liftM2 )
+import Control.Monad ( Alternative(empty, (<|>)), MonadPlus(..), sequence, liftM2 )
 
 import {-# SOURCE #-} GHC.Unicode ( isSpace  )
 import GHC.List ( replicate, null )
@@ -99,9 +100,14 @@ data P a
   | Fail
   | Result a (P a)
   | Final [(a,String)] -- invariant: list is non-empty!
+  deriving Functor
 
 -- Monad, MonadPlus
 
+instance Applicative P where
+  pure  = return
+  (<*>) = liftA2 id
+
 instance Monad P where
   return x = Result x Fail
 
@@ -113,34 +119,39 @@ instance Monad P where
 
   fail _ = Fail
 
-instance MonadPlus P where
-  mzero = Fail
+
+instance Alternative P where
+  empty = Fail
 
   -- most common case: two gets are combined
-  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)
-  
+  Get f1     <|> Get f2     = Get (\c -> f1 c `mplus` f2 c)
+
   -- results are delivered as soon as possible
-  Result x p `mplus` q          = Result x (p `mplus` q)
-  p          `mplus` Result x q = Result x (p `mplus` q)
+  Result x p <|> q          = Result x (p `mplus` q)
+  p          <|> Result x q = Result x (p `mplus` q)
 
   -- fail disappears
-  Fail       `mplus` p          = p
-  p          `mplus` Fail       = p
+  Fail       <|> p          = p
+  p          <|> Fail       = p
 
   -- two finals are combined
   -- final + look becomes one look and one final (=optimization)
   -- final + sthg else becomes one look and one final
-  Final r    `mplus` Final t    = Final (r ++ t)
-  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))
-  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))
-  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))
-  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))
+  Final r    <|> Final t    = Final (r ++ t)
+  Final r    <|> Look f     = Look (\s -> Final (r ++ run (f s) s))
+  Final r    <|> p          = Look (\s -> Final (r ++ run p s))
+  Look f     <|> Final r    = Look (\s -> Final (run (f s) s ++ r))
+  p          <|> Final r    = Look (\s -> Final (run p s ++ r))
 
   -- two looks are combined (=optimization)
   -- look + sthg else floats upwards
-  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)
-  Look f     `mplus` p          = Look (\s -> f s `mplus` p)
-  p          `mplus` Look f     = Look (\s -> p `mplus` f s)
+  Look f     <|> Look g     = Look (\s -> f s <|> g s)
+  Look f     <|> p          = Look (\s -> f s <|> p)
+  p          <|> Look f     = Look (\s -> p <|> f s)
+
+instance MonadPlus P where
+  mzero = empty
+  mplus = (<|>)
 
 -- ---------------------------------------------------------------------------
 -- The ReadP type
@@ -152,11 +163,19 @@ newtype ReadP a = R (forall b . (a -> P b) -> P b)
 instance Functor ReadP where
   fmap h (R f) = R (\k -> f (k . h))
 
+instance Applicative ReadP where
+    pure = return
+    (<*>) = liftA2 id
+
 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))
 
+instance Alternative ReadP where
+    empty = mzero
+    (<|>) = mplus
+
 instance MonadPlus ReadP where
   mzero = pfail
   mplus = (+++)
diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs
index 235436c4d6..1d109b59bc 100644
--- a/libraries/base/Text/ParserCombinators/ReadPrec.hs
+++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs
@@ -16,9 +16,9 @@
 -----------------------------------------------------------------------------
 
 module Text.ParserCombinators.ReadPrec
-  ( 
+  (
   ReadPrec,
-  
+
   -- * Precedences
   Prec,
   minPrec,
@@ -61,7 +61,7 @@ import qualified Text.ParserCombinators.ReadP as ReadP
   , pfail
   )
 
-import Control.Monad( MonadPlus(..) )
+import Control.Monad( MonadPlus(..), Alternative(..) )
 import GHC.Num( Num(..) )
 import GHC.Base
 
@@ -75,17 +75,24 @@ newtype ReadPrec a = P (Prec -> ReadP a)
 instance Functor ReadPrec where
   fmap h (P f) = P (\n -> fmap h (f n))
 
+instance Applicative ReadPrec where
+    pure = return
+    (<*>) = liftA2 id
+
 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)
-  
+
+instance Alternative ReadPrec where
+    empty = mzero
+    (<|>) = mplus
+
 instance MonadPlus ReadPrec where
   mzero = pfail
   mplus = (+++)
 
 -- precedences
-  
 type Prec = Int
 
 minPrec :: Prec
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 589c66a530..76318cc14f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -19,7 +19,9 @@ module Language.Haskell.TH.Syntax where
 import GHC.Exts
 import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex)
 import qualified Data.Data as Data
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative( Applicative(..) )
+#endif
 import Data.IORef
 import System.IO.Unsafe	( unsafePerformIO )
 import Control.Monad (liftM)