darcs patch: forkChild, waitForChild, parIO, timeout

[Taral]

On 11/9/06, Simon Marlow <simonmarhaskell at gmail.com> wrote:
> If you can modify your version to nest properly, I think it's a winner.  The
> ideal unique value to use is the ThreadId of the timeout thread.

You know, that's what I though, but then I realized that the timeout
thread's ThreadId isn't easily visible outside of the bracket, where
the catch is. So Unique it is:

module Timeout (timeout) where

import Control.Concurrent(forkIO, threadDelay, myThreadId, killThread)
import Control.Exception(handleJust, throwDynTo, dynExceptions, bracket)
import Control.Monad(guard)
import Data.Dynamic(Typeable, fromDynamic)
import Data.Unique(Unique, newUnique)

data Timeout = Timeout Unique deriving (Eq, Typeable)

timeout :: Int -> IO a -> IO (Maybe a)
timeout n f
    | n < 0 = fmap Just f
    | n == 0 = return Nothing
    | otherwise = do
        pt <- myThreadId
        ex <- fmap Timeout newUnique
        handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==))
                   (\_ -> return Nothing) $
                   bracket (forkIO (threadDelay n >> throwDynTo pt ex))
                           (killThread)
                           (\_ -> fmap Just f)

-- 
Taral <taralx at gmail.com>
"You can't prove anything."
    -- Gödel's Incompetence Theorem