X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FApplicative.hs;h=6ef8bba3869c96238d65c3912d8b21fe3f97172b;hb=7dbb606d7b57cdad87a0ffbdb6ea4a274ebca7c0;hp=154b591288c4e21088e778c48f63ad4e34510254;hpb=8abb469bd2210d78da74b334a0f4397be5ac37f6;p=ghc-base.git diff --git a/Control/Applicative.hs b/Control/Applicative.hs index 154b591..6ef8bba 100644 --- a/Control/Applicative.hs +++ b/Control/Applicative.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Applicative @@ -9,39 +11,49 @@ -- Portability : portable -- -- This module describes a structure intermediate between a functor and --- a monad: it provides pure expressions and sequencing, but no binding. --- (Technically, a strong lax monoidal functor.) For more details, see --- /Applicative Programming with Effects/, --- by Conor McBride and Ross Paterson, online at --- . +-- a monad (technically, a strong lax monoidal functor). Compared with +-- monads, this interface lacks the full power of the binding operation +-- '>>=', but +-- +-- * it has more instances. +-- +-- * it is sufficient for many uses, e.g. context-free parsing, or the +-- 'Data.Traversable.Traversable' class. +-- +-- * instances can perform analysis of computations before they are +-- executed, and thus produce shared optimizations. -- -- This interface was introduced for parsers by Niklas Röjemo, because -- it admits more sharing than the monadic interface. The names here are --- mostly based on recent parsing work by Doaitse Swierstra. +-- mostly based on parsing work by Doaitse Swierstra. -- --- This class is also useful with instances of the --- 'Data.Traversable.Traversable' class. +-- For more details, see /Applicative Programming with Effects/, +-- by Conor McBride and Ross Paterson, online at +-- . module Control.Applicative ( - -- * Applicative functors - Applicative(..), - -- * Alternatives - Alternative(..), - -- * Instances - Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..), - -- * Utility functions - (<$>), (<$), (<**>), - liftA, liftA2, liftA3, - optional, - ) where + -- * Applicative functors + Applicative(..), + -- * Alternatives + Alternative(..), + -- * Instances + Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..), + -- * Utility functions + (<$>), (<$), (<**>), + liftA, liftA2, liftA3, + optional, + ) where import Prelude hiding (id,(.)) import Control.Category -import Control.Arrow - (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>))) +import Control.Arrow (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>))) import Control.Monad (liftM, ap, MonadPlus(..)) import Control.Monad.Instances () +#ifndef __NHC__ +import Control.Monad.ST (ST) +import qualified Control.Monad.ST.Lazy as Lazy (ST) +#endif import Data.Functor ((<$>), (<$)) import Data.Monoid (Monoid(..)) @@ -52,9 +64,14 @@ import GHC.Conc (STM, retry, orElse) infixl 3 <|> infixl 4 <*>, <*, *>, <**> --- | A functor with application. +-- | A functor with application, providing operations to +-- +-- * embed pure expressions ('pure'), and +-- +-- * sequence computations and combine their results ('<*>'). -- --- Instances should satisfy the following laws: +-- A minimal complete definition must include implementations of these +-- functions satisfying the following laws: -- -- [/identity/] -- @'pure' 'id' '<*>' v = v@ @@ -68,86 +85,101 @@ infixl 4 <*>, <*, *>, <**> -- [/interchange/] -- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@ -- --- [/ignore left value/] --- @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@ +-- The other methods have the following default definitions, which may +-- be overridden with equivalent specialized implementations: -- --- [/ignore right value/] --- @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@ +-- @ +-- u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v +-- u '<*' v = 'pure' 'const' '<*>' u '<*>' v +-- @ -- --- The 'Functor' instance should satisfy +-- 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', define @'pure' = 'return'@ and @('<*>') = 'ap'@. --- --- Minimal complete definition: 'pure' and '<*>'. +-- If @f@ is also a 'Monad', it should satisfy @'pure' = 'return'@ and +-- @('<*>') = 'ap'@ (which implies that 'pure' and '<*>' satisfy the +-- applicative functor laws). class Functor f => Applicative f where - -- | Lift a value. - pure :: a -> f a + -- | Lift a value. + pure :: a -> f a - -- | Sequential application. - (<*>) :: f (a -> b) -> f a -> f b + -- | 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 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 + -- | 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 '<|>'. -- --- 'some' and 'many' should be the least solutions of the equations: +-- 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 + -- | 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 + pure = return + (<*>) = ap instance Alternative Maybe where - empty = Nothing - Nothing <|> p = p - Just x <|> _ = Just x + empty = Nothing + Nothing <|> p = p + Just x <|> _ = Just x instance Applicative [] where - pure = return - (<*>) = ap + pure = return + (<*>) = ap instance Alternative [] where - empty = [] - (<|>) = (++) + empty = [] + (<|>) = (++) instance Applicative IO where - pure = return - (<*>) = ap + pure = return + (<*>) = ap + +#ifndef __NHC__ +instance Applicative (ST s) where + pure = return + (<*>) = ap + +instance Applicative (Lazy.ST s) where + pure = return + (<*>) = ap +#endif #ifdef __GLASGOW_HASKELL__ instance Applicative STM where @@ -160,54 +192,54 @@ instance Alternative STM where #endif instance Applicative ((->) a) where - pure = const - (<*>) f g x = f x (g x) + 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) + 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 + pure = Right + Left e <*> _ = Left e + Right f <*> r = fmap f r -- new instances newtype Const a b = Const { getConst :: a } instance Functor (Const m) where - fmap _ (Const v) = Const v + fmap _ (Const v) = Const v instance Monoid m => Applicative (Const m) where - pure _ = Const mempty - Const f <*> Const v = Const (f `mappend` v) + pure _ = Const mempty + Const f <*> Const v = Const (f `mappend` v) newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } instance Monad m => Functor (WrappedMonad m) where - fmap f (WrapMonad v) = WrapMonad (liftM f v) + fmap f (WrapMonad v) = WrapMonad (liftM f v) instance Monad m => Applicative (WrappedMonad m) where - pure = WrapMonad . return - WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) + pure = WrapMonad . return + WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) instance MonadPlus m => Alternative (WrappedMonad m) where - empty = WrapMonad mzero - WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) + empty = WrapMonad mzero + WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } instance Arrow a => Functor (WrappedArrow a b) where - fmap f (WrapArrow a) = WrapArrow (a >>> arr f) + fmap f (WrapArrow a) = WrapArrow (a >>> arr f) instance Arrow a => Applicative (WrappedArrow a b) where - pure x = WrapArrow (arr (const x)) - WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id)) + pure x = WrapArrow (arr (const x)) + WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id)) instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where - empty = WrapArrow zeroArrow - WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v) + empty = WrapArrow zeroArrow + WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v) -- | Lists, but with an 'Applicative' functor based on zipping, so that -- @@ -216,11 +248,11 @@ instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where newtype ZipList a = ZipList { getZipList :: [a] } instance Functor ZipList where - fmap f (ZipList xs) = ZipList (map f xs) + fmap f (ZipList xs) = ZipList (map f xs) instance Applicative ZipList where - pure x = ZipList (repeat x) - ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs) + pure x = ZipList (repeat x) + ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs) -- extra functions