module GHC.IO.Handle.Internals (
withHandle, withHandle', withHandle_,
withHandle__', withHandle_', withAllHandles__,
wantWritableHandle, wantReadableHandle, wantReadableHandle_,
wantSeekableHandle,
mkHandle, mkFileHandle, mkDuplexHandle,
openTextEncoding, closeTextCodecs, initBufferState,
dEFAULT_CHAR_BUFFER_SIZE,
flushBuffer, flushWriteBuffer, flushCharReadBuffer,
flushCharBuffer, flushByteReadBuffer, flushByteWriteBuffer,
readTextDevice, writeCharBuffer, readTextDeviceNonBlocking,
decodeByteBuf,
augmentIOError,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
ioe_finalizedHandle, ioe_bufsiz,
hClose_help, hLookAhead_,
HandleFinalizer, handleFinalizer,
debugIO,
) where
import GHC.IO
import GHC.IO.IOMode
import GHC.IO.Encoding as Encoding
import GHC.IO.Handle.Types
import GHC.IO.Buffer
import GHC.IO.BufferedIO (BufferedIO)
import GHC.IO.Exception
import GHC.IO.Device (IODevice, SeekMode(..))
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.BufferedIO as Buffered
import GHC.Conc.Sync
import GHC.Real
import GHC.Base
import GHC.Exception
import GHC.Num ( Num(..) )
import GHC.Show
import GHC.IORef
import GHC.MVar
import Data.Typeable
import Control.Monad
import Data.Maybe
import Foreign.Safe
import System.Posix.Internals hiding (FD)
import Foreign.C
c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = False
type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()
newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle
newFileHandle filepath mb_finalizer hc = do
m <- newMVar hc
case mb_finalizer of
Just finalizer -> addMVarFinalizer m (finalizer filepath m)
Nothing -> return ()
return (FileHandle filepath m)
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' :: String -> Handle -> MVar Handle__
-> (Handle__ -> IO (Handle__,a)) -> IO a
withHandle' fun h m act =
mask_ $ do
(h',v) <- do_operation fun h act m
checkHandleInvariants h'
putMVar m h'
return v
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_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do
a <- act h_
return (h_,a)
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
withHandle__' fun h r act
withHandle__' fun h w act
withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
-> IO ()
withHandle__' fun h m act =
mask_ $ do
h' <- do_operation fun h act m
checkHandleInvariants h'
putMVar m h'
return ()
do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a
do_operation fun h act m = do
h_ <- takeMVar m
checkHandleInvariants h_
act h_ `catchException` handler h_
where
handler h_ e = do
putMVar m h_
case () of
_ | Just ioe <- fromException e ->
ioError (augmentIOError ioe fun h)
_ | Just async_ex <- fromException e -> do
let _ = async_ex :: AsyncException
t <- myThreadId
throwTo t e
do_operation fun h act m
_otherwise ->
throwIO e
augmentIOError :: IOException -> String -> Handle -> IOException
augmentIOError ioe@IOError{ ioe_filename = fp } fun h
= ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }
where filepath
| Just _ <- fp = fp
| otherwise = case h of
FileHandle path _ -> Just path
DuplexHandle path _ _ -> Just path
wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle fun h@(FileHandle _ m) act
= wantWritableHandle' fun h m act
wantWritableHandle fun h@(DuplexHandle _ _ m) act
= wantWritableHandle' fun h m act
wantWritableHandle'
:: String -> Handle -> MVar Handle__
-> (Handle__ -> IO a) -> IO a
wantWritableHandle' fun h m act
= withHandle_' fun h m (checkWritableHandle act)
checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkWritableHandle act h_@Handle__{..}
= case haType of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_closedHandle
ReadHandle -> ioe_notWritable
ReadWriteHandle -> do
buf <- readIORef haCharBuffer
when (not (isWriteBuffer buf)) $ do
flushCharReadBuffer h_
flushByteReadBuffer h_
buf <- readIORef haCharBuffer
writeIORef haCharBuffer buf{ bufState = WriteBuffer }
buf <- readIORef haByteBuffer
buf' <- Buffered.emptyWriteBuffer haDevice buf
writeIORef haByteBuffer buf'
act h_
_other -> act h_
wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act)
wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantReadableHandle_ fun h@(FileHandle _ m) act
= wantReadableHandle' fun h m act
wantReadableHandle_ fun h@(DuplexHandle _ m _) act
= wantReadableHandle' fun h m act
wantReadableHandle'
:: String -> Handle -> MVar Handle__
-> (Handle__ -> IO a) -> IO a
wantReadableHandle' fun h m act
= withHandle_' fun h m (checkReadableHandle act)
checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkReadableHandle act h_@Handle__{..} =
case haType of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_closedHandle
AppendHandle -> ioe_notReadable
WriteHandle -> ioe_notReadable
ReadWriteHandle -> do
bbuf <- readIORef haByteBuffer
when (isWriteBuffer bbuf) $ do
when (not (isEmptyBuffer bbuf)) $ flushByteWriteBuffer h_
cbuf' <- readIORef haCharBuffer
writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }
bbuf <- readIORef haByteBuffer
writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }
act h_
_other -> act h_
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
ioException (IOError (Just h) IllegalOperation fun
"handle is not seekable" Nothing Nothing)
wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkSeekableHandle act handle_@Handle__{haDevice=dev} =
case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_closedHandle
AppendHandle -> ioe_notSeekable
_ -> do b <- IODevice.isSeekable dev
if b then act handle_
else ioe_notSeekable
ioe_closedHandle, ioe_EOF,
ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable,
ioe_notSeekable :: IO a
ioe_closedHandle = ioException
(IOError Nothing IllegalOperation ""
"handle is closed" Nothing Nothing)
ioe_EOF = ioException
(IOError Nothing EOF "" "" Nothing Nothing)
ioe_notReadable = ioException
(IOError Nothing IllegalOperation ""
"handle is not open for reading" Nothing Nothing)
ioe_notWritable = ioException
(IOError Nothing IllegalOperation ""
"handle is not open for writing" Nothing Nothing)
ioe_notSeekable = ioException
(IOError Nothing IllegalOperation ""
"handle is not seekable" Nothing Nothing)
ioe_cannotFlushNotSeekable = ioException
(IOError Nothing IllegalOperation ""
"cannot flush the read buffer: underlying device is not seekable"
Nothing Nothing)
ioe_finalizedHandle :: FilePath -> Handle__
ioe_finalizedHandle fp = throw
(IOError Nothing IllegalOperation ""
"handle is finalized" Nothing (Just fp))
ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
(IOError Nothing InvalidArgument "hSetBuffering"
("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
streamEncode :: BufferCodec from to state
-> Buffer from -> Buffer to
-> IO (Buffer from, Buffer to)
streamEncode codec from to = go (from, to)
where
go (from, to) = do
(why, from', to') <- encode codec from to
case why of
Encoding.InvalidSequence | bufL from == bufL from' -> recover codec from' to' >>= go
_ -> return (from', to')
handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
handleFinalizer fp m = do
handle_ <- takeMVar m
(handle_', _) <- hClose_help handle_
putMVar m handle_'
return ()
dEFAULT_CHAR_BUFFER_SIZE :: Int
dEFAULT_CHAR_BUFFER_SIZE = 2048
getCharBuffer :: IODevice dev => dev -> BufferState
-> IO (IORef CharBuffer, BufferMode)
getCharBuffer dev state = do
buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
ioref <- newIORef buffer
is_tty <- IODevice.isTerminal dev
let buffer_mode
| is_tty = LineBuffering
| otherwise = BlockBuffering Nothing
return (ioref, buffer_mode)
mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
mkUnBuffer state = do
buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
ref <- newIORef buffer
return (ref, NoBuffering)
flushBuffer :: Handle__ -> IO ()
flushBuffer h_@Handle__{..} = do
buf <- readIORef haCharBuffer
case bufState buf of
ReadBuffer -> do
flushCharReadBuffer h_
flushByteReadBuffer h_
WriteBuffer -> do
flushByteWriteBuffer h_
flushCharBuffer :: Handle__ -> IO ()
flushCharBuffer h_@Handle__{..} = do
cbuf <- readIORef haCharBuffer
case bufState cbuf of
ReadBuffer -> do
flushCharReadBuffer h_
WriteBuffer ->
when (not (isEmptyBuffer cbuf)) $
error "internal IO library error: Char buffer non-empty"
flushWriteBuffer :: Handle__ -> IO ()
flushWriteBuffer h_@Handle__{..} = do
buf <- readIORef haByteBuffer
when (isWriteBuffer buf) $ flushByteWriteBuffer h_
flushByteWriteBuffer :: Handle__ -> IO ()
flushByteWriteBuffer h_@Handle__{..} = do
bbuf <- readIORef haByteBuffer
when (not (isEmptyBuffer bbuf)) $ do
bbuf' <- Buffered.flushWriteBuffer haDevice bbuf
writeIORef haByteBuffer bbuf'
writeCharBuffer :: Handle__ -> CharBuffer -> IO ()
writeCharBuffer h_@Handle__{..} !cbuf = do
bbuf <- readIORef haByteBuffer
debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++
" bbuf=" ++ summaryBuffer bbuf)
(cbuf',bbuf') <- case haEncoder of
Nothing -> latin1_encode cbuf bbuf
Just encoder -> (streamEncode encoder) cbuf bbuf
debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer bbuf')
if isFullBuffer bbuf'
|| not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf
|| (case haBufferMode of
BlockBuffering (Just s) -> bufferElems bbuf' >= s
NoBuffering -> True
_other -> False)
then do
bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'
writeIORef haByteBuffer bbuf''
else
writeIORef haByteBuffer bbuf'
if not (isEmptyBuffer cbuf')
then writeCharBuffer h_ cbuf'
else return ()
flushCharReadBuffer :: Handle__ -> IO ()
flushCharReadBuffer Handle__{..} = do
cbuf <- readIORef haCharBuffer
if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do
(codec_state, bbuf0) <- readIORef haLastDecode
cbuf0 <- readIORef haCharBuffer
writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }
if bufL cbuf0 == 0
then do writeIORef haByteBuffer bbuf0
return ()
else do
case haDecoder of
Nothing -> do
writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }
Just decoder -> do
debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
" cbuf=" ++ summaryBuffer cbuf0)
setState decoder codec_state
(bbuf1,cbuf1) <- (streamEncode decoder) bbuf0
cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
" cbuf=" ++ summaryBuffer cbuf1)
writeIORef haByteBuffer bbuf1
flushByteReadBuffer :: Handle__ -> IO ()
flushByteReadBuffer h_@Handle__{..} = do
bbuf <- readIORef haByteBuffer
if isEmptyBuffer bbuf then return () else do
seekable <- IODevice.isSeekable haDevice
when (not seekable) $ ioe_cannotFlushNotSeekable
let seek = negate (bufR bbuf bufL bbuf)
debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)
IODevice.seek haDevice RelativeSeek (fromIntegral seek)
writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 }
mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
-> FilePath
-> HandleType
-> Bool
-> Maybe TextEncoding
-> NewlineMode
-> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
let buf_state = initBufferState ha_type
bbuf <- Buffered.newBuffer dev buf_state
bbufref <- newIORef bbuf
last_decode <- newIORef (error "codec_state", bbuf)
(cbufref,bmode) <-
if buffered then getCharBuffer dev buf_state
else mkUnBuffer buf_state
spares <- newIORef BufferListNil
newFileHandle filepath finalizer
(Handle__ { haDevice = dev,
haType = ha_type,
haBufferMode = bmode,
haByteBuffer = bbufref,
haLastDecode = last_decode,
haCharBuffer = cbufref,
haBuffers = spares,
haEncoder = mb_encoder,
haDecoder = mb_decoder,
haCodec = mb_codec,
haInputNL = inputNL nl,
haOutputNL = outputNL nl,
haOtherSide = other_side
})
mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
=> dev
-> FilePath
-> IOMode
-> Maybe TextEncoding
-> NewlineMode
-> IO Handle
mkFileHandle dev filepath iomode mb_codec tr_newlines = do
mkHandle dev filepath (ioModeToHandleType iomode) True mb_codec
tr_newlines
(Just handleFinalizer) Nothing
mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
-> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
mkDuplexHandle dev filepath mb_codec tr_newlines = do
write_side@(FileHandle _ write_m) <-
mkHandle dev filepath WriteHandle True mb_codec
tr_newlines
(Just handleFinalizer)
Nothing
read_side@(FileHandle _ read_m) <-
mkHandle dev filepath ReadHandle True mb_codec
tr_newlines
Nothing
(Just write_m)
return (DuplexHandle filepath read_m write_m)
ioModeToHandleType :: IOMode -> HandleType
ioModeToHandleType ReadMode = ReadHandle
ioModeToHandleType WriteMode = WriteHandle
ioModeToHandleType ReadWriteMode = ReadWriteHandle
ioModeToHandleType AppendMode = AppendHandle
initBufferState :: HandleType -> BufferState
initBufferState ReadHandle = ReadBuffer
initBufferState _ = WriteBuffer
openTextEncoding
:: Maybe TextEncoding
-> HandleType
-> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
-> IO a
openTextEncoding Nothing ha_type cont = cont Nothing Nothing
openTextEncoding (Just TextEncoding{..}) ha_type cont = do
mb_decoder <- if isReadableHandleType ha_type then do
decoder <- mkTextDecoder
return (Just decoder)
else
return Nothing
mb_encoder <- if isWritableHandleType ha_type then do
encoder <- mkTextEncoder
return (Just encoder)
else
return Nothing
cont mb_encoder mb_decoder
closeTextCodecs :: Handle__ -> IO ()
closeTextCodecs Handle__{..} = do
case haDecoder of Nothing -> return (); Just d -> Encoding.close d
case haEncoder of Nothing -> return (); Just d -> Encoding.close d
hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return (handle_,Nothing)
_ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_
(h_, mb_exc2) <- hClose_handle_ handle_
return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)
trymaybe :: IO () -> IO (Maybe SomeException)
trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_handle_ h_@Handle__{..} = do
maybe_exception <-
case haOtherSide of
Nothing -> trymaybe $ IODevice.close haDevice
Just _ -> return Nothing
writeIORef haBuffers BufferListNil
writeIORef haCharBuffer noCharBuffer
writeIORef haByteBuffer noByteBuffer
closeTextCodecs h_
return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)
noCharBuffer :: CharBuffer
noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer
noByteBuffer :: Buffer Word8
noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer
hLookAhead_ :: Handle__ -> IO Char
hLookAhead_ handle_@Handle__{..} = do
buf <- readIORef haCharBuffer
new_buf <- if isEmptyBuffer buf
then readTextDevice handle_ buf
else return buf
writeIORef haCharBuffer new_buf
peekCharBuf (bufRaw buf) (bufL buf)
debugIO :: String -> IO ()
debugIO s
| c_DEBUG_DUMP
= do _ <- withCStringLen (s ++ "\n") $
\(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
return ()
| otherwise = return ()
readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
readTextDevice h_@Handle__{..} cbuf = do
bbuf0 <- readIORef haByteBuffer
debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
" bbuf=" ++ summaryBuffer bbuf0)
bbuf1 <- if not (isEmptyBuffer bbuf0)
then return bbuf0
else do
(r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
if r == 0 then ioe_EOF else do
return bbuf1
debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
(bbuf2,cbuf') <-
case haDecoder of
Nothing -> do
writeIORef haLastDecode (error "codec_state", bbuf1)
latin1_decode bbuf1 cbuf
Just decoder -> do
state <- getState decoder
writeIORef haLastDecode (state, bbuf1)
(streamEncode decoder) bbuf1 cbuf
debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
" bbuf=" ++ summaryBuffer bbuf2)
writeIORef haByteBuffer bbuf2
if bufR cbuf' == bufR cbuf
then readTextDevice' h_ bbuf2 cbuf
else return cbuf'
readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
readTextDevice' h_@Handle__{..} bbuf0 cbuf0 = do
bbuf1 <- slideContents bbuf0
let Just decoder = haDecoder
(r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
if r == 0
then do
(bbuf3, cbuf1) <- recover decoder bbuf2 cbuf0
writeIORef haByteBuffer bbuf3
if bufR cbuf1 == bufR cbuf0
then readTextDevice h_ cbuf1
else return cbuf1
else do
debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)
(bbuf3,cbuf1) <- do
state <- getState decoder
writeIORef haLastDecode (state, bbuf2)
(streamEncode decoder) bbuf2 cbuf0
debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf1 ++
" bbuf=" ++ summaryBuffer bbuf3)
writeIORef haByteBuffer bbuf3
if bufR cbuf0 == bufR cbuf1
then readTextDevice' h_ bbuf3 cbuf1
else return cbuf1
readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
bbuf0 <- readIORef haByteBuffer
when (isEmptyBuffer bbuf0) $ do
(r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
if isNothing r then ioe_EOF else do
writeIORef haByteBuffer bbuf1
decodeByteBuf h_ cbuf
decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer
decodeByteBuf h_@Handle__{..} cbuf = do
bbuf0 <- readIORef haByteBuffer
(bbuf2,cbuf') <-
case haDecoder of
Nothing -> do
writeIORef haLastDecode (error "codec_state", bbuf0)
latin1_decode bbuf0 cbuf
Just decoder -> do
state <- getState decoder
writeIORef haLastDecode (state, bbuf0)
(streamEncode decoder) bbuf0 cbuf
writeIORef haByteBuffer bbuf2
return cbuf'
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4