ghc/tests/concurrent/should_run/conc022.hs

   1 -- !!! test tryTakeMVar
   2
   3 import Concurrent
   4 import Exception
   5 import IO
   6
   7 import PrelIOBase
   8 import PrelConc
   9 import PrelGHC
  10
  11 main = do
  12   m <- newEmptyMVar
  13   r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
  14   print (r :: Maybe Int)
  15
  16
  17 timeout
  18    :: Int       -- secs
  19    -> IO a      -- action to run
  20    -> IO a      -- action to run on timeout
  21    -> IO a
  22
  23 timeout secs action on_timeout
  24   = do
  25     threadid <- myThreadId
  26     timeout <- forkIOIgnoreExceptions (
  27                             do threadDelay (secs * 1000000)
  28                                raiseInThread threadid (ErrorCall "__timeout")
  29                           )
  30     ( do result <- action
  31          killThread timeout
  32          return result
  33       )
  34       `catchAllIO`
  35       ( \exception -> case exception of
  36                        ErrorCall "__timeout" -> on_timeout
  37                        _other                -> do
  38                                                 killThread timeout
  39                                                 throw exception )
  40
  41 forkIOIgnoreExceptions :: IO () -> IO ThreadId
  42 forkIOIgnoreExceptions action = IO $ \ s ->
  43    case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
  44  where
  45   action_plus = catchAllIO action (\_ -> return ())
  46