Monad transformer

MaybeT.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

import Control.Monad
import Control.Monad.State
import Control.Monad.Trans

newtype MaybeT m a = MaybeT {
  runMaybeT :: m (Maybe a)
}

bindMT :: (Monad m) => MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b
x `bindMT` f = MaybeT $ do
                unwrapped <- runMaybeT x
                case unwrapped of
                  Nothing -> return Nothing
                  Just y -> runMaybeT (f y)

x `altBinMT` f =
  MaybeT $ runMaybeT x >>= maybe (return Nothing) (runMaybeT . f)

pureMT :: (Applicative f) => a -> MaybeT f a
pureMT a = MaybeT $ pure (Just a)

returnMT :: (Monad m) => a -> MaybeT m a
returnMT = pureMT

failMT :: (Monad m) => t -> MaybeT m a
failMT _ = MaybeT $ return Nothing

fmapMT :: (Functor f) => (a -> b) -> MaybeT f a -> MaybeT f b
fmapMT f x =
  let x' = runMaybeT x
  in MaybeT $ fmap (fmap f) x'

apMT :: (Applicative f) => MaybeT f (a -> b) -> MaybeT f a -> MaybeT f b
apMT f a =
  let f' = runMaybeT f
      a' = runMaybeT a
  in MaybeT $ ap <$> f' <*> a'
  where
    ap :: Maybe (a -> b) -> Maybe a -> Maybe b
    ap = (<*>)

instance (Functor f) => Functor (MaybeT f) where
  fmap = fmapMT
  
instance (Applicative f) => Applicative (MaybeT f) where
  pure = pureMT
  (<*>) = apMT

instance (Monad m) => Monad (MaybeT m) where
  return = returnMT
  (>>=) = bindMT
  fail = failMT

instance MonadTrans MaybeT where
  lift m = MaybeT (Just `liftM` m)

instance (MonadIO m) => MonadIO (MaybeT m) where
  liftIO m = lift (liftIO m)

instance (MonadState s m) => MonadState s (MaybeT m) where
  get = lift get
  put k = lift (put k)