module Control.Monad.Maybe (
MaybeT(..)
) where
import Control.Monad.Fix
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.RWS
import Control.Monad.Cont
import Control.Monad.Error
newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
instance (Monad m) => Functor (MaybeT m) where
fmap f m = MaybeT $ do
a <- runMaybeT m
case a of
Nothing -> return (Nothing)
Just r -> return (Just (f r))
instance (Monad m) => Monad (MaybeT m) where
return a = MaybeT $ return (Just a)
m >>= k = MaybeT $ do
a <- runMaybeT m
case a of
Nothing -> return (Nothing)
Just r -> runMaybeT (k r)
fail msg = MaybeT $ return (Nothing)
instance (Monad m) => MonadPlus (MaybeT m) where
mzero = MaybeT $ return (Nothing)
m `mplus` n = MaybeT $ do
a <- runMaybeT m
case a of
Nothing -> runMaybeT n
Just r -> return (Just r)
instance (MonadFix m) => MonadFix (MaybeT m) where
mfix f = MaybeT $ mfix $ \a -> runMaybeT $ f $ case a of
Just r -> r
_ -> error "empty mfix argument"
instance MonadTrans (MaybeT) where
lift m = MaybeT $ do
a <- m
return (Just a)
instance (MonadIO m) => MonadIO (MaybeT m) where
liftIO = lift . liftIO
instance (MonadReader r m) => MonadReader r (MaybeT m) where
ask = lift ask
local f m = MaybeT $ local f (runMaybeT m)
instance (MonadWriter w m) => MonadWriter w (MaybeT m) where
tell = lift . tell
listen m = MaybeT $ do
(a, w) <- listen (runMaybeT m)
return $ case a of
Nothing -> Nothing
Just r -> Just (r, w)
pass m = MaybeT $ pass $ do
a <- runMaybeT m
return $ case a of
Nothing -> (Nothing, id)
Just (r, f) -> (Just r, f)
instance (MonadState s m) => MonadState s (MaybeT m) where
get = lift get
put = lift . put
instance (MonadCont m) => MonadCont (MaybeT m) where
callCC f = MaybeT $
callCC $ \c ->
runMaybeT (f (\a -> MaybeT $ c (Just a)))