Commit 818b3c38 authored by Xia Li-yao's avatar Xia Li-yao Committed by Marge Bot

base: add strict IO functions: readFile', getContents', hGetContents'

parent cfcc3c9a
Pipeline #16790 passed with stages
in 417 minutes and 7 seconds
...@@ -45,7 +45,7 @@ module GHC.IO.Handle ( ...@@ -45,7 +45,7 @@ module GHC.IO.Handle (
hShow, hShow,
hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, hWaitForInput, hGetChar, hGetLine, hGetContents, hGetContents', hPutChar, hPutStr,
hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking
) where ) where
......
...@@ -28,7 +28,7 @@ module GHC.IO.Handle.Text ( ...@@ -28,7 +28,7 @@ module GHC.IO.Handle.Text (
hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
commitBuffer', -- hack, see below commitBuffer', -- hack, see below
hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
memcpy, hPutStrLn, memcpy, hPutStrLn, hGetContents',
) where ) where
import GHC.IO import GHC.IO
...@@ -48,6 +48,7 @@ import Foreign.C ...@@ -48,6 +48,7 @@ import Foreign.C
import qualified Control.Exception as Exception import qualified Control.Exception as Exception
import Data.Typeable import Data.Typeable
import System.IO.Error import System.IO.Error
import Data.Either (Either(..))
import Data.Maybe import Data.Maybe
import GHC.IORef import GHC.IORef
...@@ -453,6 +454,90 @@ getSomeCharacters handle_@Handle__{..} buf@Buffer{..} = ...@@ -453,6 +454,90 @@ getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
_otherwise -> _otherwise ->
return buf return buf
-- -----------------------------------------------------------------------------
-- hGetContents'
-- We read everything into a list of CharBuffer chunks, and convert it lazily
-- to a string, which minimizes memory usage.
-- In the worst case, space usage is at most that of the complete String,
-- as the chunks can be garbage collected progressively.
-- For streaming consumers, space usage is at most that of the list of chunks.
-- | The 'hGetContents'' operation reads all input on the given handle
-- before returning it as a 'String' and closing the handle.
--
-- @since 4.14.0.0
hGetContents' :: Handle -> IO String
hGetContents' handle = do
es <- wantReadableHandle "hGetContents'" handle (strictRead handle)
case es of
Right s -> return s
Left e ->
case fromException e of
Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle)
Nothing -> throwIO e
strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String)
strictRead h handle_@Handle__{..} = do
cbuf <- readIORef haCharBuffer
cbufs <- strictReadLoop' handle_ [] cbuf
(handle_', me) <- hClose_help handle_
case me of
Just e -> return (handle_', Left e)
Nothing -> do
s <- lazyBuffersToString haInputNL cbufs ""
return (handle_', Right s)
strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer]
strictReadLoop handle_ cbufs cbuf0 = do
mcbuf <- Exception.catch
(do r <- readTextDevice handle_ cbuf0
return (Just r))
(\e -> if isEOFError e
then return Nothing
else throw e)
case mcbuf of
Nothing -> return (cbuf0 : cbufs)
Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1
-- If 'cbuf' is full, allocate a new buffer.
strictReadLoop' :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer]
strictReadLoop' handle_ cbufs cbuf
| isFullCharBuffer cbuf = do
cbuf' <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE ReadBuffer
strictReadLoop handle_ (cbuf : cbufs) cbuf'
| otherwise = strictReadLoop handle_ cbufs cbuf
-- Lazily convert a list of buffers to a String. The buffers are
-- in reverse order: the first buffer is the end of the String.
lazyBuffersToString :: Newline -> [CharBuffer] -> String -> IO String
lazyBuffersToString LF = loop where
loop [] s = return s
loop (Buffer{..} : cbufs) s = do
s' <- unsafeInterleaveIO (unpack bufRaw bufL bufR s)
loop cbufs s'
lazyBuffersToString CRLF = loop '\0' where
loop before [] s = return s
loop before (Buffer{..} : cbufs) s
| bufL == bufR = loop before cbufs s -- skip empty buffers
| otherwise = do
-- When a CRLF is broken across two buffers, we already have a newline
-- from decoding the LF, so we ignore the CR in the current buffer.
s1 <- if before == '\n'
then return s
else do
-- We restore trailing CR not followed by LF.
c <- peekCharBuf bufRaw (bufR - 1)
if c == '\r'
then return ('\r' : s)
else return s
s2 <- unsafeInterleaveIO (do
(s2, _) <- unpack_nl bufRaw bufL bufR s1
return s2)
c0 <- peekCharBuf bufRaw bufL
loop c0 cbufs s2
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- hPutChar -- hPutChar
......
...@@ -60,6 +60,7 @@ module System.IO ( ...@@ -60,6 +60,7 @@ module System.IO (
-- | These functions are also exported by the "Prelude". -- | These functions are also exported by the "Prelude".
readFile, readFile,
readFile',
writeFile, writeFile,
appendFile, appendFile,
...@@ -123,6 +124,7 @@ module System.IO ( ...@@ -123,6 +124,7 @@ module System.IO (
hGetLine, hGetLine,
hLookAhead, hLookAhead,
hGetContents, hGetContents,
hGetContents',
-- ** Text output -- ** Text output
...@@ -143,6 +145,7 @@ module System.IO ( ...@@ -143,6 +145,7 @@ module System.IO (
getChar, getChar,
getLine, getLine,
getContents, getContents,
getContents',
readIO, readIO,
readLn, readLn,
...@@ -305,6 +308,15 @@ getLine = hGetLine stdin ...@@ -305,6 +308,15 @@ getLine = hGetLine stdin
getContents :: IO String getContents :: IO String
getContents = hGetContents stdin getContents = hGetContents stdin
-- | The 'getContents'' operation returns all user input as a single string,
-- which is fully read before being returned
-- (same as 'hGetContents'' 'stdin').
--
-- @since 4.14.0.0
getContents' :: IO String
getContents' = hGetContents' stdin
-- | The 'interact' function takes a function of type @String->String@ -- | The 'interact' function takes a function of type @String->String@
-- as its argument. The entire input from the standard input device is -- as its argument. The entire input from the standard input device is
-- passed to this function as its argument, and the resulting string is -- passed to this function as its argument, and the resulting string is
...@@ -321,6 +333,15 @@ interact f = do s <- getContents ...@@ -321,6 +333,15 @@ interact f = do s <- getContents
readFile :: FilePath -> IO String readFile :: FilePath -> IO String
readFile name = openFile name ReadMode >>= hGetContents readFile name = openFile name ReadMode >>= hGetContents
-- | The 'readFile'' function reads a file and
-- returns the contents of the file as a string.
-- The file is fully read before being returned, as with 'getContents''.
--
-- @since 4.14.0.0
readFile' :: FilePath -> IO String
readFile' name = openFile name ReadMode >>= hGetContents'
-- | The computation 'writeFile' @file str@ function writes the string @str@, -- | The computation 'writeFile' @file str@ function writes the string @str@,
-- to the file @file@. -- to the file @file@.
writeFile :: FilePath -> String -> IO () writeFile :: FilePath -> String -> IO ()
......
...@@ -51,6 +51,9 @@ ...@@ -51,6 +51,9 @@
* Add `IsList` instance for `ZipList`. * Add `IsList` instance for `ZipList`.
* Add `hGetContents'`, `getContents'`, and `readFile'` in `System.IO`:
Strict IO variants of `hGetContents`, `getContents`, and `readFile`.
## 4.13.0.0 *July 2019* ## 4.13.0.0 *July 2019*
* Bundled with GHC 8.8.1 * Bundled with GHC 8.8.1
......
...@@ -122,6 +122,7 @@ ...@@ -122,6 +122,7 @@
/IO/hFlush001.out /IO/hFlush001.out
/IO/hGetBuf001 /IO/hGetBuf001
/IO/hGetBuffering001 /IO/hGetBuffering001
/IO/hGetContentsS001
/IO/hGetChar001 /IO/hGetChar001
/IO/hGetLine001 /IO/hGetLine001
/IO/hGetLine002 /IO/hGetLine002
......
...@@ -20,6 +20,7 @@ test('hGetBuffering001', ...@@ -20,6 +20,7 @@ test('hGetBuffering001',
[omit_ways(['ghci']), set_stdin('hGetBuffering001.hs')], [omit_ways(['ghci']), set_stdin('hGetBuffering001.hs')],
compile_and_run, ['']) compile_and_run, [''])
test('hGetContentsS001', normal, compile_and_run, [''])
test('hGetChar001', normal, compile_and_run, ['']) test('hGetChar001', normal, compile_and_run, [''])
test('hGetLine001', set_stdin('hGetLine001.hs'), compile_and_run, ['-cpp']) test('hGetLine001', set_stdin('hGetLine001.hs'), compile_and_run, ['-cpp'])
test('hGetLine002', normal, compile_and_run, ['']) test('hGetLine002', normal, compile_and_run, [''])
......
import System.IO
file = "hGetContentsS001.txt"
main = do
writeFile file "ab\ncd\nef\ngh\n"
h <- openFile file ReadMode
hGetContents' h >>= putStr
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment