async-1.3: Control/Async.hs

{- |
   Module      :  Control.Async
   License     :  BSD3
   Maintainer  :  simons@cryp.to
   Stability   :  stable
   Portability :  portable

   An implementation of IO computations that return their value asynchronously.
-}

module Control.Async
  ( Async
  , forkAsync
  , throwToAsync
  , killAsync
  , isReadyAsync
  , waitForAsync
  , parIO
  )
  where

import Control.Concurrent
import Control.Exception

type AsyncMVar a = MVar (Either SomeException a)

-- | @Async a@ represents a value @a@ that is being computed
-- asynchronously, i.e. a value that is going to become available at
-- some point in the future.
data Async a = Child ThreadId (AsyncMVar a)

forkAsync' :: IO a -> AsyncMVar a -> IO (Async a)
forkAsync' f mv = fmap (`Child` mv) (mask $ \unmask -> forkIO (try (unmask f) >>= tryPutMVar mv >> return ()))

-- | Start an asynchronous computation.
forkAsync :: IO a -> IO (Async a)
forkAsync f = newEmptyMVar >>= forkAsync' f

-- | Throw an asynchronous exception to the thread that performs the
-- computation associated with this value.
throwToAsync :: Exception e => Async a -> e -> IO ()
throwToAsync (Child pid _) = throwTo pid

-- | Abort the asynchronous computation associated with this value.
killAsync :: Async a -> IO ()
killAsync (Child pid _) = killThread pid

-- | Test whether the asynchronous value has become available.
isReadyAsync :: Async a -> IO Bool
isReadyAsync (Child _ mv) = fmap not (isEmptyMVar mv)

-- | Wait for the asynchronous value to become available, and retrieve
-- it. If the computation that generated the value has thrown an
-- exception, then that exception will be raised here.
waitForAsync :: Async a -> IO a
waitForAsync (Child _ sync) = fmap (either throw id) (readMVar sync)

-- | Run both computations in parallel and return the @a@ value of the
-- computation that terminates first. An exception in either of the two
-- computations aborts the entire @parIO@ computation.

parIO :: IO a -> IO a -> IO a
parIO f g = do
  sync <- newEmptyMVar
  bracket
    (forkAsync' f sync)
    killAsync
    (\_ -> bracket
             (forkAsync' g sync)
             killAsync
             waitForAsync)