module GHC.IO.Handle (
Handle,
BufferMode(..),
mkFileHandle, mkDuplexHandle,
hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead,
hSetBuffering, hSetBinaryMode, hSetEncoding, hGetEncoding,
hFlush, hFlushAll, hDuplicate, hDuplicateTo,
hClose, hClose_help,
LockMode(..), hLock, hTryLock,
HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
SeekMode(..), hSeek, hTell,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
hSetEcho, hGetEcho, hIsTerminalDevice,
hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline,
noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
hShow,
hWaitForInput, hGetChar, hGetLine, hGetContents, hGetContents', hPutChar, hPutStr,
hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking
) where
import GHC.IO
import GHC.IO.Exception
import GHC.IO.Encoding
import GHC.IO.Buffer
import GHC.IO.BufferedIO ( BufferedIO )
import GHC.IO.Device as IODevice
import GHC.IO.StdHandles
import GHC.IO.SubSystem
import GHC.IO.Handle.Lock
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Text
import qualified GHC.IO.BufferedIO as Buffered
import GHC.Base
import GHC.Exception
import GHC.MVar
import GHC.IORef
import GHC.Show
import GHC.Num
import GHC.Real
import Data.Maybe
import Data.Typeable
hClose :: Handle -> IO ()
hClose h@(FileHandle _ m) = do
mb_exc <- hClose' h m
hClose_maybethrow mb_exc h
hClose h@(DuplexHandle _ r w) = do
excs <- mapM (hClose' h) [r,w]
hClose_maybethrow (listToMaybe (catMaybes excs)) h
hClose_maybethrow :: Maybe SomeException -> Handle -> IO ()
hClose_maybethrow Nothing h = return ()
hClose_maybethrow (Just e) h = hClose_rethrow e h
hClose_rethrow :: SomeException -> Handle -> IO ()
hClose_rethrow e h =
case fromException e of
Just ioe -> ioError (augmentIOError ioe "hClose" h)
Nothing -> throwIO e
hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
hClose' h m = withHandle' "hClose" h m $ hClose_help
hFileSize :: Handle -> IO Integer
hFileSize handle =
withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_semiclosedHandle
_ -> do flushWriteBuffer handle_
r <- IODevice.getSize dev
debugIO $ "hFileSize: " ++ show r ++ " " ++ show handle
if r /= 1
then return r
else ioException (IOError Nothing InappropriateType "hFileSize"
"not a regular file" Nothing Nothing)
hSetFileSize :: Handle -> Integer -> IO ()
hSetFileSize handle size =
withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_semiclosedHandle
_ -> do flushWriteBuffer handle_
IODevice.setSize dev size
return ()
hIsEOF :: Handle -> IO Bool
hIsEOF handle = wantReadableHandle_ "hIsEOF" handle $ \Handle__{..} -> do
cbuf <- readIORef haCharBuffer
if not (isEmptyBuffer cbuf) then return False else do
bbuf <- readIORef haByteBuffer
if not (isEmptyBuffer bbuf) then return False else do
(r,bbuf') <- Buffered.fillReadBuffer haDevice bbuf
if r == 0
then return True
else do writeIORef haByteBuffer bbuf'
return False
isEOF :: IO Bool
isEOF = hIsEOF stdin
hLookAhead :: Handle -> IO Char
hLookAhead handle =
wantReadableHandle_ "hLookAhead" handle hLookAhead_
hSetBuffering :: Handle -> BufferMode -> IO ()
hSetBuffering handle mode =
withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do
case haType of
ClosedHandle -> ioe_closedHandle
_ -> do
if mode == haBufferMode then return handle_ else do
case mode of
BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
_ -> return ()
is_tty <- IODevice.isTerminal haDevice
when (is_tty && isReadableHandleType haType) $
case mode of
#if !defined(mingw32_HOST_OS)
NoBuffering -> IODevice.setRaw haDevice True
#else
NoBuffering -> return () <!> IODevice.setRaw haDevice True
#endif
_ -> IODevice.setRaw haDevice False
writeIORef haBuffers BufferListNil
return Handle__{ haBufferMode = mode,.. }
hSetEncoding :: Handle -> TextEncoding -> IO ()
hSetEncoding hdl encoding = do
withAllHandles__ "hSetEncoding" hdl $ \h_@Handle__{..} -> do
flushCharBuffer h_
closeTextCodecs h_
openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do
bbuf <- readIORef haByteBuffer
ref <- newIORef (errorWithoutStackTrace "last_decode")
return (Handle__{ haLastDecode = ref,
haDecoder = mb_decoder,
haEncoder = mb_encoder,
haCodec = Just encoding, .. })
hGetEncoding :: Handle -> IO (Maybe TextEncoding)
hGetEncoding hdl =
withHandle_ "hGetEncoding" hdl $ \h_@Handle__{..} -> return haCodec
hFlush :: Handle -> IO ()
hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
hFlushAll :: Handle -> IO ()
hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer
data HandlePosn = HandlePosn Handle HandlePosition
instance Eq HandlePosn where
(HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
instance Show HandlePosn where
showsPrec p (HandlePosn h pos) =
showsPrec p h . showString " at position " . shows pos
type HandlePosition = Integer
hGetPosn :: Handle -> IO HandlePosn
hGetPosn handle = do
posn <- hTell handle
return (HandlePosn handle posn)
hSetPosn :: HandlePosn -> IO ()
hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
hSeek :: Handle -> SeekMode -> Integer -> IO ()
hSeek handle mode offset =
wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do
debugIO ("hSeek " ++ show (mode,offset))
cbuf <- readIORef haCharBuffer
bbuf <- readIORef haByteBuffer
debugIO $ "hSeek - bbuf:" ++ summaryBuffer bbuf
debugIO $ "hSeek - cbuf:" ++ summaryBuffer cbuf
if isWriteBuffer cbuf
then do flushWriteBuffer handle_
new_offset <- IODevice.seek haDevice mode offset
bbuf1 <- readIORef haByteBuffer
let bbuf2 = bbuf1{ bufOffset = fromIntegral new_offset }
debugIO $ "hSeek - seek:: " ++ show offset ++
" - " ++ show new_offset
debugIO $ "hSeek - wr flush bbuf1:" ++ summaryBuffer bbuf2
writeIORef haByteBuffer bbuf2
else do
let r = bufL cbuf; w = bufR cbuf
if mode == RelativeSeek && isNothing haDecoder &&
offset >= 0 && offset < fromIntegral (w r)
then writeIORef haCharBuffer cbuf{ bufL = r + fromIntegral offset }
else do
flushCharReadBuffer handle_
flushByteReadBuffer handle_
bbuf2 <- readIORef haByteBuffer
new_offset <- IODevice.seek haDevice mode offset
debugIO $ "hSeek after: " ++ show new_offset
writeIORef haByteBuffer bbuf2{ bufOffset = fromIntegral new_offset }
hTell :: Handle -> IO Integer
hTell handle =
wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do
posn <- if ioSubSystem == IoNative
then (fromIntegral . bufOffset) `fmap` readIORef haByteBuffer
else IODevice.tell haDevice
flushCharBuffer handle_
bbuf <- readIORef haByteBuffer
debugIO ("hTell bbuf (elems=" ++ show (bufferElems bbuf) ++ ")"
++ summaryBuffer bbuf)
let real_posn
| isWriteBuffer bbuf = posn + fromIntegral (bufferElems bbuf)
| otherwise = posn fromIntegral (bufferElems bbuf)
cbuf <- readIORef haCharBuffer
debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn))
debugIO (" cbuf: " ++ summaryBuffer cbuf ++
" bbuf: " ++ summaryBuffer bbuf)
return real_posn
hIsOpen :: Handle -> IO Bool
hIsOpen handle =
withHandle_ "hIsOpen" handle $ \ handle_ -> do
case haType handle_ of
ClosedHandle -> return False
SemiClosedHandle -> return False
_ -> return True
hIsClosed :: Handle -> IO Bool
hIsClosed handle =
withHandle_ "hIsClosed" handle $ \ handle_ -> do
case haType handle_ of
ClosedHandle -> return True
_ -> return False
hIsReadable :: Handle -> IO Bool
hIsReadable (DuplexHandle _ _ _) = return True
hIsReadable handle =
withHandle_ "hIsReadable" handle $ \ handle_ -> do
case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_semiclosedHandle
htype -> return (isReadableHandleType htype)
hIsWritable :: Handle -> IO Bool
hIsWritable (DuplexHandle _ _ _) = return True
hIsWritable handle =
withHandle_ "hIsWritable" handle $ \ handle_ -> do
case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_semiclosedHandle
htype -> return (isWritableHandleType htype)
hGetBuffering :: Handle -> IO BufferMode
hGetBuffering handle =
withHandle_ "hGetBuffering" handle $ \ handle_ -> do
case haType handle_ of
ClosedHandle -> ioe_closedHandle
_ ->
return (haBufferMode handle_)
hIsSeekable :: Handle -> IO Bool
hIsSeekable handle =
withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do
case haType of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_semiclosedHandle
AppendHandle -> return False
_ -> IODevice.isSeekable haDevice
hSetEcho :: Handle -> Bool -> IO ()
hSetEcho handle on = do
isT <- hIsTerminalDevice handle
if not isT
then return ()
else
withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do
case haType of
ClosedHandle -> ioe_closedHandle
_ -> IODevice.setEcho haDevice on
hGetEcho :: Handle -> IO Bool
hGetEcho handle = do
isT <- hIsTerminalDevice handle
if not isT
then return False
else
withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do
case haType of
ClosedHandle -> ioe_closedHandle
_ -> IODevice.getEcho haDevice
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice handle = do
withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do
case haType of
ClosedHandle -> ioe_closedHandle
_ -> IODevice.isTerminal haDevice
hSetBinaryMode :: Handle -> Bool -> IO ()
hSetBinaryMode handle bin =
withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} ->
do
flushCharBuffer h_
closeTextCodecs h_
mb_te <- if bin then return Nothing
else fmap Just getLocaleEncoding
openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do
let nl | bin = noNewlineTranslation
| otherwise = nativeNewlineMode
bbuf <- readIORef haByteBuffer
ref <- newIORef (errorWithoutStackTrace "codec_state", bbuf)
return Handle__{ haLastDecode = ref,
haEncoder = mb_encoder,
haDecoder = mb_decoder,
haCodec = mb_te,
haInputNL = inputNL nl,
haOutputNL = outputNL nl, .. }
hSetNewlineMode :: Handle -> NewlineMode -> IO ()
hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =
withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{} ->
do
flushBuffer h_
return h_{ haInputNL=i, haOutputNL=o }
hDuplicate :: Handle -> IO Handle
hDuplicate h@(FileHandle path m) = do
withHandle_' "hDuplicate" h m $ \h_ ->
dupHandle path h Nothing h_ (Just handleFinalizer)
hDuplicate h@(DuplexHandle path r w) = do
write_side@(FileHandle _ write_m) <-
withHandle_' "hDuplicate" h w $ \h_ ->
dupHandle path h Nothing h_ (Just handleFinalizer)
read_side@(FileHandle _ read_m) <-
withHandle_' "hDuplicate" h r $ \h_ ->
dupHandle path h (Just write_m) h_ Nothing
return (DuplexHandle path read_m write_m)
dupHandle :: FilePath
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do
flushBuffer h_
case other_side of
Nothing -> do
new_dev <- IODevice.dup haDevice
dupHandle_ new_dev filepath other_side h_ mb_finalizer
Just r ->
withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do
dupHandle_ dev filepath other_side h_ mb_finalizer
dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
-> FilePath
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing
mkHandle new_dev filepath haType True mb_codec
NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
mb_finalizer other_side
hDuplicateTo :: Handle -> Handle -> IO ()
hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
try $ flushWriteBuffer h2_
withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
try $ flushWriteBuffer w2_
withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
try $ flushWriteBuffer r2_
withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
hDuplicateTo h1 _ =
ioe_dupHandlesNotCompatible h1
try :: IO () -> IO ()
try io = io `catchException` (const (pure ()) :: SomeException -> IO ())
ioe_dupHandlesNotCompatible :: Handle -> IO a
ioe_dupHandlesNotCompatible h =
ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
"handles are incompatible" Nothing Nothing)
dupHandleTo :: FilePath
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo filepath h other_side
hto_@Handle__{haDevice=devTo}
h_@Handle__{haDevice=dev} mb_finalizer = do
flushBuffer h_
case cast devTo of
Nothing -> ioe_dupHandlesNotCompatible h
Just dev' -> do
_ <- IODevice.dup2 dev dev'
FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
takeMVar m
hShow :: Handle -> IO String
hShow h@(FileHandle path _) = showHandle' path False h
hShow h@(DuplexHandle path _ _) = showHandle' path True h
showHandle' :: String -> Bool -> Handle -> IO String
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 "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
) "")
where
showHdl :: HandleType -> ShowS -> ShowS
showHdl ht cont =
case ht of
ClosedHandle -> shows ht . showString "}"
_ -> cont
showBufMode :: Buffer e -> 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