mtl.hs

------------------------------------------------------------------------------
class MonadTrans t where
    lift   :: Monad m => m a -> t m a
    lifted :: Monad m => ((t m a -> m a) -> m a) -> t m a

    lift = lifted . const

-----------------------------------------------------------------------------
instance (MonadTrans t, Monad m) => Monad (t m) where
    return  = lift . return
    m >>= k = lifted $ \unlift -> (unlift m) >>= (unlift . k)
    fail    = lift . fail


------------------------------------------------------------------------------
instance (MonadTrans t, Monad m) => Functor (t m) where
    fmap = liftM


------------------------------------------------------------------------------
instance (MonadTrans t, Monad m) => Applicative (t m) where
    pure  = return
    (<*>) = ap


------------------------------------------------------------------------------
instance (MonadTrans t, MonadPlus m) => MonadPlus (t m) where
    mzero       = lift mzero
    m `mplus` n = lifted $ \unlift -> unlift m `mplus` unlift n


------------------------------------------------------------------------------
instance (MonadTrans t, MonadPlus m) => Alternative (t m) where
    empty = mzero
    (<|>) = mplus


------------------------------------------------------------------------------
instance (MonadTrans t, MonadFix m) => MonadFix (t m) where
    mfix f = lifted $ \unlift -> mfix $ unlift . f


------------------------------------------------------------------------------
instance (MonadTrans t, MonadIO m) => MonadIO (t m) where
    liftIO = lift . liftIO


------------------------------------------------------------------------------
instance (MonadTrans t, MonadCatchIO m) => MonadCatchIO (t m) where
    m `catch` h = lifted $ \unlift -> unlift m `catch` (unlift . h)


------------------------------------------------------------------------------
instance (MonadTrans t, MonadCont m) => MonadCont (t m) where
    callCC f = lifted $ \unlift -> callCC $ \c -> unlift (f (lift . c))


------------------------------------------------------------------------------
instance (MonadTrans t, MonadError e m) => MonadError e (t m) where
    throwError       = lift . throwError
    m `catchError` h = lifted $ \unlift -> unlift m `catchError` (unlift . h)


------------------------------------------------------------------------------
instance (MonadTrans t, MonadReader m) => MonadReader (t m) where
    ask       = lift ask
    local f m = lifted $ \unlift -> local f $ unlift m


------------------------------------------------------------------------------
instance (MonadTrans t, MonadState s m) => MonadState s (t m) where
    get = lift get
    put = lift . put


------------------------------------------------------------------------------
instance (MonadTrans t, MonadWriter w m) => MonadWriter w (t m) where
    tell     = lift . tell
    listen m = lifted $ \unlift -> listen $ unlift m
    pass   m = lifted $ \unlift -> pass   $ unlift m