[project @ 2003-05-12 10:16:22 by ross]

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

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 260074d..eae9a3a 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -60,8 +60,8 @@ import Data.Maybe
 import Foreign
 import Foreign.C
 import System.IO.Error
+import System.Posix.Internals
 
-import GHC.Posix
 import GHC.Real
 
 import GHC.Arr
@@ -319,24 +319,14 @@ stdHandleFinalizer m = do
 
 handleFinalizer :: MVar Handle__ -> IO ()
 handleFinalizer m = do
-  h_ <- takeMVar m
-  let
-    -- hClose puts both the fd and the handle's type
-    -- into a closed state, so it's a bit excessive
-    -- to test for both here, but caution sometimes
-    -- pays off..
-   alreadyClosed = 
-     case haType h_ of { ClosedHandle{} -> True; _ -> False }
-   fd = fromIntegral (haFD h_)
-
-  when (not alreadyClosed && fd /= -1) $ do
-       flushWriteBufferOnly h_
-       unlockFile fd
-#ifdef mingw32_TARGET_OS
-       (closeFd (haIsStream h_) fd >> return ())
-#else
-       (c_close fd >> return ())
-#endif
+  handle_ <- takeMVar m
+  case haType handle_ of 
+      ClosedHandle -> return ()
+      _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
+               -- ignore errors and async exceptions, and close the
+               -- descriptor anyway...
+             hClose_handle_ handle_
+             return ()
 
 -- ---------------------------------------------------------------------------
 -- Grimy buffer operations
@@ -839,7 +829,7 @@ mkDuplexHandle fd is_stream filepath binary = do
                      }
   read_side <- newMVar r_handle_
 
-  addMVarFinalizer read_side (handleFinalizer read_side)
+  addMVarFinalizer write_side (handleFinalizer write_side)
   return (DuplexHandle read_side write_side)
    
 
@@ -871,37 +861,38 @@ hClose_help :: Handle__ -> IO Handle__
 hClose_help handle_ =
   case haType handle_ of 
       ClosedHandle -> return handle_
-      _ -> do
-         let fd = haFD handle_
-             c_fd = fromIntegral fd
-
-         flushWriteBufferOnly handle_
-
-         -- close the file descriptor, but not when this is the read
-         -- side of a duplex handle, and not when this is one of the
-         -- std file handles.
-         case haOtherSide handle_ of
-           Nothing -> 
-               when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
-                       throwErrnoIfMinus1Retry_ "hClose" 
+      _ -> do flushWriteBufferOnly handle_ -- interruptible
+             hClose_handle_ handle_
+
+hClose_handle_ handle_ = do
+    let fd = haFD handle_
+        c_fd = fromIntegral fd
+
+    -- close the file descriptor, but not when this is the read
+    -- side of a duplex handle, and not when this is one of the
+    -- std file handles.
+    case haOtherSide handle_ of
+      Nothing -> 
+         when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
+                 throwErrnoIfMinus1Retry_ "hClose" 
 #ifdef mingw32_TARGET_OS
                                (closeFd (haIsStream handle_) c_fd)
 #else
                                (c_close c_fd)
 #endif
-           Just _  -> return ()
-
-         -- free the spare buffers
-         writeIORef (haBuffers handle_) BufferListNil
-
-         -- unlock it
-         unlockFile c_fd
+      Just _  -> return ()
 
-         -- we must set the fd to -1, because the finalizer is going
-         -- to run eventually and try to close/unlock it.
-         return (handle_{ haFD        = -1, 
-                          haType      = ClosedHandle
-                        })
+    -- free the spare buffers
+    writeIORef (haBuffers handle_) BufferListNil
+  
+    -- unlock it
+    unlockFile c_fd
+  
+    -- we must set the fd to -1, because the finalizer is going
+    -- to run eventually and try to close/unlock it.
+    return (handle_{ haFD        = -1, 
+                    haType      = ClosedHandle
+                  })
 
 -----------------------------------------------------------------------------
 -- Detecting the size of a file
@@ -1257,10 +1248,9 @@ hIsSeekable handle =
                                                || tEXT_MODE_SEEK_ALLOWED))
 
 -- -----------------------------------------------------------------------------
--- Changing echo status
+-- Changing echo status (Non-standard GHC extensions)
 
--- Non-standard GHC extension is to allow the echoing status
--- of a handles connected to terminals to be reconfigured:
+-- | Set the echoing status of a handle connected to a terminal (GHC only).
 
 hSetEcho :: Handle -> Bool -> IO ()
 hSetEcho handle on = do
@@ -1273,6 +1263,8 @@ hSetEcho handle on = do
          ClosedHandle -> ioe_closedHandle
          _            -> setEcho (haFD handle_) on
 
+-- | Get the echoing status of a handle connected to a terminal (GHC only).
+
 hGetEcho :: Handle -> IO Bool
 hGetEcho handle = do
     isT   <- hIsTerminalDevice handle
@@ -1284,6 +1276,8 @@ hGetEcho handle = do
          ClosedHandle -> ioe_closedHandle
          _            -> getEcho (haFD handle_)
 
+-- | Is the handle connected to a terminal? (GHC only)
+
 hIsTerminalDevice :: Handle -> IO Bool
 hIsTerminalDevice handle = do
     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do