--- /dev/null
+{-# OPTIONS -fglasgow-exts #-}
+-------------------------------------------------------------------------------
+-- |
+-- Module : System.Timeout
+-- Copyright : (c) 2006 Taral
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Attach a timeout event to arbitrary 'IO' computations.
+--
+-------------------------------------------------------------------------------
+
+module System.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)
+
+-- An internal type that is thrown as a dynamic exception to interrupt the
+-- running IO computation when the timeout has expired.
+
+data Timeout = Timeout Unique deriving (Eq, Typeable)
+
+-- |Wrap an 'IO' computation to time out and return @Nothing@ if it hasn't
+-- succeeded after @n@ microseconds. If the computation finishes before the
+-- timeout expires, @Just a@ is returned. Timeouts are specified in microseconds
+-- (@1\/10^6@ seconds). Negative values mean \"wait indefinitely\". When
+-- specifying long timeouts, be careful not to exceed @maxBound :: Int@.
+
+timeout :: Int -> IO a -> IO (Maybe a)
+timeout n f
+ | n < 0 = fmap Just f
+ | n == 0 = return Nothing
+ | otherwise = do
+ pid <- myThreadId
+ ex <- fmap Timeout newUnique
+ handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==))
+ (\_ -> return Nothing)
+ (bracket (forkIO (threadDelay n >> throwDynTo pid ex))
+ (killThread)
+ (\_ -> fmap Just f))