X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FTimeout.hs;fp=System%2FTimeout.hs;h=4c37e600dc70d512fea8feaa58e49a173875b226;hb=5249233a5f74979e76f7fb559ba9a397e81cf915;hp=0000000000000000000000000000000000000000;hpb=aabdf00d73c91a25cdfa0dc809260ee24bd70401;p=ghc-base.git

diff --git a/System/Timeout.hs b/System/Timeout.hs
new file mode 100644
index 0000000..4c37e60
--- /dev/null
+++ b/System/Timeout.hs
@@ -0,0 +1,46 @@
+{-# 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))