blob: 5d420d8af7355493e4f9d3dfac102c274c8b7fd6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
{-# LANGUAGE MagicHash #-}
-- !!! test tryTakeMVar
import Control.Concurrent
import Control.Exception
import GHC.Exts ( fork# )
import GHC.IO ( IO(..) )
import GHC.Conc ( ThreadId(..) )
main = do
m <- newEmptyMVar
r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
print (r :: Maybe Int)
m <- newMVar True
r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
print r
timeout
:: Int -- secs
-> IO a -- action to run
-> IO a -- action to run on timeout
-> IO a
timeout secs action on_timeout
= do
threadid <- myThreadId
timeout <- forkIO $ do threadDelay (secs * 1000000)
throwTo threadid (ErrorCall "__timeout")
( do result <- action
killThread timeout
return result
)
`Control.Exception.catch`
\exception -> case fromException exception of
Just (ErrorCall "__timeout") -> on_timeout
_other -> do killThread timeout
throw exception
|
