#if __GLASGOW_HASKELL__ >= 709
#endif
module Control.Monad.Trans.Maybe (
MaybeT(..),
mapMaybeT,
maybeToExceptT,
exceptToMaybeT,
liftCallCC,
liftCatch,
liftListen,
liftPass,
) where
import Control.Monad.IO.Class
import Control.Monad.Signatures
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (ExceptT(..))
import Data.Functor.Classes
import Control.Applicative
import Control.Monad (MonadPlus(mzero, mplus), liftM, ap)
import Control.Monad.Fix (MonadFix(mfix))
import Data.Foldable (Foldable(foldMap))
import Data.Maybe (fromMaybe)
import Data.Traversable (Traversable(traverse))
newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
instance (Eq1 m, Eq a) => Eq (MaybeT m a) where
MaybeT x == MaybeT y = eq1 x y
instance (Ord1 m, Ord a) => Ord (MaybeT m a) where
compare (MaybeT x) (MaybeT y) = compare1 x y
instance (Read1 m, Read a) => Read (MaybeT m a) where
readsPrec = readsData $ readsUnary1 "MaybeT" MaybeT
instance (Show1 m, Show a) => Show (MaybeT m a) where
showsPrec d (MaybeT m) = showsUnary1 "MaybeT" d m
instance (Eq1 m) => Eq1 (MaybeT m) where eq1 = (==)
instance (Ord1 m) => Ord1 (MaybeT m) where compare1 = compare
instance (Read1 m) => Read1 (MaybeT m) where readsPrec1 = readsPrec
instance (Show1 m) => Show1 (MaybeT m) where showsPrec1 = showsPrec
mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT f = MaybeT . f . runMaybeT
maybeToExceptT :: (Functor m) => e -> MaybeT m a -> ExceptT e m a
maybeToExceptT e (MaybeT m) = ExceptT $ fmap (maybe (Left e) Right) m
exceptToMaybeT :: (Functor m) => ExceptT e m a -> MaybeT m a
exceptToMaybeT (ExceptT m) = MaybeT $ fmap (either (const Nothing) Just) m
instance (Functor m) => Functor (MaybeT m) where
fmap f = mapMaybeT (fmap (fmap f))
instance (Foldable f) => Foldable (MaybeT f) where
foldMap f (MaybeT a) = foldMap (foldMap f) a
instance (Traversable f) => Traversable (MaybeT f) where
traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a
instance (Functor m, Monad m) => Applicative (MaybeT m) where
pure = return
(<*>) = ap
instance (Functor m, Monad m) => Alternative (MaybeT m) where
empty = mzero
(<|>) = mplus
instance (Monad m) => Monad (MaybeT m) where
fail _ = MaybeT (return Nothing)
return = lift . return
x >>= f = MaybeT $ do
v <- runMaybeT x
case v of
Nothing -> return Nothing
Just y -> runMaybeT (f y)
instance (Monad m) => MonadPlus (MaybeT m) where
mzero = MaybeT (return Nothing)
mplus x y = MaybeT $ do
v <- runMaybeT x
case v of
Nothing -> runMaybeT y
Just _ -> return v
instance (MonadFix m) => MonadFix (MaybeT m) where
mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb))
where bomb = error "mfix (MaybeT): inner computation returned Nothing"
instance MonadTrans MaybeT where
lift = MaybeT . liftM Just
instance (MonadIO m) => MonadIO (MaybeT m) where
liftIO = lift . liftIO
liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b
liftCallCC callCC f =
MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just))
liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a
liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h)
liftListen :: (Monad m) => Listen w m (Maybe a) -> Listen w (MaybeT m) a
liftListen listen = mapMaybeT $ \ m -> do
(a, w) <- listen m
return $! fmap (\ r -> (r, w)) a
liftPass :: (Monad m) => Pass w m (Maybe a) -> Pass w (MaybeT m) a
liftPass pass = mapMaybeT $ \ m -> pass $ do
a <- m
return $! case a of
Nothing -> (Nothing, id)
Just (v, f) -> (Just v, f)