From: Peter Simons <simons@cryp.to>
Date: Fri, 26 Jan 2007 22:26:15 +0000 (+0000)
Subject: This patch adds a timeout function to the base libraries. Trac #980 is
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5249233a5f74979e76f7fb559ba9a397e81cf915;p=ghc-base.git

This patch adds a timeout function to the base libraries. Trac #980 is
concerned with this issue. The design guideline for this implementation
is that 'timeout N E' should behave exactly the same as E as long as E
doesn't time out. In our implementation, this means that E has the same
myThreadId it would have without the timeout wrapper. Any exception E
might throw cancels the timeout and propagates further up. It also
possible for E to receive exceptions thrown to it by another thread.
---

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))