Define custom (*>) for various transformers to fix space leaks (fixes #33)
[darcs-mirrors/transformers.git] / Control / Monad / Trans / Maybe.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__ >= 702
3 {-# LANGUAGE Safe #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 710
6 {-# LANGUAGE AutoDeriveTypeable #-}
7 #endif
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Control.Monad.Trans.Maybe
11 -- Copyright : (c) 2007 Yitzak Gale, Eric Kidd
12 -- License : BSD-style (see the file LICENSE)
13 --
14 -- Maintainer : R.Paterson@city.ac.uk
15 -- Stability : experimental
16 -- Portability : portable
17 --
18 -- The 'MaybeT' monad transformer extends a monad with the ability to exit
19 -- the computation without returning a value.
20 --
21 -- A sequence of actions produces a value only if all the actions in
22 -- the sequence do. If one exits, the rest of the sequence is skipped
23 -- and the composite action exits.
24 --
25 -- For a variant allowing a range of exception values, see
26 -- "Control.Monad.Trans.Except".
27 -----------------------------------------------------------------------------
28
29 module Control.Monad.Trans.Maybe (
30 -- * The MaybeT monad transformer
31 MaybeT(..),
32 mapMaybeT,
33 -- * Monad transformations
34 maybeToExceptT,
35 exceptToMaybeT,
36 -- * Lifting other operations
37 liftCallCC,
38 liftCatch,
39 liftListen,
40 liftPass,
41 ) where
42
43 import Control.Monad.IO.Class
44 import Control.Monad.Signatures
45 import Control.Monad.Trans.Class
46 import Control.Monad.Trans.Except (ExceptT(..))
47 import Data.Functor.Classes
48
49 import Control.Applicative
50 import Control.Monad (MonadPlus(mzero, mplus), liftM)
51 #if MIN_VERSION_base(4,9,0)
52 import qualified Control.Monad.Fail as Fail
53 #endif
54 import Control.Monad.Fix (MonadFix(mfix))
55 #if MIN_VERSION_base(4,4,0)
56 import Control.Monad.Zip (MonadZip(mzipWith))
57 #endif
58 import Data.Foldable (Foldable(foldMap))
59 import Data.Maybe (fromMaybe)
60 import Data.Traversable (Traversable(traverse))
61
62 -- | The parameterizable maybe monad, obtained by composing an arbitrary
63 -- monad with the 'Maybe' monad.
64 --
65 -- Computations are actions that may produce a value or exit.
66 --
67 -- The 'return' function yields a computation that produces that
68 -- value, while @>>=@ sequences two subcomputations, exiting if either
69 -- computation does.
70 newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
71
72 instance (Eq1 m) => Eq1 (MaybeT m) where
73 liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y
74 {-# INLINE liftEq #-}
75
76 instance (Ord1 m) => Ord1 (MaybeT m) where
77 liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y
78 {-# INLINE liftCompare #-}
79
80 instance (Read1 m) => Read1 (MaybeT m) where
81 liftReadsPrec rp rl = readsData $
82 readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT
83 where
84 rp' = liftReadsPrec rp rl
85 rl' = liftReadList rp rl
86
87 instance (Show1 m) => Show1 (MaybeT m) where
88 liftShowsPrec sp sl d (MaybeT m) =
89 showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m
90 where
91 sp' = liftShowsPrec sp sl
92 sl' = liftShowList sp sl
93
94 instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1
95 instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1
96 instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1
97 instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1
98
99 -- | Transform the computation inside a @MaybeT@.
100 --
101 -- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@
102 mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
103 mapMaybeT f = MaybeT . f . runMaybeT
104 {-# INLINE mapMaybeT #-}
105
106 -- | Convert a 'MaybeT' computation to 'ExceptT', with a default
107 -- exception value.
108 maybeToExceptT :: (Functor m) => e -> MaybeT m a -> ExceptT e m a
109 maybeToExceptT e (MaybeT m) = ExceptT $ fmap (maybe (Left e) Right) m
110 {-# INLINE maybeToExceptT #-}
111
112 -- | Convert a 'ExceptT' computation to 'MaybeT', discarding the
113 -- value of any exception.
114 exceptToMaybeT :: (Functor m) => ExceptT e m a -> MaybeT m a
115 exceptToMaybeT (ExceptT m) = MaybeT $ fmap (either (const Nothing) Just) m
116 {-# INLINE exceptToMaybeT #-}
117
118 instance (Functor m) => Functor (MaybeT m) where
119 fmap f = mapMaybeT (fmap (fmap f))
120 {-# INLINE fmap #-}
121
122 instance (Foldable f) => Foldable (MaybeT f) where
123 foldMap f (MaybeT a) = foldMap (foldMap f) a
124 {-# INLINE foldMap #-}
125
126 instance (Traversable f) => Traversable (MaybeT f) where
127 traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a
128 {-# INLINE traverse #-}
129
130 instance (Functor m, Monad m) => Applicative (MaybeT m) where
131 pure = MaybeT . return . Just
132 {-# INLINE pure #-}
133 mf <*> mx = MaybeT $ do
134 mb_f <- runMaybeT mf
135 case mb_f of
136 Nothing -> return Nothing
137 Just f -> do
138 mb_x <- runMaybeT mx
139 case mb_x of
140 Nothing -> return Nothing
141 Just x -> return (Just (f x))
142 {-# INLINE (<*>) #-}
143 m *> k = m >>= \_ -> k
144 {-# INLINE (*>) #-}
145
146 instance (Functor m, Monad m) => Alternative (MaybeT m) where
147 empty = MaybeT (return Nothing)
148 {-# INLINE empty #-}
149 x <|> y = MaybeT $ do
150 v <- runMaybeT x
151 case v of
152 Nothing -> runMaybeT y
153 Just _ -> return v
154 {-# INLINE (<|>) #-}
155
156 instance (Monad m) => Monad (MaybeT m) where
157 #if !(MIN_VERSION_base(4,8,0))
158 return = MaybeT . return . Just
159 {-# INLINE return #-}
160 #endif
161 x >>= f = MaybeT $ do
162 v <- runMaybeT x
163 case v of
164 Nothing -> return Nothing
165 Just y -> runMaybeT (f y)
166 {-# INLINE (>>=) #-}
167 fail _ = MaybeT (return Nothing)
168 {-# INLINE fail #-}
169
170 #if MIN_VERSION_base(4,9,0)
171 instance (Monad m) => Fail.MonadFail (MaybeT m) where
172 fail _ = MaybeT (return Nothing)
173 {-# INLINE fail #-}
174 #endif
175
176 instance (Monad m) => MonadPlus (MaybeT m) where
177 mzero = MaybeT (return Nothing)
178 {-# INLINE mzero #-}
179 mplus x y = MaybeT $ do
180 v <- runMaybeT x
181 case v of
182 Nothing -> runMaybeT y
183 Just _ -> return v
184 {-# INLINE mplus #-}
185
186 instance (MonadFix m) => MonadFix (MaybeT m) where
187 mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb))
188 where bomb = error "mfix (MaybeT): inner computation returned Nothing"
189 {-# INLINE mfix #-}
190
191 instance MonadTrans MaybeT where
192 lift = MaybeT . liftM Just
193 {-# INLINE lift #-}
194
195 instance (MonadIO m) => MonadIO (MaybeT m) where
196 liftIO = lift . liftIO
197 {-# INLINE liftIO #-}
198
199 #if MIN_VERSION_base(4,4,0)
200 instance (MonadZip m) => MonadZip (MaybeT m) where
201 mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b
202 {-# INLINE mzipWith #-}
203 #endif
204
205 -- | Lift a @callCC@ operation to the new monad.
206 liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b
207 liftCallCC callCC f =
208 MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just))
209 {-# INLINE liftCallCC #-}
210
211 -- | Lift a @catchE@ operation to the new monad.
212 liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a
213 liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h)
214 {-# INLINE liftCatch #-}
215
216 -- | Lift a @listen@ operation to the new monad.
217 liftListen :: (Monad m) => Listen w m (Maybe a) -> Listen w (MaybeT m) a
218 liftListen listen = mapMaybeT $ \ m -> do
219 (a, w) <- listen m
220 return $! fmap (\ r -> (r, w)) a
221 {-# INLINE liftListen #-}
222
223 -- | Lift a @pass@ operation to the new monad.
224 liftPass :: (Monad m) => Pass w m (Maybe a) -> Pass w (MaybeT m) a
225 liftPass pass = mapMaybeT $ \ m -> pass $ do
226 a <- m
227 return $! case a of
228 Nothing -> (Nothing, id)
229 Just (v, f) -> (Just v, f)
230 {-# INLINE liftPass #-}