[project @ 2003-07-21 16:50:20 by simonmar]

GHC's instance Show Handle is wrong, because it is impure.  This
commit makes the Show instance pure by restricting what it shows to
just the filename.

I moved the filename from the Handle__ (the mutable portion of the
Handle) to the Handle proper, to facilitate this.  This might result
in a small performance improvment because Handle__ is now slightly
smaller.

Also added:

  GHC.Handle.hShow :: Handle -> IO String

which provides the old functionality, but now in the IO monad.
Pending discussion on the libraries list, this may be exposed by
System.IO.

Also, while I was here, I did something I've been meaning to do for a
long time: change the godawful IOError Show instance.

Previously:

   illegal operation
   Action: hGetChar
   Handle: {loc=<stdin>,type=semi-closed,binary=False,buffering=block (8192)}
   Reason: handle is closed
   File: <stdin>

Now:

   <stdin>: hGetChar: illegal operation (handle is closed)

This is going to result in a bunch of test failures, but I'll deal
with those later.

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 26e4140..d5cada3 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -46,6 +46,8 @@ module GHC.Handle (
   hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
   hSetEcho, hGetEcho, hIsTerminalDevice,
 
+  hShow,
+
 #ifdef DEBUG_DUMP
   puts,
 #endif
@@ -96,11 +98,11 @@ dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
 -- ---------------------------------------------------------------------------
 -- Creating a new handle
 
-newFileHandle     :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle finalizer hc = do 
+newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
+newFileHandle filepath finalizer hc = do 
   m <- newMVar hc
   addMVarFinalizer m (finalizer m)
-  return (FileHandle m)
+  return (FileHandle filepath m)
 
 -- ---------------------------------------------------------------------------
 -- Working with Handles
@@ -129,8 +131,8 @@ but we might want to revisit this in the future --SDM ].
 
 {-# INLINE withHandle #-}
 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle fun h@(FileHandle m)     act = withHandle' fun h m act
-withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
+withHandle fun h@(FileHandle _ m)     act = withHandle' fun h m act
+withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
 
 withHandle' :: String -> Handle -> MVar Handle__
    -> (Handle__ -> IO (Handle__,a)) -> IO a
@@ -141,16 +143,16 @@ withHandle' fun h m act =
    (h',v)  <- catchException (act h_) 
                (\ err -> putMVar m h_ >>
                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h h_)
-                             _ -> throw err)
+                            IOException ex -> ioError (augmentIOError ex fun h)
+                            _ -> throw err)
    checkBufferInvariants h'
    putMVar m h'
    return v
 
 {-# INLINE withHandle_ #-}
 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
-withHandle_ fun h@(FileHandle m)     act = withHandle_' fun h m act
-withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
+withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act
+withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
 
 withHandle_' fun h m act = 
    block $ do
@@ -159,15 +161,15 @@ withHandle_' fun h m act =
    v  <- catchException (act h_) 
                (\ err -> putMVar m h_ >>
                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h h_)
-                             _ -> throw err)
+                            IOException ex -> ioError (augmentIOError ex fun h)
+                            _ -> throw err)
    checkBufferInvariants h_
    putMVar m h_
    return v
 
 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
-withAllHandles__ fun h@(FileHandle m)     act = withHandle__' fun h m act
-withAllHandles__ fun h@(DuplexHandle r w) act = do
+withAllHandles__ fun h@(FileHandle _ m)     act = withHandle__' fun h m act
+withAllHandles__ fun h@(DuplexHandle _ r w) act = do
   withHandle__' fun h r act
   withHandle__' fun h w act
 
@@ -178,24 +180,27 @@ withHandle__' fun h m act =
    h'  <- catchException (act h_)
                (\ err -> putMVar m h_ >>
                          case err of
-                             IOException ex -> ioError (augmentIOError ex fun h h_)
-                             _ -> throw err)
+                            IOException ex -> ioError (augmentIOError ex fun h)
+                            _ -> throw err)
    checkBufferInvariants h'
    putMVar m h'
    return ()
 
-augmentIOError (IOError _ iot _ str fp) fun h h_
+augmentIOError (IOError _ iot _ str fp) fun h
   = IOError (Just h) iot fun str filepath
-  where filepath | Just _ <- fp = fp
-                | otherwise    = Just (haFilePath h_)
+  where filepath
+         | Just _ <- fp = fp
+         | otherwise = case h of
+                         FileHandle fp _     -> Just fp
+                         DuplexHandle fp _ _ -> Just fp
 
 -- ---------------------------------------------------------------------------
 -- Wrapper for write operations.
 
 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantWritableHandle fun h@(FileHandle m) act
+wantWritableHandle fun h@(FileHandle _ m) act
   = wantWritableHandle' fun h m act
-wantWritableHandle fun h@(DuplexHandle _ m) act
+wantWritableHandle fun h@(DuplexHandle _ _ m) act
   = wantWritableHandle' fun h m act
   -- ToDo: in the Duplex case, we don't need to checkWritableHandle
 
@@ -226,9 +231,9 @@ checkWritableHandle act handle_
 -- Wrapper for read operations.
 
 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantReadableHandle fun h@(FileHandle   m)   act
+wantReadableHandle fun h@(FileHandle  _ m)   act
   = wantReadableHandle' fun h m act
-wantReadableHandle fun h@(DuplexHandle m _) act
+wantReadableHandle fun h@(DuplexHandle _ m _) act
   = wantReadableHandle' fun h m act
   -- ToDo: in the Duplex case, we don't need to checkReadableHandle
 
@@ -257,10 +262,10 @@ checkReadableHandle act handle_ =
 -- Wrapper for seek operations.
 
 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantSeekableHandle fun h@(DuplexHandle _ _) _act =
+wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
   ioException (IOError (Just h) IllegalOperation fun 
                   "handle is not seekable" Nothing)
-wantSeekableHandle fun h@(FileHandle m) act =
+wantSeekableHandle fun h@(FileHandle _ m) act =
   withHandle_' fun h m (checkSeekableHandle act)
   
 checkSeekableHandle act handle_ = 
@@ -756,13 +761,12 @@ mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
        -> IO Handle
 mkStdHandle fd filepath ha_type buf bmode = do
    spares <- newIORef BufferListNil
-   newFileHandle stdHandleFinalizer
+   newFileHandle filepath stdHandleFinalizer
            (Handle__ { haFD = fd,
                        haType = ha_type,
                         haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
                        haIsStream = False,
                        haBufferMode = bmode,
-                       haFilePath = filepath,
                        haBuffer = buf,
                        haBuffers = spares,
                        haOtherSide = Nothing
@@ -772,13 +776,12 @@ mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
 mkFileHandle fd is_stream filepath ha_type binary = do
   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
   spares <- newIORef BufferListNil
-  newFileHandle handleFinalizer
+  newFileHandle filepath handleFinalizer
            (Handle__ { haFD = fd,
                        haType = ha_type,
                         haIsBin = binary,
                        haIsStream = is_stream,
                        haBufferMode = bmode,
-                       haFilePath = filepath,
                        haBuffer = buf,
                        haBuffers = spares,
                        haOtherSide = Nothing
@@ -794,7 +797,6 @@ mkDuplexHandle fd is_stream filepath binary = do
                         haIsBin = binary,
                        haIsStream = is_stream,
                        haBufferMode = w_bmode,
-                       haFilePath = filepath,
                        haBuffer = w_buf,
                        haBuffers = w_spares,
                        haOtherSide = Nothing
@@ -809,7 +811,6 @@ mkDuplexHandle fd is_stream filepath binary = do
                         haIsBin = binary,
                        haIsStream = is_stream,
                        haBufferMode = r_bmode,
-                       haFilePath = filepath,
                        haBuffer = r_buf,
                        haBuffers = r_spares,
                        haOtherSide = Just write_side
@@ -817,7 +818,7 @@ mkDuplexHandle fd is_stream filepath binary = do
   read_side <- newMVar r_handle_
 
   addMVarFinalizer write_side (handleFinalizer write_side)
-  return (DuplexHandle read_side write_side)
+  return (DuplexHandle filepath read_side write_side)
    
 
 initBufferState ReadHandle = ReadBuffer
@@ -834,8 +835,8 @@ initBufferState _      = WriteBuffer
 -- the read side.
 
 hClose :: Handle -> IO ()
-hClose h@(FileHandle m)     = hClose' h m
-hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
+hClose h@(FileHandle _ m)     = hClose' h m
+hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
 
 hClose' h m = withHandle__' "hClose" h m $ hClose_help
 
@@ -1193,7 +1194,7 @@ hIsClosed handle =
 -}
 
 hIsReadable :: Handle -> IO Bool
-hIsReadable (DuplexHandle _ _) = return True
+hIsReadable (DuplexHandle _ _ _) = return True
 hIsReadable handle =
     withHandle_ "hIsReadable" handle $ \ handle_ -> do
     case haType handle_ of 
@@ -1202,7 +1203,7 @@ hIsReadable handle =
       htype               -> return (isReadableHandleType htype)
 
 hIsWritable :: Handle -> IO Bool
-hIsWritable (DuplexHandle _ _) = return True
+hIsWritable (DuplexHandle _ _ _) = return True
 hIsWritable handle =
     withHandle_ "hIsWritable" handle $ \ handle_ -> do
     case haType handle_ of 
@@ -1301,16 +1302,16 @@ foreign import ccall unsafe "__hscore_setmode"
 -- discarding any input data, before the handle is duplicated.
 
 hDuplicate :: Handle -> IO Handle
-hDuplicate h@(FileHandle m) = do
+hDuplicate h@(FileHandle path m) = do
   new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
   new_m <- newMVar new_h_
-  return (FileHandle new_m)
-hDuplicate h@(DuplexHandle r w) = do
+  return (FileHandle path new_m)
+hDuplicate h@(DuplexHandle path r w) = do
   new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
   new_w <- newMVar new_w_
   new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
   new_r <- newMVar new_r_
-  return (DuplexHandle new_r new_w)
+  return (DuplexHandle path new_r new_w)
 
 dupHandle_ other_side h_ = do
   -- flush the buffer first, so we don't have to copy its contents
@@ -1340,11 +1341,11 @@ This can be used to retarget the standard Handles, for example:
 -}
 
 hDuplicateTo :: Handle -> Handle -> IO ()
-hDuplicateTo h1@(FileHandle m1) h2@(FileHandle m2)  = do
+hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2)  = do
  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
    _ <- hClose_help h2_
    withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
-hDuplicateTo h1@(DuplexHandle r1 w1) h2@(DuplexHandle r2 w2)  = do
+hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2)  = do
  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
    _ <- hClose_help w2_
    withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
@@ -1356,6 +1357,49 @@ hDuplicateTo h1 _ =
                "handles are incompatible" Nothing)
 
 -- ---------------------------------------------------------------------------
+-- showing Handles.
+--
+-- hShow is in the IO monad, and gives more comprehensive output
+-- than the (pure) instance of Show for Handle.
+
+hShow :: Handle -> IO String
+hShow h@(FileHandle path _) = showHandle' path False h
+hShow h@(DuplexHandle path _ _) = showHandle' path True h
+
+showHandle' filepath is_duplex h = 
+  withHandle_ "showHandle" h $ \hdl_ ->
+    let
+     showType | is_duplex = showString "duplex (read-write)"
+             | otherwise = shows (haType hdl_)
+    in
+    return 
+      (( showChar '{' . 
+        showHdl (haType hdl_) 
+           (showString "loc=" . showString filepath . showChar ',' .
+            showString "type=" . showType . showChar ',' .
+            showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
+            showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
+      ) "")
+   where
+
+    showHdl :: HandleType -> ShowS -> ShowS
+    showHdl ht cont = 
+       case ht of
+        ClosedHandle  -> shows ht . showString "}"
+       _ -> cont
+
+    showBufMode :: Buffer -> BufferMode -> ShowS
+    showBufMode buf bmo =
+      case bmo of
+        NoBuffering   -> showString "none"
+       LineBuffering -> showString "line"
+       BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
+       BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
+      where
+       def :: Int 
+       def = bufSize buf
+
+-- ---------------------------------------------------------------------------
 -- debugging
 
 #ifdef DEBUG_DUMP

diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs
index 43073c0..cbad7db 100644 (file)
--- a/GHC/IOBase.lhs
+++ b/GHC/IOBase.lhs
@@ -222,9 +222,12 @@ instance Eq (MVar a) where
 
 data Handle 
   = FileHandle                         -- A normal handle to a file
+       FilePath                        -- the file (invariant)
        !(MVar Handle__)
 
   | DuplexHandle                       -- A handle to a read/write stream
+       FilePath                        -- file for a FIFO, otherwise some
+                                       --   descriptive string.
        !(MVar Handle__)                -- The read side
        !(MVar Handle__)                -- The write side
 
@@ -233,8 +236,8 @@ data Handle
 --      seekable.
 
 instance Eq Handle where
- (FileHandle h1)     == (FileHandle h2)     = h1 == h2
- (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2
+ (FileHandle _ h1)     == (FileHandle _ h2)     = h1 == h2
+ (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2
  _ == _ = False 
 
 type FD = Int -- XXX ToDo: should be CInt
@@ -246,7 +249,6 @@ data Handle__
       haIsBin       :: Bool,                -- binary mode?
       haIsStream    :: Bool,                -- is this a stream handle?
       haBufferMode  :: BufferMode,          -- buffer contains read/write data?
-      haFilePath    :: FilePath,            -- file name, possibly
       haBuffer     :: !(IORef Buffer),      -- the current buffer
       haBuffers     :: !(IORef BufferList),  -- spare buffers
       haOtherSide   :: Maybe (MVar Handle__) -- ptr to the write side of a 
@@ -467,46 +469,10 @@ instance Show HandleType where
       ReadWriteHandle   -> showString "read-writable"
 
 instance Show Handle where 
-  showsPrec p (FileHandle   h)   = showHandle p h False
-  showsPrec p (DuplexHandle _ h) = showHandle p h True
-   
-showHandle p h duplex =
-    let
-     -- (Big) SIGH: unfolded defn of takeMVar to avoid
-     -- an (oh-so) unfortunate module loop with GHC.Conc.
-     hdl_ = unsafePerformIO (IO $ \ s# ->
-            case h                 of { MVar h# ->
-            case takeMVar# h# s#   of { (# s2# , r #) -> 
-            case putMVar# h# r s2# of { s3# ->
-            (# s3#, r #) }}})
-
-     showType | duplex = showString "duplex (read-write)"
-             | otherwise = showsPrec p (haType hdl_)
-    in
-    showChar '{' . 
-    showHdl (haType hdl_) 
-           (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
-            showString "type=" . showType . showChar ',' .
-            showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' .
-            showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
-   where
-
-    showHdl :: HandleType -> ShowS -> ShowS
-    showHdl ht cont = 
-       case ht of
-        ClosedHandle  -> showsPrec p ht . showString "}"
-       _ -> cont
-       
-    showBufMode :: Buffer -> BufferMode -> ShowS
-    showBufMode buf bmo =
-      case bmo of
-        NoBuffering   -> showString "none"
-       LineBuffering -> showString "line"
-       BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
-       BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
-      where
-       def :: Int 
-       def = bufSize buf
+  showsPrec p (FileHandle   file _)   = showHandle file
+  showsPrec p (DuplexHandle file _ _) = showHandle file
+
+showHandle file = showString "{handle: " . showString file . showString "}"
 
 -- ------------------------------------------------------------------------
 -- Exception datatype and operations
@@ -830,19 +796,18 @@ userError str     =  IOError Nothing UserError "" str Nothing
 
 instance Show IOException where
     showsPrec p (IOError hdl iot loc s fn) =
-      showsPrec p iot .
+      (case fn of
+        Nothing -> case hdl of
+                       Nothing -> id
+                       Just h  -> showsPrec p h . showString ": "
+        Just name -> showString name . showString ": ") .
       (case loc of
          "" -> id
-        _  -> showString "\nAction: " . showString loc) .
-      (case hdl of
-        Nothing -> id
-       Just h  -> showString "\nHandle: " . showsPrec p h) .
+        _  -> showString loc . showString ": ") .
+      showsPrec p iot . 
       (case s of
         "" -> id
-        _  -> showString "\nReason: " . showString s) .
-      (case fn of
-        Nothing -> id
-        Just name -> showString "\nFile: " . showString name)
+        _  -> showString " (" . showString s . showString ")")
 
 -- -----------------------------------------------------------------------------
 -- IOMode type