There was once a very inspiring message from Jules Bean on the cafe, about "Monadic Tunneling" (http://www.haskell.org/pipermail/haskell-cafe/2007-July/028501.html). At the time his idea perfectly served my needs, so I wrote a module to encapsulate it. The code is below, maybe it adds another data point to the discussion about a better MonadIO. Note that the generality is not idle, I actually needed the transformer version in my project. (I have been thinking about uploading this to hackage as an independent module.) {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-} module Embed where import Control.Concurrent import Control.Exception import Control.Monad.Trans.Class import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader import Prelude hiding (catch) -- * Class Embed class Embed i o where type Content i o embed :: (Content i o -> i a) -> o a callback :: o a -> Content i o -> i a liftE :: (Embed i o) => i a -> o a liftE action = embed (const action) -- If the inner monad is IO data Void -- | We would like to give an instance @Embed m m@ once and for all @m@. -- Unfortunately this does not play nicely with the generic instances below. instance Embed IO IO where type Content IO IO = Void embed f = f undefined callback action _ = action -- The constraint @Embed IO m@ is more powerful and useful than MonadIO, -- as it allows higher-ranked liftings. io :: (Embed IO m) => IO a -> m a io = liftE bracketE :: Embed IO m => m r -> (r -> m b) -> (r -> m a) -> m a bracketE before after during = embed $ \x -> bracket (before' x) (\a -> after' a x) (\a -> during' a x) where before' x = callback before x after' a x = callback (after a) x during' a x = callback (during a) x catchE :: (Embed IO m, Exception e) => m a -> (e -> m a) -> m a catchE action handler = embed $ \x -> catch (action' x) (\e -> handler' e x) where action' x = callback action x handler' e x = callback (handler e) x handleE :: (Embed IO m, Exception e) => (e -> m a) -> m a -> m a handleE = flip catchE throwE :: (Embed IO m, Exception e) => e -> m a throwE = liftE . throwIO forkE :: Embed IO m => m () -> m ThreadId forkE action = embed $ \x -> forkIO (callback action x) -- * Embedding Transformer class MonadTrans t => Embedding t where type ContentT t embedT :: (ContentT t -> m a) -> t m a callbackT :: t m a -> ContentT t -> m a defaultLift :: Embedding t => m a -> t m a defaultLift = embedT . const instance (Embed i o, Embedding t) => Embed i (t o) where type Content i (t o) = (ContentT t, Content i o) embed f = embedT (\x -> embed (\y -> f (x,y))) callback action (x,y) = callback (callbackT action x) y instance Embedding IdentityT where type ContentT IdentityT = Void embedT f = IdentityT (f undefined) callbackT action _ = runIdentityT action instance Embedding (ReaderT r) where type ContentT (ReaderT r) = r embedT = ReaderT callbackT = runReaderT