81ce513a58b797162c47f966464d53d86b78729f
[ghc.git] / libraries / base / Control / Applicative.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE AutoDeriveTypeable #-}
3 {-# LANGUAGE DeriveGeneric #-}
4
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module : Control.Applicative
8 -- Copyright : Conor McBride and Ross Paterson 2005
9 -- License : BSD-style (see the LICENSE file in the distribution)
10 --
11 -- Maintainer : libraries@haskell.org
12 -- Stability : experimental
13 -- Portability : portable
14 --
15 -- This module describes a structure intermediate between a functor and
16 -- a monad (technically, a strong lax monoidal functor). Compared with
17 -- monads, this interface lacks the full power of the binding operation
18 -- '>>=', but
19 --
20 -- * it has more instances.
21 --
22 -- * it is sufficient for many uses, e.g. context-free parsing, or the
23 -- 'Data.Traversable.Traversable' class.
24 --
25 -- * instances can perform analysis of computations before they are
26 -- executed, and thus produce shared optimizations.
27 --
28 -- This interface was introduced for parsers by Niklas Röjemo, because
29 -- it admits more sharing than the monadic interface. The names here are
30 -- mostly based on parsing work by Doaitse Swierstra.
31 --
32 -- For more details, see
33 -- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>,
34 -- by Conor McBride and Ross Paterson.
35
36 module Control.Applicative (
37 -- * Applicative functors
38 Applicative(..),
39 -- * Alternatives
40 Alternative(..),
41 -- * Instances
42 Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
43 -- * Utility functions
44 (<$>), (<$), (<**>),
45 liftA, liftA2, liftA3,
46 optional,
47 ) where
48
49 import Prelude hiding (id,(.))
50
51 import Control.Category
52 import Control.Arrow
53 import Control.Monad (liftM, ap, MonadPlus(..))
54 import Control.Monad.ST.Safe (ST)
55 import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)
56 import Data.Functor ((<$>), (<$))
57 import Data.Monoid (Monoid(..), First(..), Last(..))
58 import Data.Proxy
59
60 import Text.ParserCombinators.ReadP (ReadP)
61 import Text.ParserCombinators.ReadPrec (ReadPrec)
62
63 import GHC.Conc (STM, retry, orElse)
64 import GHC.Generics
65
66 infixl 3 <|>
67 infixl 4 <*>, <*, *>, <**>
68
69 -- | A functor with application, providing operations to
70 --
71 -- * embed pure expressions ('pure'), and
72 --
73 -- * sequence computations and combine their results ('<*>').
74 --
75 -- A minimal complete definition must include implementations of these
76 -- functions satisfying the following laws:
77 --
78 -- [/identity/]
79 --
80 -- @'pure' 'id' '<*>' v = v@
81 --
82 -- [/composition/]
83 --
84 -- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
85 --
86 -- [/homomorphism/]
87 --
88 -- @'pure' f '<*>' 'pure' x = 'pure' (f x)@
89 --
90 -- [/interchange/]
91 --
92 -- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
93 --
94 -- The other methods have the following default definitions, which may
95 -- be overridden with equivalent specialized implementations:
96 --
97 -- * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@
98 --
99 -- * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@
100 --
101 -- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
102 --
103 -- * @'fmap' f x = 'pure' f '<*>' x@
104 --
105 -- If @f@ is also a 'Monad', it should satisfy
106 --
107 -- * @'pure' = 'return'@
108 --
109 -- * @('<*>') = 'ap'@
110 --
111 -- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
112
113 class Functor f => Applicative f where
114 -- | Lift a value.
115 pure :: a -> f a
116
117 -- | Sequential application.
118 (<*>) :: f (a -> b) -> f a -> f b
119
120 -- | Sequence actions, discarding the value of the first argument.
121 (*>) :: f a -> f b -> f b
122 (*>) = liftA2 (const id)
123
124 -- | Sequence actions, discarding the value of the second argument.
125 (<*) :: f a -> f b -> f a
126 (<*) = liftA2 const
127
128 -- | A monoid on applicative functors.
129 --
130 -- Minimal complete definition: 'empty' and '<|>'.
131 --
132 -- If defined, 'some' and 'many' should be the least solutions
133 -- of the equations:
134 --
135 -- * @some v = (:) '<$>' v '<*>' many v@
136 --
137 -- * @many v = some v '<|>' 'pure' []@
138 class Applicative f => Alternative f where
139 -- | The identity of '<|>'
140 empty :: f a
141 -- | An associative binary operation
142 (<|>) :: f a -> f a -> f a
143
144 -- | One or more.
145 some :: f a -> f [a]
146 some v = some_v
147 where
148 many_v = some_v <|> pure []
149 some_v = (:) <$> v <*> many_v
150
151 -- | Zero or more.
152 many :: f a -> f [a]
153 many v = many_v
154 where
155 many_v = some_v <|> pure []
156 some_v = (:) <$> v <*> many_v
157
158 -- instances for Prelude types
159
160 instance Applicative Maybe where
161 pure = return
162 (<*>) = ap
163
164 instance Alternative Maybe where
165 empty = Nothing
166 Nothing <|> r = r
167 l <|> _ = l
168
169 instance Applicative [] where
170 pure = return
171 (<*>) = ap
172
173 instance Alternative [] where
174 empty = []
175 (<|>) = (++)
176
177 instance Applicative IO where
178 pure = return
179 (<*>) = ap
180
181 instance Applicative (ST s) where
182 pure = return
183 (<*>) = ap
184
185 instance Applicative (Lazy.ST s) where
186 pure = return
187 (<*>) = ap
188
189 instance Applicative STM where
190 pure = return
191 (<*>) = ap
192
193 instance Alternative STM where
194 empty = retry
195 (<|>) = orElse
196
197 instance Applicative ((->) a) where
198 pure = const
199 (<*>) f g x = f x (g x)
200
201 instance Monoid a => Applicative ((,) a) where
202 pure x = (mempty, x)
203 (u, f) <*> (v, x) = (u `mappend` v, f x)
204
205 instance Applicative (Either e) where
206 pure = Right
207 Left e <*> _ = Left e
208 Right f <*> r = fmap f r
209
210 instance Applicative ReadP where
211 pure = return
212 (<*>) = ap
213
214 instance Alternative ReadP where
215 empty = mzero
216 (<|>) = mplus
217
218 instance Applicative ReadPrec where
219 pure = return
220 (<*>) = ap
221
222 instance Alternative ReadPrec where
223 empty = mzero
224 (<|>) = mplus
225
226 instance Arrow a => Applicative (ArrowMonad a) where
227 pure x = ArrowMonad (arr (const x))
228 ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
229
230 instance ArrowPlus a => Alternative (ArrowMonad a) where
231 empty = ArrowMonad zeroArrow
232 ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
233
234 -- new instances
235
236 newtype Const a b = Const { getConst :: a }
237 deriving (Generic, Generic1)
238
239 instance Functor (Const m) where
240 fmap _ (Const v) = Const v
241
242 -- Added in base-4.7.0.0
243 instance Monoid a => Monoid (Const a b) where
244 mempty = Const mempty
245 mappend (Const a) (Const b) = Const (mappend a b)
246
247 instance Monoid m => Applicative (Const m) where
248 pure _ = Const mempty
249 Const f <*> Const v = Const (f `mappend` v)
250
251 newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
252 deriving (Generic, Generic1)
253
254 instance Monad m => Functor (WrappedMonad m) where
255 fmap f (WrapMonad v) = WrapMonad (liftM f v)
256
257 instance Monad m => Applicative (WrappedMonad m) where
258 pure = WrapMonad . return
259 WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
260
261 -- Added in base-4.7.0.0 (GHC Trac #8218)
262 instance Monad m => Monad (WrappedMonad m) where
263 return = WrapMonad . return
264 a >>= f = WrapMonad (unwrapMonad a >>= unwrapMonad . f)
265
266 instance MonadPlus m => Alternative (WrappedMonad m) where
267 empty = WrapMonad mzero
268 WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)
269
270 newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }
271 deriving (Generic, Generic1)
272
273 instance Arrow a => Functor (WrappedArrow a b) where
274 fmap f (WrapArrow a) = WrapArrow (a >>> arr f)
275
276 instance Arrow a => Applicative (WrappedArrow a b) where
277 pure x = WrapArrow (arr (const x))
278 WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))
279
280 instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
281 empty = WrapArrow zeroArrow
282 WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)
283
284 -- Added in base-4.8.0.0
285 instance Applicative First where
286 pure x = First (Just x)
287 First x <*> First y = First (x <*> y)
288
289 instance Applicative Last where
290 pure x = Last (Just x)
291 Last x <*> Last y = Last (x <*> y)
292
293 -- | Lists, but with an 'Applicative' functor based on zipping, so that
294 --
295 -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@
296 --
297 newtype ZipList a = ZipList { getZipList :: [a] }
298 deriving (Show, Eq, Ord, Read, Generic, Generic1)
299
300 instance Functor ZipList where
301 fmap f (ZipList xs) = ZipList (map f xs)
302
303 instance Applicative ZipList where
304 pure x = ZipList (repeat x)
305 ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
306
307 instance Applicative Proxy where
308 pure _ = Proxy
309 {-# INLINE pure #-}
310 _ <*> _ = Proxy
311 {-# INLINE (<*>) #-}
312
313 -- extra functions
314
315 -- | A variant of '<*>' with the arguments reversed.
316 (<**>) :: Applicative f => f a -> f (a -> b) -> f b
317 (<**>) = liftA2 (flip ($))
318
319 -- | Lift a function to actions.
320 -- This function may be used as a value for `fmap` in a `Functor` instance.
321 liftA :: Applicative f => (a -> b) -> f a -> f b
322 liftA f a = pure f <*> a
323
324 -- | Lift a binary function to actions.
325 liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
326 liftA2 f a b = f <$> a <*> b
327
328 -- | Lift a ternary function to actions.
329 liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
330 liftA3 f a b c = f <$> a <*> b <*> c
331
332 -- | One or none.
333 optional :: Alternative f => f a -> f (Maybe a)
334 optional v = Just <$> v <|> pure Nothing