module GHC.IO.Handle.Text (
hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
commitBuffer',
hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
memcpy, hPutStrLn,
) where
import GHC.IO
import GHC.IO.FD
import GHC.IO.Buffer
import qualified GHC.IO.BufferedIO as Buffered
import GHC.IO.Exception
import GHC.Exception
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.Device as RawIO
import Foreign
import Foreign.C
import qualified Control.Exception as Exception
import Data.Typeable
import System.IO.Error
import Data.Maybe
import Control.Monad
import GHC.IORef
import GHC.Base
import GHC.Real
import GHC.Num
import GHC.Show
import GHC.List
hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput h msecs = do
wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
cbuf <- readIORef haCharBuffer
if not (isEmptyBuffer cbuf) then return True else do
if msecs < 0
then do cbuf' <- readTextDevice handle_ cbuf
writeIORef haCharBuffer cbuf'
return True
else do
cbuf' <- decodeByteBuf handle_ cbuf
writeIORef haCharBuffer cbuf'
if not (isEmptyBuffer cbuf') then return True else do
r <- IODevice.ready haDevice False msecs
if r then do
_ <- hLookAhead_ handle_
return True
else return False
hGetChar :: Handle -> IO Char
hGetChar handle =
wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
buf0 <- readIORef haCharBuffer
buf1 <- if isEmptyBuffer buf0
then readTextDevice handle_ buf0
else return buf0
(c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
let buf2 = bufferAdjustL i buf1
if haInputNL == CRLF && c1 == '\r'
then do
mbuf3 <- if isEmptyBuffer buf2
then maybeFillReadBuffer handle_ buf2
else return (Just buf2)
case mbuf3 of
Nothing -> do
writeIORef haCharBuffer buf2
return '\r'
Just buf3 -> do
(c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
if c2 == '\n'
then do
writeIORef haCharBuffer (bufferAdjustL i2 buf3)
return '\n'
else do
writeIORef haCharBuffer buf3
return '\r'
else do
writeIORef haCharBuffer buf2
return c1
hGetLine :: Handle -> IO String
hGetLine h =
wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
hGetLineBuffered handle_
hGetLineBuffered :: Handle__ -> IO String
hGetLineBuffered handle_@Handle__{..} = do
buf <- readIORef haCharBuffer
hGetLineBufferedLoop handle_ buf []
hGetLineBufferedLoop :: Handle__
-> CharBuffer -> [String]
-> IO String
hGetLineBufferedLoop handle_@Handle__{..}
buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
let
loop raw r
| r == w = return (False, w)
| otherwise = do
(c,r') <- readCharBuf raw r
if c == '\n'
then return (True, r)
else loop raw r'
in do
(eol, off) <- loop raw0 r0
debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
(xs,r') <- if haInputNL == CRLF
then unpack_nl raw0 r0 off ""
else do xs <- unpack raw0 r0 off ""
return (xs,off)
if eol
then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
return (concat (reverse (xs:xss)))
else do
let buf1 = bufferAdjustL r' buf
maybe_buf <- maybeFillReadBuffer handle_ buf1
case maybe_buf of
Nothing -> do
let pre = if not (isEmptyBuffer buf1) then "\r" else ""
writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
let str = concat (reverse (pre:xs:xss))
if not (null str)
then return str
else ioe_EOF
Just new_buf ->
hGetLineBufferedLoop handle_ new_buf (xs:xss)
maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
maybeFillReadBuffer handle_ buf
= Exception.catch
(do buf' <- getSomeCharacters handle_ buf
return (Just buf')
)
(\e -> do if isEOFError e
then return Nothing
else ioError e)
#define CHARBUF_UTF32
unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
unpack !buf !r !w acc0
| r == w = return acc0
| otherwise =
withRawBuffer buf $ \pbuf ->
let
unpackRB acc !i
| i < r = return acc
| otherwise = do
#ifdef CHARBUF_UTF16
c2 <- peekElemOff pbuf i
if (c2 < 0xdc00 || c2 > 0xdffff)
then unpackRB (unsafeChr (fromIntegral c2) : acc) (i1)
else do c1 <- peekElemOff pbuf (i1)
let c = (fromIntegral c1 0xd800) * 0x400 +
(fromIntegral c2 0xdc00) + 0x10000
case desurrogatifyRoundtripCharacter (unsafeChr c) of
{ C# c# -> unpackRB (C# c# : acc) (i2) }
#else
c <- peekElemOff pbuf i
unpackRB (c : acc) (i1)
#endif
in
unpackRB acc0 (w1)
unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
unpack_nl !buf !r !w acc0
| r == w = return (acc0, 0)
| otherwise =
withRawBuffer buf $ \pbuf ->
let
unpackRB acc !i
| i < r = return acc
| otherwise = do
c <- peekElemOff pbuf i
if (c == '\n' && i > r)
then do
c1 <- peekElemOff pbuf (i1)
if (c1 == '\r')
then unpackRB ('\n':acc) (i2)
else unpackRB ('\n':acc) (i1)
else do
unpackRB (c : acc) (i1)
in do
c <- peekElemOff pbuf (w1)
if (c == '\r')
then do
str <- unpackRB acc0 (w2)
return (str, w1)
else do
str <- unpackRB acc0 (w1)
return (str, w)
hGetContents :: Handle -> IO String
hGetContents handle =
wantReadableHandle "hGetContents" handle $ \handle_ -> do
xs <- lazyRead handle
return (handle_{ haType=SemiClosedHandle}, xs )
lazyRead :: Handle -> IO String
lazyRead handle =
unsafeInterleaveIO $
withHandle "hGetContents" handle $ \ handle_ -> do
case haType handle_ of
ClosedHandle -> return (handle_, "")
SemiClosedHandle -> lazyReadBuffered handle handle_
_ -> ioException
(IOError (Just handle) IllegalOperation "hGetContents"
"illegal handle type" Nothing Nothing)
lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
lazyReadBuffered h handle_@Handle__{..} = do
buf <- readIORef haCharBuffer
Exception.catch
(do
buf'@Buffer{..} <- getSomeCharacters handle_ buf
lazy_rest <- lazyRead h
(s,r) <- if haInputNL == CRLF
then unpack_nl bufRaw bufL bufR lazy_rest
else do s <- unpack bufRaw bufL bufR lazy_rest
return (s,bufR)
writeIORef haCharBuffer (bufferAdjustL r buf')
return (handle_, s)
)
(\e -> do (handle_', _) <- hClose_help handle_
debugIO ("hGetContents caught: " ++ show e)
let r = if isEOFError e
then if not (isEmptyBuffer buf)
then "\r"
else ""
else
throw (augmentIOError e "hGetContents" h)
return (handle_', r)
)
getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
case bufferElems buf of
0 -> readTextDevice handle_ buf
1 | haInputNL == CRLF -> do
(c,_) <- readCharBuf bufRaw bufL
if c == '\r'
then do
_ <- writeCharBuf bufRaw 0 '\r'
let buf' = buf{ bufL=0, bufR=1 }
readTextDevice handle_ buf'
else do
return buf
_otherwise ->
return buf
hPutChar :: Handle -> Char -> IO ()
hPutChar handle c = do
c `seq` return ()
wantWritableHandle "hPutChar" handle $ \ handle_ -> do
hPutcBuffered handle_ c
hPutcBuffered :: Handle__ -> Char -> IO ()
hPutcBuffered handle_@Handle__{..} c = do
buf <- readIORef haCharBuffer
if c == '\n'
then do buf1 <- if haOutputNL == CRLF
then do
buf1 <- putc buf '\r'
putc buf1 '\n'
else do
putc buf '\n'
writeCharBuffer handle_ buf1
when is_line $ flushByteWriteBuffer handle_
else do
buf1 <- putc buf c
writeCharBuffer handle_ buf1
return ()
where
is_line = case haBufferMode of
LineBuffering -> True
_ -> False
putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
debugIO ("putc: " ++ summaryBuffer buf)
w' <- writeCharBuf raw w c
return buf{ bufR = w' }
hPutStr :: Handle -> String -> IO ()
hPutStr handle str = hPutStr' handle str False
hPutStrLn :: Handle -> String -> IO ()
hPutStrLn handle str = hPutStr' handle str True
hPutStr' :: Handle -> String -> Bool -> IO ()
hPutStr' handle str add_nl =
do
(buffer_mode, nl) <-
wantWritableHandle "hPutStr" handle $ \h_ -> do
bmode <- getSpareBuffer h_
return (bmode, haOutputNL h_)
case buffer_mode of
(NoBuffering, _) -> do
hPutChars handle str
when add_nl $ hPutChar handle '\n'
(LineBuffering, buf) -> do
writeBlocks handle True add_nl nl buf str
(BlockBuffering _, buf) -> do
writeBlocks handle False add_nl nl buf str
hPutChars :: Handle -> [Char] -> IO ()
hPutChars _ [] = return ()
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
getSpareBuffer Handle__{haCharBuffer=ref,
haBuffers=spare_ref,
haBufferMode=mode}
= do
case mode of
NoBuffering -> return (mode, error "no buffer!")
_ -> do
bufs <- readIORef spare_ref
buf <- readIORef ref
case bufs of
BufferListCons b rest -> do
writeIORef spare_ref rest
return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
BufferListNil -> do
new_buf <- newCharBuffer (bufSize buf) WriteBuffer
return (mode, new_buf)
writeBlocks :: Handle -> Bool -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
writeBlocks hdl line_buffered add_nl nl
buf@Buffer{ bufRaw=raw, bufSize=len } s =
let
shoveString :: Int -> [Char] -> [Char] -> IO ()
shoveString !n [] [] = do
commitBuffer hdl raw len n False True
shoveString !n [] rest = do
shoveString n rest []
shoveString !n (c:cs) rest
| n + 1 >= len = do
commitBuffer hdl raw len n False False
shoveString 0 (c:cs) rest
| c == '\n' = do
n' <- if nl == CRLF
then do
n1 <- writeCharBuf raw n '\r'
writeCharBuf raw n1 '\n'
else do
writeCharBuf raw n c
if line_buffered
then do
commitBuffer hdl raw len n' True False
shoveString 0 cs rest
else do
shoveString n' cs rest
| otherwise = do
n' <- writeCharBuf raw n c
shoveString n' cs rest
in
shoveString 0 s (if add_nl then "\n" else "")
commitBuffer
:: Handle
-> RawCharBuffer -> Int
-> Int
-> Bool
-> Bool
-> IO ()
commitBuffer hdl !raw !sz !count flush release =
wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do
debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
++ ", flush=" ++ show flush ++ ", release=" ++ show release)
writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer,
bufL=0, bufR=count, bufSize=sz }
when flush $ flushByteWriteBuffer h_
when release $ do
old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
when (sz == size) $ do
spare_bufs <- readIORef haBuffers
writeIORef haBuffers (BufferListCons raw spare_bufs)
return ()
commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
-> IO CharBuffer
commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..}
= do
debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
++ ", flush=" ++ show flush ++ ", release=" ++ show release)
let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer,
bufL=0, bufR=count, bufSize=sz }
writeCharBuffer h_ this_buf
when flush $ flushByteWriteBuffer h_
when release $ do
old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
when (sz == size) $ do
spare_bufs <- readIORef haBuffers
writeIORef haBuffers (BufferListCons raw spare_bufs)
return this_buf
hPutBuf :: Handle
-> Ptr a
-> Int
-> IO ()
hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
return ()
hPutBufNonBlocking
:: Handle
-> Ptr a
-> Int
-> IO Int
hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
hPutBuf':: Handle
-> Ptr a
-> Int
-> Bool
-> IO Int
hPutBuf' handle ptr count can_block
| count == 0 = return 0
| count < 0 = illegalBufferSize handle "hPutBuf" count
| otherwise =
wantWritableHandle "hPutBuf" handle $
\ h_@Handle__{..} -> do
debugIO ("hPutBuf count=" ++ show count)
r <- bufWrite h_ (castPtr ptr) count can_block
case haBufferMode of
BlockBuffering _ -> do return ()
_line_or_no_buffering -> do flushWriteBuffer h_
return r
bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
bufWrite h_@Handle__{..} ptr count can_block =
seq count $ do
old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
<- readIORef haByteBuffer
if (size w > count)
then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
copyToRawBuffer old_raw w ptr count
writeIORef haByteBuffer old_buf{ bufR = w + count }
return count
else do debugIO "hPutBuf: flushing first"
old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
writeIORef haByteBuffer old_buf'
if count < size
then bufWrite h_ ptr count can_block
else if can_block
then do writeChunk h_ (castPtr ptr) count
return count
else writeChunkNonBlocking h_ (castPtr ptr) count
writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
writeChunk h_@Handle__{..} ptr bytes
| Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
| otherwise = error "Todo: hPutBuf"
writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
writeChunkNonBlocking h_@Handle__{..} ptr bytes
| Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
| otherwise = error "Todo: hPutBuf"
hGetBuf :: Handle -> Ptr a -> Int -> IO Int
hGetBuf h ptr count
| count == 0 = return 0
| count < 0 = illegalBufferSize h "hGetBuf" count
| otherwise =
wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
flushCharReadBuffer h_
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
<- readIORef haByteBuffer
if isEmptyBuffer buf
then bufReadEmpty h_ buf (castPtr ptr) 0 count
else bufReadNonEmpty h_ buf (castPtr ptr) 0 count
bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNonEmpty h_@Handle__{..}
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
ptr !so_far !count
= do
let avail = w r
if (count < avail)
then do
copyFromRawBuffer ptr raw r count
writeIORef haByteBuffer buf{ bufL = r + count }
return (so_far + count)
else do
copyFromRawBuffer ptr raw r avail
let buf' = buf{ bufR=0, bufL=0 }
writeIORef haByteBuffer buf'
let remaining = count avail
so_far' = so_far + avail
ptr' = ptr `plusPtr` avail
if remaining == 0
then return so_far'
else bufReadEmpty h_ buf' ptr' so_far' remaining
bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadEmpty h_@Handle__{..}
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
ptr so_far count
| count > sz, Just fd <- cast haDevice = loop fd 0 count
| otherwise = do
(r,buf') <- Buffered.fillReadBuffer haDevice buf
if r == 0
then return so_far
else do writeIORef haByteBuffer buf'
bufReadNonEmpty h_ buf' ptr so_far count
where
loop :: FD -> Int -> Int -> IO Int
loop fd off bytes | bytes <= 0 = return (so_far + off)
loop fd off bytes = do
r <- RawIO.read (fd::FD) (ptr `plusPtr` off) bytes
if r == 0
then return (so_far + off)
else loop fd (off + r) (bytes r)
hGetBufSome :: Handle -> Ptr a -> Int -> IO Int
hGetBufSome h ptr count
| count == 0 = return 0
| count < 0 = illegalBufferSize h "hGetBufSome" count
| otherwise =
wantReadableHandle_ "hGetBufSome" h $ \ h_@Handle__{..} -> do
flushCharReadBuffer h_
buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer
if isEmptyBuffer buf
then if count > sz
then do RawIO.read (haFD h_) (castPtr ptr) count
else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
if r == 0
then return 0
else do writeIORef haByteBuffer buf'
bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 (min r count)
else
bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count
haFD :: Handle__ -> FD
haFD h_@Handle__{..} =
case cast haDevice of
Nothing -> error "not an FD"
Just fd -> fd
hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
hGetBufNonBlocking h ptr count
| count == 0 = return 0
| count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
| otherwise =
wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do
flushCharReadBuffer h_
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
<- readIORef haByteBuffer
if isEmptyBuffer buf
then bufReadNBEmpty h_ buf (castPtr ptr) 0 count
else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count
bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNBEmpty h_@Handle__{..}
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
ptr so_far count
| count > sz,
Just fd <- cast haDevice = do
m <- RawIO.readNonBlocking (fd::FD) ptr count
case m of
Nothing -> return so_far
Just n -> return (so_far + n)
| otherwise = do
buf <- readIORef haByteBuffer
(r,buf') <- Buffered.fillReadBuffer0 haDevice buf
case r of
Nothing -> return so_far
Just 0 -> return so_far
Just r -> do
writeIORef haByteBuffer buf'
bufReadNBNonEmpty h_ buf' ptr so_far (min count r)
bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNBNonEmpty h_@Handle__{..}
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
ptr so_far count
= do
let avail = w r
if (count < avail)
then do
copyFromRawBuffer ptr raw r count
writeIORef haByteBuffer buf{ bufL = r + count }
return (so_far + count)
else do
copyFromRawBuffer ptr raw r avail
let buf' = buf{ bufR=0, bufL=0 }
writeIORef haByteBuffer buf'
let remaining = count avail
so_far' = so_far + avail
ptr' = ptr `plusPtr` avail
if remaining == 0
then return so_far'
else bufReadNBEmpty h_ buf' ptr' so_far' remaining
copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
copyToRawBuffer raw off ptr bytes =
withRawBuffer raw $ \praw ->
do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
return ()
copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
copyFromRawBuffer ptr raw off bytes =
withRawBuffer raw $ \praw ->
do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
return ()
foreign import ccall unsafe "memcpy"
memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
illegalBufferSize :: Handle -> String -> Int -> IO a
illegalBufferSize handle fn sz =
ioException (IOError (Just handle)
InvalidArgument fn
("illegal buffer size " ++ showsPrec 9 sz [])
Nothing Nothing)
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