Fix hReady (trac #1063)

[ghc-base.git] / GHC / Handle.hs

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 0ada376..e94d2d5 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -38,7 +38,7 @@ module GHC.Handle (
 
   stdin, stdout, stderr,
   IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
-  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode,
   hFlush, hDuplicate, hDuplicateTo,
 
   hClose, hClose_help,
@@ -58,7 +58,6 @@ module GHC.Handle (
  ) where
 
 import Control.Monad
-import Data.Bits
 import Data.Maybe
 import Foreign
 import Foreign.C
@@ -77,7 +76,6 @@ import GHC.Exception
 import GHC.Enum
 import GHC.Num          ( Integer(..), Num(..) )
 import GHC.Show
-import GHC.Real         ( toInteger )
 #if defined(DEBUG_DUMP)
 import GHC.Pack
 #endif
@@ -145,11 +143,8 @@ withHandle' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   (h',v)  <- catchException (act h_)
-                (\ err -> putMVar m h_ >>
-                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h)
-                             _ -> throw err)
+   (h',v)  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+              `catchException` \ex -> ioError (augmentIOError ex fun h)
    checkBufferInvariants h'
    putMVar m h'
    return v
@@ -164,11 +159,8 @@ withHandle_' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   v  <- catchException (act h_)
-                (\ err -> putMVar m h_ >>
-                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h)
-                             _ -> throw err)
+   v  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+         `catchException` \ex -> ioError (augmentIOError ex fun h)
    checkBufferInvariants h_
    putMVar m h_
    return v
@@ -183,11 +175,8 @@ withHandle__' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   h'  <- catchException (act h_)
-                (\ err -> putMVar m h_ >>
-                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h)
-                             _ -> throw err)
+   h'  <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+          `catchException` \ex -> ioError (augmentIOError ex fun h)
    checkBufferInvariants h'
    putMVar m h'
    return ()
@@ -308,9 +297,9 @@ ioe_notSeekable_notBin = ioException
       "seek operations on text-mode handles are not allowed on this platform"
         Nothing)
 
-ioe_finalizedHandle fp = throw (IOException
+ioe_finalizedHandle fp = throw
    (IOError Nothing IllegalOperation ""
-        "handle is finalized" (Just fp)))
+        "handle is finalized" (Just fp))
 
 ioe_bufsiz :: Int -> IO a
 ioe_bufsiz n = ioException
@@ -345,7 +334,7 @@ handleFinalizer fp m = do
   handle_ <- takeMVar m
   case haType handle_ of
       ClosedHandle -> return ()
-      _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
+      _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()
                 -- ignore errors and async exceptions, and close the
                 -- descriptor anyway...
               hClose_handle_ handle_
@@ -905,7 +894,7 @@ openFile' filepath mode binary =
     stat@(fd_type,_,_) <- fdStat fd
 
     h <- fdToHandle_stat fd (Just stat) False filepath mode binary
-            `catchException` \e -> do c_close fd; throw e
+            `catchAny` \e -> do c_close fd; throw e
         -- NB. don't forget to close the FD if fdToHandle' fails, otherwise
         -- this FD leaks.
         -- ASSERT: if we just created the file, then fdToHandle' won't fail
@@ -1137,13 +1126,14 @@ hClose' h m = withHandle' "hClose" h m $ hClose_help
 -- then closed immediately.  We have to be careful with DuplexHandles
 -- though: we have to leave the closing to the finalizer in that case,
 -- because the write side may still be in use.
-hClose_help :: Handle__ -> IO (Handle__, Maybe Exception)
+hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
 hClose_help handle_ =
   case haType handle_ of 
       ClosedHandle -> return (handle_,Nothing)
       _ -> do flushWriteBufferOnly handle_ -- interruptible
               hClose_handle_ handle_
 
+hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
 hClose_handle_ handle_ = do
     let fd = haFD handle_
 
@@ -1255,8 +1245,11 @@ isEOF = hIsEOF stdin
 --  * 'isEOFError' if the end of file has been reached.
 
 hLookAhead :: Handle -> IO Char
-hLookAhead handle = do
-  wantReadableHandle "hLookAhead"  handle $ \handle_ -> do
+hLookAhead handle =
+  wantReadableHandle "hLookAhead"  handle hLookAhead'
+
+hLookAhead' :: Handle__ -> IO Char
+hLookAhead' handle_ = do
   let ref     = haBuffer handle_
       fd      = haFD handle_
       is_line = haBufferMode handle_ == LineBuffering
@@ -1266,7 +1259,7 @@ hLookAhead handle = do
   new_buf <- if bufferEmpty buf
                 then fillReadBuffer fd True (haIsStream handle_) buf
                 else return buf
-  
+
   writeIORef ref new_buf
 
   (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)