X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FTimeout.hs;fp=System%2FTimeout.hs;h=634b3548afcc156e6156a1af8c7318b14a531b05;hb=8e9892cd14b7558649fcd9ba0597805eb57505b3;hp=ce487b5d1c8fc4d9e23c8a3caa31b5ef959b21f3;hpb=b3768993c0fa634d54a15a0eefa370208110be21;p=ghc-base.git

diff --git a/System/Timeout.hs b/System/Timeout.hs
index ce487b5..634b354 100644
--- a/System/Timeout.hs
+++ b/System/Timeout.hs
@@ -19,11 +19,12 @@ timeout :: Int -> IO a -> IO (Maybe a)
 timeout n f = fmap Just f
 #else
 
-import Prelude             (IO, Ord((<)), Eq((==)), Int, (.), otherwise, fmap)
+import Prelude             (Show(show), IO, Ord((<)), Eq((==)), Int,
+                            (.), otherwise, fmap)
 import Data.Maybe          (Maybe(..))
 import Control.Monad       (Monad(..), guard)
 import Control.Concurrent  (forkIO, threadDelay, myThreadId, killThread)
-import Control.Exception   (handleJust, throwDynTo, dynExceptions, bracket)
+import Control.Exception   (Exception, handleJust, throwTo, bracket)
 import Data.Dynamic        (Typeable, fromDynamic)
 import Data.Unique         (Unique, newUnique)
 
@@ -33,6 +34,11 @@ import Data.Unique         (Unique, newUnique)
 
 data Timeout = Timeout Unique deriving (Eq, Typeable)
 
+instance Show Timeout where
+    show _ = "<<timeout>>"
+
+instance Exception Timeout
+
 -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
 -- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
 -- is available before the timeout expires, @Just a@ is returned. A negative
@@ -69,9 +75,9 @@ timeout n f
     | otherwise = do
         pid <- myThreadId
         ex  <- fmap Timeout newUnique
-        handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==))
+        handleJust (\e -> if e == ex then Just () else Nothing)
                    (\_ -> return Nothing)
-                   (bracket (forkIO (threadDelay n >> throwDynTo pid ex))
+                   (bracket (forkIO (threadDelay n >> throwTo pid ex))
                             (killThread)
                             (\_ -> fmap Just f))
 #endif