System/Timeout.hs

   1 {-# OPTIONS -fglasgow-exts #-}
   2 -------------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  System.Timeout
   5 -- Copyright   :  (c) The University of Glasgow 2007
   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))