text 1.2.3.0 → 1.2.3.1
raw patch · 15 files changed
+171/−57 lines, 15 filesdep ~QuickCheckdep ~integer-gmp
Dependency ranges changed: QuickCheck, integer-gmp
Files
- Data/Text.hs +0/−4
- Data/Text/Encoding.hs +50/−7
- Data/Text/IO.hs +15/−6
- Data/Text/Internal/Fusion/Common.hs +7/−3
- Data/Text/Internal/Fusion/Size.hs +5/−1
- Data/Text/Lazy.hs +0/−4
- Data/Text/Lazy/Builder/RealFloat.hs +8/−0
- benchmarks/text-benchmarks.cabal +1/−1
- changelog.md +14/−0
- tests/.ghci +1/−1
- tests/Tests/Properties.hs +41/−17
- tests/Tests/QuickCheckUtils.hs +4/−1
- tests/Tests/Regressions.hs +15/−0
- tests/text-tests.cabal +0/−2
- text.cabal +10/−10
Data/Text.hs view
@@ -204,9 +204,7 @@ Read(..), (&&), (||), (+), (-), (.), ($), ($!), (>>), not, return, otherwise, quot)-#if defined(HAVE_DEEPSEQ) import Control.DeepSeq (NFData(rnf))-#endif #if defined(ASSERTS) import Control.Exception (assert) #endif@@ -381,9 +379,7 @@ toList = unpack #endif -#if defined(HAVE_DEEPSEQ) instance NFData Text where rnf !_ = ()-#endif -- | @since 1.2.1.0 instance Binary Text where
Data/Text/Encoding.hs view
@@ -65,7 +65,7 @@ import Control.Monad.ST (unsafeIOToST, unsafeSTToIO) #endif -import Control.Exception (evaluate, try)+import Control.Exception (evaluate, try, throwIO, ErrorCall(ErrorCall)) import Control.Monad.ST (runST) import Data.Bits ((.&.)) import Data.ByteString as B@@ -131,6 +131,13 @@ return dest -- | Decode a 'ByteString' containing UTF-8 encoded text.+--+-- __NOTE__: The replacement character returned by 'OnDecodeError'+-- MUST be within the BMP plane; surrogate code points will+-- automatically be remapped to the replacement char @U+FFFD@+-- (/since 0.11.3.0/), whereas code points beyond the BMP will throw an+-- 'error' (/since 1.2.3.1/); For earlier versions of @text@ using+-- those unsupported code points would result in undefined behavior. decodeUtf8With :: OnDecodeError -> ByteString -> Text decodeUtf8With onErr (PS fp off len) = runText $ \done -> do let go dest = withForeignPtr fp $ \ptr ->@@ -146,16 +153,52 @@ x <- peek curPtr' case onErr desc (Just x) of Nothing -> loop $ curPtr' `plusPtr` 1- Just c -> do- destOff <- peek destOffPtr- w <- unsafeSTToIO $- unsafeWrite dest (fromIntegral destOff) (safe c)- poke destOffPtr (destOff + fromIntegral w)- loop $ curPtr' `plusPtr` 1+ Just c+ | c > '\xFFFF' -> throwUnsupportedReplChar+ | otherwise -> do+ destOff <- peek destOffPtr+ w <- unsafeSTToIO $+ unsafeWrite dest (fromIntegral destOff)+ (safe c)+ poke destOffPtr (destOff + fromIntegral w)+ loop $ curPtr' `plusPtr` 1 loop (ptr `plusPtr` off) (unsafeIOToST . go) =<< A.new len where desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"++ throwUnsupportedReplChar = throwIO $+ ErrorCall "decodeUtf8With: non-BMP replacement characters not supported"+ -- TODO: The code currently assumes that the transcoded UTF-16+ -- stream is at most twice as long (in bytes) as the input UTF-8+ -- stream. To justify this assumption one has to assume that the+ -- error handler replacement character also satisfies this+ -- invariant, by emitting at most one UTF16 code unit.+ --+ -- One easy way to support the full range of code-points for+ -- replacement characters in the error handler is to simply change+ -- the (over-)allocation to `A.new (2*len)` and then shrink back the+ -- `ByteArray#` to the real size (recent GHCs have a cheap+ -- `ByteArray#` resize-primop for that which allow the GC to reclaim+ -- the overallocation). However, this would require 4 times as much+ -- (temporary) storage as the original UTF-8 required.+ --+ -- Another strategy would be to optimistically assume that+ -- replacement characters are within the BMP, and if the case of a+ -- non-BMP replacement occurs reallocate the target buffer (or throw+ -- an exception, and fallback to a pessimistic codepath, like e.g.+ -- `decodeUtf8With onErr bs = F.unstream (E.streamUtf8 onErr bs)`)+ --+ -- Alternatively, `OnDecodeError` could become a datastructure which+ -- statically encodes the replacement-character range,+ -- e.g. something isomorphic to+ --+ -- Either (... -> Maybe Word16) (... -> Maybe Char)+ --+ -- And allow to statically switch between the BMP/non-BMP+ -- replacement-character codepaths. There's multiple ways to address+ -- this with different tradeoffs; but ideally we should optimise for+ -- the optimistic/error-free case. {- INLINE[0] decodeUtf8With #-} -- $stream
Data/Text/IO.hs view
@@ -95,15 +95,23 @@ appendFile :: FilePath -> Text -> IO () appendFile p = withFile p AppendMode . flip hPutStr -catchError :: String -> Handle -> Handle__ -> IOError -> IO Text+catchError :: String -> Handle -> Handle__ -> IOError -> IO (Text, Bool) catchError caller h Handle__{..} err | isEOFError err = do buf <- readIORef haCharBuffer return $ if isEmptyBuffer buf- then T.empty- else T.singleton '\r'+ then (T.empty, True)+ else (T.singleton '\r', True) | otherwise = E.throwIO (augmentIOError err caller h) +-- | Wrap readChunk and return a value indicating if we're reached the EOF.+-- This is needed because unpack_nl is unable to discern the difference+-- between a buffer with just \r due to EOF or because not enough data was left+-- for decoding. e.g. the final character decoded from the byte buffer was \r.+readChunkEof :: Handle__ -> CharBuffer -> IO (Text, Bool)+readChunkEof hh buf = do t <- readChunk hh buf+ return (t, False)+ -- | /Experimental./ Read a single chunk of strict text from a -- 'Handle'. The size of the chunk depends on the amount of input -- currently buffered.@@ -116,7 +124,7 @@ where readSingleChunk hh@Handle__{..} = do buf <- readIORef haCharBuffer- t <- readChunk hh buf `E.catch` catchError "hGetChunk" h hh+ (t, _) <- readChunkEof hh buf `E.catch` catchError "hGetChunk" h hh return (hh, t) -- | Read the remaining contents of a 'Handle' as a string. The@@ -138,8 +146,9 @@ readAll hh@Handle__{..} = do let readChunks = do buf <- readIORef haCharBuffer- t <- readChunk hh buf `E.catch` catchError "hGetContents" h hh- if T.null t+ (t, eof) <- readChunkEof hh buf+ `E.catch` catchError "hGetContents" h hh+ if eof then return [t] else (t:) `fmap` readChunks ts <- readChunks
Data/Text/Internal/Fusion/Common.hs view
@@ -400,7 +400,7 @@ caseConvert :: (forall s. Char -> s -> Step (CC s) Char) -> Stream Char -> Stream Char caseConvert remap (Stream next0 s0 len) =- Stream next (CC s0 '\0' '\0') (len `unionSize` 3*len)+ Stream next (CC s0 '\0' '\0') (len `unionSize` (3*len)) where next (CC s '\0' _) = case next0 s of@@ -735,8 +735,10 @@ -- length of the stream. take :: Integral a => a -> Stream Char -> Stream Char take n0 (Stream next0 s0 len) =- Stream next (n0 :*: s0) (smaller len (codePointsSize $ fromIntegral n0))+ Stream next (n0' :*: s0) (smaller len (codePointsSize $ fromIntegral n0')) where+ n0' = max n0 0+ {-# INLINE next #-} next (n :*: s) | n <= 0 = Done | otherwise = case next0 s of@@ -753,8 +755,10 @@ -- is greater than the length of the stream. drop :: Integral a => a -> Stream Char -> Stream Char drop n0 (Stream next0 s0 len) =- Stream next (JS n0 s0) (len - codePointsSize (fromIntegral n0))+ Stream next (JS n0' s0) (len - codePointsSize (fromIntegral n0')) where+ n0' = max n0 0+ {-# INLINE next #-} next (JS n s) | n <= 0 = Skip (NS s)
Data/Text/Internal/Fusion/Size.hs view
@@ -61,7 +61,11 @@ -- | The 'Size' of @n@ code points. codePointsSize :: Int -> Size-codePointsSize n = Between n (2*n)+codePointsSize n =+#if defined(ASSERTS)+ assert (n >= 0)+#endif+ Between n (2*n) {-# INLINE codePointsSize #-} exactSize :: Int -> Size
Data/Text/Lazy.hs view
@@ -205,9 +205,7 @@ (&&), (||), (+), (-), (.), ($), (++), error, flip, fmap, fromIntegral, not, otherwise, quot) import qualified Prelude as P-#if defined(HAVE_DEEPSEQ) import Control.DeepSeq (NFData(..))-#endif import Data.Int (Int64) import qualified Data.List as L import Data.Char (isSpace)@@ -375,11 +373,9 @@ toList = unpack #endif -#if defined(HAVE_DEEPSEQ) instance NFData Text where rnf Empty = () rnf (Chunk _ ts) = rnf ts-#endif -- | @since 1.2.1.0 instance Binary Text where
Data/Text/Lazy/Builder/RealFloat.hs view
@@ -46,6 +46,14 @@ {-# SPECIALIZE realFloat :: Double -> Builder #-} realFloat x = formatRealFloat Generic Nothing x +-- | Encode a signed 'RealFloat' according to 'FPFormat' and optionally requested precision.+--+-- This corresponds to the @show{E,F,G}Float@ operations provided by @base@'s "Numeric" module.+--+-- __NOTE__: The functions in @base-4.12@ changed the serialisation in+-- case of a @Just 0@ precision; this version of @text@ still provides+-- the serialisation as implemented in @base-4.11@. The next major+-- version of @text@ will switch to the more correct @base-4.12@ serialisation. formatRealFloat :: (RealFloat a) => FPFormat -> Maybe Int -- ^ Number of decimal places to render.
benchmarks/text-benchmarks.cabal view
@@ -28,7 +28,7 @@ ghc-options: -Wall -O2 -rtsopts if flag(llvm) ghc-options: -fllvm- cpp-options: -DHAVE_DEEPSEQ -DINTEGER_GMP+ cpp-options: -DINTEGER_GMP build-depends: array, base == 4.*, binary,
changelog.md view
@@ -1,3 +1,17 @@+### 1.2.3.1++* Make `decodeUtf8With` fail explicitly for unsupported non-BMP+ replacement characters instead silent undefined behaviour (gh-213)++* Fix termination condition for file reads via `Data.Text.IO`+ operations (gh-223)++* A serious correctness issue affecting uses of `take` and `drop` with+ negative counts has been fixed (gh-227)++* A bug in the case-mapping functions resulting in unreasonably large+ allocations with large arguments has been fixed (gh-221)+ ### 1.2.3.0 * Spec compliance: `toCaseFold` now follows the Unicode 9.0 spec
tests/.ghci view
@@ -1,1 +1,1 @@-:set -DHAVE_DEEPSEQ -isrc -i../..+:set -isrc -i../..
tests/Tests/Properties.hs view
@@ -1,5 +1,6 @@ -- | QuickCheck properties for the text library. +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}@@ -122,23 +123,39 @@ instance Arbitrary Badness where arbitrary = elements [Solo, Leading, Trailing] -t_utf8_err :: Badness -> DecodeErr -> Property-t_utf8_err bad de = do+t_utf8_err :: Badness -> Maybe DecodeErr -> Property+t_utf8_err bad mde = do let gen = case bad of Solo -> genInvalidUTF8 Leading -> B.append <$> genInvalidUTF8 <*> genUTF8 Trailing -> B.append <$> genUTF8 <*> genInvalidUTF8 genUTF8 = E.encodeUtf8 <$> genUnicode- forAll gen $ \bs -> MkProperty $ do- onErr <- genDecodeErr de- unProperty . monadicIO $ do- l <- run $ let len = T.length (E.decodeUtf8With onErr bs)- in (len `seq` return (Right len)) `Exception.catch`- (\(e::UnicodeException) -> return (Left e))- assert $ case l of- Left err -> length (show err) >= 0- Right _ -> de /= Strict+ forAll gen $ \bs -> MkProperty $+ case mde of+ -- generate an invalid character+ Nothing -> do+ c <- choose ('\x10000', maxBound)+ let onErr _ _ = Just c+ unProperty . monadicIO $ do+ l <- run $ let len = T.length (E.decodeUtf8With onErr bs)+ in (len `seq` return (Right len)) `Exception.catch`+ (\(e::Exception.SomeException) -> return (Left e))+ assert $ case l of+ Left err ->+ "non-BMP replacement characters not supported" `T.isInfixOf` T.pack (show err)+ Right _ -> False + -- generate a valid onErr+ Just de -> do+ onErr <- genDecodeErr de+ unProperty . monadicIO $ do+ l <- run $ let len = T.length (E.decodeUtf8With onErr bs)+ in (len `seq` return (Right len)) `Exception.catch`+ (\(e::UnicodeException) -> return (Left e))+ assert $ case l of+ Left err -> length (show err) >= 0+ Right _ -> de /= Strict+ t_utf8_err' :: B.ByteString -> Property t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of Left err -> length (show err) >= 0@@ -203,9 +220,10 @@ case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97, 97]) of E.Some x _ _ -> x === "xaaa" -t_infix_concat bs1 text bs2 rep =+t_infix_concat bs1 text bs2 =+ forAll (genDecodeErr Replace) $ \onErr -> text `T.isInfixOf`- E.decodeUtf8With (\_ _ -> rep) (B.concat [bs1, E.encodeUtf8 text, bs2])+ E.decodeUtf8With onErr (B.concat [bs1, E.encodeUtf8 text, bs2]) s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList) where _types = s :: String@@ -853,16 +871,22 @@ tb_realfloat_double (a::Double) = tb_realfloat a showFloat :: (RealFloat a) => TB.FPFormat -> Maybe Int -> a -> ShowS-showFloat TB.Exponent = showEFloat-showFloat TB.Fixed = showFFloat-showFloat TB.Generic = showGFloat+showFloat TB.Exponent (Just 0) = showEFloat (Just 1) -- see gh-231+showFloat TB.Exponent p = showEFloat p+showFloat TB.Fixed p = showFFloat p+showFloat TB.Generic p = showGFloat p tb_formatRealFloat :: (RealFloat a, Show a) => a -> TB.FPFormat -> Precision a -> Property-tb_formatRealFloat a fmt prec =+tb_formatRealFloat a fmt prec = cond ==> TB.formatRealFloat fmt p a === TB.fromString (showFloat fmt p a "") where p = precision a prec+ cond = case (p,fmt) of+#if MIN_VERSION_base(4,12,0)+ (Just 0, TB.Generic) -> False -- skipping due to gh-231+#endif+ _ -> True tb_formatRealFloat_float (a::Float) = tb_formatRealFloat a tb_formatRealFloat_double (a::Double) = tb_formatRealFloat a
tests/Tests/QuickCheckUtils.hs view
@@ -210,7 +210,10 @@ genDecodeErr Lenient = return T.lenientDecode genDecodeErr Ignore = return T.ignore genDecodeErr Strict = return T.strictDecode-genDecodeErr Replace = arbitrary+genDecodeErr Replace = (\c _ _ -> c) <$> frequency+ [ (1, return Nothing)+ , (50, Just <$> choose ('\x1', '\xffff'))+ ] instance Arbitrary DecodeErr where arbitrary = elements [Lenient, Ignore, Strict, Replace]
tests/Tests/Regressions.hs view
@@ -7,6 +7,7 @@ ) where import Control.Exception (SomeException, handle)+import Data.Char (isLetter) import System.IO import Test.HUnit (assertBool, assertEqual, assertFailure) import qualified Data.ByteString as B@@ -82,6 +83,18 @@ cond = length fltr fltr = filter (== ',') x +t221 :: IO ()+t221 =+ assertEqual "toLower of large input shouldn't crash"+ (T.toLower (T.replicate 200000 "0") `seq` ())+ ()++t227 :: IO ()+t227 =+ assertEqual "take (-3) shouldn't crash with overflow"+ (T.length $ T.filter isLetter $ T.take (-3) "Hello! How are you doing today?")+ 0+ tests :: F.Test tests = F.testGroup "Regressions" [ F.testCase "hGetContents_crash" hGetContents_crash@@ -90,4 +103,6 @@ , F.testCase "replicate_crash" replicate_crash , F.testCase "utf8_decode_unsafe" utf8_decode_unsafe , F.testCase "t197" t197+ , F.testCase "t221" t221+ , F.testCase "t227" t227 ]
tests/text-tests.cabal view
@@ -47,7 +47,6 @@ cpp-options: -DTEST_SUITE -DASSERTS- -DHAVE_DEEPSEQ build-depends: HUnit >= 1.2,@@ -139,7 +138,6 @@ cpp-options: -DTEST_SUITE- -DHAVE_DEEPSEQ -DASSERTS -DINTEGER_GMP
text.cabal view
@@ -1,5 +1,7 @@+cabal-version: >= 1.8 name: text-version: 1.2.3.0+version: 1.2.3.1+ homepage: https://github.com/haskell/text bug-reports: https://github.com/haskell/text/issues synopsis: An efficient packed Unicode text type.@@ -37,13 +39,12 @@ license: BSD2 license-file: LICENSE author: Bryan O'Sullivan <bos@serpentine.com>-maintainer: Bryan O'Sullivan <bos@serpentine.com>+maintainer: Bryan O'Sullivan <bos@serpentine.com>, Herbert Valerio Riedel <hvr@gnu.org> copyright: 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper-bug-reports: https://github.com/haskell/text/issues category: Data, Text build-type: Simple-cabal-version: >= 1.8-tested-with: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4,+tested-with: GHC==8.6.1, GHC==8.4.3,+ GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 extra-source-files: -- scripts/CaseFolding.txt@@ -152,9 +153,8 @@ build-depends: bytestring >= 0.9 && < 0.10.4, bytestring-builder >= 0.10.4 else- build-depends: bytestring >= 0.10.4+ build-depends: bytestring >= 0.10.4 && < 0.11 - cpp-options: -DHAVE_DEEPSEQ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 if flag(developer) ghc-prof-options: -auto-all@@ -166,7 +166,7 @@ build-depends: integer-simple >= 0.1 && < 0.5 else cpp-options: -DINTEGER_GMP- build-depends: integer-gmp >= 0.2+ build-depends: integer-gmp >= 0.2 && < 1.1 test-suite tests type: exitcode-stdio-1.0@@ -177,7 +177,7 @@ -Wall -threaded -rtsopts cpp-options:- -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE+ -DASSERTS -DTEST_SUITE -- modules specific to test-suite hs-source-dirs: tests@@ -246,7 +246,7 @@ build-depends: HUnit >= 1.2,- QuickCheck >= 2.7 && < 2.10,+ QuickCheck >= 2.7 && < 2.11, array, base, binary,