diff options
Diffstat (limited to 'libraries/base/Control/Applicative.hs')
| -rw-r--r-- | libraries/base/Control/Applicative.hs | 334 |
1 files changed, 334 insertions, 0 deletions
diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs new file mode 100644 index 0000000000..81ce513a58 --- /dev/null +++ b/libraries/base/Control/Applicative.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This module describes a structure intermediate between a functor and +-- 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 parsing work by Doaitse Swierstra. +-- +-- For more details, see +-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>, +-- by Conor McBride and Ross Paterson. + +module Control.Applicative ( + -- * 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 +import Control.Monad (liftM, ap, MonadPlus(..)) +import Control.Monad.ST.Safe (ST) +import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST) +import Data.Functor ((<$>), (<$)) +import Data.Monoid (Monoid(..), First(..), Last(..)) +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) + +instance Functor (Const m) where + fmap _ (Const v) = Const v + +-- Added in base-4.7.0.0 +instance Monoid a => Monoid (Const a b) where + mempty = Const mempty + mappend (Const a) (Const b) = Const (mappend a b) + +instance Monoid m => Applicative (Const m) where + pure _ = Const mempty + Const f <*> Const v = Const (f `mappend` v) + +newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } + deriving (Generic, Generic1) + +instance Monad m => Functor (WrappedMonad m) where + 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) + +-- Added in base-4.7.0.0 (GHC Trac #8218) +instance Monad m => Monad (WrappedMonad m) where + return = WrapMonad . return + a >>= f = WrapMonad (unwrapMonad a >>= unwrapMonad . f) + +instance MonadPlus m => Alternative (WrappedMonad m) where + empty = WrapMonad mzero + WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) + +newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } + deriving (Generic, Generic1) + +instance Arrow a => Functor (WrappedArrow a b) where + 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)) + +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)@ +-- +newtype ZipList a = ZipList { getZipList :: [a] } + deriving (Show, Eq, Ord, Read, Generic, Generic1) + +instance Functor ZipList where + fmap f (ZipList xs) = ZipList (map f xs) + +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 |