X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FTimeout.hs;h=f27a936ed29edb9a984c7088bd40c8ccde5c3a3b;hb=6e20be4ad2cb641f29e9972aaacd775f82487719;hp=c7e4ee21930158114ac58f1dfc801376471b8902;hpb=48b5ddb3fc2d52d172230da3916e1b06bf36eafa;p=ghc-base.git

diff --git a/System/Timeout.hs b/System/Timeout.hs
index c7e4ee2..f27a936 100644
--- a/System/Timeout.hs
+++ b/System/Timeout.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS -fglasgow-exts #-}
 -------------------------------------------------------------------------------
 -- |
 -- Module      :  System.Timeout
@@ -13,26 +12,35 @@
 --
 -------------------------------------------------------------------------------
 
-module System.Timeout ( timeout ) where
+#ifdef __GLASGOW_HASKELL__
+#include "Typeable.h"
+#endif
 
-#if __NHC__
-timeout :: Int -> IO a -> IO (Maybe a)
-timeout n f = fmap Just f
-#else
+module System.Timeout ( timeout ) where
 
-import Prelude             (IO, Ord((<)), Eq((==)), Int, (.), otherwise, fmap)
+#ifdef __GLASGOW_HASKELL__
+import Prelude             (Show(show), IO, Ord((<)), Eq((==)), Int,
+                            otherwise, fmap)
 import Data.Maybe          (Maybe(..))
-import Control.Monad       (Monad(..), guard)
+import Control.Monad       (Monad(..))
 import Control.Concurrent  (forkIO, threadDelay, myThreadId, killThread)
-import Control.Exception   (handleJust, throwDynTo, dynExceptions, bracket)
-import Data.Dynamic        (Typeable, fromDynamic)
+import Control.Exception   (Exception, handleJust, throwTo, bracket)
+import Data.Typeable
 import Data.Unique         (Unique, newUnique)
+import GHC.Num
 
 -- An internal type that is thrown as a dynamic exception to
 -- interrupt the running IO computation when the timeout has
 -- expired.
 
-data Timeout = Timeout Unique deriving (Eq, Typeable)
+data Timeout = Timeout Unique deriving Eq
+INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout")
+
+instance Show Timeout where
+    show _ = "<<timeout>>"
+
+instance Exception Timeout
+#endif /* !__GLASGOW_HASKELL__ */
 
 -- |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
@@ -57,22 +65,25 @@ data Timeout = Timeout Unique deriving (Eq, Typeable)
 -- blocks, no timeout event can be delivered until the FFI call returns, which
 -- pretty much negates the purpose of the combinator. In practice, however,
 -- this limitation is less severe than it may sound. Standard I\/O functions
--- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', 'Network.Socket.accept', or
+-- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', Network.Socket.accept, or
 -- 'System.IO.hWaitForInput' appear to be blocking, but they really don't
 -- because the runtime system uses scheduling mechanisms like @select(2)@ to
 -- perform asynchronous I\/O, so it is possible to interrupt standard socket
 -- I\/O or file I\/O using this combinator.
 
 timeout :: Int -> IO a -> IO (Maybe a)
+#ifdef __GLASGOW_HASKELL__
 timeout n f
     | n <  0    = fmap Just f
     | n == 0    = return Nothing
     | 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
+#else
+timeout n f = fmap Just f
+#endif /* !__GLASGOW_HASKELL__ */