summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libraries/base/GHC/IO/Handle.hs7
-rw-r--r--libraries/base/GHC/IO/Handle/Internals.hs12
-rw-r--r--libraries/base/GHC/IO/Handle/Text.hs38
-rw-r--r--libraries/base/GHC/IO/Windows/Handle.hsc1
4 files changed, 37 insertions, 21 deletions
diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index 6b00706fc0..cdd878e3da 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -123,9 +123,10 @@ hFileSize handle =
r <- IODevice.getSize dev
debugIO $ "hFileSize: " ++ show r ++ " " ++ show handle
if r /= -1
- then return r
- else ioException (IOError Nothing InappropriateType "hFileSize"
- "not a regular file" Nothing Nothing)
+ then return r
+ else ioException (IOError Nothing InappropriateType "hFileSize"
+ "not a regular file" Nothing Nothing)
+
-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs
index 55c18d24b8..6aee4bb619 100644
--- a/libraries/base/GHC/IO/Handle/Internals.hs
+++ b/libraries/base/GHC/IO/Handle/Internals.hs
@@ -51,7 +51,7 @@ module GHC.IO.Handle.Internals (
HandleFinalizer, handleFinalizer,
- debugIO,
+ debugIO, traceIO
) where
import GHC.IO
@@ -268,7 +268,8 @@ checkWritableHandle act h_@Handle__{..}
-- Wrapper for read operations.
wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act)
+wantReadableHandle fun h act =
+ withHandle fun h (checkReadableHandle act)
wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantReadableHandle_ fun h@(FileHandle _ m) act
@@ -832,6 +833,13 @@ debugIO s
return ()
| otherwise = return ()
+-- For development, like debugIO but always on.
+traceIO :: String -> IO ()
+traceIO s = do
+ _ <- withCStringLen (s ++ "\n") $
+ \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
+ return ()
+
-- ----------------------------------------------------------------------------
-- Text input/output
diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs
index 75a59c3897..ee0289f066 100644
--- a/libraries/base/GHC/IO/Handle/Text.hs
+++ b/libraries/base/GHC/IO/Handle/Text.hs
@@ -6,7 +6,7 @@
, NondecreasingIndentation
, MagicHash
#-}
-{-# OPTIONS_GHC -Wno-name-shadowing #-}
+-- {-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -576,9 +576,9 @@ hPutcBuffered handle_@Handle__{..} c = do
LineBuffering -> True
_ -> False
- putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
+ putc buf@Buffer{ bufRaw=raw, bufR=w } c' = do
debugIO ("putc: " ++ summaryBuffer buf)
- w' <- writeCharBuf raw w c
+ w' <- writeCharBuf raw w c'
return buf{ bufR = w' }
-- ---------------------------------------------------------------------------
@@ -913,7 +913,7 @@ hGetBuf h !ptr count
| count < 0 = illegalBufferSize h "hGetBuf" count
| otherwise =
wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
- debugIO $ ":: hGetBuf - " ++ show h
+ debugIO $ ":: hGetBuf - " ++ show h ++ " - " ++ show count
flushCharReadBuffer h_
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
<- readIORef haByteBuffer
@@ -954,26 +954,32 @@ bufReadNonEmpty h_@Handle__{..}
ptr' = ptr `plusPtr` avail
debugIO ("bufReadNonEmpty: " ++ summaryBuffer buf' ++ " s:" ++ show so_far' ++ " r:" ++ show remaining)
- if remaining == 0
+ b <- if remaining == 0
then return so_far'
else bufReadEmpty h_ buf' ptr' so_far' remaining
+ debugIO ":: bufReadNonEmpty - done"
+ return b
-- We want to read more data, but the buffer is empty. (buffL == buffR == 0)
-- See also Note [INVARIANTS on Buffers] in Buffer.hs
bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadEmpty h_@Handle__{..}
- buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz, bufOffset=bff }
+ buf@Buffer{ bufRaw=raw, bufR=w, bufL=_r, bufSize=sz, bufOffset=bff }
ptr so_far count
| count > sz
= do
- count <- loop haDevice 0 bff count
- let buf1 = bufferAddOffset (fromIntegral count) buf
+ bytes_read <- loop haDevice 0 bff count
+ -- bytes_read includes so_far (content that was in the buffer)
+ -- but that is already accounted for in the old offset, so don't
+ -- count it twice.
+ let buf1 = bufferAddOffset (fromIntegral $ bytes_read - so_far) buf
writeIORef haByteBuffer buf1
- debugIO ("bufReadEmpty: " ++ summaryBuffer buf1)
- return count
+ debugIO ("bufReadEmpty1.1: " ++ summaryBuffer buf1 ++ " read:" ++ show bytes_read)
+ return bytes_read
| otherwise = do
(r,buf') <- Buffered.fillReadBuffer haDevice buf
- if r == 0
+ writeIORef haByteBuffer buf'
+ if r == 0 -- end of file reached
then return so_far
else do writeIORef haByteBuffer buf'
bufReadNonEmpty h_ buf' ptr so_far count
@@ -1067,7 +1073,7 @@ hGetBufNonBlocking h !ptr count
bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadNBEmpty h_@Handle__{..}
- buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz
+ buf@Buffer{ bufRaw=raw, bufR=w, bufL=_r, bufSize=sz
, bufOffset=offset }
ptr so_far count
| count > sz = do
@@ -1077,15 +1083,15 @@ bufReadNBEmpty h_@Handle__{..}
Just n -> return (so_far + n)
| otherwise = do
- buf <- readIORef haByteBuffer
+ -- buf <- readIORef haByteBuffer
(r,buf') <- Buffered.fillReadBuffer0 haDevice buf
case r of
Nothing -> return so_far
Just 0 -> return so_far
- Just r -> do
+ Just r' -> do
writeIORef haByteBuffer buf'
- bufReadNBNonEmpty h_ buf' ptr so_far (min count r)
- -- NOTE: new count is min count r
+ bufReadNBNonEmpty h_ buf' ptr so_far (min count r')
+ -- NOTE: new count is min count r'
-- so we will just copy the contents of the
-- buffer in the recursive call, and not
-- loop again.
diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc
index d96ccc364e..1611ece011 100644
--- a/libraries/base/GHC/IO/Windows/Handle.hsc
+++ b/libraries/base/GHC/IO/Windows/Handle.hsc
@@ -482,6 +482,7 @@ hwndWriteNonBlocking hwnd ptr offset bytes
(startCB ptr) completionCB
return $ fromIntegral $ ioValue val
where
+ startCB :: Ptr a -> LPOVERLAPPED -> IO (Mgr.CbResult a1)
startCB outBuf lpOverlapped = do
debugIO ":: hwndWriteNonBlocking"
-- See Note [ReadFile/WriteFile].