Improving MonadIO

[Ben Franksen]

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 at .
-- 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