added a bounds assert for writeCharBuff in hPutStr

src/Data/Text/IO.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-}
 {-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NamedFieldPuns #-}
 -- |
 -- Module      : Data.Text.IO
 -- Copyright   : (c) 2009, 2010 Bryan O'Sullivan,
@@ -54,9 +55,9 @@ import qualified Data.Text as T
 import Data.Text.Internal.Fusion (stream)
 import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
 import Data.Text.Internal.IO (hGetLineWith, readChunk)
-import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,
-                      RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer,
-                      writeCharBuf)
+import GHC.IO.Buffer (Buffer(..), BufferState(..), RawCharBuffer, CharBuffer,
+                      emptyBuffer, isEmptyBuffer, newCharBuffer)
+import qualified GHC.IO.Buffer
 import GHC.IO.Exception (IOException(ioe_type), IOErrorType(InappropriateType))
 import GHC.IO.Handle.Internals (augmentIOError, hClose_help, wantReadableHandle,
                                 wantWritableHandle)
@@ -206,55 +207,60 @@ hPutChars h (Stream next0 s0 _len) = loop s0
 -- performance improvement.  Lifting out the raw/cooked newline
 -- handling gave a few more percent on top.
 
-writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO ()
+writeLines :: Handle -> Newline -> CharBuffer -> Stream Char -> IO ()
 writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0
  where
-  outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
+  outer s1 buf@Buffer{..} = inner s1 (0::Int)
    where
     inner !s !n =
       case next0 s of
         Done -> commit n False{-no flush-} True{-release-} >> return ()
         Skip s' -> inner s' n
         Yield x s'
-          | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s
+          | n + 1 >= bufSize -> commit n True{-needs flush-} False >>= outer s
           | x == '\n'    -> do
                    n' <- if nl == CRLF
-                         then do n1 <- writeCharBuf raw n '\r'
-                                 writeCharBuf raw n1 '\n'
-                         else writeCharBuf raw n x
+                         then do n1 <- writeCharBuf bufRaw bufSize n '\r'
+                                 writeCharBuf bufRaw bufSize n1 '\n'
+                         else writeCharBuf bufRaw bufSize n x
                    commit n' True{-needs flush-} False >>= outer s'
-          | otherwise    -> writeCharBuf raw n x >>= inner s'
-    commit = commitBuffer h raw len
+          | otherwise    -> writeCharBuf bufRaw bufSize n x >>= inner s'
+    commit = commitBuffer h buf
 
-writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
+writeBlocksCRLF :: Handle -> CharBuffer -> Stream Char -> IO ()
 writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
  where
-  outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
+  outer s1 buf@Buffer{..} = inner s1 (0::Int)
    where
     inner !s !n =
       case next0 s of
         Done -> commit n False{-no flush-} True{-release-} >> return ()
         Skip s' -> inner s' n
         Yield x s'
-          | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s
-          | x == '\n'    -> do n1 <- writeCharBuf raw n '\r'
-                               writeCharBuf raw n1 '\n' >>= inner s'
-          | otherwise    -> writeCharBuf raw n x >>= inner s'
-    commit = commitBuffer h raw len
+          | n + 1 >= bufSize -> commit n True{-needs flush-} False >>= outer s
+          | x == '\n'    -> do n1 <- writeCharBuf bufRaw bufSize n '\r'
+                               writeCharBuf bufRaw bufSize n1 '\n' >>= inner s'
+          | otherwise    -> writeCharBuf bufRaw bufSize n x >>= inner s'
+    commit = commitBuffer h buf
 
-writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
+writeBlocksRaw :: Handle -> CharBuffer -> Stream Char -> IO ()
 writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
  where
-  outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
+  outer s1 buf@Buffer{..} = inner s1 (0::Int)
    where
     inner !s !n =
       case next0 s of
         Done -> commit n False{-no flush-} True{-release-} >> return ()
         Skip s' -> inner s' n
         Yield x s'
-          | n - 10 >= len -> commit n True{-needs flush-} False >>= outer s
-          | otherwise    -> writeCharBuf raw n x >>= inner s'
-    commit = commitBuffer h raw len
+          | n >= bufSize -> commit n True{-needs flush-} False >>= outer s
+          | otherwise    -> writeCharBuf bufRaw bufSize n x >>= inner s'
+    commit = commitBuffer h buf
+
+-- | Only modifies the raw buffer and not the buffer attributes
+writeCharBuf :: RawCharBuffer -> Int -> Int -> Char -> IO Int
+writeCharBuf bufRaw bufSize n c = E.assert (n >= 0 && n < bufSize) $
+  GHC.IO.Buffer.writeCharBuf bufRaw n c
 
 -- This function is completely lifted from GHC.IO.Handle.Text.
 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
@@ -276,12 +282,12 @@ getSpareBuffer Handle__{haCharBuffer=ref,
                 return (mode, new_buf)
 
 
--- This function is completely lifted from GHC.IO.Handle.Text.
-commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
+-- This function is modified from GHC.Internal.IO.Handle.Text.
+commitBuffer :: Handle -> CharBuffer -> Int -> Bool -> Bool
              -> IO CharBuffer
-commitBuffer hdl !raw !sz !count flush release =
+commitBuffer hdl Buffer{bufRaw, bufSize} !count flush release =
   wantWritableHandle "commitAndReleaseBuffer" hdl $
-     commitBuffer' raw sz count flush release
+     commitBuffer' bufRaw bufSize count flush release
 {-# INLINE commitBuffer #-}
 
 -- | Write a string to a handle, followed by a newline.