added noShrink to write_read shrinking takes forever on type

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,
@@ -42,6 +43,7 @@ module Data.Text.IO
     , putStrLn
     ) where
 
+import Data.Bool (bool)
 import Data.Text (Text)
 import Prelude hiding (appendFile, getContents, getLine, interact,
                        putStr, putStrLn, readFile, writeFile)
@@ -54,9 +56,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)
@@ -184,9 +186,7 @@ hPutStr h t = do
   case buffer_mode of
      (NoBuffering, _)        -> hPutChars h str
      (LineBuffering, buf)    -> writeLines h nl buf str
-     (BlockBuffering _, buf)
-         | nl == CRLF        -> writeBlocksCRLF h buf str
-         | otherwise         -> writeBlocksRaw h buf str
+     (BlockBuffering _, buf) -> writeBlocks (nl == CRLF) h buf str
 
 hPutChars :: Handle -> Stream Char -> IO ()
 hPutChars h (Stream next0 s0 _len) = loop s0
@@ -206,55 +206,48 @@ 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 h buf0 (Stream next0 s0 _len) = outer s0 buf0
+writeBlocks :: Bool -> Handle -> CharBuffer -> Stream Char -> IO ()
+writeBlocks isCRLF 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 >= bufSize + bool 10 10 (isCRLF && x == '\n') ->
+            commit n True{-needs flush-} False >>= outer s
+          | isCRLF && 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 h buf0 (Stream next0 s0 _len) = outer s0 buf0
- where
-  outer s1 Buffer{bufRaw=raw, bufSize=len} = 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
-          | otherwise    -> writeCharBuf raw n x >>= inner s'
-    commit = commitBuffer h raw len
+-- | 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 +269,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.

tests/Tests/QuickCheckUtils.hs

@@ -40,7 +40,7 @@
 import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
 import Data.Word (Word8, Word16)
 import GHC.IO.Encoding.Types (TextEncoding(TextEncoding,textEncodingName))
-import Test.QuickCheck (Arbitrary(..), arbitraryUnicodeChar, arbitraryBoundedEnum, getUnicodeString, arbitrarySizedIntegral, shrinkIntegral, Property, ioProperty, discard, counterexample, scale, (.&&.), NonEmptyList(..), forAll, getPositive)
+import Test.QuickCheck (Arbitrary(..), arbitraryUnicodeChar, arbitraryBoundedEnum, getUnicodeString, arbitrarySizedIntegral, shrinkIntegral, Property, ioProperty, discard, counterexample, scale, (.&&.), NonEmptyList(..), forAll, getPositive, noShrinking)
 import Test.QuickCheck.Gen (Gen, choose, chooseAny, elements, frequency, listOf, oneof, resize, sized)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.QuickCheck (testProperty)
@@ -263,9 +263,9 @@
     , testProperty "BlockBuffering" $ propTest enc blockBuffering
     ]
   where
-  propTest :: TextEncoding -> Gen IO.BufferMode -> IO.NewlineMode -> c -> Property
-  propTest _   _ (IO.NewlineMode IO.LF IO.CRLF) _ = discard
-  propTest enc genBufferMode nl d = forAll genBufferMode $ \mode -> ioProperty $ withTempFile $ \_ h -> do
+  propTest :: TextEncoding -> Gen IO.BufferMode -> NoShrink IO.NewlineMode -> c -> Property
+  propTest _   _ (NoShrink (IO.NewlineMode IO.LF IO.CRLF)) _ = discard
+  propTest enc genBufferMode (NoShrink nl) d = forAll (NoShrink <$> genBufferMode) $ \(NoShrink mode) -> ioProperty $ withTempFile $ \_ h -> do
     let ts = modData d
         t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
     IO.hSetEncoding h enc
@@ -282,6 +282,10 @@
   blockBuffering :: Gen IO.BufferMode
   blockBuffering = IO.BlockBuffering <$> fmap (fmap $ min 4 . getPositive) arbitrary
 
+newtype NoShrink a = NoShrink a deriving Show
+instance Arbitrary a => Arbitrary (NoShrink a) where
+  arbitrary = NoShrink <$> arbitrary
+
 -- Generate various Unicode space characters with high probability
 arbitrarySpacyChar :: Gen Char
 arbitrarySpacyChar = oneof