From 88c9403264950326e39a05f262bbbb069cf12977 Mon Sep 17 00:00:00 2001 From: Austin Seipp Date: Tue, 22 Apr 2014 06:09:40 -0500 Subject: Make Applicative a superclass of Monad Signed-off-by: Austin Seipp --- compiler/utils/Maybes.lhs | 3 + compiler/utils/Stream.hs | 3 + libraries/base/Control/Applicative.hs | 204 +-------------------- libraries/base/Control/Arrow.hs | 8 + libraries/base/Control/Monad.hs | 66 +++++-- libraries/base/Control/Monad/ST/Lazy/Imp.hs | 6 +- libraries/base/Data/Either.hs | 5 + libraries/base/Data/Maybe.hs | 16 ++ libraries/base/Data/Monoid.hs | 99 +--------- libraries/base/Data/Proxy.hs | 11 ++ libraries/base/GHC/Base.lhs | 203 +++++++++++++++++++- libraries/base/GHC/Conc/Sync.lhs | 12 +- libraries/base/GHC/Event/Array.hs | 2 +- libraries/base/GHC/Event/EPoll.hsc | 1 - libraries/base/GHC/Event/Internal.hs | 1 - libraries/base/GHC/Event/Manager.hs | 1 - libraries/base/GHC/Event/Poll.hsc | 1 - libraries/base/GHC/Event/TimerManager.hs | 1 - libraries/base/GHC/GHCi.hs | 9 +- libraries/base/GHC/ST.lhs | 4 + libraries/base/Prelude.hs | 3 +- libraries/base/Text/ParserCombinators/ReadP.hs | 57 ++++-- libraries/base/Text/ParserCombinators/ReadPrec.hs | 17 +- .../template-haskell/Language/Haskell/TH/Syntax.hs | 4 +- 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 @@ -115,19 +113,65 @@ mapM_ :: Monad m => (a -> m b) -> [a] -> m () {-# INLINE mapM_ #-} 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 +-- : \"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 --- : \"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) -- cgit v1.2.1