module GHC.IO.Handle.Text (
hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
commitBuffer',
hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
memcpy,
) 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 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
= 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
unpackRB (unsafeChr 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
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
case haBufferMode handle_ of
LineBuffering -> hPutcBuffered handle_ True c
_other -> hPutcBuffered handle_ False c
hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
hPutcBuffered handle_@Handle__{..} is_line 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'
if is_line
then do
flushed_buf <- flushWriteBuffer_ handle_ buf1
writeIORef haCharBuffer flushed_buf
else
writeIORef haCharBuffer buf1
else do
buf1 <- putc buf c
writeIORef haCharBuffer buf1
where
putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
debugIO ("putc: " ++ summaryBuffer buf)
w' <- writeCharBuf raw w c
let buf' = buf{ bufR = w' }
if isFullCharBuffer buf'
then flushWriteBuffer_ handle_ buf'
else return buf'
hPutStr :: Handle -> String -> IO ()
hPutStr handle str = 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
(LineBuffering, buf) -> do
writeBlocks handle True nl buf str
(BlockBuffering _, buf) -> do
writeBlocks handle False 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 -> Newline -> Buffer CharBufElem -> String -> IO ()
writeBlocks hdl line_buffered nl
buf@Buffer{ bufRaw=raw, bufSize=len } s =
let
shoveString :: Int -> [Char] -> IO ()
shoveString !n [] = do
_ <- commitBuffer hdl raw len n False True
return ()
shoveString !n (c:cs)
| n + 1 >= len = do
new_buf <- commitBuffer hdl raw len n True False
writeBlocks hdl line_buffered nl new_buf (c:cs)
| 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
new_buf <- commitBuffer hdl raw len n' True False
writeBlocks hdl line_buffered nl new_buf cs
else do
shoveString n' cs
| otherwise = do
n' <- writeCharBuf raw n c
shoveString n' cs
in
shoveString 0 s
commitBuffer
:: Handle
-> RawCharBuffer -> Int
-> Int
-> Bool
-> Bool
-> IO CharBuffer
commitBuffer hdl !raw !sz !count flush release =
wantWritableHandle "commitAndReleaseBuffer" hdl $
commitBuffer' raw sz count flush release
commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
-> IO CharBuffer
commitBuffer' raw sz@(I# _) count@(I# _) flush release
handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
++ ", flush=" ++ show flush ++ ", release=" ++ show release)
old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
<- readIORef ref
buf_ret <-
if (not flush && (size w > count))
then do withRawBuffer raw $ \praw ->
copyToRawBuffer old_raw (w*charSize)
praw (fromIntegral (count*charSize))
writeIORef ref old_buf{ bufR = w + count }
return (emptyBuffer raw sz WriteBuffer)
else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
let this_buf =
Buffer{ bufRaw=raw, bufState=WriteBuffer,
bufL=0, bufR=count, bufSize=sz }
if (not flush && sz == size && count /= sz)
then do
writeIORef ref this_buf
return flushed_buf
else do
_ <- flushWriteBuffer_ handle_ this_buf
writeIORef ref flushed_buf
if sz == size
then return (emptyBuffer raw sz WriteBuffer)
else newCharBuffer size WriteBuffer
case buf_ret of
Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
if release && buf_ret_sz == size
then do
spare_bufs <- readIORef spare_buf_ref
writeIORef spare_buf_ref
(BufferListCons buf_ret_raw spare_bufs)
return buf_ret
else
return buf_ret
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)
cbuf <- readIORef haCharBuffer
when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
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 (fromIntegral 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 (fromIntegral r) (fromIntegral 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) (fromIntegral 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
bufReadNBEmpty 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 (fromIntegral r) (fromIntegral 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)