-- |
-- 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 :: (Content IO -> IO a) -> IO a
embed Content IO -> IO a
f = Content IO -> IO a
f Content IO
forall a. HasCallStack => a
undefined
	callback :: IO a -> Content IO -> IO a
callback IO a
action Content IO
_ = IO a
action

-- |'bracket' equivalent.
bracketE :: EmbedIO m => m r -> (r -> m b) -> (r -> m a) -> m a
bracketE :: m r -> (r -> m b) -> (r -> m a) -> m a
bracketE m r
before r -> m b
after r -> m a
during =
	(Content m -> IO a) -> m a
forall (o :: * -> *) a. EmbedIO o => (Content o -> IO a) -> o a
embed ((Content m -> IO a) -> m a) -> (Content m -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \Content m
x -> IO r -> (r -> IO b) -> (r -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Content m -> IO r
before' Content m
x) (\r
a -> r -> Content m -> IO b
after' r
a Content m
x) (\r
a -> r -> Content m -> IO a
during' r
a Content m
x)
	where
	before' :: Content m -> IO r
before' Content m
x = m r -> Content m -> IO r
forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback m r
before Content m
x
	after' :: r -> Content m -> IO b
after' r
a Content m
x = m b -> Content m -> IO b
forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback (r -> m b
after r
a) Content m
x
	during' :: r -> Content m -> IO a
during' r
a Content m
x = m a -> Content m -> IO a
forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback (r -> m a
during r
a) Content m
x

-- |'catch' equivalent.
catchE :: (EmbedIO m, Exception e) => m a -> (e -> m a) -> m a
catchE :: m a -> (e -> m a) -> m a
catchE m a
action e -> m a
handler = (Content m -> IO a) -> m a
forall (o :: * -> *) a. EmbedIO o => (Content o -> IO a) -> o a
embed ((Content m -> IO a) -> m a) -> (Content m -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \Content m
x -> IO a -> (e -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Content m -> IO a
action' Content m
x) (\e
e -> e -> Content m -> IO a
handler' e
e Content m
x)
	where
	action' :: Content m -> IO a
action' Content m
x = m a -> Content m -> IO a
forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback m a
action Content m
x
	handler' :: e -> Content m -> IO a
handler' e
e Content m
x = m a -> Content m -> IO a
forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback (e -> m a
handler e
e) Content m
x

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

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

-- |'throw' equivalent.
throwE :: (EmbedIO m, Exception e) => e -> m a
throwE :: e -> m a
throwE = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (e -> IO a) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall e a. Exception e => e -> IO a
throwIO

-- |'forkIO' equivalent.
forkE :: EmbedIO m => m () -> m ThreadId
forkE :: m () -> m ThreadId
forkE m ()
action = (Content m -> IO ThreadId) -> m ThreadId
forall (o :: * -> *) a. EmbedIO o => (Content o -> IO a) -> o a
embed ((Content m -> IO ThreadId) -> m ThreadId)
-> (Content m -> IO ThreadId) -> m ThreadId
forall a b. (a -> b) -> a -> b
$ \Content m
x -> IO () -> IO ThreadId
forkIO (m () -> Content m -> IO ()
forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback m ()
action Content m
x)