GHC/IO/Handle.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude #-}
   2 {-# OPTIONS_GHC -XRecordWildCards #-}
   3 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
   4 -----------------------------------------------------------------------------
   5 -- |
   6 -- Module      :  GHC.IO.Handle
   7 -- Copyright   :  (c) The University of Glasgow, 1994-2009
   8 -- License     :  see libraries/base/LICENSE
   9 --
  10 -- Maintainer  :  libraries@haskell.org
  11 -- Stability   :  provisional
  12 -- Portability :  non-portable
  13 --
  14 -- External API for GHC's Handle implementation
  15 --
  16 -----------------------------------------------------------------------------
  17
  18 module GHC.IO.Handle (
  19    Handle,
  20    BufferMode(..),
  21
  22    mkFileHandle, mkDuplexHandle,
  23
  24    hFileSize, hSetFileSize, hIsEOF, hLookAhead,
  25    hSetBuffering, hSetBinaryMode, hSetEncoding,
  26    hFlush, hDuplicate, hDuplicateTo,
  27
  28    hClose, hClose_help,
  29
  30    HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
  31    SeekMode(..), hSeek, hTell,
  32
  33    hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  34    hSetEcho, hGetEcho, hIsTerminalDevice,
  35
  36    hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline,
  37    noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
  38
  39    hShow,
  40
  41    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
  42
  43    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking
  44  ) where
  45
  46 import GHC.IO
  47 import GHC.IO.Exception
  48 import GHC.IO.Encoding
  49 import GHC.IO.Buffer
  50 import GHC.IO.BufferedIO ( BufferedIO )
  51 import GHC.IO.Device as IODevice
  52 import GHC.IO.Handle.Types
  53 import GHC.IO.Handle.Internals
  54 import GHC.IO.Handle.Text
  55 import System.IO.Error
  56
  57 import GHC.Base
  58 import GHC.Exception
  59 import GHC.MVar
  60 import GHC.IORef
  61 import GHC.Show
  62 import GHC.Num
  63 import GHC.Real
  64 import Data.Maybe
  65 import Data.Typeable
  66 import Control.Monad
  67
  68 -- ---------------------------------------------------------------------------
  69 -- Closing a handle
  70
  71 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the
  72 -- computation finishes, if @hdl@ is writable its buffer is flushed as
  73 -- for 'hFlush'.
  74 -- Performing 'hClose' on a handle that has already been closed has no effect;
  75 -- doing so is not an error.  All other operations on a closed handle will fail.
  76 -- If 'hClose' fails for any reason, any further operations (apart from
  77 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
  78 -- closed.
  79
  80 hClose :: Handle -> IO ()
  81 hClose h@(FileHandle _ m)     = do
  82   mb_exc <- hClose' h m
  83   hClose_maybethrow mb_exc h
  84 hClose h@(DuplexHandle _ r w) = do
  85   mb_exc1 <- hClose' h w
  86   mb_exc2 <- hClose' h r
  87   case mb_exc1 of
  88     Nothing -> return ()
  89     Just e  -> hClose_maybethrow mb_exc2 h
  90
  91 hClose_maybethrow :: Maybe SomeException -> Handle -> IO ()
  92 hClose_maybethrow Nothing  h  = return ()
  93 hClose_maybethrow (Just e) h = hClose_rethrow e h
  94
  95 hClose_rethrow :: SomeException -> Handle -> IO ()
  96 hClose_rethrow e h =
  97   case fromException e of
  98     Just ioe -> ioError (augmentIOError ioe "hClose" h)
  99     Nothing  -> throwIO e
 100
 101 hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
 102 hClose' h m = withHandle' "hClose" h m $ hClose_help
 103
 104 -----------------------------------------------------------------------------
 105 -- Detecting and changing the size of a file
 106
 107 -- | For a handle @hdl@ which attached to a physical file,
 108 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
 109
 110 hFileSize :: Handle -> IO Integer
 111 hFileSize handle =
 112     withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
 113     case haType handle_ of
 114       ClosedHandle              -> ioe_closedHandle
 115       SemiClosedHandle          -> ioe_closedHandle
 116       _ -> do flushWriteBuffer handle_
 117               r <- IODevice.getSize dev
 118               if r /= -1
 119                  then return r
 120                  else ioException (IOError Nothing InappropriateType "hFileSize"
 121                                    "not a regular file" Nothing Nothing)
 122
 123
 124 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
 125
 126 hSetFileSize :: Handle -> Integer -> IO ()
 127 hSetFileSize handle size =
 128     withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
 129     case haType handle_ of
 130       ClosedHandle              -> ioe_closedHandle
 131       SemiClosedHandle          -> ioe_closedHandle
 132       _ -> do flushWriteBuffer handle_
 133               IODevice.setSize dev size
 134               return ()
 135
 136 -- ---------------------------------------------------------------------------
 137 -- Detecting the End of Input
 138
 139 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
 140 -- 'True' if no further input can be taken from @hdl@ or for a
 141 -- physical file, if the current I\/O position is equal to the length of
 142 -- the file.  Otherwise, it returns 'False'.
 143 --
 144 -- NOTE: 'hIsEOF' may block, because it is the same as calling
 145 -- 'hLookAhead' and checking for an EOF exception.
 146
 147 hIsEOF :: Handle -> IO Bool
 148 hIsEOF handle =
 149   catch
 150      (do hLookAhead handle; return False)
 151      (\e -> if isEOFError e then return True else ioError e)
 152
 153 -- ---------------------------------------------------------------------------
 154 -- Looking ahead
 155
 156 -- | Computation 'hLookAhead' returns the next character from the handle
 157 -- without removing it from the input buffer, blocking until a character
 158 -- is available.
 159 --
 160 -- This operation may fail with:
 161 --
 162 --  * 'isEOFError' if the end of file has been reached.
 163
 164 hLookAhead :: Handle -> IO Char
 165 hLookAhead handle =
 166   wantReadableHandle_ "hLookAhead"  handle hLookAhead_
 167
 168 -- ---------------------------------------------------------------------------
 169 -- Buffering Operations
 170
 171 -- Three kinds of buffering are supported: line-buffering,
 172 -- block-buffering or no-buffering.  See GHC.IO.Handle for definition and
 173 -- further explanation of what the type represent.
 174
 175 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
 176 -- handle @hdl@ on subsequent reads and writes.
 177 --
 178 -- If the buffer mode is changed from 'BlockBuffering' or
 179 -- 'LineBuffering' to 'NoBuffering', then
 180 --
 181 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
 182 --
 183 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
 184 --
 185 -- This operation may fail with:
 186 --
 187 --  * 'isPermissionError' if the handle has already been used for reading
 188 --    or writing and the implementation does not allow the buffering mode
 189 --    to be changed.
 190
 191 hSetBuffering :: Handle -> BufferMode -> IO ()
 192 hSetBuffering handle mode =
 193   withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do
 194   case haType of
 195     ClosedHandle -> ioe_closedHandle
 196     _ -> do
 197          if mode == haBufferMode then return handle_ else do
 198
 199          {- Note:
 200             - we flush the old buffer regardless of whether
 201               the new buffer could fit the contents of the old buffer
 202               or not.
 203             - allow a handle's buffering to change even if IO has
 204               occurred (ANSI C spec. does not allow this, nor did
 205               the previous implementation of IO.hSetBuffering).
 206             - a non-standard extension is to allow the buffering
 207               of semi-closed handles to change [sof 6/98]
 208           -}
 209           flushCharBuffer handle_
 210
 211           let state = initBufferState haType
 212               reading = not (isWritableHandleType haType)
 213
 214           new_buf <-
 215             case mode of
 216                 --  See [note Buffer Sizing], GHC.IO.Handle.Types
 217               NoBuffering | reading   -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 218                           | otherwise -> newCharBuffer 1 state
 219               LineBuffering          -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 220               BlockBuffering Nothing -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 221               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 222                                       | otherwise -> newCharBuffer n state
 223
 224           writeIORef haCharBuffer new_buf
 225
 226           -- for input terminals we need to put the terminal into
 227           -- cooked or raw mode depending on the type of buffering.
 228           is_tty <- IODevice.isTerminal haDevice
 229           when (is_tty && isReadableHandleType haType) $
 230                 case mode of
 231 #ifndef mingw32_HOST_OS
 232         -- 'raw' mode under win32 is a bit too specialised (and troublesome
 233         -- for most common uses), so simply disable its use here.
 234                   NoBuffering -> IODevice.setRaw haDevice True
 235 #else
 236                   NoBuffering -> return ()
 237 #endif
 238                   _           -> IODevice.setRaw haDevice False
 239
 240           -- throw away spare buffers, they might be the wrong size
 241           writeIORef haBuffers BufferListNil
 242
 243           return Handle__{ haBufferMode = mode,.. }
 244
 245 -- -----------------------------------------------------------------------------
 246 -- hSetEncoding
 247
 248 -- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding
 249 -- for the handle @hdl@ to @encoding@.  Encodings are available from the
 250 -- module "GHC.IO.Encoding".  The default encoding when a 'Handle' is
 251 -- created is 'localeEncoding', namely the default encoding for the current
 252 -- locale.
 253 --
 254 -- To create a 'Handle' with no encoding at all, use 'openBinaryFile'.  To
 255 -- stop further encoding or decoding on an existing 'Handle', use
 256 -- 'hSetBinaryMode'.
 257 --
 258 hSetEncoding :: Handle -> TextEncoding -> IO ()
 259 hSetEncoding hdl encoding = do
 260   withHandle "hSetEncoding" hdl $ \h_@Handle__{..} -> do
 261     flushCharBuffer h_
 262     openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do
 263     bbuf <- readIORef haByteBuffer
 264     ref <- newIORef (error "last_decode")
 265     return (Handle__{ haLastDecode = ref, haDecoder = mb_decoder, haEncoder = mb_encoder, .. },
 266             ())
 267
 268 -- -----------------------------------------------------------------------------
 269 -- hFlush
 270
 271 -- | The action 'hFlush' @hdl@ causes any items buffered for output
 272 -- in handle @hdl@ to be sent immediately to the operating system.
 273 --
 274 -- This operation may fail with:
 275 --
 276 --  * 'isFullError' if the device is full;
 277 --
 278 --  * 'isPermissionError' if a system resource limit would be exceeded.
 279 --    It is unspecified whether the characters in the buffer are discarded
 280 --    or retained under these circumstances.
 281
 282 hFlush :: Handle -> IO ()
 283 hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
 284
 285 -- -----------------------------------------------------------------------------
 286 -- Repositioning Handles
 287
 288 data HandlePosn = HandlePosn Handle HandlePosition
 289
 290 instance Eq HandlePosn where
 291     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 292
 293 instance Show HandlePosn where
 294    showsPrec p (HandlePosn h pos) =
 295         showsPrec p h . showString " at position " . shows pos
 296
 297   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 298   -- We represent it as an Integer on the Haskell side, but
 299   -- cheat slightly in that hGetPosn calls upon a C helper
 300   -- that reports the position back via (merely) an Int.
 301 type HandlePosition = Integer
 302
 303 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
 304 -- @hdl@ as a value of the abstract type 'HandlePosn'.
 305
 306 hGetPosn :: Handle -> IO HandlePosn
 307 hGetPosn handle = do
 308     posn <- hTell handle
 309     return (HandlePosn handle posn)
 310
 311 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
 312 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
 313 -- to the position it held at the time of the call to 'hGetPosn'.
 314 --
 315 -- This operation may fail with:
 316 --
 317 --  * 'isPermissionError' if a system resource limit would be exceeded.
 318
 319 hSetPosn :: HandlePosn -> IO ()
 320 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 321
 322 -- ---------------------------------------------------------------------------
 323 -- hSeek
 324
 325 {- Note:
 326  - when seeking using `SeekFromEnd', positive offsets (>=0) means
 327    seeking at or past EOF.
 328
 329  - we possibly deviate from the report on the issue of seeking within
 330    the buffer and whether to flush it or not.  The report isn't exactly
 331    clear here.
 332 -}
 333
 334 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
 335 -- @hdl@ depending on @mode@.
 336 -- The offset @i@ is given in terms of 8-bit bytes.
 337 --
 338 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
 339 -- in the current buffer will first cause any items in the output buffer to be
 340 -- written to the device, and then cause the input buffer to be discarded.
 341 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
 342 -- subset of the possible positioning operations (for instance, it may only
 343 -- be possible to seek to the end of a tape, or to a positive offset from
 344 -- the beginning or current position).
 345 -- It is not possible to set a negative I\/O position, or for
 346 -- a physical file, an I\/O position beyond the current end-of-file.
 347 --
 348 -- This operation may fail with:
 349 --
 350 --  * 'isPermissionError' if a system resource limit would be exceeded.
 351
 352 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 353 hSeek handle mode offset =
 354     wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do
 355     debugIO ("hSeek " ++ show (mode,offset))
 356     buf <- readIORef haCharBuffer
 357
 358     if isWriteBuffer buf
 359         then do flushWriteBuffer handle_
 360                 IODevice.seek haDevice mode offset
 361         else do
 362
 363     let r = bufL buf; w = bufR buf
 364     if mode == RelativeSeek && isNothing haDecoder &&
 365        offset >= 0 && offset < fromIntegral (w - r)
 366         then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset }
 367         else do
 368
 369     flushCharReadBuffer handle_
 370     flushByteReadBuffer handle_
 371     IODevice.seek haDevice mode offset
 372
 373
 374 hTell :: Handle -> IO Integer
 375 hTell handle =
 376     wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do
 377
 378       posn <- IODevice.tell haDevice
 379
 380       cbuf <- readIORef haCharBuffer
 381       bbuf <- readIORef haByteBuffer
 382
 383       let real_posn
 384            | isWriteBuffer cbuf = posn + fromIntegral (bufR cbuf)
 385            | otherwise = posn - fromIntegral (bufR cbuf - bufL cbuf)
 386                               - fromIntegral (bufR bbuf - bufL bbuf)
 387
 388       debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn))
 389       debugIO ("   cbuf: " ++ summaryBuffer cbuf ++
 390             "   bbuf: " ++ summaryBuffer bbuf)
 391
 392       return real_posn
 393
 394 -- -----------------------------------------------------------------------------
 395 -- Handle Properties
 396
 397 -- A number of operations return information about the properties of a
 398 -- handle.  Each of these operations returns `True' if the handle has
 399 -- the specified property, and `False' otherwise.
 400
 401 hIsOpen :: Handle -> IO Bool
 402 hIsOpen handle =
 403     withHandle_ "hIsOpen" handle $ \ handle_ -> do
 404     case haType handle_ of
 405       ClosedHandle         -> return False
 406       SemiClosedHandle     -> return False
 407       _                    -> return True
 408
 409 hIsClosed :: Handle -> IO Bool
 410 hIsClosed handle =
 411     withHandle_ "hIsClosed" handle $ \ handle_ -> do
 412     case haType handle_ of
 413       ClosedHandle         -> return True
 414       _                    -> return False
 415
 416 {- not defined, nor exported, but mentioned
 417    here for documentation purposes:
 418
 419     hSemiClosed :: Handle -> IO Bool
 420     hSemiClosed h = do
 421        ho <- hIsOpen h
 422        hc <- hIsClosed h
 423        return (not (ho || hc))
 424 -}
 425
 426 hIsReadable :: Handle -> IO Bool
 427 hIsReadable (DuplexHandle _ _ _) = return True
 428 hIsReadable handle =
 429     withHandle_ "hIsReadable" handle $ \ handle_ -> do
 430     case haType handle_ of
 431       ClosedHandle         -> ioe_closedHandle
 432       SemiClosedHandle     -> ioe_closedHandle
 433       htype                -> return (isReadableHandleType htype)
 434
 435 hIsWritable :: Handle -> IO Bool
 436 hIsWritable (DuplexHandle _ _ _) = return True
 437 hIsWritable handle =
 438     withHandle_ "hIsWritable" handle $ \ handle_ -> do
 439     case haType handle_ of
 440       ClosedHandle         -> ioe_closedHandle
 441       SemiClosedHandle     -> ioe_closedHandle
 442       htype                -> return (isWritableHandleType htype)
 443
 444 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
 445 -- for @hdl@.
 446
 447 hGetBuffering :: Handle -> IO BufferMode
 448 hGetBuffering handle =
 449     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
 450     case haType handle_ of
 451       ClosedHandle         -> ioe_closedHandle
 452       _ ->
 453            -- We're being non-standard here, and allow the buffering
 454            -- of a semi-closed handle to be queried.   -- sof 6/98
 455           return (haBufferMode handle_)  -- could be stricter..
 456
 457 hIsSeekable :: Handle -> IO Bool
 458 hIsSeekable handle =
 459     withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do
 460     case haType of
 461       ClosedHandle         -> ioe_closedHandle
 462       SemiClosedHandle     -> ioe_closedHandle
 463       AppendHandle         -> return False
 464       _                    -> IODevice.isSeekable haDevice
 465
 466 -- -----------------------------------------------------------------------------
 467 -- Changing echo status (Non-standard GHC extensions)
 468
 469 -- | Set the echoing status of a handle connected to a terminal.
 470
 471 hSetEcho :: Handle -> Bool -> IO ()
 472 hSetEcho handle on = do
 473     isT   <- hIsTerminalDevice handle
 474     if not isT
 475      then return ()
 476      else
 477       withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do
 478       case haType of
 479          ClosedHandle -> ioe_closedHandle
 480          _            -> IODevice.setEcho haDevice on
 481
 482 -- | Get the echoing status of a handle connected to a terminal.
 483
 484 hGetEcho :: Handle -> IO Bool
 485 hGetEcho handle = do
 486     isT   <- hIsTerminalDevice handle
 487     if not isT
 488      then return False
 489      else
 490        withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do
 491        case haType of
 492          ClosedHandle -> ioe_closedHandle
 493          _            -> IODevice.getEcho haDevice
 494
 495 -- | Is the handle connected to a terminal?
 496
 497 hIsTerminalDevice :: Handle -> IO Bool
 498 hIsTerminalDevice handle = do
 499     withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do
 500      case haType of
 501        ClosedHandle -> ioe_closedHandle
 502        _            -> IODevice.isTerminal haDevice
 503
 504 -- -----------------------------------------------------------------------------
 505 -- hSetBinaryMode
 506
 507 -- | Select binary mode ('True') or text mode ('False') on a open handle.
 508 -- (See also 'openBinaryFile'.)
 509 --
 510 -- This has the same effect as calling 'hSetEncoding' with 'latin1', together
 511 -- with 'hSetNewlineMode' with 'noNewlineTranslation'.
 512 --
 513 hSetBinaryMode :: Handle -> Bool -> IO ()
 514 hSetBinaryMode handle bin =
 515   withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} ->
 516     do
 517          flushBuffer h_
 518
 519          let mb_te | bin       = Nothing
 520                    | otherwise = Just localeEncoding
 521
 522          openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do
 523
 524          -- should match the default newline mode, whatever that is
 525          let nl    | bin       = noNewlineTranslation
 526                    | otherwise = nativeNewlineMode
 527
 528          bbuf <- readIORef haByteBuffer
 529          ref <- newIORef (error "codec_state", bbuf)
 530
 531          return Handle__{ haLastDecode = ref,
 532                           haEncoder  = mb_encoder,
 533                           haDecoder  = mb_decoder,
 534                           haInputNL  = inputNL nl,
 535                           haOutputNL = outputNL nl, .. }
 536
 537 -- -----------------------------------------------------------------------------
 538 -- hSetNewlineMode
 539
 540 -- | Set the 'NewlineMode' on the specified 'Handle'.  All buffered
 541 -- data is flushed first.
 542 hSetNewlineMode :: Handle -> NewlineMode -> IO ()
 543 hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =
 544   withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} ->
 545     do
 546          flushBuffer h_
 547          return h_{ haInputNL=i, haOutputNL=o }
 548
 549 -- -----------------------------------------------------------------------------
 550 -- Duplicating a Handle
 551
 552 -- | Returns a duplicate of the original handle, with its own buffer.
 553 -- The two Handles will share a file pointer, however.  The original
 554 -- handle's buffer is flushed, including discarding any input data,
 555 -- before the handle is duplicated.
 556
 557 hDuplicate :: Handle -> IO Handle
 558 hDuplicate h@(FileHandle path m) = do
 559   withHandle_' "hDuplicate" h m $ \h_ ->
 560       dupHandle path h Nothing h_ (Just handleFinalizer)
 561 hDuplicate h@(DuplexHandle path r w) = do
 562   write_side@(FileHandle _ write_m) <-
 563      withHandle_' "hDuplicate" h w $ \h_ ->
 564         dupHandle path h Nothing h_ (Just handleFinalizer)
 565   read_side@(FileHandle _ read_m) <-
 566     withHandle_' "hDuplicate" h r $ \h_ ->
 567         dupHandle path h (Just write_m) h_  Nothing
 568   return (DuplexHandle path read_m write_m)
 569
 570 dupHandle :: FilePath
 571           -> Handle
 572           -> Maybe (MVar Handle__)
 573           -> Handle__
 574           -> Maybe HandleFinalizer
 575           -> IO Handle
 576 dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do
 577   -- flush the buffer first, so we don't have to copy its contents
 578   flushBuffer h_
 579   case other_side of
 580     Nothing -> do
 581        new_dev <- IODevice.dup haDevice
 582        dupHandle_ new_dev filepath other_side h_ mb_finalizer
 583     Just r  ->
 584        withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do
 585          dupHandle_ dev filepath other_side h_ mb_finalizer
 586
 587 dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 588            -> FilePath
 589            -> Maybe (MVar Handle__)
 590            -> Handle__
 591            -> Maybe HandleFinalizer
 592            -> IO Handle
 593 dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
 594    -- XXX wrong!
 595   let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing
 596   mkHandle new_dev filepath haType True{-buffered-} mb_codec
 597       NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
 598       mb_finalizer other_side
 599
 600 -- -----------------------------------------------------------------------------
 601 -- Replacing a Handle
 602
 603 {- |
 604 Makes the second handle a duplicate of the first handle.  The second
 605 handle will be closed first, if it is not already.
 606
 607 This can be used to retarget the standard Handles, for example:
 608
 609 > do h <- openFile "mystdout" WriteMode
 610 >    hDuplicateTo h stdout
 611 -}
 612
 613 hDuplicateTo :: Handle -> Handle -> IO ()
 614 hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do
 615  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
 616    _ <- hClose_help h2_
 617    withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
 618      dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
 619 hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do
 620  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
 621    _ <- hClose_help w2_
 622    withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
 623      dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
 624  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
 625    _ <- hClose_help r2_
 626    withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
 627      dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
 628 hDuplicateTo h1 _ =
 629   ioe_dupHandlesNotCompatible h1
 630
 631
 632 ioe_dupHandlesNotCompatible :: Handle -> IO a
 633 ioe_dupHandlesNotCompatible h =
 634    ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
 635                 "handles are incompatible" Nothing Nothing)
 636
 637 dupHandleTo :: FilePath
 638             -> Handle
 639             -> Maybe (MVar Handle__)
 640             -> Handle__
 641             -> Handle__
 642             -> Maybe HandleFinalizer
 643             -> IO Handle__
 644 dupHandleTo filepath h other_side
 645             hto_@Handle__{haDevice=devTo,..}
 646             h_@Handle__{haDevice=dev} mb_finalizer = do
 647   flushBuffer h_
 648   case cast devTo of
 649     Nothing   -> ioe_dupHandlesNotCompatible h
 650     Just dev' -> do
 651       IODevice.dup2 dev dev'
 652       FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
 653       takeMVar m
 654
 655 -- ---------------------------------------------------------------------------
 656 -- showing Handles.
 657 --
 658 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
 659 -- than the (pure) instance of 'Show' for 'Handle'.
 660
 661 hShow :: Handle -> IO String
 662 hShow h@(FileHandle path _) = showHandle' path False h
 663 hShow h@(DuplexHandle path _ _) = showHandle' path True h
 664
 665 showHandle' :: String -> Bool -> Handle -> IO String
 666 showHandle' filepath is_duplex h =
 667   withHandle_ "showHandle" h $ \hdl_ ->
 668     let
 669      showType | is_duplex = showString "duplex (read-write)"
 670               | otherwise = shows (haType hdl_)
 671     in
 672     return
 673       (( showChar '{' .
 674         showHdl (haType hdl_)
 675             (showString "loc=" . showString filepath . showChar ',' .
 676              showString "type=" . showType . showChar ',' .
 677              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
 678       ) "")
 679    where
 680
 681     showHdl :: HandleType -> ShowS -> ShowS
 682     showHdl ht cont =
 683        case ht of
 684         ClosedHandle  -> shows ht . showString "}"
 685         _ -> cont
 686
 687     showBufMode :: Buffer e -> BufferMode -> ShowS
 688     showBufMode buf bmo =
 689       case bmo of
 690         NoBuffering   -> showString "none"
 691         LineBuffering -> showString "line"
 692         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
 693         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
 694       where
 695        def :: Int
 696        def = bufSize buf