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

8 files changed, 125 insertions, 2 deletions

diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index 256cf59061..a847bcffca 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -45,7 +45,7 @@ module GHC.IO.Handle (
 
    hShow,
 
-   hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
+   hWaitForInput, hGetChar, hGetLine, hGetContents, hGetContents', hPutChar, hPutStr,
 
    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking
  ) where
diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs
index 1222946d46..b1533e3c5d 100644
--- a/libraries/base/GHC/IO/Handle/Text.hs
+++ b/libraries/base/GHC/IO/Handle/Text.hs
@@ -28,7 +28,7 @@ module GHC.IO.Handle.Text (
         hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
         commitBuffer',       -- hack, see below
         hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
-        memcpy, hPutStrLn,
+        memcpy, hPutStrLn, hGetContents',
     ) where
 
 import GHC.IO
@@ -48,6 +48,7 @@ import Foreign.C
 import qualified Control.Exception as Exception
 import Data.Typeable
 import System.IO.Error
+import Data.Either (Either(..))
 import Data.Maybe
 
 import GHC.IORef
@@ -453,6 +454,90 @@ getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
     _otherwise ->
       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
 
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index 2ae0e1e6da..70bc61c90b 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -60,6 +60,7 @@ module System.IO (
     -- | These functions are also exported by the "Prelude".
 
     readFile,
+    readFile',
     writeFile,
     appendFile,
 
@@ -123,6 +124,7 @@ module System.IO (
     hGetLine,
     hLookAhead,
     hGetContents,
+    hGetContents',
 
     -- ** Text output
 
@@ -143,6 +145,7 @@ module System.IO (
     getChar,
     getLine,
     getContents,
+    getContents',
     readIO,
     readLn,
 
@@ -305,6 +308,15 @@ getLine         =  hGetLine stdin
 getContents     :: IO String
 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@
 -- as its argument.  The entire input from the standard input device is
 -- passed to this function as its argument, and the resulting string is
@@ -321,6 +333,15 @@ interact f      =   do s <- getContents
 readFile        :: FilePath -> IO String
 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@,
 -- to the file @file@.
 writeFile :: FilePath -> String -> IO ()
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index e667b3fef9..741b5ebca2 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -51,6 +51,9 @@
 
   * 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*
   * Bundled with GHC 8.8.1
 
diff --git a/libraries/base/tests/.gitignore b/libraries/base/tests/.gitignore
index 32b9d10188..9851140c53 100644
--- a/libraries/base/tests/.gitignore
+++ b/libraries/base/tests/.gitignore
@@ -122,6 +122,7 @@
 /IO/hFlush001.out
 /IO/hGetBuf001
 /IO/hGetBuffering001
+/IO/hGetContentsS001
 /IO/hGetChar001
 /IO/hGetLine001
 /IO/hGetLine002
diff --git a/libraries/base/tests/IO/all.T b/libraries/base/tests/IO/all.T
index 818ce67267..0ba27f1b42 100644
--- a/libraries/base/tests/IO/all.T
+++ b/libraries/base/tests/IO/all.T
@@ -20,6 +20,7 @@ test('hGetBuffering001',
 	[omit_ways(['ghci']), set_stdin('hGetBuffering001.hs')], 
 	compile_and_run, [''])
 
+test('hGetContentsS001', normal, compile_and_run, [''])
 test('hGetChar001', normal, compile_and_run, [''])
 test('hGetLine001', set_stdin('hGetLine001.hs'), compile_and_run, ['-cpp'])
 test('hGetLine002', normal, compile_and_run, [''])
diff --git a/libraries/base/tests/IO/hGetContentsS001.hs b/libraries/base/tests/IO/hGetContentsS001.hs
new file mode 100644
index 0000000000..be0935795e
--- /dev/null
+++ b/libraries/base/tests/IO/hGetContentsS001.hs
@@ -0,0 +1,8 @@
+import System.IO
+
+file = "hGetContentsS001.txt"
+
+main = do
+  writeFile file "ab\ncd\nef\ngh\n"
+  h <- openFile file ReadMode
+  hGetContents' h >>= putStr
diff --git a/libraries/base/tests/IO/hGetContentsS001.stdout b/libraries/base/tests/IO/hGetContentsS001.stdout
new file mode 100644
index 0000000000..7cddf5ba9e
--- /dev/null
+++ b/libraries/base/tests/IO/hGetContentsS001.stdout
@@ -0,0 +1,4 @@
+ab
+cd
+ef
+gh