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
29module 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
43import Control.Monad.IO.Class
44import Control.Monad.Signatures
45import Control.Monad.Trans.Class
46import Control.Monad.Trans.Except (ExceptT(..))
47import Data.Functor.Classes
48#if MIN_VERSION_base(4,12,0)
49import Data.Functor.Contravariant
50#endif
51
52import Control.Applicative
53import Control.Monad (MonadPlus(mzero, mplus), liftM)
54#if MIN_VERSION_base(4,9,0)
55import qualified Control.Monad.Fail as Fail
56#endif
57import Control.Monad.Fix (MonadFix(mfix))
58#if MIN_VERSION_base(4,4,0)
59import Control.Monad.Zip (MonadZip(mzipWith))
60#endif
61import Data.Foldable (Foldable(foldMap))
62import Data.Maybe (fromMaybe)
63import Data.Traversable (Traversable(traverse))
64
65-- | The parameterizable maybe monad, obtained by composing an arbitrary
66-- monad with the 'Maybe' monad.
67--
68-- Computations are actions that may produce a value or exit.
69--
70-- The 'return' function yields a computation that produces that
71-- value, while @>>=@ sequences two subcomputations, exiting if either
72-- computation does.
73newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
74
75instance (Eq1 m) => Eq1 (MaybeT m) where
76    liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y
77    {-# INLINE liftEq #-}
78
79instance (Ord1 m) => Ord1 (MaybeT m) where
80    liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y
81    {-# INLINE liftCompare #-}
82
83instance (Read1 m) => Read1 (MaybeT m) where
84    liftReadsPrec rp rl = readsData $
85        readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT
86      where
87        rp' = liftReadsPrec rp rl
88        rl' = liftReadList rp rl
89
90instance (Show1 m) => Show1 (MaybeT m) where
91    liftShowsPrec sp sl d (MaybeT m) =
92        showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m
93      where
94        sp' = liftShowsPrec sp sl
95        sl' = liftShowList sp sl
96
97instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1
98instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1
99instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1
100instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1
101
102-- | Transform the computation inside a @MaybeT@.
103--
104-- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@
105mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
106mapMaybeT f = MaybeT . f . runMaybeT
107{-# INLINE mapMaybeT #-}
108
109-- | Convert a 'MaybeT' computation to 'ExceptT', with a default
110-- exception value.
111maybeToExceptT :: (Functor m) => e -> MaybeT m a -> ExceptT e m a
112maybeToExceptT e (MaybeT m) = ExceptT $ fmap (maybe (Left e) Right) m
113{-# INLINE maybeToExceptT #-}
114
115-- | Convert a 'ExceptT' computation to 'MaybeT', discarding the
116-- value of any exception.
117exceptToMaybeT :: (Functor m) => ExceptT e m a -> MaybeT m a
118exceptToMaybeT (ExceptT m) = MaybeT $ fmap (either (const Nothing) Just) m
119{-# INLINE exceptToMaybeT #-}
120
121instance (Functor m) => Functor (MaybeT m) where
122    fmap f = mapMaybeT (fmap (fmap f))
123    {-# INLINE fmap #-}
124
125instance (Foldable f) => Foldable (MaybeT f) where
126    foldMap f (MaybeT a) = foldMap (foldMap f) a
127    {-# INLINE foldMap #-}
128
129instance (Traversable f) => Traversable (MaybeT f) where
130    traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a
131    {-# INLINE traverse #-}
132
133instance (Functor m, Monad m) => Applicative (MaybeT m) where
134    pure = MaybeT . return . Just
135    {-# INLINE pure #-}
136    mf <*> mx = MaybeT $ do
137        mb_f <- runMaybeT mf
138        case mb_f of
139            Nothing -> return Nothing
140            Just f  -> do
141                mb_x <- runMaybeT mx
142                case mb_x of
143                    Nothing -> return Nothing
144                    Just x  -> return (Just (f x))
145    {-# INLINE (<*>) #-}
146    m *> k = m >>= \_ -> k
147    {-# INLINE (*>) #-}
148
149instance (Functor m, Monad m) => Alternative (MaybeT m) where
150    empty = MaybeT (return Nothing)
151    {-# INLINE empty #-}
152    x <|> y = MaybeT $ do
153        v <- runMaybeT x
154        case v of
155            Nothing -> runMaybeT y
156            Just _  -> return v
157    {-# INLINE (<|>) #-}
158
159instance (Monad m) => Monad (MaybeT m) where
160#if !(MIN_VERSION_base(4,8,0))
161    return = MaybeT . return . Just
162    {-# INLINE return #-}
163#endif
164    x >>= f = MaybeT $ do
165        v <- runMaybeT x
166        case v of
167            Nothing -> return Nothing
168            Just y  -> runMaybeT (f y)
169    {-# INLINE (>>=) #-}
170#if !(MIN_VERSION_base(4,13,0))
171    fail _ = MaybeT (return Nothing)
172    {-# INLINE fail #-}
173#endif
174
175#if MIN_VERSION_base(4,9,0)
176instance (Monad m) => Fail.MonadFail (MaybeT m) where
177    fail _ = MaybeT (return Nothing)
178    {-# INLINE fail #-}
179#endif
180
181instance (Monad m) => MonadPlus (MaybeT m) where
182    mzero = MaybeT (return Nothing)
183    {-# INLINE mzero #-}
184    mplus x y = MaybeT $ do
185        v <- runMaybeT x
186        case v of
187            Nothing -> runMaybeT y
188            Just _  -> return v
189    {-# INLINE mplus #-}
190
191instance (MonadFix m) => MonadFix (MaybeT m) where
192    mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb))
193      where bomb = error "mfix (MaybeT): inner computation returned Nothing"
194    {-# INLINE mfix #-}
195
196instance MonadTrans MaybeT where
197    lift = MaybeT . liftM Just
198    {-# INLINE lift #-}
199
200instance (MonadIO m) => MonadIO (MaybeT m) where
201    liftIO = lift . liftIO
202    {-# INLINE liftIO #-}
203
204#if MIN_VERSION_base(4,4,0)
205instance (MonadZip m) => MonadZip (MaybeT m) where
206    mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b
207    {-# INLINE mzipWith #-}
208#endif
209
210#if MIN_VERSION_base(4,12,0)
211instance Contravariant m => Contravariant (MaybeT m) where
212    contramap f = MaybeT . contramap (fmap f) . runMaybeT
213    {-# INLINE contramap #-}
214#endif
215
216-- | Lift a @callCC@ operation to the new monad.
217liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b
218liftCallCC callCC f =
219    MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just))
220{-# INLINE liftCallCC #-}
221
222-- | Lift a @catchE@ operation to the new monad.
223liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a
224liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h)
225{-# INLINE liftCatch #-}
226
227-- | Lift a @listen@ operation to the new monad.
228liftListen :: (Monad m) => Listen w m (Maybe a) -> Listen w (MaybeT m) a
229liftListen listen = mapMaybeT $ \ m -> do
230    (a, w) <- listen m
231    return $! fmap (\ r -> (r, w)) a
232{-# INLINE liftListen #-}
233
234-- | Lift a @pass@ operation to the new monad.
235liftPass :: (Monad m) => Pass w m (Maybe a) -> Pass w (MaybeT m) a
236liftPass pass = mapMaybeT $ \ m -> pass $ do
237    a <- m
238    return $! case a of
239        Nothing     -> (Nothing, id)
240        Just (v, f) -> (Just v, f)
241{-# INLINE liftPass #-}
242