module Control.Async
(
Async
, forkAsync
, throwToAsync
, killAsync
, isReadyAsync
, waitForAsync
, parIO
)
where
import Control.Concurrent
import Control.Exception
type AsyncMVar a = MVar (Either SomeException a)
data Async a = Child ThreadId (AsyncMVar a)
forkAsync' :: IO a -> AsyncMVar a -> IO (Async a)
forkAsync' f mv = fmap (\p -> Child p mv) (block (forkIO f'))
where
f' = try f >>= tryPutMVar mv >> return ()
forkAsync :: IO a -> IO (Async a)
forkAsync f = newEmptyMVar >>= forkAsync' f
throwToAsync :: Async a -> SomeException -> IO ()
throwToAsync (Child pid _) = throwTo pid
killAsync :: Async a -> IO ()
killAsync (Child pid _) = killThread pid
isReadyAsync :: Async a -> IO Bool
isReadyAsync (Child _ mv) = fmap not (isEmptyMVar mv)
waitForAsync :: Async a -> IO a
waitForAsync (Child _ sync) = fmap (either throw id) (readMVar sync)
parIO :: IO a -> IO a -> IO a
parIO f g = do
sync <- newEmptyMVar
bracket
(forkAsync' f sync)
(killAsync)
(\_ -> bracket
(forkAsync' g sync)
(killAsync)
(waitForAsync))