Start to actually use extensible exceptions

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

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index a5ab3c9..c33ddab 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -145,11 +145,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 +161,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 +177,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 +299,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 +336,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 +896,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
@@ -976,6 +967,9 @@ fdToHandle_stat fd mb_stat is_socket filepath mode binary = do
         -- regular files need to be locked
         RegularFile -> do
 #ifndef mingw32_HOST_OS
+           -- On Windows we use explicit exclusion via sopen() to implement
+           -- this locking (see __hscore_open()); on Unix we have to
+           -- implment it in the RTS.
            r <- lockFile fd dev ino (fromBool write)
            when (r == -1)  $
                 ioException (IOError Nothing ResourceBusy "openFile"
@@ -1134,13 +1128,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_