diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index a4e5b2d2..df1470c4 100644 --- a/src/Data/Text/IO.hs +++ b/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. diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs index d38eddee..73d4f0ae 100644 --- a/tests/Tests/QuickCheckUtils.hs +++ b/tests/Tests/QuickCheckUtils.hs @@ -40,7 +40,7 @@ import Data.Text.Foreign (I8) 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 @@ write_read unline filt writer reader modData , 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 @@ write_read unline filt writer reader modData 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