+-- -----------------------------------------------------------------------------
+-- Duplicating a Handle
+
+-- |Returns a duplicate of the original handle, with its own buffer
+-- and file pointer. The original handle's buffer is flushed, including
+-- discarding any input data, before the handle is duplicated.
+
+hDuplicate :: Handle -> IO Handle
+hDuplicate h@(FileHandle path m) = do
+ new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
+ new_m <- newMVar new_h_
+ 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 path new_r new_w)
+
+dupHandle_ other_side h_ = do
+ -- flush the buffer first, so we don't have to copy its contents
+ flushBuffer h_
+ new_fd <- c_dup (fromIntegral (haFD h_))
+ buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
+ ioref <- newIORef buffer
+ ioref_buffers <- newIORef BufferListNil
+
+ let new_handle_ = h_{ haFD = fromIntegral new_fd,
+ haBuffer = ioref,
+ haBuffers = ioref_buffers,
+ haOtherSide = other_side }
+ return (h_, new_handle_)
+
+-- -----------------------------------------------------------------------------
+-- Replacing a Handle
+
+{- |
+Makes the second handle a duplicate of the first handle. The second
+handle will be closed first, if it is not already.
+
+This can be used to retarget the standard Handles, for example:
+
+> do h <- openFile "mystdout" WriteMode
+> hDuplicateTo h stdout
+-}
+
+hDuplicateTo :: Handle -> Handle -> IO ()
+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
+ withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
+ _ <- hClose_help w2_
+ withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
+ withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
+ _ <- hClose_help r2_
+ withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
+hDuplicateTo h1 _ =
+ ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
+ "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
+