This patch adds a timeout function to the base libraries. Trac #980 is
[packages/old-time.git] / System / Timeout.hs
1 {-# OPTIONS -fglasgow-exts #-}
2 -------------------------------------------------------------------------------
3 -- |
4 -- Module : System.Timeout
5 -- Copyright : (c) 2006 Taral
6 -- License : BSD-style (see the file libraries/base/LICENSE)
7 --
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable
11 --
12 -- Attach a timeout event to arbitrary 'IO' computations.
13 --
14 -------------------------------------------------------------------------------
15
16 module System.Timeout ( timeout ) where
17
18 import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
19 import Control.Exception (handleJust, throwDynTo, dynExceptions, bracket)
20 import Control.Monad (guard)
21 import Data.Dynamic (Typeable, fromDynamic)
22 import Data.Unique (Unique, newUnique)
23
24 -- An internal type that is thrown as a dynamic exception to interrupt the
25 -- running IO computation when the timeout has expired.
26
27 data Timeout = Timeout Unique deriving (Eq, Typeable)
28
29 -- |Wrap an 'IO' computation to time out and return @Nothing@ if it hasn't
30 -- succeeded after @n@ microseconds. If the computation finishes before the
31 -- timeout expires, @Just a@ is returned. Timeouts are specified in microseconds
32 -- (@1\/10^6@ seconds). Negative values mean \"wait indefinitely\". When
33 -- specifying long timeouts, be careful not to exceed @maxBound :: Int@.
34
35 timeout :: Int -> IO a -> IO (Maybe a)
36 timeout n f
37 | n < 0 = fmap Just f
38 | n == 0 = return Nothing
39 | otherwise = do
40 pid <- myThreadId
41 ex <- fmap Timeout newUnique
42 handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==))
43 (\_ -> return Nothing)
44 (bracket (forkIO (threadDelay n >> throwDynTo pid ex))
45 (killThread)
46 (\_ -> fmap Just f))