module Control.Monad.Trans.InterleavableIO
( InterleavableIO (..)
, embedCallback
, embedInner
, promoteState
, promoteReader
, promoteWriter
, InterleaveErrorTException (..)
)
where
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Error
import Control.Exception
import Data.IORef
import Data.Typeable
class MonadIO inner => InterleavableIO inner trans buffer | trans -> inner buffer where
embed :: (buffer -> inner result) -> trans result
callback :: buffer -> trans result -> inner result
instance InterleavableIO IO IO () where
embed readBuffer = readBuffer ()
callback = flip const
embedCallback
:: (InterleavableIO innerCaller caller buffer, InterleavableIO innerFunction function buffer)
=> (innerFunction resultFunction -> innerCaller resultCaller)
-> function resultFunction
-> caller resultCaller
embedCallback caller function = embed $ \buffer -> caller $ callback buffer function
embedInner :: (InterleavableIO inner trans innerBuffer)
=> ((buffer, innerBuffer) -> inner result)
-> buffer
-> trans result
embedInner readBuffer buffer = embed $ \innerBuffer -> readBuffer (buffer, innerBuffer)
instance
(MonadIO inner, InterleavableIO deepInner inner buffer) =>
InterleavableIO deepInner (StateT state inner) (IORef state, buffer)
where
embed readBuffer
= do
state <- get >>= (liftIO . newIORef)
result <- lift $ embedInner readBuffer state
liftIO (readIORef state) >>= put
return result
callback (buffer, innerBuffer) function
= do
(result, newState) <- liftIO (readIORef buffer) >>= callback innerBuffer . runStateT function
liftIO $ writeIORef buffer newState
return result
instance
(MonadIO inner, InterleavableIO deepInner inner buffer)
=> InterleavableIO deepInner (ReaderT reader inner) (reader, buffer)
where
embed readBuffer = ask >>= (lift . embedInner readBuffer)
callback (buffer, innerBuffer) function = callback innerBuffer $ runReaderT function buffer
instance
(MonadIO inner, InterleavableIO deepInner inner buffer, Monoid writer) =>
InterleavableIO deepInner (WriterT writer inner) (IORef writer, buffer)
where
embed readBuffer
= do
writer <- liftIO $ newIORef mempty
result <- lift $ embedInner readBuffer writer
liftIO (readIORef writer) >>= tell
return result
callback (buffer, innerBuffer) function
= do
(result, writer) <- callback innerBuffer $ runWriterT function
liftIO $ modifyIORef buffer $ mappend writer
return result
promoteState :: MonadState state monad => State state result -> monad result
promoteState function
= do
(result, state) <- runState function `liftM` get
put state
return result
promoteReader :: MonadReader reader monad => Reader reader result -> monad result
promoteReader function = runReader function `liftM` ask
promoteWriter :: MonadWriter writer monad => Writer writer result -> monad result
promoteWriter function
= tell writer >> return result
where (result, writer) = runWriter function
data InterleaveErrorTException error = InterleaveErrorTException error deriving (Typeable)
instance
( MonadIO inner
, InterleavableIO deepInner inner buffer
, InterleavableIO IO inner buffer
, InterleavableIO IO deepInner buffer
, Error error
, Typeable error)
=> InterleavableIO deepInner (ErrorT error inner) ((), buffer)
where
embed readBuffer
= do
eError
<- lift $ embed $ \buffer -> catchDyn (Right `fmap` callback buffer (readBuffer ((), buffer)))
$ \(InterleaveErrorTException error_) -> return $ Left error_
case eError of
Right result -> return result
Left error_ -> throwError error_
callback ((), buffer) function
= do
eError <- callback buffer $ runErrorT function
case eError of
Right result -> return result
Left error_ -> liftIO $ throwDyn $ InterleaveErrorTException error_