EmbedIO.hs

-- |
-- Stability   :  Ultra-Violence
-- Portability :  I'm too young to die
-- Provides one with the ability to pass her own monads in the callbacks.
{-# LANGUAGE TypeFamilies, EmptyDataDecls #-}
module Control.Monad.EmbedIO
	( EmbedIO(..)
	, Void
	, bracketE
	, catchE
	, handleE
	, tryE
	, throwE
	, forkE
	) where

import Control.Concurrent
import Control.Exception
import Control.Monad.IO.Class
import Prelude hiding (catch)

-- |'MonadIO's that can be collapsed to and restored from a distinct value.
class (MonadIO o) => EmbedIO o where
	-- |Intermediate state storage type.
	type Content o
	-- |Propagate an 'IO' operation over the storage type to the monadic type.
	embed :: (Content o -> IO a) -> o a
	-- |Run the monadic computation using supplied state.
	callback :: o a -> Content o -> IO a

-- |Empty type. Used to represent state for 'IO' monad.
data Void

instance EmbedIO IO where
	type Content IO = Void
	embed f = f undefined
	callback action _ = action

-- |'bracket' equivalent.
bracketE :: EmbedIO 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

-- |'catch' equivalent.
catchE :: (EmbedIO 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

-- |'handle' equivalent.
handleE :: (EmbedIO m, Exception e) => (e -> m a) -> m a -> m a
handleE = flip catchE

-- |'try' equivalent.
tryE :: (EmbedIO m, Exception e) => m a -> m (Either e a)
tryE action = embed $ \x -> try (callback action x)

-- |'throw' equivalent.
throwE :: (EmbedIO m, Exception e) => e -> m a
throwE = liftIO . throwIO

-- |'forkIO' equivalent.
forkE :: EmbedIO m => m () -> m ThreadId
forkE action = embed $ \x -> forkIO (callback action x)