text 2.1.2 → 2.1.3
raw patch · 30 files changed
+2107/−1827 lines, 30 filesdep +splitmixdep +temporarydep ~QuickCheckdep ~ghc-primdep ~template-haskell
Dependencies added: splitmix, temporary
Dependency ranges changed: QuickCheck, ghc-prim, template-haskell
Files
- benchmarks/haskell/Benchmarks.hs +3/−2
- benchmarks/haskell/Benchmarks/FileWrite.hs +6/−3
- benchmarks/haskell/Benchmarks/Micro.hs +2/−1
- benchmarks/haskell/Benchmarks/Programs/Fold.hs +5/−4
- benchmarks/haskell/Benchmarks/Pure.hs +18/−0
- benchmarks/haskell/Benchmarks/ReadNumbers.hs +2/−1
- benchmarks/haskell/Benchmarks/WordFrequencies.hs +3/−2
- changelog.md +392/−380
- src/Data/Text.hs +13/−0
- src/Data/Text/Encoding/Error.hs +2/−3
- src/Data/Text/Internal.hs +0/−3
- src/Data/Text/Internal/Encoding/Utf8.hs +6/−15
- src/Data/Text/Internal/Fusion/CaseMapping.hs +81/−0
- src/Data/Text/Internal/IO.hs +308/−306
- src/Data/Text/Internal/Lazy.hs +1/−3
- src/Data/Text/Internal/Transformation.hs +3/−3
- src/Data/Text/Lazy.hs +24/−1
- src/Data/Text/Lazy/Builder/RealFloat.hs +3/−0
- src/Data/Text/Lazy/Internal.hs +0/−1
- src/Data/Text/Show.hs +25/−4
- tests/Tests/Properties.hs +2/−0
- tests/Tests/Properties/CornerCases.hs +39/−0
- tests/Tests/Properties/Instances.hs +9/−0
- tests/Tests/Properties/LowLevel.hs +174/−164
- tests/Tests/Properties/Substrings.hs +2/−3
- tests/Tests/Properties/Transcoding.hs +4/−1
- tests/Tests/QuickCheckUtils.hs +321/−307
- tests/Tests/Regressions.hs +236/−204
- tests/Tests/Utils.hs +50/−51
- text.cabal +373/−365
benchmarks/haskell/Benchmarks.hs view
@@ -10,6 +10,7 @@ import System.IO #ifdef mingw32_HOST_OS+import System.IO.Temp (emptySystemTempFile) import System.Directory (removeFile) #endif @@ -40,11 +41,11 @@ mkSink :: IO (FilePath, Handle) mkSink = do #ifdef mingw32_HOST_OS- (sinkFn, sink) <- openTempFile "." "dev.null"+ sinkFn <- emptySystemTempFile "dev.null" #else let sinkFn = "/dev/null"- sink <- openFile sinkFn WriteMode #endif+ sink <- openFile sinkFn WriteMode hSetEncoding sink utf8 pure (sinkFn, sink)
benchmarks/haskell/Benchmarks/FileWrite.hs view
@@ -15,11 +15,10 @@ import Control.DeepSeq (NFData, deepseq) import Data.Bifunctor (first) import Data.List (intercalate, intersperse)-import Data.Semigroup ((<>)) import Data.String (fromString) import Data.Text (StrictText) import Data.Text.Internal.Lazy (LazyText, defaultChunkSize)-import System.IO (Handle, Newline(CRLF,LF), NewlineMode(NewlineMode), BufferMode(NoBuffering,LineBuffering,BlockBuffering), hSetBuffering, hSetNewlineMode)+import System.IO (Handle, Newline(CRLF,LF), NewlineMode(NewlineMode), BufferMode(..), hSetBuffering, hSetNewlineMode) import Test.Tasty.Bench (Benchmark, bgroup, bench, whnfAppIO) import qualified Data.Text as T import qualified Data.Text.IO as T@@ -112,11 +111,15 @@ #endif where- lazy, lazyNewlines, lazySmallChunks, lazySmallChunksNewlines :: (String, StrictText -> LazyText)+ lazy, lazyNewlines :: (String, StrictText -> LazyText) lazy = ("lazy", L.fromChunks . T.chunksOf defaultChunkSize) lazyNewlines = ("lazy many newlines", snd lazy . snd strictNewlines)++#ifdef ExtendedBenchmarks+ lazySmallChunks, lazySmallChunksNewlines :: (String, StrictText -> LazyText) lazySmallChunks = ("lazy small chunks", L.fromChunks . T.chunksOf 10) lazySmallChunksNewlines = ("lazy small chunks many newlines", snd lazySmallChunks . snd strictNewlines)+#endif strict, strictNewlines :: (String, StrictText -> StrictText) strict = ("strict", id)
benchmarks/haskell/Benchmarks/Micro.hs view
@@ -2,6 +2,7 @@ module Benchmarks.Micro (benchmark) where +import qualified Data.List.NonEmpty as NE import qualified Data.Text.Lazy as TL import qualified Data.Text as T import Test.Tasty.Bench (Benchmark, Benchmarkable, bgroup, bcompareWithin, bench, nf)@@ -9,7 +10,7 @@ benchmark :: Benchmark benchmark = bgroup "Micro" [ blinear "lazy-inits--last" 500000 2 0.1 $ \len ->- nf (last . TL.inits) (chunks len)+ nf (NE.last . TL.initsNE) (chunks len) , blinear "lazy-inits--map-take1" 500000 2 0.1 $ \len -> nf (map (TL.take 1) . TL.inits) (chunks len) ]
benchmarks/haskell/Benchmarks/Programs/Fold.hs view
@@ -17,8 +17,9 @@ ( benchmark ) where -import Data.List (foldl')+import Data.Foldable (Foldable(..)) import Data.List (intersperse)+import Prelude hiding (Foldable(..)) import System.IO (Handle) import Test.Tasty.Bench (Benchmark, bench, whnfIO) import qualified Data.Text as T@@ -29,7 +30,7 @@ benchmark :: FilePath -> Handle -> Benchmark benchmark i o =- bench "Fold" $ whnfIO $ T.readFile i >>= TL.hPutStr o . fold 80+ bench "Fold" $ whnfIO $ T.readFile i >>= TL.hPutStr o . foldText 80 -- | We represent a paragraph by a word list --@@ -37,8 +38,8 @@ -- | Fold a text ---fold :: Int -> T.Text -> TL.Text-fold maxWidth = TLB.toLazyText . mconcat .+foldText :: Int -> T.Text -> TL.Text+foldText maxWidth = TLB.toLazyText . mconcat . intersperse "\n\n" . map (foldParagraph maxWidth) . paragraphs -- | Fold a paragraph
benchmarks/haskell/Benchmarks/Pure.hs view
@@ -26,6 +26,8 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Encoding as TL+import Data.Semigroup+import Data.List.NonEmpty (NonEmpty((:|))) data Env = Env { bsa :: !BS.ByteString@@ -83,6 +85,14 @@ [ benchT $ nf T.concat tl , benchTL $ nf TL.concat tll ]+ , bgroup "sconcat"+ [ benchT $ nf sconcat (T.empty :| tl)+ , benchTL $ nf sconcat (TL.empty :| tll)+ ]+ , bgroup "stimes"+ [ benchT $ nf (stimes (10 :: Int)) ta+ , benchTL $ nf (stimes (10 :: Int)) tla+ ] , bgroup "cons" [ benchT $ nf (T.cons c) ta , benchTL $ nf (TL.cons c) tla@@ -207,6 +217,14 @@ , bgroup "zipWith" [ benchT $ nf (T.zipWith min tb) ta , benchTL $ nf (TL.zipWith min tlb) tla+ ]+ , bgroup "length . unpack" -- length should fuse with unpack+ [ benchT $ nf (L.length . T.unpack) ta+ , benchTL $ nf (L.length . TL.unpack) tla+ ]+ , bgroup "length . drop 1 . unpack" -- no list fusion because of drop 1+ [ benchT $ nf (L.length . L.drop 1 . T.unpack) ta+ , benchTL $ nf (L.length . L.drop 1 . TL.unpack) tla ] , bgroup "length" [ bgroup "cons"
benchmarks/haskell/Benchmarks/ReadNumbers.hs view
@@ -21,8 +21,9 @@ , benchmark ) where +import Data.Foldable (Foldable(..))+import Prelude hiding (Foldable(..)) import Test.Tasty.Bench (Benchmark, bgroup, bench, whnf)-import Data.List (foldl') import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL
benchmarks/haskell/Benchmarks/WordFrequencies.hs view
@@ -13,9 +13,10 @@ , benchmark ) where -import Test.Tasty.Bench (Benchmark, bench, bgroup, whnf)-import Data.List (foldl')+import Data.Foldable (Foldable(..)) import Data.Map (Map)+import Prelude hiding (Foldable(..))+import Test.Tasty.Bench (Benchmark, bench, bgroup, whnf) import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.IO as T
changelog.md view
@@ -1,380 +1,392 @@-### 2.1.2--* [Update case mappings for Unicode 16.0](https://github.com/haskell/text/pull/618)--* [Add type synonym for lazy builders. Deprecated `StrictBuilder` for `StrictTextBuilder`](https://github.com/haskell/text/pull/581)--* [Add `initsNE` and `tailsNE`](https://github.com/haskell/text/pull/558)--* [Add `foldlM'`](https://github.com/haskell/text/pull/543)--* [Add `Data.Text.Foreign.peekCString`](https://github.com/haskell/text/pull/599)--* [Add `Data.Text.show` and `Data.Text.Lazy.show`](https://github.com/haskell/text/pull/608)--* [Add pattern synonyms `Empty`, `(:<)`, and `(:>)`](https://github.com/haskell/text/pull/619)--* [Improve precision of `Data.Text.Read.rational`](https://github.com/haskell/text/pull/565)--* [`Data.Text.IO.Utf8`: use `B.putStrLn` instead of `B.putStr t >> B.putStr "\n"`](https://github.com/haskell/text/pull/579)--* [`Data.Text.IO` and `Data.Text.Lazy.IO`: Make `putStrLn` more atomic with line or block buffering](https://github.com/haskell/text/pull/600)--* [Integrate UTF-8 `hPutStr` to standard `hPutStr`](https://github.com/haskell/text/pull/589)--* [Serialise `Text` without going through `ByteString`](https://github.com/haskell/text/pull/617)--* [Make `splitAt` strict in its first argument, even if input is empty](https://github.com/haskell/text/pull/575)--* [Improve lazy performance of `Data.Text.Lazy.inits`](https://github.com/haskell/text/pull/572)--* [Implement `Data.Text.unpack` and `Data.Text.toTitle` directly, without streaming](https://github.com/haskell/text/pull/611)--* [Make `fromString` `INLINEABLE` instead of `INLINE`](https://github.com/haskell/text/pull/571) to reduce the size of generated code.--### 2.1.1--* Add pure Haskell implementations as an alternative to C-based ones,- suitable for JavaScript backend.--* [Add type synonyms for lazy and strict text flavours](https://github.com/haskell/text/pull/547)--* [Share empty `Text` values](https://github.com/haskell/text/pull/493)--* [Fix bug in `isValidUtf8ByteArray`](https://github.com/haskell/text/pull/553)--* [Optimize the implementation of `Data.Text.concat`](https://github.com/haskell/text/pull/551)--* [Fix `filter/filter` rules for `Text` and lazy `Text`](https://github.com/haskell/text/pull/560)--### 2.1--* [Switch `Data.Text.Array` to `Data.Array.Byte`](https://github.com/haskell/text/pull/474)--* [Add `Text.IO.Utf8` module](https://github.com/haskell/text/pull/503)--* [Expose UTF-8 validation functions from internal module](https://github.com/haskell/text/pull/483)--* [Fix handling of incomplete input in stream decoders](https://github.com/haskell/text/pull/527)--* [Fix handling of invalid bytes in stream decoders](https://github.com/haskell/text/pull/528)--* [Make Lift Text work under RebindableSyntax](https://github.com/haskell/text/pull/534)--### 2.0.2--* [Add decoding functions in `Data.Text.Encoding` that allow- more control for error handling and for how to allocate text](https://github.com/haskell/text/pull/448). Thanks to David Sledge!- * `decodeASCIIPrefix`- * `decodeUtf8Chunk`- * `decodeUtf8More`- * `Utf8ValidState`- * `startUtf8ValidState`- * `StrictBuilder`- * `strictBuilderToText`- * `textToStrictBuilder`- * `validateUtf8Chunk`- * `validateUtf8More`--* [Fix quadratic slowdown when decoding invalid UTF-8 bytestrings](https://github.com/haskell/text/issues/495)--* [Add `isAscii :: Text -> Bool`](https://github.com/haskell/text/issues/497)--* [Add `decodeASCII' :: ByteString -> Maybe Text`](https://github.com/haskell/text/issues/499)--* Add internal module `Data.Text.Internal.StrictBuilder`--* Add internal module `Data.Text.Internal.Encoding`--* Add `Data.Text.Internal.Encoding.Utf8.updateDecoderState` and export `utf8{Accept,Reject}State` from the same module.--* [Speed up case conversions](https://github.com/haskell/text/pull/460)--* [Reduce code bloat for literal strings](https://github.com/haskell/text/pull/468)--* [Remove support for GHC 8.0](https://github.com/haskell/text/pull/485)--### 2.0.1--* Improve portability of C and C++ code.-* [Make `Lift` instance more efficient](https://github.com/haskell/text/pull/413)-* [Make `toCaseFold` idempotent](https://github.com/haskell/text/pull/402)-* [Add `fromPtr0`](https://github.com/haskell/text/pull/423)-* [Add `Data.Text.foldr'`](https://github.com/haskell/text/pull/436)-* [Add `withCString`](https://github.com/haskell/text/pull/431)-* [Add `spanM` and `spanEndM`](https://github.com/haskell/text/pull/437)--### 2.0--* [Switch internal representation of text from UTF-16 to UTF-8](https://github.com/haskell/text/pull/365):- * Functions in `Data.Text.Array` now operate over arrays of `Word8` instead of `Word16`.- * Rename constructors of `Array` and `MArray` to `ByteArray` and `MutableByteArray`.- * Rename functions and types in `Data.Text.Foreign` to reflect switch- from `Word16` to `Word8`.- * Rename slicing functions in `Data.Text.Unsafe` to reflect switch- from `Word16` to `Word8`.- * Rename `Data.Text.Internal.Unsafe.Char.unsafeChr` to `unsafeChr16`.- * Change semantics and order of arguments of `Data.Text.Array.copyI`:- pass length, not end offset.- * Extend `Data.Text.Internal.Encoding.Utf8` to provide more UTF-8 related routines.- * Extend interface of `Data.Text.Array` with more utility functions.- * Add `instance Show Data.Text.Unsafe.Iter`.- * Add `Data.Text.measureOff`.- * Extend `Data.Text.Unsafe` with `iterArray` and `reverseIterArray`.- * Export `Data.Text.Internal.Lazy.equal`.- * Export `Data.Text.Internal.append`.- * Add `Data.Text.Internal.Private.spanAscii_`.- * Replacement characters in `decodeUtf8With` are no longer limited to Basic Multilingual Plane.-* [Disable implicit fusion rules](https://github.com/haskell/text/pull/348)-* [Add `Data.Text.Encoding.decodeUtf8Lenient`](https://github.com/haskell/text/pull/342)-* [Remove `Data.Text.Internal.Unsafe.Shift`](https://github.com/haskell/text/pull/343)-* [Remove `Data.Text.Internal.Functions`](https://github.com/haskell/text/pull/354)-* [Bring type of `Data.Text.Unsafe.reverseIter` in line with `iter`](https://github.com/haskell/text/pull/355)-* [Add `instance Bounded FPFormat`](https://github.com/haskell/text/pull/355)-* [Add HasCallStack to partial functions](https://github.com/haskell/text/pull/388)--### 1.2.5.0--* [Support sized primitives from GHC 9.2](https://github.com/haskell/text/pull/305)-* [Allow `template-haskell-2.18.0.0`](https://github.com/haskell/text/pull/320)-* [Add `elem :: Char -> Text -> Bool` to `Data.Text` and `Data.Text.Lazy`](https://github.com/haskell/text/pull/274)-* [Replace surrogate code points in `Data.Text.Internal.Builder.{singleton,fromString}`](https://github.com/haskell/text/pull/281)-* [Use `unsafeWithForeignPtr` when available](https://github.com/haskell/text/pull/325)-* [Use vectorized CPU instructions for decoding and encoding](https://github.com/haskell/text/pull/302)-* [Regenerate case mapping in accordance to Unicode 13.0](https://github.com/haskell/text/pull/334)-* [Fix UTF-8 decoding of lazy bytestrings](https://github.com/haskell/text/pull/333)--### 1.2.4.1--* Support `template-haskell-2.17.0.0`-* Support `bytestring-0.11`-* Add `take . drop` related RULE--### 1.2.4.0--* Add TH `Lift` instances for `Data.Text.Text` and `Data.Text.Lazy.Text` (gh-232)--* Update Haddock documentation to better reflect fusion eligibility; improve fusion- rules for `takeWhileEnd` and `length` (gh-241, ghc-202)--* Optimise `Data.Text.replicate`. Rather than calling `memcpy` `n` times,- call it only `O(log n)` times on chunks of increasing size. The total- asymptotic complexity remains `O(nm)`. (gh-209)--* Support `base-4.13.0.0`--### 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- (updated from 8.0).--* Bug fix: the lazy `takeWhileEnd` function violated the- [lazy text invariant](https://github.com/bos/text/blob/1.2.3.0/Data/Text/Internal/Lazy.hs#L51)- (gh-184).--* Bug fix: Fixed usage of size hints causing incorrect behavior (gh-197).--* New function: `unsnoc` (gh-173).--* Reduce memory overhead in `encodeUTF8` (gh-194).--* Improve UTF-8 decoder error-recovery (gh-182).--* Minor documentation improvements (`@since` annotations, more- examples, clarifications).--#### 1.2.2.2--* The `toTitle` function now correctly handles letters that- immediately follow punctuation. Before, `"there's"` would turn into- `"There'S"`. Now, it becomes `"There's"`.--* The implementation of unstreaming is faster, resulting in operations- such as `map` and `intersperse` speeding up by up to 30%, with- smaller code generated.--* The optimised length comparison function is now more likely to be- used after some rewrite rule tweaking.--* Bug fix: an off-by-one bug in `takeEnd` is fixed.--* Bug fix: a logic error in `takeWord16` is fixed.--#### 1.2.2.1--* The switch to `integer-pure` in 1.2.2.0 was apparently mistaken.- The build flag has been renamed accordingly. Your army of diligent- maintainers apologizes for the churn.--* Spec compliance: `toCaseFold` now follows the Unicode 8.0 spec- (updated from 7.0)--* An STG lint error has been fixed--### 1.2.2.0--* The `integer-simple` package, upon which this package optionally- depended, has been replaced with `integer-pure`. The build flag has- been renamed accordingly.--* Bug fix: For the `Binary` instance, If UTF-8 decoding fails during a- `get`, the error is propagated via `fail` instead of an uncatchable- crash.--* New function: `takeWhileEnd`--* New instances for the `Text` types:- * if `base` >= 4.7: `PrintfArg`- * if `base` >= 4.9: `Semigroup`--#### 1.2.1.3--* Bug fix: As it turns out, moving the literal rewrite rules to simplifier- phase 2 does not prevent competition with the `unpack` rule, which is- also active in this phase. Unfortunately this was hidden due to a silly- test environment mistake. Moving literal rules back to phase 1 finally- fixes GHC Trac #10528 correctly.--#### 1.2.1.2--* Bug fix: Run literal rewrite rules in simplifier phase 2.- The behavior of the simplifier changed in GHC 7.10.2,- causing these rules to fail to fire, leading to poor code generation- and long compilation times. See- [GHC Trac #10528](https://ghc.haskell.org/trac/ghc/ticket/10528).--#### 1.2.1.1--* Expose unpackCString#, which you should never use.--### 1.2.1.0--* Added Binary instances for both Text types. (If you have previously- been using the text-binary package to get a Binary instance, it is- now obsolete.)--#### 1.2.0.6--* Fixed a space leak in UTF-8 decoding--#### 1.2.0.5--* Feature parity: repeat, cycle, iterate are now implemented for lazy- Text, and the Data instance is more complete--* Build speed: an inliner space explosion has been fixed with toCaseFold--* Bug fix: encoding Int to a Builder would infinite-loop if the- integer-simple package was used--* Deprecation: OnEncodeError and EncodeError are deprecated, as they- are never used--* Internals: some types that are used internally in fusion-related- functions have moved around, been renamed, or been deleted (we don't- bump the major version if .Internal modules change)--* Spec compliance: toCaseFold now follows the Unicode 7.0 spec- (updated from 6.3)--#### 1.2.0.4--* Fixed an incompatibility with base < 4.5--#### 1.2.0.3--* Update formatRealFloat to correspond to the definition in versions- of base newer than 4.5 (https://github.com/bos/text/issues/105)--#### 1.2.0.2--* Bumped lower bound on deepseq to 1.4 for compatibility with the- upcoming GHC 7.10--#### 1.2.0.1--* Fixed a buffer overflow in rendering of large Integers- (https://github.com/bos/text/issues/99)--## 1.2.0.0--* Fixed an integer overflow in the replace function- (https://github.com/bos/text/issues/81)--* Fixed a hang in lazy decodeUtf8With- (https://github.com/bos/text/issues/87)--* Reduced codegen bloat caused by use of empty and single-character- literals--* Added an instance of IsList for GHC 7.8 and above--### 1.1.1.0--* The Data.Data instance now allows gunfold to work, via a virtual- pack constructor--* dropEnd, takeEnd: new functions--* Comparing the length of a Text against a number can now- short-circuit in more cases--#### 1.1.0.1--* streamDecodeUtf8: fixed gh-70, did not return all unconsumed bytes- in single-byte chunks--## 1.1.0.0--* encodeUtf8: Performance is improved by up to 4x.--* encodeUtf8Builder, encodeUtf8BuilderEscaped: new functions,- available only if bytestring >= 0.10.4.0 is installed, that allow- very fast and flexible encoding of a Text value to a bytestring- Builder.-- As an example of the performance gain to be had, the- encodeUtf8BuilderEscaped function helps to double the speed of JSON- encoding in the latest version of aeson! (Note: if all you need is a- plain ByteString, encodeUtf8 is still the faster way to go.)--* All of the internal module hierarchy is now publicly exposed. If a- module is in the .Internal hierarchy, or is documented as internal,- use at your own risk - there are no API stability guarantees for- internal modules!--#### 1.0.0.1--* decodeUtf8: Fixed a regression that caused us to incorrectly- identify truncated UTF-8 as valid (gh-61)--# 1.0.0.0--* Added support for Unicode 6.3.0 to case conversion functions--* New function toTitle converts words in a string to title case--* New functions peekCStringLen and withCStringLen simplify- interoperability with C functions--* Added support for decoding UTF-8 in stream-friendly fashion--* Fixed a bug in mapAccumL--* Added trusted Haskell support--* Removed support for GHC 6.10 (released in 2008) and older+### 2.1.3 - 2025-08-01 + +* [Fix CRLF handling in IO functions](https://github.com/haskell/text/pull/649) + +* [Change `utf8LengthByLeader` to a branching implementation](https://github.com/haskell/text/pull/635) + +* [Define `stimes 0` for lazy text](https://github.com/haskell/text/pull/641) + +* [Add implementation of `sconcat` and `stimes` for strict `Text`](https://github.com/haskell/text/pull/580) and [Fix `stimes` for strict text when size wraps around `Int`](https://github.com/haskell/text/pull/639) + +* [Allow list fusion for `unpack` over both strict and lazy `Text`](https://github.com/haskell/text/pull/629) + +### 2.1.2 + +* [Update case mappings for Unicode 16.0](https://github.com/haskell/text/pull/618) + +* [Add type synonym for lazy builders. Deprecated `StrictBuilder` for `StrictTextBuilder`](https://github.com/haskell/text/pull/581) + +* [Add `initsNE` and `tailsNE`](https://github.com/haskell/text/pull/558) + +* [Add `foldlM'`](https://github.com/haskell/text/pull/543) + +* [Add `Data.Text.Foreign.peekCString`](https://github.com/haskell/text/pull/599) + +* [Add `Data.Text.show` and `Data.Text.Lazy.show`](https://github.com/haskell/text/pull/608) + +* [Add pattern synonyms `Empty`, `(:<)`, and `(:>)`](https://github.com/haskell/text/pull/619) + +* [Improve precision of `Data.Text.Read.rational`](https://github.com/haskell/text/pull/565) + +* [`Data.Text.IO.Utf8`: use `B.putStrLn` instead of `B.putStr t >> B.putStr "\n"`](https://github.com/haskell/text/pull/579) + +* [`Data.Text.IO` and `Data.Text.Lazy.IO`: Make `putStrLn` more atomic with line or block buffering](https://github.com/haskell/text/pull/600) + +* [Integrate UTF-8 `hPutStr` to standard `hPutStr`](https://github.com/haskell/text/pull/589) + +* [Serialise `Text` without going through `ByteString`](https://github.com/haskell/text/pull/617) + +* [Make `splitAt` strict in its first argument, even if input is empty](https://github.com/haskell/text/pull/575) + +* [Improve lazy performance of `Data.Text.Lazy.inits`](https://github.com/haskell/text/pull/572) + +* [Implement `Data.Text.unpack` and `Data.Text.toTitle` directly, without streaming](https://github.com/haskell/text/pull/611) + +* [Make `fromString` `INLINEABLE` instead of `INLINE`](https://github.com/haskell/text/pull/571) to reduce the size of generated code. + +### 2.1.1 + +* Add pure Haskell implementations as an alternative to C-based ones, + suitable for JavaScript backend. + +* [Add type synonyms for lazy and strict text flavours](https://github.com/haskell/text/pull/547) + +* [Share empty `Text` values](https://github.com/haskell/text/pull/493) + +* [Fix bug in `isValidUtf8ByteArray`](https://github.com/haskell/text/pull/553) + +* [Optimize the implementation of `Data.Text.concat`](https://github.com/haskell/text/pull/551) + +* [Fix `filter/filter` rules for `Text` and lazy `Text`](https://github.com/haskell/text/pull/560) + +### 2.1 + +* [Switch `Data.Text.Array` to `Data.Array.Byte`](https://github.com/haskell/text/pull/474) + +* [Add `Text.IO.Utf8` module](https://github.com/haskell/text/pull/503) + +* [Expose UTF-8 validation functions from internal module](https://github.com/haskell/text/pull/483) + +* [Fix handling of incomplete input in stream decoders](https://github.com/haskell/text/pull/527) + +* [Fix handling of invalid bytes in stream decoders](https://github.com/haskell/text/pull/528) + +* [Make Lift Text work under RebindableSyntax](https://github.com/haskell/text/pull/534) + +### 2.0.2 + +* [Add decoding functions in `Data.Text.Encoding` that allow + more control for error handling and for how to allocate text](https://github.com/haskell/text/pull/448). Thanks to David Sledge! + * `decodeASCIIPrefix` + * `decodeUtf8Chunk` + * `decodeUtf8More` + * `Utf8ValidState` + * `startUtf8ValidState` + * `StrictBuilder` + * `strictBuilderToText` + * `textToStrictBuilder` + * `validateUtf8Chunk` + * `validateUtf8More` + +* [Fix quadratic slowdown when decoding invalid UTF-8 bytestrings](https://github.com/haskell/text/issues/495) + +* [Add `isAscii :: Text -> Bool`](https://github.com/haskell/text/issues/497) + +* [Add `decodeASCII' :: ByteString -> Maybe Text`](https://github.com/haskell/text/issues/499) + +* Add internal module `Data.Text.Internal.StrictBuilder` + +* Add internal module `Data.Text.Internal.Encoding` + +* Add `Data.Text.Internal.Encoding.Utf8.updateDecoderState` and export `utf8{Accept,Reject}State` from the same module. + +* [Speed up case conversions](https://github.com/haskell/text/pull/460) + +* [Reduce code bloat for literal strings](https://github.com/haskell/text/pull/468) + +* [Remove support for GHC 8.0](https://github.com/haskell/text/pull/485) + +### 2.0.1 + +* Improve portability of C and C++ code. +* [Make `Lift` instance more efficient](https://github.com/haskell/text/pull/413) +* [Make `toCaseFold` idempotent](https://github.com/haskell/text/pull/402) +* [Add `fromPtr0`](https://github.com/haskell/text/pull/423) +* [Add `Data.Text.foldr'`](https://github.com/haskell/text/pull/436) +* [Add `withCString`](https://github.com/haskell/text/pull/431) +* [Add `spanM` and `spanEndM`](https://github.com/haskell/text/pull/437) + +### 2.0 + +* [Switch internal representation of text from UTF-16 to UTF-8](https://github.com/haskell/text/pull/365): + * Functions in `Data.Text.Array` now operate over arrays of `Word8` instead of `Word16`. + * Rename constructors of `Array` and `MArray` to `ByteArray` and `MutableByteArray`. + * Rename functions and types in `Data.Text.Foreign` to reflect switch + from `Word16` to `Word8`. + * Rename slicing functions in `Data.Text.Unsafe` to reflect switch + from `Word16` to `Word8`. + * Rename `Data.Text.Internal.Unsafe.Char.unsafeChr` to `unsafeChr16`. + * Change semantics and order of arguments of `Data.Text.Array.copyI`: + pass length, not end offset. + * Extend `Data.Text.Internal.Encoding.Utf8` to provide more UTF-8 related routines. + * Extend interface of `Data.Text.Array` with more utility functions. + * Add `instance Show Data.Text.Unsafe.Iter`. + * Add `Data.Text.measureOff`. + * Extend `Data.Text.Unsafe` with `iterArray` and `reverseIterArray`. + * Export `Data.Text.Internal.Lazy.equal`. + * Export `Data.Text.Internal.append`. + * Add `Data.Text.Internal.Private.spanAscii_`. + * Replacement characters in `decodeUtf8With` are no longer limited to Basic Multilingual Plane. +* [Disable implicit fusion rules](https://github.com/haskell/text/pull/348) +* [Add `Data.Text.Encoding.decodeUtf8Lenient`](https://github.com/haskell/text/pull/342) +* [Remove `Data.Text.Internal.Unsafe.Shift`](https://github.com/haskell/text/pull/343) +* [Remove `Data.Text.Internal.Functions`](https://github.com/haskell/text/pull/354) +* [Bring type of `Data.Text.Unsafe.reverseIter` in line with `iter`](https://github.com/haskell/text/pull/355) +* [Add `instance Bounded FPFormat`](https://github.com/haskell/text/pull/355) +* [Add HasCallStack to partial functions](https://github.com/haskell/text/pull/388) + +### 1.2.5.0 + +* [Support sized primitives from GHC 9.2](https://github.com/haskell/text/pull/305) +* [Allow `template-haskell-2.18.0.0`](https://github.com/haskell/text/pull/320) +* [Add `elem :: Char -> Text -> Bool` to `Data.Text` and `Data.Text.Lazy`](https://github.com/haskell/text/pull/274) +* [Replace surrogate code points in `Data.Text.Internal.Builder.{singleton,fromString}`](https://github.com/haskell/text/pull/281) +* [Use `unsafeWithForeignPtr` when available](https://github.com/haskell/text/pull/325) +* [Use vectorized CPU instructions for decoding and encoding](https://github.com/haskell/text/pull/302) +* [Regenerate case mapping in accordance to Unicode 13.0](https://github.com/haskell/text/pull/334) +* [Fix UTF-8 decoding of lazy bytestrings](https://github.com/haskell/text/pull/333) + +### 1.2.4.1 + +* Support `template-haskell-2.17.0.0` +* Support `bytestring-0.11` +* Add `take . drop` related RULE + +### 1.2.4.0 + +* Add TH `Lift` instances for `Data.Text.Text` and `Data.Text.Lazy.Text` (gh-232) + +* Update Haddock documentation to better reflect fusion eligibility; improve fusion + rules for `takeWhileEnd` and `length` (gh-241, ghc-202) + +* Optimise `Data.Text.replicate`. Rather than calling `memcpy` `n` times, + call it only `O(log n)` times on chunks of increasing size. The total + asymptotic complexity remains `O(nm)`. (gh-209) + +* Support `base-4.13.0.0` + +### 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 + (updated from 8.0). + +* Bug fix: the lazy `takeWhileEnd` function violated the + [lazy text invariant](https://github.com/bos/text/blob/1.2.3.0/Data/Text/Internal/Lazy.hs#L51) + (gh-184). + +* Bug fix: Fixed usage of size hints causing incorrect behavior (gh-197). + +* New function: `unsnoc` (gh-173). + +* Reduce memory overhead in `encodeUTF8` (gh-194). + +* Improve UTF-8 decoder error-recovery (gh-182). + +* Minor documentation improvements (`@since` annotations, more + examples, clarifications). + +#### 1.2.2.2 + +* The `toTitle` function now correctly handles letters that + immediately follow punctuation. Before, `"there's"` would turn into + `"There'S"`. Now, it becomes `"There's"`. + +* The implementation of unstreaming is faster, resulting in operations + such as `map` and `intersperse` speeding up by up to 30%, with + smaller code generated. + +* The optimised length comparison function is now more likely to be + used after some rewrite rule tweaking. + +* Bug fix: an off-by-one bug in `takeEnd` is fixed. + +* Bug fix: a logic error in `takeWord16` is fixed. + +#### 1.2.2.1 + +* The switch to `integer-pure` in 1.2.2.0 was apparently mistaken. + The build flag has been renamed accordingly. Your army of diligent + maintainers apologizes for the churn. + +* Spec compliance: `toCaseFold` now follows the Unicode 8.0 spec + (updated from 7.0) + +* An STG lint error has been fixed + +### 1.2.2.0 + +* The `integer-simple` package, upon which this package optionally + depended, has been replaced with `integer-pure`. The build flag has + been renamed accordingly. + +* Bug fix: For the `Binary` instance, If UTF-8 decoding fails during a + `get`, the error is propagated via `fail` instead of an uncatchable + crash. + +* New function: `takeWhileEnd` + +* New instances for the `Text` types: + * if `base` >= 4.7: `PrintfArg` + * if `base` >= 4.9: `Semigroup` + +#### 1.2.1.3 + +* Bug fix: As it turns out, moving the literal rewrite rules to simplifier + phase 2 does not prevent competition with the `unpack` rule, which is + also active in this phase. Unfortunately this was hidden due to a silly + test environment mistake. Moving literal rules back to phase 1 finally + fixes GHC Trac #10528 correctly. + +#### 1.2.1.2 + +* Bug fix: Run literal rewrite rules in simplifier phase 2. + The behavior of the simplifier changed in GHC 7.10.2, + causing these rules to fail to fire, leading to poor code generation + and long compilation times. See + [GHC Trac #10528](https://ghc.haskell.org/trac/ghc/ticket/10528). + +#### 1.2.1.1 + +* Expose unpackCString#, which you should never use. + +### 1.2.1.0 + +* Added Binary instances for both Text types. (If you have previously + been using the text-binary package to get a Binary instance, it is + now obsolete.) + +#### 1.2.0.6 + +* Fixed a space leak in UTF-8 decoding + +#### 1.2.0.5 + +* Feature parity: repeat, cycle, iterate are now implemented for lazy + Text, and the Data instance is more complete + +* Build speed: an inliner space explosion has been fixed with toCaseFold + +* Bug fix: encoding Int to a Builder would infinite-loop if the + integer-simple package was used + +* Deprecation: OnEncodeError and EncodeError are deprecated, as they + are never used + +* Internals: some types that are used internally in fusion-related + functions have moved around, been renamed, or been deleted (we don't + bump the major version if .Internal modules change) + +* Spec compliance: toCaseFold now follows the Unicode 7.0 spec + (updated from 6.3) + +#### 1.2.0.4 + +* Fixed an incompatibility with base < 4.5 + +#### 1.2.0.3 + +* Update formatRealFloat to correspond to the definition in versions + of base newer than 4.5 (https://github.com/bos/text/issues/105) + +#### 1.2.0.2 + +* Bumped lower bound on deepseq to 1.4 for compatibility with the + upcoming GHC 7.10 + +#### 1.2.0.1 + +* Fixed a buffer overflow in rendering of large Integers + (https://github.com/bos/text/issues/99) + +## 1.2.0.0 + +* Fixed an integer overflow in the replace function + (https://github.com/bos/text/issues/81) + +* Fixed a hang in lazy decodeUtf8With + (https://github.com/bos/text/issues/87) + +* Reduced codegen bloat caused by use of empty and single-character + literals + +* Added an instance of IsList for GHC 7.8 and above + +### 1.1.1.0 + +* The Data.Data instance now allows gunfold to work, via a virtual + pack constructor + +* dropEnd, takeEnd: new functions + +* Comparing the length of a Text against a number can now + short-circuit in more cases + +#### 1.1.0.1 + +* streamDecodeUtf8: fixed gh-70, did not return all unconsumed bytes + in single-byte chunks + +## 1.1.0.0 + +* encodeUtf8: Performance is improved by up to 4x. + +* encodeUtf8Builder, encodeUtf8BuilderEscaped: new functions, + available only if bytestring >= 0.10.4.0 is installed, that allow + very fast and flexible encoding of a Text value to a bytestring + Builder. + + As an example of the performance gain to be had, the + encodeUtf8BuilderEscaped function helps to double the speed of JSON + encoding in the latest version of aeson! (Note: if all you need is a + plain ByteString, encodeUtf8 is still the faster way to go.) + +* All of the internal module hierarchy is now publicly exposed. If a + module is in the .Internal hierarchy, or is documented as internal, + use at your own risk - there are no API stability guarantees for + internal modules! + +#### 1.0.0.1 + +* decodeUtf8: Fixed a regression that caused us to incorrectly + identify truncated UTF-8 as valid (gh-61) + +# 1.0.0.0 + +* Added support for Unicode 6.3.0 to case conversion functions + +* New function toTitle converts words in a string to title case + +* New functions peekCStringLen and withCStringLen simplify + interoperability with C functions + +* Added support for decoding UTF-8 in stream-friendly fashion + +* Fixed a bug in mapAccumL + +* Added trusted Haskell support + +* Removed support for GHC 6.10 (released in 2008) and older
src/Data/Text.hs view
@@ -370,8 +370,21 @@ readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str] -- | @since 1.2.2.0+--+-- Beware: @stimes@ will crash if the given number does not fit into+-- an @Int@. instance Semigroup Text where (<>) = append++ stimes howManyTimes+ | howManyTimes < 0 = P.error "Data.Text.stimes: given number is negative!"+ | otherwise =+ let howManyTimesInt = P.fromIntegral howManyTimes :: Int+ in if P.fromIntegral howManyTimesInt == howManyTimes && howManyTimesInt >= 0+ then replicate howManyTimesInt+ else P.error "Data.Text.stimes: given number does not fit into an Int!"++ sconcat = concat . NonEmptyList.toList instance Monoid Text where mempty = empty
src/Data/Text/Encoding/Error.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Encoding.Error@@ -36,7 +36,6 @@ import Control.DeepSeq (NFData (..)) import Control.Exception (Exception, throw)-import Data.Typeable (Typeable) import Data.Word (Word8) import Numeric (showHex) @@ -74,7 +73,7 @@ | EncodeError String (Maybe Char) -- ^ Tried to encode a character that could not be represented -- under the given encoding, or ran out of input in mid-encode.- deriving (Eq, Typeable)+ deriving (Eq) {-# DEPRECATED EncodeError "This constructor is never used, and will be removed." #-}
src/Data/Text/Internal.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-}@@ -58,7 +57,6 @@ import Data.Bits import Data.Int (Int32, Int64) import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)-import Data.Typeable (Typeable) import qualified Data.Text.Array as A -- | A space efficient, packed, unboxed Unicode text type.@@ -66,7 +64,6 @@ {-# UNPACK #-} !A.Array -- ^ bytearray encoded as UTF-8 {-# UNPACK #-} !Int -- ^ offset in bytes (not in Char!), pointing to a start of UTF-8 sequence {-# UNPACK #-} !Int -- ^ length in bytes (not in Char!), pointing to an end of UTF-8 sequence- deriving (Typeable) -- | Type synonym for the strict flavour of 'Text'. type StrictText = Text
src/Data/Text/Internal/Encoding/Utf8.hs view
@@ -48,7 +48,7 @@ import Control.Exception (assert) import GHC.Stack (HasCallStack) #endif-import Data.Bits (Bits(..), FiniteBits(..))+import Data.Bits (Bits(..)) import Data.Char (ord, chr) import GHC.Exts import GHC.Word (Word8(..))@@ -80,22 +80,13 @@ utf8Length (C# c) = I# ((1# +# geChar# c (chr# 0x80#)) +# (geChar# c (chr# 0x800#) +# geChar# c (chr# 0x10000#))) {-# INLINE utf8Length #-} --- This is a branchless version of--- utf8LengthByLeader w--- | w < 0x80 = 1--- | w < 0xE0 = 2--- | w < 0xF0 = 3--- | otherwise = 4------ c `xor` I# (c# <=# 0#) is a branchless equivalent of c `max` 1.--- It is crucial to write c# <=# 0# and not c# ==# 0#, otherwise--- GHC is tempted to "optimize" by introduction of branches.- -- | @since 2.0 utf8LengthByLeader :: Word8 -> Int-utf8LengthByLeader w = c `xor` I# (c# <=# 0#)- where- !c@(I# c#) = countLeadingZeros (complement w)+utf8LengthByLeader w+ | w < 0x80 = 1+ | w < 0xE0 = 2+ | w < 0xF0 = 3+ | otherwise = 4 {-# INLINE utf8LengthByLeader #-} ord2 ::
src/Data/Text/Internal/Fusion/CaseMapping.hs view
@@ -350,6 +350,7 @@ '\x0195'# -> unI64 502 '\x0199'# -> unI64 408 '\x019a'# -> unI64 573+ '\x019b'# -> unI64 42972 '\x019e'# -> unI64 544 '\x01a1'# -> unI64 416 '\x01a3'# -> unI64 418@@ -440,6 +441,7 @@ '\x0260'# -> unI64 403 '\x0261'# -> unI64 42924 '\x0263'# -> unI64 404+ '\x0264'# -> unI64 42955 '\x0265'# -> unI64 42893 '\x0266'# -> unI64 42922 '\x0268'# -> unI64 407@@ -776,6 +778,7 @@ '\x1c86'# -> unI64 1066 '\x1c87'# -> unI64 1122 '\x1c88'# -> unI64 42570+ '\x1c8a'# -> unI64 7305 '\x1d79'# -> unI64 42877 '\x1d7d'# -> unI64 11363 '\x1d8e'# -> unI64 42950@@ -1272,9 +1275,11 @@ '\xa7c3'# -> unI64 42946 '\xa7c8'# -> unI64 42951 '\xa7ca'# -> unI64 42953+ '\xa7cd'# -> unI64 42956 '\xa7d1'# -> unI64 42960 '\xa7d7'# -> unI64 42966 '\xa7d9'# -> unI64 42968+ '\xa7db'# -> unI64 42970 '\xa7f6'# -> unI64 42997 '\xab53'# -> unI64 42931 '\xab70'# -> unI64 5024@@ -1545,6 +1550,28 @@ '\x10cf0'# -> unI64 68784 '\x10cf1'# -> unI64 68785 '\x10cf2'# -> unI64 68786+ '\x10d70'# -> unI64 68944+ '\x10d71'# -> unI64 68945+ '\x10d72'# -> unI64 68946+ '\x10d73'# -> unI64 68947+ '\x10d74'# -> unI64 68948+ '\x10d75'# -> unI64 68949+ '\x10d76'# -> unI64 68950+ '\x10d77'# -> unI64 68951+ '\x10d78'# -> unI64 68952+ '\x10d79'# -> unI64 68953+ '\x10d7a'# -> unI64 68954+ '\x10d7b'# -> unI64 68955+ '\x10d7c'# -> unI64 68956+ '\x10d7d'# -> unI64 68957+ '\x10d7e'# -> unI64 68958+ '\x10d7f'# -> unI64 68959+ '\x10d80'# -> unI64 68960+ '\x10d81'# -> unI64 68961+ '\x10d82'# -> unI64 68962+ '\x10d83'# -> unI64 68963+ '\x10d84'# -> unI64 68964+ '\x10d85'# -> unI64 68965 '\x118c0'# -> unI64 71840 '\x118c1'# -> unI64 71841 '\x118c2'# -> unI64 71842@@ -2243,6 +2270,7 @@ '\x13f3'# -> unI64 5115 '\x13f4'# -> unI64 5116 '\x13f5'# -> unI64 5117+ '\x1c89'# -> unI64 7306 '\x1c90'# -> unI64 4304 '\x1c91'# -> unI64 4305 '\x1c92'# -> unI64 4306@@ -2791,9 +2819,13 @@ '\xa7c6'# -> unI64 7566 '\xa7c7'# -> unI64 42952 '\xa7c9'# -> unI64 42954+ '\xa7cb'# -> unI64 612+ '\xa7cc'# -> unI64 42957 '\xa7d0'# -> unI64 42961 '\xa7d6'# -> unI64 42967 '\xa7d8'# -> unI64 42969+ '\xa7da'# -> unI64 42971+ '\xa7dc'# -> unI64 411 '\xa7f5'# -> unI64 42998 '\xff21'# -> unI64 65345 '\xff22'# -> unI64 65346@@ -2983,6 +3015,28 @@ '\x10cb0'# -> unI64 68848 '\x10cb1'# -> unI64 68849 '\x10cb2'# -> unI64 68850+ '\x10d50'# -> unI64 68976+ '\x10d51'# -> unI64 68977+ '\x10d52'# -> unI64 68978+ '\x10d53'# -> unI64 68979+ '\x10d54'# -> unI64 68980+ '\x10d55'# -> unI64 68981+ '\x10d56'# -> unI64 68982+ '\x10d57'# -> unI64 68983+ '\x10d58'# -> unI64 68984+ '\x10d59'# -> unI64 68985+ '\x10d5a'# -> unI64 68986+ '\x10d5b'# -> unI64 68987+ '\x10d5c'# -> unI64 68988+ '\x10d5d'# -> unI64 68989+ '\x10d5e'# -> unI64 68990+ '\x10d5f'# -> unI64 68991+ '\x10d60'# -> unI64 68992+ '\x10d61'# -> unI64 68993+ '\x10d62'# -> unI64 68994+ '\x10d63'# -> unI64 68995+ '\x10d64'# -> unI64 68996+ '\x10d65'# -> unI64 68997 '\x118a0'# -> unI64 71872 '\x118a1'# -> unI64 71873 '\x118a2'# -> unI64 71874@@ -3311,6 +3365,7 @@ '\x0195'# -> unI64 502 '\x0199'# -> unI64 408 '\x019a'# -> unI64 573+ '\x019b'# -> unI64 42972 '\x019e'# -> unI64 544 '\x01a1'# -> unI64 416 '\x01a3'# -> unI64 418@@ -3401,6 +3456,7 @@ '\x0260'# -> unI64 403 '\x0261'# -> unI64 42924 '\x0263'# -> unI64 404+ '\x0264'# -> unI64 42955 '\x0265'# -> unI64 42893 '\x0266'# -> unI64 42922 '\x0268'# -> unI64 407@@ -3691,6 +3747,7 @@ '\x1c86'# -> unI64 1066 '\x1c87'# -> unI64 1122 '\x1c88'# -> unI64 42570+ '\x1c8a'# -> unI64 7305 '\x1d79'# -> unI64 42877 '\x1d7d'# -> unI64 11363 '\x1d8e'# -> unI64 42950@@ -4214,9 +4271,11 @@ '\xa7c3'# -> unI64 42946 '\xa7c8'# -> unI64 42951 '\xa7ca'# -> unI64 42953+ '\xa7cd'# -> unI64 42956 '\xa7d1'# -> unI64 42960 '\xa7d7'# -> unI64 42966 '\xa7d9'# -> unI64 42968+ '\xa7db'# -> unI64 42970 '\xa7f6'# -> unI64 42997 '\xab53'# -> unI64 42931 '\xab70'# -> unI64 5024@@ -4487,6 +4546,28 @@ '\x10cf0'# -> unI64 68784 '\x10cf1'# -> unI64 68785 '\x10cf2'# -> unI64 68786+ '\x10d70'# -> unI64 68944+ '\x10d71'# -> unI64 68945+ '\x10d72'# -> unI64 68946+ '\x10d73'# -> unI64 68947+ '\x10d74'# -> unI64 68948+ '\x10d75'# -> unI64 68949+ '\x10d76'# -> unI64 68950+ '\x10d77'# -> unI64 68951+ '\x10d78'# -> unI64 68952+ '\x10d79'# -> unI64 68953+ '\x10d7a'# -> unI64 68954+ '\x10d7b'# -> unI64 68955+ '\x10d7c'# -> unI64 68956+ '\x10d7d'# -> unI64 68957+ '\x10d7e'# -> unI64 68958+ '\x10d7f'# -> unI64 68959+ '\x10d80'# -> unI64 68960+ '\x10d81'# -> unI64 68961+ '\x10d82'# -> unI64 68962+ '\x10d83'# -> unI64 68963+ '\x10d84'# -> unI64 68964+ '\x10d85'# -> unI64 68965 '\x118c0'# -> unI64 71840 '\x118c1'# -> unI64 71841 '\x118c2'# -> unI64 71842
src/Data/Text/Internal/IO.hs view
@@ -1,306 +1,308 @@-{-# LANGUAGE BangPatterns, RecordWildCards #-}-{-# LANGUAGE MagicHash #-}--- |--- Module : Data.Text.Internal.IO--- Copyright : (c) 2009, 2010 Bryan O'Sullivan,--- (c) 2009 Simon Marlow--- License : BSD-style--- Maintainer : bos@serpentine.com--- Stability : experimental--- Portability : GHC------ /Warning/: this is an internal module, and does not have a stable--- API or name. Functions in this module may not check or enforce--- preconditions expected by public modules. Use at your own risk!------ Low-level support for text I\/O.--module Data.Text.Internal.IO- (- hGetLineWith- , readChunk- , hPutStream- , hPutStr- , hPutStrLn- ) where--import qualified Control.Exception as E-import qualified Data.ByteString as B-import Data.ByteString.Builder (hPutBuilder, charUtf8)-import Data.IORef (readIORef, writeIORef)-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8, encodeUtf8Builder)-import Data.Text.Internal.Fusion (stream, streamLn, unstream)-import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))-import Data.Text.Internal.Fusion.Size (exactSize, maxSize)-import Data.Text.Unsafe (inlinePerformIO)-import Foreign.Storable (peekElemOff)-import GHC.Exts (reallyUnsafePtrEquality#, isTrue#)-import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBuffer, RawCharBuffer,- bufferAdjustL, bufferElems, charSize, emptyBuffer,- isEmptyBuffer, newCharBuffer, readCharBuf, withRawBuffer,- writeCharBuf)-import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_,- wantWritableHandle)-import GHC.IO.Handle.Text (commitBuffer')-import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..), Newline(..))-import System.IO (Handle, hPutChar, utf8)-import System.IO.Error (isEOFError)-import qualified Data.Text as T---- | Read a single line of input from a handle, constructing a list of--- decoded chunks as we go. When we're done, transform them into the--- destination type.-hGetLineWith :: ([Text] -> t) -> Handle -> IO t-hGetLineWith f h = wantReadableHandle_ "hGetLine" h go- where- go hh@Handle__{..} = readIORef haCharBuffer >>= fmap f . hGetLineLoop hh []--hGetLineLoop :: Handle__ -> [Text] -> CharBuffer -> IO [Text]-hGetLineLoop hh@Handle__{..} = go where- go ts buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } = do- let findEOL raw r | r == w = return (False, w)- | otherwise = do- (c,r') <- readCharBuf raw r- if c == '\n'- then return (True, r)- else findEOL raw r'- (eol, off) <- findEOL raw0 r0- (t,r') <- if haInputNL == CRLF- then unpack_nl raw0 r0 off- else do t <- unpack raw0 r0 off- return (t,off)- if eol- then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)- return $ reverse (t:ts)- else do- let buf1 = bufferAdjustL r' buf- maybe_buf <- maybeFillReadBuffer hh buf1- case maybe_buf of- -- Nothing indicates we caught an EOF, and we may have a- -- partial line to return.- Nothing -> do- -- we reached EOF. There might be a lone \r left- -- in the buffer, so check for that and- -- append it to the line if necessary.- let pre | isEmptyBuffer buf1 = T.empty- | otherwise = T.singleton '\r'- writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }- let str = reverse . filter (not . T.null) $ pre:t:ts- if null str- then ioe_EOF- else return str- Just new_buf -> go (t:ts) new_buf---- This function is lifted almost verbatim from GHC.IO.Handle.Text.-maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)-maybeFillReadBuffer handle_ buf- = E.catch (Just `fmap` getSomeCharacters handle_ buf) $ \e ->- if isEOFError e- then return Nothing- else ioError e--unpack :: RawCharBuffer -> Int -> Int -> IO Text-unpack !buf !r !w- | charSize /= 4 = sizeError "unpack"- | r >= w = return T.empty- | otherwise = withRawBuffer buf go- where- go pbuf = return $! unstream (Stream next r (exactSize (w-r)))- where- next !i | i >= w = Done- | otherwise = Yield (ix i) (i+1)- ix i = inlinePerformIO $ peekElemOff pbuf i--unpack_nl :: RawCharBuffer -> Int -> Int -> IO (Text, Int)-unpack_nl !buf !r !w- | charSize /= 4 = sizeError "unpack_nl"- | r >= w = return (T.empty, 0)- | otherwise = withRawBuffer buf $ go- where- go pbuf = do- let !t = unstream (Stream next r (maxSize (w-r)))- w' = w - 1- return $ if ix w' == '\r'- then (t,w')- else (t,w)- where- next !i | i >= w = Done- | c == '\r' = let i' = i + 1- in if i' < w- then if ix i' == '\n'- then Yield '\n' (i+2)- else Yield '\n' i'- else Done- | otherwise = Yield c (i+1)- where c = ix i- ix i = inlinePerformIO $ peekElemOff pbuf i---- This function is completely lifted from GHC.IO.Handle.Text.-getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer-getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =- case bufferElems buf of- -- buffer empty: read some more- 0 -> {-# SCC "readTextDevice" #-} readTextDevice handle_ buf-- -- if the buffer has a single '\r' in it and we're doing newline- -- translation: read some more- 1 | haInputNL == CRLF -> do- (c,_) <- readCharBuf bufRaw bufL- if c == '\r'- then do -- shuffle the '\r' to the beginning. This is only safe- -- if we're about to call readTextDevice, otherwise it- -- would mess up flushCharBuffer.- -- See [note Buffer Flushing], GHC.IO.Handle.Types- _ <- writeCharBuf bufRaw 0 '\r'- let buf' = buf{ bufL=0, bufR=1 }- readTextDevice handle_ buf'- else do- return buf-- -- buffer has some chars in it already: just return it- _otherwise -> {-# SCC "otherwise" #-} return buf---- | Read a single chunk of strict text from a buffer. Used by both--- the strict and lazy implementations of hGetContents.-readChunk :: Handle__ -> CharBuffer -> IO Text-readChunk hh@Handle__{..} buf = do- buf'@Buffer{..} <- getSomeCharacters hh buf- (t,r) <- if haInputNL == CRLF- then unpack_nl bufRaw bufL bufR- else do t <- unpack bufRaw bufL bufR- return (t,bufR)- writeIORef haCharBuffer (bufferAdjustL r buf')- return t---- | Print a @Stream Char@.-hPutStream :: Handle -> Stream Char -> IO ()-hPutStream h str = hPutStreamOrUtf8 h str Nothing---- | Write a string to a handle.-hPutStr :: Handle -> Text -> IO ()-hPutStr h t = hPutStreamOrUtf8 h (stream t) (Just putUtf8)- where- putUtf8 = B.hPutStr h (encodeUtf8 t)---- | Write a string to a handle, followed by a newline.-hPutStrLn :: Handle -> Text -> IO ()-hPutStrLn h t = hPutStreamOrUtf8 h (streamLn t) (Just putUtf8)- where- -- Not using B.hPutStrLn because it's not necessarily atomic:- -- https://github.com/haskell/bytestring/issues/200- putUtf8 = hPutBuilder h (encodeUtf8Builder t <> charUtf8 '\n')---- | 'hPutStream' with an optional special case when the output encoding is--- UTF-8 and without newline conversion.-hPutStreamOrUtf8 :: Handle -> Stream Char -> Maybe (IO ()) -> IO ()--- This function is modified from GHC.IO.Handle.Text.-hPutStreamOrUtf8 h str mPutUtf8 = do- (buffer_mode, nl, isUtf8) <-- wantWritableHandle "hPutStr" h $ \h_ -> do- bmode <- getSpareBuffer h_- return (bmode, haOutputNL h_, eqUTF8 h_)- case buffer_mode of- _ | Just putUtf8 <- mPutUtf8, nl == LF && isUtf8 -> putUtf8- (NoBuffering, _) -> hPutChars h str- (LineBuffering, buf) -> writeLines h nl buf str- (BlockBuffering _, buf) -> writeBlocks (nl == CRLF) h buf str-- where- -- If the encoding is UTF-8, it's most likely pointer-equal to- -- 'System.IO.utf8', letting us avoid a String comparison.- -- If it is somehow UTF-8 but not pointer-equal to 'utf8',- -- we will just take a slower branch, but the result is still correct.- eqUTF8 = maybe False (\enc -> isTrue# (reallyUnsafePtrEquality# utf8 enc)) . haCodec-{-# INLINE hPutStreamOrUtf8 #-}--hPutChars :: Handle -> Stream Char -> IO ()-hPutChars h (Stream next0 s0 _len) = loop s0- where- loop !s = case next0 s of- Done -> return ()- Skip s' -> loop s'- Yield x s' -> hPutChar h x >> loop s'---- The following functions are largely lifted from GHC.IO.Handle.Text,--- but adapted to a coinductive stream of data instead of an inductive--- list.------ We have several variations of more or less the same code for--- performance reasons. Splitting the original buffered write--- function into line- and block-oriented versions gave us a 2.1x--- performance improvement. Lifting out the raw/cooked newline--- handling gave a few more percent on top.--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)- 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- n' <- if nl == CRLF- then do n1 <- writeCharBuf' raw len n '\r'- writeCharBuf' raw len n1 '\n'- else writeCharBuf' raw len n x- commit n' True{-needs flush-} False >>= outer s'- | otherwise -> writeCharBuf' raw len n x >>= inner s'- commit = commitBuffer h raw len--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)- 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'- | isCRLF && x == '\n' && n + 1 < len -> do- n1 <- writeCharBuf' raw len n '\r'- writeCharBuf' raw len n1 '\n' >>= inner s'- | n < len -> writeCharBuf' raw len n x >>= inner s'- | otherwise -> commit n True{-needs flush-} False >>= outer 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) $- writeCharBuf bufRaw n c---- This function is completely lifted from GHC.IO.Handle.Text.-getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)-getSpareBuffer Handle__{haCharBuffer=ref,- haBuffers=spare_ref,- haBufferMode=mode}- = do- case mode of- NoBuffering -> return (mode, error "no buffer!")- _ -> do- bufs <- readIORef spare_ref- buf <- readIORef ref- case bufs of- BufferListCons b rest -> do- writeIORef spare_ref rest- return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)- BufferListNil -> do- new_buf <- newCharBuffer (bufSize buf) WriteBuffer- return (mode, new_buf)----- This function is modified from GHC.Internal.IO.Handle.Text.-commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool- -> IO CharBuffer-commitBuffer hdl !raw !sz !count flush release =- wantWritableHandle "commitAndReleaseBuffer" hdl $- commitBuffer' raw sz count flush release-{-# INLINE commitBuffer #-}--sizeError :: String -> a-sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size"+{-# LANGUAGE BangPatterns, RecordWildCards #-} +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.Text.Internal.IO +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan, +-- (c) 2009 Simon Marlow +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- /Warning/: this is an internal module, and does not have a stable +-- API or name. Functions in this module may not check or enforce +-- preconditions expected by public modules. Use at your own risk! +-- +-- Low-level support for text I\/O. + +module Data.Text.Internal.IO + ( + hGetLineWith + , readChunk + , hPutStream + , hPutStr + , hPutStrLn + ) where + +import qualified Control.Exception as E +import qualified Data.ByteString as B +import Data.ByteString.Builder (hPutBuilder, charUtf8) +import Data.IORef (readIORef, writeIORef) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, encodeUtf8Builder) +import Data.Text.Internal.Fusion (stream, streamLn, unstream) +import Data.Text.Internal.Fusion.Types (Step(..), Stream(..)) +import Data.Text.Internal.Fusion.Size (exactSize, maxSize) +import Data.Text.Unsafe (inlinePerformIO) +import Foreign.Storable (peekElemOff) +import GHC.Exts (reallyUnsafePtrEquality#, isTrue#) +import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBuffer, RawCharBuffer, + bufferAdjustL, bufferElems, charSize, emptyBuffer, + isEmptyBuffer, newCharBuffer, readCharBuf, withRawBuffer, + writeCharBuf) +import GHC.IO.Handle.Internals (ioe_EOF, readTextDevice, wantReadableHandle_, + wantWritableHandle) +import GHC.IO.Handle.Text (commitBuffer') +import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..), Newline(..)) +import System.IO (Handle, hPutChar, utf8) +import System.IO.Error (isEOFError) +import qualified Data.Text as T + +-- | Read a single line of input from a handle, constructing a list of +-- decoded chunks as we go. When we're done, transform them into the +-- destination type. +hGetLineWith :: ([Text] -> t) -> Handle -> IO t +hGetLineWith f h = wantReadableHandle_ "hGetLine" h go + where + go hh@Handle__{..} = readIORef haCharBuffer >>= fmap f . hGetLineLoop hh [] + +hGetLineLoop :: Handle__ -> [Text] -> CharBuffer -> IO [Text] +hGetLineLoop hh@Handle__{..} = go where + go ts buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } = do + let findEOL raw r | r == w = return (False, w) + | otherwise = do + (c,r') <- readCharBuf raw r + if c == '\n' + then return (True, r) + else findEOL raw r' + (eol, off) <- findEOL raw0 r0 + (t,r') <- if haInputNL == CRLF + then unpack_nl raw0 r0 off + else do t <- unpack raw0 r0 off + return (t,off) + if eol + then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf) + return $ reverse (t:ts) + else do + let buf1 = bufferAdjustL r' buf + maybe_buf <- maybeFillReadBuffer hh buf1 + case maybe_buf of + -- Nothing indicates we caught an EOF, and we may have a + -- partial line to return. + Nothing -> do + -- we reached EOF. There might be a lone \r left + -- in the buffer, so check for that and + -- append it to the line if necessary. + let pre | isEmptyBuffer buf1 = T.empty + | otherwise = T.singleton '\r' + writeIORef haCharBuffer buf1{ bufL=0, bufR=0 } + let str = reverse . filter (not . T.null) $ pre:t:ts + if null str + then ioe_EOF + else return str + Just new_buf -> go (t:ts) new_buf + +-- This function is lifted almost verbatim from GHC.IO.Handle.Text. +maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) +maybeFillReadBuffer handle_ buf + = E.catch (Just `fmap` getSomeCharacters handle_ buf) $ \e -> + if isEOFError e + then return Nothing + else ioError e + +unpack :: RawCharBuffer -> Int -> Int -> IO Text +unpack !buf !r !w + | charSize /= 4 = sizeError "unpack" + | r >= w = return T.empty + | otherwise = withRawBuffer buf go + where + go pbuf = return $! unstream (Stream next r (exactSize (w-r))) + where + next !i | i >= w = Done + | otherwise = Yield (ix i) (i+1) + ix i = inlinePerformIO $ peekElemOff pbuf i + +-- Variant of 'unpack' with CRLF decoding. If there is a trailing '\r', leave it in the buffer. +unpack_nl :: RawCharBuffer -> Int -> Int -> IO (Text, Int) +unpack_nl !buf !r !w + | charSize /= 4 = sizeError "unpack_nl" + | r >= w = return (T.empty, 0) + | otherwise = withRawBuffer buf $ go + where + go pbuf = do + let !t = unstream (Stream next r (maxSize (w-r))) + w' = w - 1 + return $ if ix w' == '\r' + then (t,w') + else (t,w) + where + next !i | i >= w = Done + | c == '\r' = let i' = i + 1 + in if i' < w + then if ix i' == '\n' + then Yield '\n' (i+2) + else Yield '\r' i' + else Done + | otherwise = Yield c (i+1) + where c = ix i + ix i = inlinePerformIO $ peekElemOff pbuf i + +-- This function is completely lifted from GHC.IO.Handle.Text. +getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer +getSomeCharacters handle_@Handle__{..} buf@Buffer{..} = + case bufferElems buf of + -- buffer empty: read some more + 0 -> {-# SCC "readTextDevice" #-} readTextDevice handle_ buf + + -- if the buffer has a single '\r' in it and we're doing newline + -- translation: read some more + 1 | haInputNL == CRLF -> do + (c,_) <- readCharBuf bufRaw bufL + if c == '\r' + then do -- shuffle the '\r' to the beginning. This is only safe + -- if we're about to call readTextDevice, otherwise it + -- would mess up flushCharBuffer. + -- See [note Buffer Flushing], GHC.IO.Handle.Types + _ <- writeCharBuf bufRaw 0 '\r' + let buf' = buf{ bufL=0, bufR=1 } + readTextDevice handle_ buf' + else do + return buf + + -- buffer has some chars in it already: just return it + _otherwise -> {-# SCC "otherwise" #-} return buf + +-- | Read a single chunk of strict text from a buffer. Used by both +-- the strict and lazy implementations of hGetContents. +readChunk :: Handle__ -> CharBuffer -> IO Text +readChunk hh@Handle__{..} buf = do + buf'@Buffer{..} <- getSomeCharacters hh buf + (t,r) <- if haInputNL == CRLF + then unpack_nl bufRaw bufL bufR + else do t <- unpack bufRaw bufL bufR + return (t,bufR) + writeIORef haCharBuffer (bufferAdjustL r buf') + return t + +-- | Print a @Stream Char@. +hPutStream :: Handle -> Stream Char -> IO () +hPutStream h str = hPutStreamOrUtf8 h str Nothing + +-- | Write a string to a handle. +hPutStr :: Handle -> Text -> IO () +hPutStr h t = hPutStreamOrUtf8 h (stream t) (Just putUtf8) + where + putUtf8 = B.hPutStr h (encodeUtf8 t) + +-- | Write a string to a handle, followed by a newline. +hPutStrLn :: Handle -> Text -> IO () +hPutStrLn h t = hPutStreamOrUtf8 h (streamLn t) (Just putUtf8) + where + -- Not using B.hPutStrLn because it's not necessarily atomic: + -- https://github.com/haskell/bytestring/issues/200 + putUtf8 = hPutBuilder h (encodeUtf8Builder t <> charUtf8 '\n') + +-- | 'hPutStream' with an optional special case when the output encoding is +-- UTF-8 and without newline conversion. +hPutStreamOrUtf8 :: Handle -> Stream Char -> Maybe (IO ()) -> IO () +-- This function is modified from GHC.IO.Handle.Text. +hPutStreamOrUtf8 h str mPutUtf8 = do + (buffer_mode, nl, isUtf8) <- + wantWritableHandle "hPutStr" h $ \h_ -> do + bmode <- getSpareBuffer h_ + return (bmode, haOutputNL h_, eqUTF8 h_) + case buffer_mode of + _ | Just putUtf8 <- mPutUtf8, nl == LF && isUtf8 -> putUtf8 + (NoBuffering, _) -> hPutChars h str + (LineBuffering, buf) -> writeLines h nl buf str + (BlockBuffering _, buf) -> writeBlocks (nl == CRLF) h buf str + + where + -- If the encoding is UTF-8, it's most likely pointer-equal to + -- 'System.IO.utf8', letting us avoid a String comparison. + -- If it is somehow UTF-8 but not pointer-equal to 'utf8', + -- we will just take a slower branch, but the result is still correct. + eqUTF8 = maybe False (\enc -> isTrue# (reallyUnsafePtrEquality# utf8 enc)) . haCodec +{-# INLINE hPutStreamOrUtf8 #-} + +hPutChars :: Handle -> Stream Char -> IO () +hPutChars h (Stream next0 s0 _len) = loop s0 + where + loop !s = case next0 s of + Done -> return () + Skip s' -> loop s' + Yield x s' -> hPutChar h x >> loop s' + +-- The following functions are largely lifted from GHC.IO.Handle.Text, +-- but adapted to a coinductive stream of data instead of an inductive +-- list. +-- +-- We have several variations of more or less the same code for +-- performance reasons. Splitting the original buffered write +-- function into line- and block-oriented versions gave us a 2.1x +-- performance improvement. Lifting out the raw/cooked newline +-- handling gave a few more percent on top. + +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) + 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 + n' <- if nl == CRLF + then do n1 <- writeCharBuf' raw len n '\r' + writeCharBuf' raw len n1 '\n' + else writeCharBuf' raw len n x + commit n' True{-needs flush-} False >>= outer s' + | otherwise -> writeCharBuf' raw len n x >>= inner s' + commit = commitBuffer h raw len + +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) + 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' + -- Leave room for two characters for CRLF decoding + | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s + | x == '\n' && isCRLF -> do + n1 <- writeCharBuf' raw len n '\r' + writeCharBuf' raw len n1 '\n' >>= inner s' + | otherwise -> writeCharBuf' raw len 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) $ + writeCharBuf bufRaw n c + +-- This function is completely lifted from GHC.IO.Handle.Text. +getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer) +getSpareBuffer Handle__{haCharBuffer=ref, + haBuffers=spare_ref, + haBufferMode=mode} + = do + case mode of + NoBuffering -> return (mode, error "no buffer!") + _ -> do + bufs <- readIORef spare_ref + buf <- readIORef ref + case bufs of + BufferListCons b rest -> do + writeIORef spare_ref rest + return ( mode, emptyBuffer b (bufSize buf) WriteBuffer) + BufferListNil -> do + new_buf <- newCharBuffer (bufSize buf) WriteBuffer + return (mode, new_buf) + + +-- This function is modified from GHC.Internal.IO.Handle.Text. +commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool + -> IO CharBuffer +commitBuffer hdl !raw !sz !count flush release = + wantWritableHandle "commitAndReleaseBuffer" hdl $ + commitBuffer' raw sz count flush release +{-# INLINE commitBuffer #-} + +sizeError :: String -> a +sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size"
src/Data/Text/Internal/Lazy.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} -- |@@ -43,7 +43,6 @@ import Data.Bits (shiftL) import Data.Text ()-import Data.Typeable (Typeable) import Foreign.Storable (sizeOf) import qualified Data.Text.Array as A import qualified Data.Text.Internal as T@@ -55,7 +54,6 @@ -- @since 2.1.2 | Chunk {-# UNPACK #-} !T.Text Text -- ^ Chunks must be non-empty, this invariant is not checked.- deriving (Typeable) -- | Type synonym for the lazy flavour of 'Text'. type LazyText = Text
src/Data/Text/Internal/Transformation.hs view
@@ -36,9 +36,9 @@ Ord(..), Monad(..), pure, (+), (-), ($), (&&), (||), (==),- not, return, otherwise, fromIntegral, (/=), const)+ not, return, otherwise) import Data.Bits ((.&.), shiftR, shiftL)-import Data.Char (isLetter, isSpace, ord)+import Data.Char (isLetter, isSpace) import Control.Monad.ST (ST, runST) import qualified Data.Text.Array as A import Data.Text.Internal.Encoding.Utf8 (utf8LengthByLeader, chr2, chr3, chr4)@@ -47,7 +47,7 @@ import Data.Text.Internal.Unsafe.Char (unsafeWrite, unsafeChr8) import qualified Prelude as P import Data.Text.Unsafe (Iter(..), iterArray)-import Data.Word (Word8, Word)+import Data.Word (Word8) import qualified GHC.Exts as Exts import GHC.Int (Int64(..))
src/Data/Text/Lazy.hs view
@@ -328,6 +328,13 @@ -- | @since 1.2.2.0 instance Semigroup Text where (<>) = append+ stimes n _ | n < 0 = P.error "Data.Text.Lazy.stimes: given number is negative!"+ stimes n a =+ let nInt64 = fromIntegral n :: Int64+ len = if n == fromIntegral nInt64 && nInt64 >= 0 then nInt64 else P.maxBound+ -- We clamp the length to maxBound :: Int64.+ -- To tell the difference, the caller would have to skip through 2^63 chunks.+ in replicate len a instance Monoid Text where mempty = empty@@ -424,7 +431,23 @@ #endif Text -> String unpack t = S.unstreamList (stream t)-{-# INLINE [1] unpack #-}+{-# NOINLINE unpack #-}++foldrFB :: (Char -> b -> b) -> b -> Text -> b+foldrFB = foldr+{-# INLINE [0] foldrFB #-}++-- List fusion rules for `unpack`:+-- * `unpack` rewrites to `build` up till (but not including) phase 1. `build`+-- fuses if `foldr` is applied to it.+-- * If it doesn't fuse: In phase 1, `build` inlines to give us `foldrFB (:) []`+-- and we rewrite that back to `unpack`.+-- * If it fuses: In phase 0, `foldrFB` inlines and `foldr` inlines. GHC+-- optimizes the fused code.+{-# RULES+"Text.Lazy.unpack" [~1] forall t. unpack t = Exts.build (\lcons lnil -> foldrFB lcons lnil t)+"Text.Lazy.unpackBack" [1] foldrFB (:) [] = unpack+ #-} -- | /O(n)/ Convert a literal string into a Text. unpackCString# :: Addr# -> Text
src/Data/Text/Lazy/Builder/RealFloat.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE CPP, OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}+{-# OPTIONS_GHC -Wno-x-partial #-}+ -- | -- Module: Data.Text.Lazy.Builder.RealFloat -- Copyright: (c) The University of Glasgow 1994-2002
src/Data/Text/Lazy/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} -- | -- Module : Data.Text.Lazy.Internal -- Copyright : (c) 2013 Bryan O'Sullivan
src/Data/Text/Show.hs view
@@ -31,6 +31,7 @@ import Data.Text.Internal.Unsafe.Char (unsafeWrite) import Data.Text.Unsafe (Iter(..), iterArray) import GHC.Exts (Ptr(..), Int(..), Addr#, indexWord8OffAddr#)+import qualified GHC.Exts as Exts import GHC.Word (Word8(..)) import qualified Data.Text.Array as A #if !MIN_VERSION_ghc_prim(0,7,0)@@ -53,12 +54,32 @@ HasCallStack => #endif Text -> String-unpack (Text arr off len) = go off+unpack t = foldrText (:) [] t+{-# NOINLINE unpack #-}++foldrText :: (Char -> b -> b) -> b -> Text -> b+foldrText f z (Text arr off len) = go off where go !i- | i >= off + len = []- | otherwise = let !(Iter c l) = iterArray arr i in c : go (i + l)-{-# INLINE [1] unpack #-}+ | i >= off + len = z+ | otherwise = let !(Iter c l) = iterArray arr i in f c (go (i + l))+{-# INLINE foldrText #-}++foldrTextFB :: (Char -> b -> b) -> b -> Text -> b+foldrTextFB = foldrText+{-# INLINE [0] foldrTextFB #-}++-- List fusion rules for `unpack`:+-- * `unpack` rewrites to `build` up till (but not including) phase 1. `build`+-- fuses if `foldr` is applied to it.+-- * If it doesn't fuse: In phase 1, `build` inlines to give us+-- `foldrTextFB (:) []` and we rewrite that back to `unpack`.+-- * If it fuses: In phase 0, `foldrTextFB` inlines and `foldrText` inlines. GHC+-- optimizes the fused code.+{-# RULES+"Text.unpack" [~1] forall t. unpack t = Exts.build (\lcons lnil -> foldrTextFB lcons lnil t)+"Text.unpackBack" [1] foldrTextFB (:) [] = unpack+ #-} -- | /O(n)/ Convert a null-terminated -- <https://en.wikipedia.org/wiki/UTF-8#Modified_UTF-8 modified UTF-8>
tests/Tests/Properties.hs view
@@ -17,6 +17,7 @@ import Tests.Properties.Text (testText) import Tests.Properties.Transcoding (testTranscoding) import Tests.Properties.Validate (testValidate)+import Tests.Properties.CornerCases (testCornerCases) tests :: TestTree tests =@@ -30,5 +31,6 @@ testBuilder, testLowLevel, testRead,+ testCornerCases, testValidate ]
+ tests/Tests/Properties/CornerCases.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | Check that the definitions that are partial crash in the expected ways or+-- return sensible defaults.+module Tests.Properties.CornerCases (testCornerCases) where++import Control.Exception+import Data.Either+import Data.Semigroup+import Data.Text+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Tests.QuickCheckUtils ()++testCornerCases :: TestTree+testCornerCases =+ testGroup+ "corner cases"+ [ testGroup+ "stimes"+ $ let specimen = stimes :: Integer -> Text -> Text+ in [ testProperty+ "given a negative number, evaluate to error call"+ $ \(Negative number) text ->+ (ioProperty . fmap isLeft . try @ErrorCall . evaluate) $+ specimen+ (fromIntegral (number :: Int))+ text+ , testProperty+ "given a number that does not fit into Int, evaluate to error call"+ $ \(NonNegative number) text ->+ (ioProperty . fmap isLeft . try @ErrorCall . evaluate) $+ specimen+ (fromIntegral (number :: Int) + fromIntegral (maxBound :: Int) + 1)+ text+ ]+ ]
tests/Tests/Properties/Instances.hs view
@@ -7,6 +7,7 @@ ) where import Data.Binary (encode, decodeOrFail)+import Data.Semigroup import Data.String (IsString(fromString)) import Test.QuickCheck import Test.Tasty (TestTree, testGroup)@@ -37,6 +38,12 @@ tl_Show = show `eq` (show . TL.pack) t_mappend s = mappend s`eqP` (unpackS . mappend (T.pack s)) tl_mappend s = mappend s`eqP` (unpackS . mappend (TL.pack s))+t_stimes = \ number -> eq+ ((stimes :: Int -> String -> String) number . unSqrt)+ (unpackS . (stimes :: Int -> T.Text -> T.Text) number . T.pack . unSqrt)+tl_stimes = \ number -> eq+ ((stimes :: Int -> String -> String) number . unSqrt)+ (unpackS . (stimes :: Int -> TL.Text -> TL.Text) number . TL.pack . unSqrt) t_mconcat = (mconcat . unSqrt) `eq` (unpackS . mconcat . L.map T.pack . unSqrt) tl_mconcat = (mconcat . unSqrt) `eq` (unpackS . mconcat . L.map TL.pack . unSqrt) t_mempty = mempty === (unpackS (mempty :: T.Text))@@ -71,6 +78,8 @@ testProperty "tl_Show" tl_Show, testProperty "t_mappend" t_mappend, testProperty "tl_mappend" tl_mappend,+ testProperty "t_stimes" t_stimes,+ testProperty "tl_stimes" tl_stimes, testProperty "t_mconcat" t_mconcat, testProperty "tl_mconcat" tl_mconcat, testProperty "t_mempty" t_mempty,
tests/Tests/Properties/LowLevel.hs view
@@ -1,164 +1,174 @@--- | Test low-level operations--{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-imports #-}--#ifdef MIN_VERSION_tasty_inspection_testing-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}-#endif--module Tests.Properties.LowLevel (testLowLevel) where--import Prelude hiding (head, tail)-import Control.Applicative ((<$>), pure)-import Control.Exception as E (SomeException, catch, evaluate)-import Data.Int (Int32, Int64)-import Data.Text.Foreign-import Data.Text.Internal (Text(..), mul, mul32, mul64, safe)-import Data.Word (Word8, Word16, Word32)-import System.IO.Unsafe (unsafePerformIO)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, assertEqual)-import Test.Tasty.QuickCheck (testProperty)-import Test.QuickCheck hiding ((.&.))-import Tests.QuickCheckUtils-import Tests.Utils-import qualified Data.Text as T-import qualified Data.Text.Foreign as T-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.IO as TL-import qualified Data.Text.IO.Utf8 as TU-import qualified System.IO as IO--#ifdef MIN_VERSION_tasty_inspection_testing-import Test.Tasty.Inspection (inspectObligations, hasNoTypes, doesNotUseAnyOf)-import qualified Data.Text.Internal.Fusion as S-import qualified Data.Text.Internal.Fusion.Common as S-import qualified GHC.CString as GHC-#endif--mulRef :: (Integral a, Bounded a) => a -> a -> Maybe a-mulRef a b- | ab < bot || ab > top = Nothing- | otherwise = Just (fromIntegral ab)- where ab = fromIntegral a * fromIntegral b- top = fromIntegral (maxBound `asTypeOf` a) :: Integer- bot = fromIntegral (minBound `asTypeOf` a) :: Integer--eval :: (a -> b -> c) -> a -> b -> Maybe c-eval f a b = unsafePerformIO $- (Just <$> evaluate (f a b)) `E.catch` (\(_::SomeException) -> pure Nothing)--t_mul32 :: Int32 -> Int32 -> Property-t_mul32 a b = mulRef a b === eval mul32 a b--t_mul64 :: Int64 -> Int64 -> Property-t_mul64 a b = mulRef a b === eval mul64 a b--t_mul :: Int -> Int -> Property-t_mul a b = mulRef a b === eval mul a b---- Misc.--t_dropWord8 m t = dropWord8 m t `T.isSuffixOf` t-t_takeWord8 m t = takeWord8 m t `T.isPrefixOf` t-t_take_drop_8 (Small n) t = T.append (takeWord8 n t) (dropWord8 n t) === t-t_use_from t = ioProperty $ (==t) <$> useAsPtr t fromPtr-t_use_from0 t = ioProperty $ do- let t' = t `T.snoc` '\0'- (== T.takeWhile (/= '\0') t') <$> useAsPtr t' (const . fromPtr0)--t_peek_cstring t = T.all (/= '\0') t ==> ioProperty $ do- roundTrip <- T.withCString t T.peekCString- assertEqual "cstring" t roundTrip--t_peek_cstring_len t = ioProperty $ do- roundTrip <- T.withCStringLen t T.peekCStringLen- assertEqual "cstring_len" t roundTrip--t_copy t = T.copy t === t--t_literal_length1 = assertEqual xs (length xs) byteLen- where- xs = "\0\1\0\1\0"- Text _ _ byteLen = T.pack xs-t_literal_length2 = assertEqual xs (length xs) byteLen- where- xs = "\1\2\3\4\5"- Text _ _ byteLen = T.pack xs-t_literal_surrogates = assertEqual xs (T.pack xs) (T.pack ys)- where- ys = "\xd7ff \xd800 \xdbff \xdc00 \xdfff \xe000"- xs = map safe ys--#ifdef MIN_VERSION_tasty_inspection_testing-t_literal_foo :: Text-t_literal_foo = T.pack "foo"-#endif---- Input and output.---- t_put_get = write_read T.unlines T.filter put get--- where put h = withRedirect h IO.stdout . T.putStr--- get h = withRedirect h IO.stdin T.getContents--- tl_put_get = write_read TL.unlines TL.filter put get--- where put h = withRedirect h IO.stdout . TL.putStr--- get h = withRedirect h IO.stdin TL.getContents-t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents id-tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents id--t_write_read_line = write_read (T.concat . take 1) T.filter T.hPutStrLn T.hGetLine (: [])-tl_write_read_line = write_read (TL.concat . take 1) TL.filter TL.hPutStrLn TL.hGetLine (: [])--utf8_write_read = write_read T.unlines T.filter TU.hPutStr TU.hGetContents id-utf8_write_read_line = write_read (T.concat . take 1) T.filter TU.hPutStrLn TU.hGetLine (: [])--testLowLevel :: TestTree-testLowLevel =- testGroup "lowlevel" [- testGroup "mul" [- testProperty "t_mul" t_mul,- testProperty "t_mul32" t_mul32,- testProperty "t_mul64" t_mul64- ],-- testGroup "misc" [- testProperty "t_dropWord8" t_dropWord8,- testProperty "t_takeWord8" t_takeWord8,- testProperty "t_take_drop_8" t_take_drop_8,- testProperty "t_use_from" t_use_from,- testProperty "t_use_from0" t_use_from0,- testProperty "t_copy" t_copy,- testProperty "t_peek_cstring" t_peek_cstring,- testProperty "t_peek_cstring_len" t_peek_cstring_len,- testCase "t_literal_length1" t_literal_length1,- testCase "t_literal_length2" t_literal_length2,- testCase "t_literal_surrogates" t_literal_surrogates-#ifdef MIN_VERSION_tasty_inspection_testing- , $(inspectObligations- [ (`hasNoTypes` [''Char, ''[]])- , (`doesNotUseAnyOf` ['T.pack, 'S.unstream, 'T.map, 'safe, 'S.streamList])- , (`doesNotUseAnyOf` ['GHC.unpackCString#, 'GHC.unpackCStringUtf8#])- , (`doesNotUseAnyOf` ['T.unpackCString#, 'T.unpackCStringAscii#])- ]- 't_literal_foo)-#endif- ],-- testGroup "input-output" [- testGroup "t_write_read" t_write_read,- testGroup "tl_write_read" tl_write_read,- testGroup "t_write_read_line" t_write_read_line,- testGroup "tl_write_read_line" tl_write_read_line,- testGroup "utf8_write_read" utf8_write_read,- testGroup "utf8_write_read_line" utf8_write_read_line- -- These tests are subject to I/O race conditions- -- testProperty "t_put_get" t_put_get,- -- testProperty "tl_put_get" tl_put_get- ]- ]+-- | Test low-level operations + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-imports #-} + +#ifdef MIN_VERSION_tasty_inspection_testing +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} +#endif + +module Tests.Properties.LowLevel (testLowLevel) where + +import Prelude hiding (head, tail) +import Control.Applicative ((<$>), pure) +import Control.Exception as E (SomeException, catch, evaluate) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int32, Int64) +import Data.Text.Foreign +import Data.Text.Internal (Text(..), mul, mul32, mul64, safe) +import Data.Word (Word8, Word16, Word32) +import System.IO.Unsafe (unsafePerformIO) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertEqual) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck hiding ((.&.)) +import Tests.QuickCheckUtils +import Tests.Utils +import qualified Data.Text as T +import qualified Data.Text.Foreign as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL +import qualified Data.Text.IO.Utf8 as TU +import qualified System.IO as IO + +#ifdef MIN_VERSION_tasty_inspection_testing +import Test.Tasty.Inspection (inspectObligations, hasNoTypes, doesNotUseAnyOf) +import qualified Data.Text.Internal.Fusion as S +import qualified Data.Text.Internal.Fusion.Common as S +import qualified GHC.CString as GHC +#endif + +mulRef :: (Integral a, Bounded a) => a -> a -> Maybe a +mulRef a b + | ab < bot || ab > top = Nothing + | otherwise = Just (fromIntegral ab) + where ab = fromIntegral a * fromIntegral b + top = fromIntegral (maxBound `asTypeOf` a) :: Integer + bot = fromIntegral (minBound `asTypeOf` a) :: Integer + +eval :: (a -> b -> c) -> a -> b -> Maybe c +eval f a b = unsafePerformIO $ + (Just <$> evaluate (f a b)) `E.catch` (\(_::SomeException) -> pure Nothing) + +t_mul32 :: Int32 -> Int32 -> Property +t_mul32 a b = mulRef a b === eval mul32 a b + +t_mul64 :: Int64 -> Int64 -> Property +t_mul64 a b = mulRef a b === eval mul64 a b + +t_mul :: Int -> Int -> Property +t_mul a b = mulRef a b === eval mul a b + +-- Misc. + +t_dropWord8 m t = dropWord8 m t `T.isSuffixOf` t +t_takeWord8 m t = takeWord8 m t `T.isPrefixOf` t +t_take_drop_8 (Small n) t = T.append (takeWord8 n t) (dropWord8 n t) === t +t_use_from t = ioProperty $ (==t) <$> useAsPtr t fromPtr +t_use_from0 t = ioProperty $ do + let t' = t `T.snoc` '\0' + (== T.takeWhile (/= '\0') t') <$> useAsPtr t' (const . fromPtr0) + +t_peek_cstring t = T.all (/= '\0') t ==> ioProperty $ do + roundTrip <- T.withCString t T.peekCString + assertEqual "cstring" t roundTrip + +t_peek_cstring_len t = ioProperty $ do + roundTrip <- T.withCStringLen t T.peekCStringLen + assertEqual "cstring_len" t roundTrip + +t_copy t = T.copy t === t + +t_literal_length1 = assertEqual xs (length xs) byteLen + where + xs = "\0\1\0\1\0" + Text _ _ byteLen = T.pack xs +t_literal_length2 = assertEqual xs (length xs) byteLen + where + xs = "\1\2\3\4\5" + Text _ _ byteLen = T.pack xs +t_literal_surrogates = assertEqual xs (T.pack xs) (T.pack ys) + where + ys = "\xd7ff \xd800 \xdbff \xdc00 \xdfff \xe000" + xs = map safe ys + +#ifdef MIN_VERSION_tasty_inspection_testing +t_literal_foo :: Text +t_literal_foo = T.pack "foo" +#endif + +-- Input and output. + +-- t_put_get = write_read T.unlines T.filter put get +-- where put h = withRedirect h IO.stdout . T.putStr +-- get h = withRedirect h IO.stdin T.getContents +-- tl_put_get = write_read TL.unlines TL.filter put get +-- where put h = withRedirect h IO.stdout . TL.putStr +-- get h = withRedirect h IO.stdin TL.getContents + +inputOutput :: TestTree +inputOutput = testGroup "input-output" [ + testProperty "t_write_read" $ write_read arbitrary shrink (T.replace "\n" "\r\n") T.hPutStr T.hGetContents, + testProperty "tl_write_read" $ write_read arbitrary shrink (TL.replace "\n" "\r\n") TL.hPutStr TL.hGetContents, + testProperty "t_write_read_line" $ write_read genTLine shrinkTLine (`T.append` "\r") T.hPutStrLn T.hGetLine, + testProperty "tl_write_read_line" $ write_read genTLLine shrinkTLLine (`TL.append` "\r") TL.hPutStrLn TL.hGetLine, + -- Note: Data.Text.IO.Utf8 does NO newline translation + testProperty "utf8_write_read" $ write_read arbitrary shrink id TU.hPutStr TU.hGetContents, + testProperty "utf8_write_read_line" $ write_read genTLine shrinkTLine id TU.hPutStrLn TU.hGetLine + -- These tests are subject to I/O race conditions + -- testProperty "t_put_get" t_put_get, + -- testProperty "tl_put_get" tl_put_get + ] + +genTLine :: Gen T.Text +genTLine = T.filter (`notElem` ("\r\n" :: String)) <$> arbitrary + +genTLLine :: Gen TL.Text +genTLLine = TL.filter (`notElem` ("\r\n" :: String)) <$> arbitrary + +shrinkTLine :: T.Text -> [T.Text] +shrinkTLine = filter (T.all (/= '\n')) . shrink + +shrinkTLLine :: TL.Text -> [TL.Text] +shrinkTLLine = filter (TL.all (/= '\n')) . shrink + +testLowLevel :: TestTree +testLowLevel = + testGroup "lowlevel" [ + testGroup "mul" [ + testProperty "t_mul" t_mul, + testProperty "t_mul32" t_mul32, + testProperty "t_mul64" t_mul64 + ], + + testGroup "misc" [ + testProperty "t_dropWord8" t_dropWord8, + testProperty "t_takeWord8" t_takeWord8, + testProperty "t_take_drop_8" t_take_drop_8, + testProperty "t_use_from" t_use_from, + testProperty "t_use_from0" t_use_from0, + testProperty "t_copy" t_copy, + testProperty "t_peek_cstring" t_peek_cstring, + testProperty "t_peek_cstring_len" t_peek_cstring_len, + testCase "t_literal_length1" t_literal_length1, + testCase "t_literal_length2" t_literal_length2, + testCase "t_literal_surrogates" t_literal_surrogates +#ifdef MIN_VERSION_tasty_inspection_testing + , $(inspectObligations + [ (`hasNoTypes` [''Char, ''[]]) + , (`doesNotUseAnyOf` ['T.pack, 'S.unstream, 'T.map, 'safe, 'S.streamList]) + , (`doesNotUseAnyOf` ['GHC.unpackCString#, 'GHC.unpackCStringUtf8#]) + , (`doesNotUseAnyOf` ['T.unpackCString#, 'T.unpackCStringAscii#]) + ] + 't_literal_foo) +#endif + ], + + inputOutput + ]
tests/Tests/Properties/Substrings.hs view
@@ -229,9 +229,8 @@ (l, []) -> [l] (l, _ : s') -> l : loop s' -t_chunksOf_same_lengths k = conjoin . map ((===k) . T.length) . ini . T.chunksOf k- where ini [] = []- ini xs = init xs+t_chunksOf_same_lengths k =+ conjoin . map ((===k) . T.length) . drop 1 . reverse . T.chunksOf k t_chunksOf_length k t = len === T.length t .||. property (k <= 0 && len == 0) where len = L.sum . L.map T.length $ T.chunksOf k t
tests/Tests/Properties/Transcoding.hs view
@@ -1,7 +1,10 @@ -- | Tests for encoding and decoding {-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}+{-# OPTIONS_GHC -Wno-x-partial #-}+ module Tests.Properties.Transcoding ( testTranscoding ) where
tests/Tests/QuickCheckUtils.hs view
@@ -1,307 +1,321 @@--- | This module provides quickcheck utilities, e.g. arbitrary and show--- instances, and comparison functions, so we can focus on the actual properties--- in the 'Tests.Properties' module.----{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Tests.QuickCheckUtils- ( BigInt(..)- , NotEmpty(..)- , Sqrt(..)- , SpacyString(..)- , SkewedBool(..)-- , Precision(..)- , precision-- , DecodeErr(..)- , genDecodeErr-- , Stringy(..)- , unpack2- , eq- , eqP- , eqPSqrt-- , write_read- ) where--import Control.Arrow ((***))-import Data.Bool (bool)-import Data.Char (isSpace)-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.Gen (Gen, choose, chooseAny, elements, frequency, listOf, oneof, resize, sized)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.QuickCheck (testProperty)-import Tests.Utils-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding.Error as T-import qualified Data.Text.Internal.Fusion as TF-import qualified Data.Text.Internal.Fusion.Common as TF-import qualified Data.Text.Internal.Lazy as TL-import qualified Data.Text.Internal.Lazy.Fusion as TLF-import qualified Data.Text.Lazy as TL-import qualified System.IO as IO--genWord8 :: Gen Word8-genWord8 = chooseAny--genWord16 :: Gen Word16-genWord16 = chooseAny--instance Arbitrary I8 where- arbitrary = arbitrarySizedIntegral- shrink = shrinkIntegral--instance Arbitrary B.ByteString where- arbitrary = B.pack `fmap` listOf genWord8- shrink = map B.pack . shrink . B.unpack--instance Arbitrary BL.ByteString where- arbitrary = oneof- [ BL.fromChunks <$> arbitrary- -- so that a single utf8 code point could appear split over up to 4 chunks- , BL.fromChunks . map B.singleton <$> listOf genWord8- -- so that a code point with 4 byte long utf8 representation- -- could appear split over 3 non-singleton chunks- , (\a b c -> BL.fromChunks [a, b, c])- <$> arbitrary- <*> ((\a b -> B.pack [a, b]) <$> genWord8 <*> genWord8)- <*> arbitrary- ]- shrink xs = BL.fromChunks <$> shrink (BL.toChunks xs)---- | For tests that have O(n^2) running times or input sizes, resize--- their inputs to the square root of the originals.-newtype Sqrt a = Sqrt { unSqrt :: a }- deriving (Eq, Show)--instance Arbitrary a => Arbitrary (Sqrt a) where- arbitrary = fmap Sqrt $ sized $ \n -> resize (smallish n) arbitrary- where- smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs- shrink = map Sqrt . shrink . unSqrt--instance Arbitrary T.Text where- arbitrary = do- t <- (T.pack . getUnicodeString) `fmap` scale (* 2) arbitrary- -- Generate chunks that start in the middle of their buffers.- (\i -> T.drop i t) <$> choose (0, T.length t)- shrink = map T.pack . shrink . T.unpack--instance Arbitrary TL.Text where- arbitrary = (TL.fromChunks . map notEmpty . unSqrt) `fmap` arbitrary- shrink = map TL.pack . shrink . TL.unpack--newtype BigInt = Big Integer- deriving (Eq, Show)--instance Arbitrary BigInt where- arbitrary = choose (1::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e)- shrink (Big a) = [Big (a `div` 2^(l-e)) | e <- shrink l]- where l = truncate (log (fromIntegral a) / log 2 :: Double) :: Integer--newtype NotEmpty a = NotEmpty { notEmpty :: a }- deriving (Eq, Ord, Show)--instance Arbitrary (NotEmpty T.Text) where- arbitrary = fmap (NotEmpty . T.pack . getNonEmpty) arbitrary- shrink = fmap (NotEmpty . T.pack . getNonEmpty)- . shrink . NonEmpty . T.unpack . notEmpty--instance Arbitrary (NotEmpty TL.Text) where- arbitrary = fmap (NotEmpty . TL.pack . getNonEmpty) arbitrary- shrink = fmap (NotEmpty . TL.pack . getNonEmpty)- . shrink . NonEmpty . TL.unpack . notEmpty--data DecodeErr = Lenient | Ignore | Strict | Replace- deriving (Show, Eq, Bounded, Enum)--genDecodeErr :: DecodeErr -> Gen T.OnDecodeError-genDecodeErr Lenient = return T.lenientDecode-genDecodeErr Ignore = return T.ignore-genDecodeErr Strict = return T.strictDecode-genDecodeErr Replace = (\c _ _ -> c) <$> frequency- [ (1, return Nothing)- , (50, Just <$> arbitraryUnicodeChar)- ]--instance Arbitrary DecodeErr where- arbitrary = arbitraryBoundedEnum--class Stringy s where- packS :: String -> s- unpackS :: s -> String- splitAtS :: Int -> s -> (s,s)- packSChunkSize :: Int -> String -> s- packSChunkSize _ = packS--instance Stringy String where- packS = id- unpackS = id- splitAtS = splitAt--instance Stringy (TF.Stream Char) where- packS = TF.streamList- unpackS = TF.unstreamList- splitAtS n s = (TF.take n s, TF.drop n s)--instance Stringy T.Text where- packS = T.pack- unpackS = T.unpack- splitAtS = T.splitAt--instance Stringy TL.Text where- packSChunkSize k = TLF.unstreamChunks k . TF.streamList- packS = TL.pack- unpackS = TL.unpack- splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .- TL.splitAt . fromIntegral--unpack2 :: (Stringy s) => (s,s) -> (String,String)-unpack2 = unpackS *** unpackS---- Do two functions give the same answer?-eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Property-eq a b s = a s =^= b s---- What about with the RHS packed?-eqP :: (Eq a, Show a, Stringy s) =>- (String -> a) -> (s -> a) -> String -> Word8 -> Property-eqP f g s w = counterexample "orig" (f s =^= g t) .&&.- counterexample "mini" (f s =^= g mini) .&&.- counterexample "head" (f sa =^= g ta) .&&.- counterexample "tail" (f sb =^= g tb)- where t = packS s- mini = packSChunkSize 10 s- (sa,sb) = splitAt m s- (ta,tb) = splitAtS m t- l = length s- m | l == 0 = n- | otherwise = n `mod` l- n = fromIntegral w--eqPSqrt :: (Eq a, Show a, Stringy s) =>- (String -> a) -> (s -> a) -> Sqrt String -> Word8 -> Property-eqPSqrt f g s = eqP f g (unSqrt s)--instance Arbitrary FPFormat where- arbitrary = arbitraryBoundedEnum--newtype Precision a = Precision (Maybe Int)- deriving (Eq, Show)--precision :: a -> Precision a -> Maybe Int-precision _ (Precision prec) = prec--arbitraryPrecision :: Int -> Gen (Precision a)-arbitraryPrecision maxDigits = Precision <$> do- n <- choose (-1,maxDigits)- return $ if n == -1- then Nothing- else Just n--instance Arbitrary (Precision Float) where- arbitrary = arbitraryPrecision 11- shrink = map Precision . shrink . precision undefined--instance Arbitrary (Precision Double) where- arbitrary = arbitraryPrecision 22- shrink = map Precision . shrink . precision undefined--#if !MIN_VERSION_QuickCheck(2,14,3)-instance Arbitrary IO.Newline where- arbitrary = oneof [return IO.LF, return IO.CRLF]--instance Arbitrary IO.NewlineMode where- arbitrary = IO.NewlineMode <$> arbitrary <*> arbitrary-#endif--instance Arbitrary IO.BufferMode where- arbitrary = oneof [ return IO.NoBuffering,- return IO.LineBuffering,- return (IO.BlockBuffering Nothing),- (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap`- genWord16 ]---- This test harness is complex! What property are we checking?------ Reading after writing a multi-line file should give the same--- results as were written.------ What do we vary while checking this property?--- * The lines themselves, scrubbed to contain neither CR nor LF. (By--- working with a list of lines, we ensure that the data will--- sometimes contain line endings.)--- * Newline translation mode.--- * Buffering.-write_read :: forall a b c.- (Eq a, Show a, Show c, Arbitrary c)- => ([b] -> a)- -> ((Char -> Bool) -> b -> b)- -> (IO.Handle -> a -> IO ())- -> (IO.Handle -> IO a)- -> (c -> [b])- -> [TestTree]-write_read unline filt writer reader modData- = encodings <&> \enc@TextEncoding {textEncodingName} -> testGroup textEncodingName- [ testProperty "NoBuffering" $ propTest enc (pure IO.NoBuffering)- , testProperty "LineBuffering" $ propTest enc (pure IO.LineBuffering)- , 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- let ts = modData d- t = unline . map (filt (not . (`elem` "\r\n"))) $ ts- IO.hSetEncoding h enc- IO.hSetNewlineMode h nl- IO.hSetBuffering h mode- () <- writer h t- IO.hSeek h IO.AbsoluteSeek 0- r <- reader h- let isEq = r == t- seq isEq $ pure $ counterexample (show r ++ bool " /= " " == " isEq ++ show t) isEq-- encodings = [IO.utf8, IO.utf8_bom, IO.utf16, IO.utf16le, IO.utf16be, IO.utf32, IO.utf32le, IO.utf32be]-- blockBuffering :: Gen IO.BufferMode- blockBuffering = IO.BlockBuffering <$> fmap (fmap $ min 4 . getPositive) arbitrary---- Generate various Unicode space characters with high probability-arbitrarySpacyChar :: Gen Char-arbitrarySpacyChar = oneof- [ arbitraryUnicodeChar- , elements $ filter isSpace [minBound..maxBound]- ]--newtype SpacyString = SpacyString { getSpacyString :: String }- deriving (Eq, Ord, Show, Read)--instance Arbitrary SpacyString where- arbitrary = SpacyString `fmap` listOf arbitrarySpacyChar- shrink (SpacyString xs) = SpacyString `fmap` shrink xs--newtype SkewedBool = Skewed { getSkewed :: Bool }- deriving Show--instance Arbitrary SkewedBool where- arbitrary = Skewed <$> frequency [(1, pure False), (5, pure True)]--(<&>) :: [a] -> (a -> b) -> [b]-(<&>) = flip fmap-+-- | This module provides quickcheck utilities, e.g. arbitrary and show +-- instances, and comparison functions, so we can focus on the actual properties +-- in the 'Tests.Properties' module. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tests.QuickCheckUtils + ( BigInt(..) + , NotEmpty(..) + , Sqrt(..) + , SpacyString(..) + , SkewedBool(..) + + , Precision(..) + , precision + + , DecodeErr(..) + , genDecodeErr + + , Stringy(..) + , unpack2 + , eq + , eqP + , eqPSqrt + + , write_read + ) where + +import Control.Arrow ((***)) +import Control.Monad (when) +import Data.Char (isSpace) +import Data.IORef (writeIORef) +import Data.Text.Foreign (I8) +import Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) +import Data.Word (Word8, Word16) +import qualified GHC.IO.Buffer as GIO +import qualified GHC.IO.Handle.Internals as GIO +import qualified GHC.IO.Handle.Types as GIO +import GHC.IO.Encoding.Types (TextEncoding(textEncodingName)) +import Test.QuickCheck (Arbitrary(..), arbitraryUnicodeChar, arbitraryBoundedEnum, getUnicodeString, arbitrarySizedIntegral, shrinkIntegral, Property, ioProperty, counterexample, scale, (.&&.), NonEmptyList(..), forAllShrink) +import Test.QuickCheck.Gen (Gen, choose, chooseAny, elements, frequency, listOf, oneof, resize, sized) +import Tests.Utils +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Text.Internal.Fusion as TF +import qualified Data.Text.Internal.Fusion.Common as TF +import qualified Data.Text.Internal.Lazy as TL +import qualified Data.Text.Internal.Lazy.Fusion as TLF +import qualified Data.Text.Lazy as TL +import qualified System.IO as IO + +genWord8 :: Gen Word8 +genWord8 = chooseAny + +genWord16 :: Gen Word16 +genWord16 = chooseAny + +instance Arbitrary I8 where + arbitrary = arbitrarySizedIntegral + shrink = shrinkIntegral + +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` listOf genWord8 + shrink = map B.pack . shrink . B.unpack + +instance Arbitrary BL.ByteString where + arbitrary = oneof + [ BL.fromChunks <$> arbitrary + -- so that a single utf8 code point could appear split over up to 4 chunks + , BL.fromChunks . map B.singleton <$> listOf genWord8 + -- so that a code point with 4 byte long utf8 representation + -- could appear split over 3 non-singleton chunks + , (\a b c -> BL.fromChunks [a, b, c]) + <$> arbitrary + <*> ((\a b -> B.pack [a, b]) <$> genWord8 <*> genWord8) + <*> arbitrary + ] + shrink xs = BL.fromChunks <$> shrink (BL.toChunks xs) + +-- | For tests that have O(n^2) running times or input sizes, resize +-- their inputs to the square root of the originals. +newtype Sqrt a = Sqrt { unSqrt :: a } + deriving (Eq, Show) + +instance Arbitrary a => Arbitrary (Sqrt a) where + arbitrary = fmap Sqrt $ sized $ \n -> resize (smallish n) arbitrary + where + smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs + shrink = map Sqrt . shrink . unSqrt + +instance Arbitrary T.Text where + arbitrary = do + t <- (T.pack . getUnicodeString) `fmap` scale (* 2) arbitrary + -- Generate chunks that start in the middle of their buffers. + (\i -> T.drop i t) <$> choose (0, T.length t) + shrink = map T.pack . shrink . T.unpack + +instance Arbitrary TL.Text where + arbitrary = (TL.fromChunks . map notEmpty . unSqrt) `fmap` arbitrary + shrink = map TL.pack . shrink . TL.unpack + +newtype BigInt = Big Integer + deriving (Eq, Show) + +instance Arbitrary BigInt where + arbitrary = choose (1::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e) + shrink (Big a) = [Big (a `div` 2^(l-e)) | e <- shrink l] + where l = truncate (log (fromIntegral a) / log 2 :: Double) :: Integer + +newtype NotEmpty a = NotEmpty { notEmpty :: a } + deriving (Eq, Ord, Show) + +instance Arbitrary (NotEmpty T.Text) where + arbitrary = fmap (NotEmpty . T.pack . getNonEmpty) arbitrary + shrink = fmap (NotEmpty . T.pack . getNonEmpty) + . shrink . NonEmpty . T.unpack . notEmpty + +instance Arbitrary (NotEmpty TL.Text) where + arbitrary = fmap (NotEmpty . TL.pack . getNonEmpty) arbitrary + shrink = fmap (NotEmpty . TL.pack . getNonEmpty) + . shrink . NonEmpty . TL.unpack . notEmpty + +data DecodeErr = Lenient | Ignore | Strict | Replace + deriving (Show, Eq, Bounded, Enum) + +genDecodeErr :: DecodeErr -> Gen T.OnDecodeError +genDecodeErr Lenient = return T.lenientDecode +genDecodeErr Ignore = return T.ignore +genDecodeErr Strict = return T.strictDecode +genDecodeErr Replace = (\c _ _ -> c) <$> frequency + [ (1, return Nothing) + , (50, Just <$> arbitraryUnicodeChar) + ] + +instance Arbitrary DecodeErr where + arbitrary = arbitraryBoundedEnum + +class Stringy s where + packS :: String -> s + unpackS :: s -> String + splitAtS :: Int -> s -> (s,s) + packSChunkSize :: Int -> String -> s + packSChunkSize _ = packS + +instance Stringy String where + packS = id + unpackS = id + splitAtS = splitAt + +instance Stringy (TF.Stream Char) where + packS = TF.streamList + unpackS = TF.unstreamList + splitAtS n s = (TF.take n s, TF.drop n s) + +instance Stringy T.Text where + packS = T.pack + unpackS = T.unpack + splitAtS = T.splitAt + +instance Stringy TL.Text where + packSChunkSize k = TLF.unstreamChunks k . TF.streamList + packS = TL.pack + unpackS = TL.unpack + splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) . + TL.splitAt . fromIntegral + +unpack2 :: (Stringy s) => (s,s) -> (String,String) +unpack2 = unpackS *** unpackS + +-- Do two functions give the same answer? +eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Property +eq a b s = a s =^= b s + +-- What about with the RHS packed? +eqP :: (Eq a, Show a, Stringy s) => + (String -> a) -> (s -> a) -> String -> Word8 -> Property +eqP f g s w = counterexample "orig" (f s =^= g t) .&&. + counterexample "mini" (f s =^= g mini) .&&. + counterexample "head" (f sa =^= g ta) .&&. + counterexample "tail" (f sb =^= g tb) + where t = packS s + mini = packSChunkSize 10 s + (sa,sb) = splitAt m s + (ta,tb) = splitAtS m t + l = length s + m | l == 0 = n + | otherwise = n `mod` l + n = fromIntegral w + +eqPSqrt :: (Eq a, Show a, Stringy s) => + (String -> a) -> (s -> a) -> Sqrt String -> Word8 -> Property +eqPSqrt f g s = eqP f g (unSqrt s) + +instance Arbitrary FPFormat where + arbitrary = arbitraryBoundedEnum + +newtype Precision a = Precision (Maybe Int) + deriving (Eq, Show) + +precision :: a -> Precision a -> Maybe Int +precision _ (Precision prec) = prec + +arbitraryPrecision :: Int -> Gen (Precision a) +arbitraryPrecision maxDigits = Precision <$> do + n <- choose (-1,maxDigits) + return $ if n == -1 + then Nothing + else Just n + +instance Arbitrary (Precision Float) where + arbitrary = arbitraryPrecision 11 + shrink = map Precision . shrink . precision undefined + +instance Arbitrary (Precision Double) where + arbitrary = arbitraryPrecision 22 + shrink = map Precision . shrink . precision undefined + +#if !MIN_VERSION_QuickCheck(2,14,3) +instance Arbitrary IO.Newline where + arbitrary = oneof [return IO.LF, return IO.CRLF] + +instance Arbitrary IO.NewlineMode where + arbitrary = IO.NewlineMode <$> arbitrary <*> arbitrary +#endif + +instance Arbitrary IO.BufferMode where + arbitrary = oneof [ return IO.NoBuffering, + return IO.LineBuffering, + return (IO.BlockBuffering Nothing), + (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap` + genWord16 ] + +-- This test harness is complex! What property are we checking? +-- +-- Reading after writing a multi-line file should give the same +-- results as were written. +-- +-- What do we vary while checking this property? +-- * The lines themselves, scrubbed to contain neither CR nor LF. (By +-- working with a list of lines, we ensure that the data will +-- sometimes contain line endings.) +-- * Newline translation mode. +-- * Buffering. +write_read :: forall a. + (Eq a, Show a) + => Gen a + -> (a -> [a]) + -> (a -> a) -- ^ replace '\n' with '\r\n' (for multiline tests) or append '\r' (for single-line tests) + -> (IO.Handle -> a -> IO ()) + -> (IO.Handle -> IO a) + -> Property +write_read genTxt shrinkTxt expandNl writer reader + = forAllShrink genEncoding shrinkEncoding propTest + where + propTest :: TextEncoding -> IO.BufferMode -> Property + propTest enc mode = forAllShrink genTxt shrinkTxt $ \txt -> ioProperty $ do + file <- emptyTempFile + let with nl k = IO.withFile file IO.ReadWriteMode $ \h -> do + IO.hSetEncoding h enc + IO.hSetBuffering h mode + IO.hSetNewlineMode h nl + setSmallBuffer h + k h + -- Put a very small buffer in Handle to easily test boundary conditions in `writeBlocks` + setSmallBuffer h = GIO.withHandle_ "setSmallBuffer" h $ \h_ -> do + buf <- GIO.newCharBuffer 9 GIO.WriteBuffer + writeIORef (GIO.haCharBuffer h_) buf + readExpecting h txt' msg = do + out <- reader h + when (txt' /= out) $ error (show txt' ++ " /= " ++ show out ++ msg) + -- 'reader' may be 'hGetContents', which closes the handle + -- So we reopen a new file every time. + + -- Test with CRLF encoding + with (IO.NewlineMode IO.CRLF IO.CRLF) $ \h -> do + writer h txt + IO.hSeek h IO.AbsoluteSeek 0 + readExpecting h txt " (at location 1)" + + -- Re-read without CRLF decoding to check that we did encode CRLF correctly + with (IO.NewlineMode IO.LF IO.LF) $ \h -> do + readExpecting h (expandNl txt) " (at location 2)" + + -- Test without CRLF encoding + with (IO.NewlineMode IO.LF IO.LF) $ \h -> do + IO.hSetFileSize h 0 + writer h txt + IO.hSeek h IO.AbsoluteSeek 0 + readExpecting h txt " (at location 3)" + + genEncoding = elements [IO.utf8, IO.utf8_bom, IO.utf16, IO.utf16le, IO.utf16be, IO.utf32, IO.utf32le, IO.utf32be] + shrinkEncoding enc = if textEncodingName enc == textEncodingName IO.utf8 then [] else [IO.utf8] + +-- Generate various Unicode space characters with high probability +arbitrarySpacyChar :: Gen Char +arbitrarySpacyChar = oneof + [ arbitraryUnicodeChar + , elements $ filter isSpace [minBound..maxBound] + ] + +newtype SpacyString = SpacyString { getSpacyString :: String } + deriving (Eq, Ord, Show, Read) + +instance Arbitrary SpacyString where + arbitrary = SpacyString `fmap` listOf arbitrarySpacyChar + shrink (SpacyString xs) = SpacyString `fmap` shrink xs + +newtype SkewedBool = Skewed { getSkewed :: Bool } + deriving Show + +instance Arbitrary SkewedBool where + arbitrary = Skewed <$> frequency [(1, pure False), (5, pure True)]
tests/Tests/Regressions.hs view
@@ -1,204 +1,236 @@--- | Regression tests for specific bugs.----{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Tests.Regressions- (- tests- ) where--import Control.Exception (SomeException, handle)-import Data.Char (isLetter, chr)-import GHC.Exts (Int(..), sizeofByteArray#)-import System.IO-import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure)-import qualified Data.ByteString as B-import Data.ByteString.Char8 ()-import qualified Data.ByteString.Lazy as LB-import qualified Data.Text as T-import qualified Data.Text.Array as TA-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Encoding.Error as E-import qualified Data.Text.Internal as T-import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E-import qualified Data.Text.Internal.Lazy.Fusion as LF-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Lazy.Encoding as LE-import qualified Data.Text.Unsafe as T-import qualified Test.Tasty as F-import qualified Test.Tasty.HUnit as F-import Test.Tasty.HUnit ((@?=))-import System.Directory (removeFile)--import Tests.Utils (withTempFile)---- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring--- caused either a segfault or attempt to allocate a negative number--- of bytes.-lazy_encode_crash :: IO ()-lazy_encode_crash = withTempFile $ \ _ h ->- LB.hPut h . LE.encodeUtf8 . LT.pack . replicate 100000 $ 'a'---- Reported by Pieter Laeremans: attempting to read an incorrectly--- encoded file can result in a crash in the RTS (i.e. not merely an--- exception).-hGetContents_crash :: IO ()-hGetContents_crash = do- (path, h) <- openTempFile "." "crashy.txt"- B.hPut h (B.pack [0x78, 0xc4 ,0x0a]) >> hClose h- h' <- openFile path ReadMode- hSetEncoding h' utf8- handle (\(_::SomeException) -> return ()) $- T.hGetContents h' >> assertFailure "T.hGetContents should crash"- hClose h'- removeFile path---- Reported by Ian Lynagh: attempting to allocate a sufficiently large--- string (via either Array.new or Text.replicate) could result in an--- integer overflow.-replicate_crash :: IO ()-replicate_crash = handle (\(_::SomeException) -> return ()) $- T.replicate (2^power) "0123456789abcdef" `seq`- assertFailure "T.replicate should crash"- where- power | maxBound == (2147483647::Int) = 28- | otherwise = 60 :: Int---- Reported by John Millikin: a UTF-8 decode error handler could--- return a bogus substitution character, which we would write without--- checking.-utf8_decode_unsafe :: IO ()-utf8_decode_unsafe = do- let t = TE.decodeUtf8With (\_ _ -> Just '\xdc00') "\x80"- assertBool "broken error recovery shouldn't break us" (t == "\xfffd")---- Reported by Eric Seidel: we mishandled mapping Chars that fit in a--- single Word16 to Chars that require two.-mapAccumL_resize :: IO ()-mapAccumL_resize = do- let f a _ = (a, '\65536')- count = 5- val = T.mapAccumL f (0::Int) (T.replicate count "a")- assertEqual "mapAccumL should correctly fill buffers for four-byte results"- (0, T.replicate count "\65536") val- assertEqual "mapAccumL should correctly size buffers for four-byte results"- (count * 4) (T.lengthWord8 (snd val))---- See GitHub #197-t197 :: IO ()-t197 =- assertBool "length (filter (==',') \"0,00\") should be 1" (currencyParser "0,00")- where- currencyParser x = cond == 1- where- 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--t280_fromString :: IO ()-t280_fromString =- assertEqual "TB.fromString performs replacement on invalid scalar values"- (TB.toLazyText (TB.fromString "\xD800"))- (LT.pack "\xFFFD")--t280_singleton :: IO ()-t280_singleton =- assertEqual "TB.singleton performs replacement on invalid scalar values"- (TB.toLazyText (TB.singleton '\xD800'))- (LT.pack "\xFFFD")---- See GitHub issue #301--- This tests whether the "TEXT take . drop -> unfused" rule is applied to the--- slice function. When the slice function is fused, a new array will be--- constructed that is shorter than the original array. Without fusion the--- array remains unmodified.-t301 :: IO ()-t301 = do- assertEqual "The length of the array remains the same despite slicing"- (I# (sizeofByteArray# originalArr))- (I# (sizeofByteArray# newArr))-- assertEqual "The new array still contains the original value"- (T.Text (TA.ByteArray newArr) originalOff originalLen)- original- where- !original@(T.Text (TA.ByteArray originalArr) originalOff originalLen) = T.pack "1234567890"- !(T.Text (TA.ByteArray newArr) _off _len) = T.take 1 $ T.drop 1 original--t330 :: IO ()-t330 = do- let decodeL = LE.decodeUtf8With E.lenientDecode- assertEqual "The lenient decoding of lazy bytestrings should not depend on how they are chunked"- (decodeL (LB.fromChunks [B.pack [194], B.pack [97, 98, 99]]))- (decodeL (LB.fromChunks [B.pack [194, 97, 98, 99]]))---- Stream decoders should not loop on incomplete code points-t525 :: IO ()-t525 = do- let decodeUtf8With onErr bs = LF.unstream (E.streamUtf8 onErr bs)- decodeUtf8With E.lenientDecode "\xC0" @?= "\65533"- LE.decodeUtf16BEWith E.lenientDecode "\0" @?= "\65533"- LE.decodeUtf16LEWith E.lenientDecode "\0" @?= "\65533"- LE.decodeUtf32BEWith E.lenientDecode "\0" @?= "\65533"- LE.decodeUtf32LEWith E.lenientDecode "\0" @?= "\65533"---- Stream decoders skip one invalid byte at a time-t528 :: IO ()-t528 = do- let decodeUtf8With onErr bs = LF.unstream (E.streamUtf8 onErr bs)- decodeUtf8With E.lenientDecode "\xC0\xF0\x90\x80\x80" @?= "\65533\65536"- LE.decodeUtf16BEWith E.lenientDecode "\xD8\xD8\x00\xDC\x00" @?= "\65533\65536"- LE.decodeUtf16LEWith E.lenientDecode "\xD8\xD8\x00\xD8\x00\xDC" @?= "\65533\65533\65536"- LE.decodeUtf32BEWith E.lenientDecode "\xFF\x00\x00\x00\x00" @?= "\65533\0"- LE.decodeUtf32LEWith E.lenientDecode "\x00\x00\xFF\x00\x00" @?= "\65533\65280"--t529 :: IO ()-t529 = do- let decode = TE.decodeUtf8With E.lenientDecode- -- https://github.com/haskell/bytestring/issues/575- assertEqual "Data.ByteString.isValidUtf8 should work correctly"- (T.pack (chr 33 : replicate 31 (chr 0) ++ [chr 65533, chr 0]))- (decode (B.pack (33 : replicate 31 0 ++ [128, 0])))---- See Github #559--- filter/filter fusion rules should apply predicates in the right order.-t559 :: IO ()-t559 = do- T.filter undefined (T.filter (const False) "a") @?= ""- LT.filter undefined (LT.filter (const False) "a") @?= ""--tests :: F.TestTree-tests = F.testGroup "Regressions"- [ F.testCase "hGetContents_crash" hGetContents_crash- , F.testCase "lazy_encode_crash" lazy_encode_crash- , F.testCase "mapAccumL_resize" mapAccumL_resize- , 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- , F.testCase "t280/fromString" t280_fromString- , F.testCase "t280/singleton" t280_singleton- , F.testCase "t301" t301- , F.testCase "t330" t330- , F.testCase "t525" t525- , F.testCase "t528" t528- , F.testCase "t529" t529- , F.testCase "t559" t559- ]+-- | Regression tests for specific bugs. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Tests.Regressions + ( + tests + ) where + +import Control.Exception (ErrorCall, SomeException, handle, evaluate, displayException, try) +import Data.Char (isLetter, chr) +import GHC.Exts (Int(..), sizeofByteArray#) +import System.IO +import System.IO.Temp (withSystemTempFile) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, (@?=)) +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import qualified Data.ByteString.Lazy as LB +import Data.Semigroup (stimes) +import qualified Data.Text as T +import qualified Data.Text.Array as TA +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as E +import qualified Data.Text.Internal as T +import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E +import qualified Data.Text.Internal.Lazy.Fusion as LF +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Encoding as LE +import qualified Data.Text.Unsafe as T +import qualified Test.Tasty as F +import qualified Test.Tasty.HUnit as F +import Tests.Utils (withTempFile) +import System.IO.Error (isFullError) + +-- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring +-- caused either a segfault or attempt to allocate a negative number +-- of bytes. +lazy_encode_crash :: IO () +lazy_encode_crash = withTempFile $ \ _ h -> do + putRes <- try $ LB.hPut h $ LE.encodeUtf8 $ LT.pack $ replicate 100000 'a' + case putRes of + Left e + -- If disk is full (as it happens on some of our CI runners), it's not our issue, skip it + | isFullError e -> pure () + | otherwise -> assertFailure $ "hPut crashed because of " ++ displayException e + Right () -> pure () + +-- Reported by Pieter Laeremans: attempting to read an incorrectly +-- encoded file can result in a crash in the RTS (i.e. not merely an +-- exception). +hGetContents_crash :: IO () +hGetContents_crash = withSystemTempFile "crashy.txt" $ \path h -> do + putRes <- try $ B.hPut h (B.pack [0x78, 0xc4 ,0x0a]) + case putRes of + Left e + -- If disk is full (as it happens on some of our CI runners), it's not our issue, skip it + | isFullError e -> pure () + | otherwise -> assertFailure $ "hPut crashed because of " ++ displayException e + Right () -> do + hClose h + h' <- openFile path ReadMode + hSetEncoding h' utf8 + handle (\(_::SomeException) -> pure ()) $ + T.hGetContents h' >> assertFailure "T.hGetContents should crash" + hClose h' + +-- Reported by Ian Lynagh: attempting to allocate a sufficiently large +-- string (via either Array.new or Text.replicate) could result in an +-- integer overflow. +replicate_crash :: IO () +replicate_crash = handle (\(_::SomeException) -> return ()) $ + T.replicate (2^power) "0123456789abcdef" `seq` + assertFailure "T.replicate should crash" + where + power | maxBound == (2147483647::Int) = 28 + | otherwise = 60 :: Int + +-- Reported by John Millikin: a UTF-8 decode error handler could +-- return a bogus substitution character, which we would write without +-- checking. +utf8_decode_unsafe :: IO () +utf8_decode_unsafe = do + let t = TE.decodeUtf8With (\_ _ -> Just '\xdc00') "\x80" + assertBool "broken error recovery shouldn't break us" (t == "\xfffd") + +-- Reported by Eric Seidel: we mishandled mapping Chars that fit in a +-- single Word16 to Chars that require two. +mapAccumL_resize :: IO () +mapAccumL_resize = do + let f a _ = (a, '\65536') + count = 5 + val = T.mapAccumL f (0::Int) (T.replicate count "a") + assertEqual "mapAccumL should correctly fill buffers for four-byte results" + (0, T.replicate count "\65536") val + assertEqual "mapAccumL should correctly size buffers for four-byte results" + (count * 4) (T.lengthWord8 (snd val)) + +-- See GitHub #197 +t197 :: IO () +t197 = + assertBool "length (filter (==',') \"0,00\") should be 1" (currencyParser "0,00") + where + currencyParser x = cond == 1 + where + 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 + +t280_fromString :: IO () +t280_fromString = + assertEqual "TB.fromString performs replacement on invalid scalar values" + (TB.toLazyText (TB.fromString "\xD800")) + (LT.pack "\xFFFD") + +t280_singleton :: IO () +t280_singleton = + assertEqual "TB.singleton performs replacement on invalid scalar values" + (TB.toLazyText (TB.singleton '\xD800')) + (LT.pack "\xFFFD") + +-- See GitHub issue #301 +-- This tests whether the "TEXT take . drop -> unfused" rule is applied to the +-- slice function. When the slice function is fused, a new array will be +-- constructed that is shorter than the original array. Without fusion the +-- array remains unmodified. +t301 :: IO () +t301 = do + assertEqual "The length of the array remains the same despite slicing" + (I# (sizeofByteArray# originalArr)) + (I# (sizeofByteArray# newArr)) + + assertEqual "The new array still contains the original value" + (T.Text (TA.ByteArray newArr) originalOff originalLen) + original + where + !original@(T.Text (TA.ByteArray originalArr) originalOff originalLen) = T.pack "1234567890" + !(T.Text (TA.ByteArray newArr) _off _len) = T.take 1 $ T.drop 1 original + +t330 :: IO () +t330 = do + let decodeL = LE.decodeUtf8With E.lenientDecode + assertEqual "The lenient decoding of lazy bytestrings should not depend on how they are chunked" + (decodeL (LB.fromChunks [B.pack [194], B.pack [97, 98, 99]])) + (decodeL (LB.fromChunks [B.pack [194, 97, 98, 99]])) + +-- Stream decoders should not loop on incomplete code points +t525 :: IO () +t525 = do + let decodeUtf8With onErr bs = LF.unstream (E.streamUtf8 onErr bs) + decodeUtf8With E.lenientDecode "\xC0" @?= "\65533" + LE.decodeUtf16BEWith E.lenientDecode "\0" @?= "\65533" + LE.decodeUtf16LEWith E.lenientDecode "\0" @?= "\65533" + LE.decodeUtf32BEWith E.lenientDecode "\0" @?= "\65533" + LE.decodeUtf32LEWith E.lenientDecode "\0" @?= "\65533" + +-- Stream decoders skip one invalid byte at a time +t528 :: IO () +t528 = do + let decodeUtf8With onErr bs = LF.unstream (E.streamUtf8 onErr bs) + decodeUtf8With E.lenientDecode "\xC0\xF0\x90\x80\x80" @?= "\65533\65536" + LE.decodeUtf16BEWith E.lenientDecode "\xD8\xD8\x00\xDC\x00" @?= "\65533\65536" + LE.decodeUtf16LEWith E.lenientDecode "\xD8\xD8\x00\xD8\x00\xDC" @?= "\65533\65533\65536" + LE.decodeUtf32BEWith E.lenientDecode "\xFF\x00\x00\x00\x00" @?= "\65533\0" + LE.decodeUtf32LEWith E.lenientDecode "\x00\x00\xFF\x00\x00" @?= "\65533\65280" + +t529 :: IO () +t529 = do + let decode = TE.decodeUtf8With E.lenientDecode + -- https://github.com/haskell/bytestring/issues/575 + assertEqual "Data.ByteString.isValidUtf8 should work correctly" + (T.pack (chr 33 : replicate 31 (chr 0) ++ [chr 65533, chr 0])) + (decode (B.pack (33 : replicate 31 0 ++ [128, 0]))) + +-- See Github #559 +-- filter/filter fusion rules should apply predicates in the right order. +t559 :: IO () +t559 = do + T.filter undefined (T.filter (const False) "a") @?= "" + LT.filter undefined (LT.filter (const False) "a") @?= "" + +-- Github #633 +-- stimes checked for an `a` to `Int` to `a` roundtrip, but the `a` and `Int` values could represent different integers. +t633 :: IO () +t633 = + handle (\(_ :: ErrorCall) -> return ()) $ do + _ <- evaluate (stimes (maxBound :: Word) "a" :: T.Text) + assertFailure "should fail" + +t648 :: IO () +t648 = withTempFile $ \_ h -> do + hSetEncoding h utf8 + hSetNewlineMode h (NewlineMode LF CRLF) + hSetBuffering h (BlockBuffering $ Just 4) + let line = T.replicate 2047 "_" + T.hPutStrLn h line + hSeek h AbsoluteSeek 0 + line' <- T.hGetLine h + T.append line "\r" @?= line' + +tests :: F.TestTree +tests = F.testGroup "Regressions" + [ F.testCase "hGetContents_crash" hGetContents_crash + , F.testCase "lazy_encode_crash" lazy_encode_crash + , F.testCase "mapAccumL_resize" mapAccumL_resize + , 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 + , F.testCase "t280/fromString" t280_fromString + , F.testCase "t280/singleton" t280_singleton + , F.testCase "t301" t301 + , F.testCase "t330" t330 + , F.testCase "t525" t525 + , F.testCase "t528" t528 + , F.testCase "t529" t529 + , F.testCase "t559" t559 + , F.testCase "t633" t633 + , F.testCase "t648" t648 + ]
tests/Tests/Utils.hs view
@@ -1,51 +1,50 @@--- | Miscellaneous testing utilities----{-# LANGUAGE ScopedTypeVariables #-}-module Tests.Utils- (- (=^=)- , withRedirect- , withTempFile- ) where--import Control.Exception (SomeException, bracket, bracket_, evaluate, try)-import Control.Monad (when, unless)-import GHC.IO.Handle.Internals (withHandle)-import System.Directory (removeFile)-import System.IO (Handle, hClose, hFlush, hIsOpen, hIsClosed, hIsWritable, openTempFile)-import Test.QuickCheck (Property, ioProperty, property, (===), counterexample)---- Ensure that two potentially bottom values (in the sense of crashing--- for some inputs, not looping infinitely) either both crash, or both--- give comparable results for some input.-(=^=) :: (Eq a, Show a) => a -> a -> Property-i =^= j = ioProperty $ do- x <- try (evaluate i)- y <- try (evaluate j)- return $ case (x, y) of- (Left (_ :: SomeException), Left (_ :: SomeException))- -> property True- (Right a, Right b) -> a === b- e -> counterexample ("Divergence: " ++ show e) $ property False-infix 4 =^=-{-# NOINLINE (=^=) #-}--withTempFile :: (FilePath -> Handle -> IO a) -> IO a-withTempFile = bracket (openTempFile "." "crashy.txt") cleanupTemp . uncurry- where- cleanupTemp (path,h) = do- closed <- hIsClosed h- unless closed $ hClose h- removeFile path--withRedirect :: Handle -> Handle -> IO a -> IO a-withRedirect tmp h = bracket_ swap swap- where- whenM p a = p >>= (`when` a)- swap = do- whenM (hIsOpen tmp) $ whenM (hIsWritable tmp) $ hFlush tmp- whenM (hIsOpen h) $ whenM (hIsWritable h) $ hFlush h- withHandle "spam" tmp $ \tmph -> do- hh <- withHandle "spam" h $ \hh ->- return (tmph,hh)- return (hh,())+-- | Miscellaneous testing utilities +-- +{-# LANGUAGE ScopedTypeVariables #-} +module Tests.Utils + ( + (=^=) + , withRedirect + , withTempFile + , emptyTempFile + ) where + +import Control.Exception (SomeException, bracket_, evaluate, try) +import Control.Monad (when) +import System.IO.Temp (withSystemTempFile, emptySystemTempFile) +import GHC.IO.Handle.Internals (withHandle) +import System.IO (Handle, hFlush, hIsOpen, hIsWritable) +import Test.QuickCheck (Property, ioProperty, property, (===), counterexample) + +-- Ensure that two potentially bottom values (in the sense of crashing +-- for some inputs, not looping infinitely) either both crash, or both +-- give comparable results for some input. +(=^=) :: (Eq a, Show a) => a -> a -> Property +i =^= j = ioProperty $ do + x <- try (evaluate i) + y <- try (evaluate j) + return $ case (x, y) of + (Left (_ :: SomeException), Left (_ :: SomeException)) + -> property True + (Right a, Right b) -> a === b + e -> counterexample ("Divergence: " ++ show e) $ property False +infix 4 =^= +{-# NOINLINE (=^=) #-} + +withTempFile :: (FilePath -> Handle -> IO a) -> IO a +withTempFile = withSystemTempFile "crashy.txt" + +emptyTempFile :: IO FilePath +emptyTempFile = emptySystemTempFile "crashy.txt" + +withRedirect :: Handle -> Handle -> IO a -> IO a +withRedirect tmp h = bracket_ swap swap + where + whenM p a = p >>= (`when` a) + swap = do + whenM (hIsOpen tmp) $ whenM (hIsWritable tmp) $ hFlush tmp + whenM (hIsOpen h) $ whenM (hIsWritable h) $ hFlush h + withHandle "spam" tmp $ \tmph -> do + hh <- withHandle "spam" h $ \hh -> + return (tmph,hh) + return (hh,())
text.cabal view
@@ -1,365 +1,373 @@-cabal-version: 2.2-name: text-version: 2.1.2--homepage: https://github.com/haskell/text-bug-reports: https://github.com/haskell/text/issues-synopsis: An efficient packed Unicode text type.-description:- .- An efficient packed, immutable Unicode text type (both strict and- lazy).- .- The 'Text' type represents Unicode character strings, in a time and- space-efficient manner. This package provides text processing- capabilities that are optimized for performance critical use, both- in terms of large data quantities and high speed.- .- The 'Text' type provides character-encoding, type-safe case- conversion via whole-string case conversion functions (see "Data.Text").- It also provides a range of functions for converting 'Text' values to- and from 'ByteStrings', using several standard encodings- (see "Data.Text.Encoding").- .- Efficient locale-sensitive support for text IO is also supported- (see "Data.Text.IO").- .- These modules are intended to be imported qualified, to avoid name- clashes with Prelude functions, e.g.- .- > import qualified Data.Text as T- .- == ICU Support- .- To use an extended and very rich family of functions for working- with Unicode text (including normalization, regular expressions,- non-standard encodings, text breaking, and locales), see- the [text-icu package](https://hackage.haskell.org/package/text-icu)- based on the well-respected and liberally- licensed [ICU library](http://site.icu-project.org/).--license: BSD-2-Clause-license-file: LICENSE-author: Bryan O'Sullivan <bos@serpentine.com>-maintainer: Haskell Text Team <andrew.lelechenko@gmail.com>, Core Libraries Committee-copyright: 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper, 2021 Andrew Lelechenko-category: Data, Text-build-type: Simple-tested-with:- GHC == 8.4.4- GHC == 8.6.5- GHC == 8.8.4- GHC == 8.10.7- GHC == 9.0.2- GHC == 9.2.8- GHC == 9.4.8- GHC == 9.6.4- GHC == 9.8.2- GHC == 9.10.1--extra-source-files:- -- scripts/CaseFolding.txt- -- scripts/SpecialCasing.txt- README.md- changelog.md- scripts/*.hs- simdutf/LICENSE-APACHE- simdutf/LICENSE-MIT- simdutf/simdutf.h- tests/literal-rule-test.sh- tests/LiteralRuleTest.hs--flag developer- description: operate in developer mode- default: False- manual: True--flag simdutf- description: use simdutf library, causes Data.Text.Internal.Validate.Simd to be exposed- default: True- manual: True--flag pure-haskell- description: Don't use text's standard C routines- NB: This feature is not fully implemented. Several C routines are still in- use.-- When this flag is true, text will use pure Haskell variants of the- routines. This is not recommended except for use with GHC's JavaScript- backend.-- This flag also disables simdutf.-- default: False- manual: True--flag ExtendedBenchmarks- description: Runs extra benchmarks which can be very slow.- default: False- manual: True--library- if arch(javascript) || flag(pure-haskell)- cpp-options: -DPURE_HASKELL- else- c-sources: cbits/is_ascii.c- cbits/reverse.c- cbits/utils.c- if (arch(aarch64))- c-sources: cbits/aarch64/measure_off.c- else- c-sources: cbits/measure_off.c-- hs-source-dirs: src-- if flag(simdutf) && !(arch(javascript) || flag(pure-haskell))- exposed-modules: Data.Text.Internal.Validate.Simd- include-dirs: simdutf- cxx-sources: simdutf/simdutf.cpp- cbits/validate_utf8.cpp- cxx-options: -std=c++17- cpp-options: -DSIMDUTF- if impl(ghc >= 9.4)- build-depends: system-cxx-std-lib == 1.0- elif os(darwin) || os(freebsd)- extra-libraries: c++- elif os(openbsd)- extra-libraries: c++ c++abi pthread- elif os(windows)- -- GHC's Windows toolchain is based on clang/libc++ in GHC 9.4 and later- if impl(ghc < 9.3)- extra-libraries: stdc++- else- extra-libraries: c++ c++abi- elif arch(wasm32)- cpp-options: -DSIMDUTF_NO_THREADS- cxx-options: -fno-exceptions- extra-libraries: c++ c++abi- else- extra-libraries: stdc++-- -- Certain version of GHC crash on Windows, when TemplateHaskell encounters C++.- -- https://gitlab.haskell.org/ghc/ghc/-/issues/19417- if flag(simdutf) && os(windows) && impl(ghc >= 8.8 && < 8.10.5 || == 9.0.1)- build-depends: base < 0-- -- For GHC 8.2, 8.6.3 and 8.10.1 even TH + C crash Windows linker.- if os(windows) && impl(ghc >= 8.2 && < 8.4 || == 8.6.3 || == 8.10.1)- build-depends: base < 0-- -- GHC 8.10 has linking issues (probably TH-related) on ARM.- if (arch(aarch64) || arch(arm)) && impl(ghc == 8.10.*)- build-depends: base < 0-- -- Subword primitives in GHC 9.2.1 are broken on ARM platforms.- if (arch(aarch64) || arch(arm)) && impl(ghc == 9.2.1)- build-depends: base < 0-- -- NetBSD + GHC 9.2.1 + TH + C++ does not work together.- -- https://gitlab.haskell.org/ghc/ghc/-/issues/22577- if flag(simdutf) && os(netbsd) && impl(ghc < 9.4)- build-depends: base < 0-- exposed-modules:- Data.Text- Data.Text.Array- Data.Text.Encoding- Data.Text.Encoding.Error- Data.Text.Foreign- Data.Text.IO- Data.Text.IO.Utf8- Data.Text.Internal- Data.Text.Internal.ArrayUtils- Data.Text.Internal.Builder- Data.Text.Internal.Builder.Functions- Data.Text.Internal.Builder.Int.Digits- Data.Text.Internal.Builder.RealFloat.Functions- Data.Text.Internal.ByteStringCompat- Data.Text.Internal.PrimCompat- Data.Text.Internal.Encoding- Data.Text.Internal.Encoding.Fusion- Data.Text.Internal.Encoding.Fusion.Common- Data.Text.Internal.Encoding.Utf16- Data.Text.Internal.Encoding.Utf32- Data.Text.Internal.Encoding.Utf8- Data.Text.Internal.Fusion- Data.Text.Internal.Fusion.CaseMapping- Data.Text.Internal.Fusion.Common- Data.Text.Internal.Fusion.Size- Data.Text.Internal.Fusion.Types- Data.Text.Internal.IO- Data.Text.Internal.Lazy- Data.Text.Internal.Lazy.Encoding.Fusion- Data.Text.Internal.Lazy.Fusion- Data.Text.Internal.Lazy.Search- Data.Text.Internal.Private- Data.Text.Internal.Read- Data.Text.Internal.Search- Data.Text.Internal.StrictBuilder- Data.Text.Internal.Unsafe- Data.Text.Internal.Unsafe.Char- Data.Text.Internal.Validate- Data.Text.Internal.Validate.Native- Data.Text.Lazy- Data.Text.Lazy.Builder- Data.Text.Lazy.Builder.Int- Data.Text.Lazy.Builder.RealFloat- Data.Text.Lazy.Encoding- Data.Text.Lazy.IO- Data.Text.Lazy.Internal- Data.Text.Lazy.Read- Data.Text.Read- Data.Text.Unsafe-- other-modules:- Data.Text.Show- Data.Text.Internal.Measure- Data.Text.Internal.Reverse- Data.Text.Internal.Transformation- Data.Text.Internal.IsAscii-- build-depends:- array >= 0.3 && < 0.6,- base >= 4.11 && < 5,- binary >= 0.5 && < 0.9,- bytestring >= 0.10.4 && < 0.13,- deepseq >= 1.1 && < 1.6,- ghc-prim >= 0.2 && < 0.12,- template-haskell >= 2.5 && < 2.23-- if impl(ghc < 9.4)- build-depends: data-array-byte >= 0.1 && < 0.2-- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2- if flag(developer)- ghc-options: -fno-ignore-asserts- cpp-options: -DASSERTS- if impl(ghc >= 9.2.2)- ghc-options: -fcheck-prim-bounds-- default-language: Haskell2010- default-extensions:- NondecreasingIndentation- other-extensions:- BangPatterns- CPP- DeriveDataTypeable- ExistentialQuantification- ForeignFunctionInterface- GeneralizedNewtypeDeriving- MagicHash- OverloadedStrings- Rank2Types- RankNTypes- RecordWildCards- Safe- ScopedTypeVariables- TemplateHaskellQuotes- Trustworthy- TypeFamilies- UnboxedTuples- UnliftedFFITypes--source-repository head- type: git- location: https://github.com/haskell/text--test-suite tests- type: exitcode-stdio-1.0- ghc-options:- -Wall -threaded -rtsopts -with-rtsopts=-N-- hs-source-dirs: tests- main-is: Tests.hs- other-modules:- Tests.Lift- Tests.Properties- Tests.Properties.Basics- Tests.Properties.Builder- Tests.Properties.Folds- Tests.Properties.Instances- Tests.Properties.LowLevel- Tests.Properties.Read- Tests.Properties.Substrings- Tests.Properties.Text- Tests.Properties.Transcoding- Tests.Properties.Validate- Tests.QuickCheckUtils- Tests.RebindableSyntaxTest- Tests.Regressions- Tests.SlowFunctions- Tests.ShareEmpty- Tests.Utils-- build-depends:- QuickCheck >= 2.12.6 && < 2.16,- base <5,- binary,- bytestring,- deepseq,- directory,- ghc-prim,- tasty,- tasty-hunit,- tasty-quickcheck,- template-haskell,- transformers,- text- if impl(ghc < 9.4)- build-depends: data-array-byte >= 0.1 && < 0.2- -- Plugin infrastructure does not work properly in 8.6.1, and- -- ghc-9.2.1 library depends on parsec, which causes a circular dependency.- if impl(ghc >= 8.2.1 && < 8.6 || >= 8.6.2 && < 9.2 || >= 9.2.2)- build-depends: tasty-inspection-testing-- default-language: Haskell2010- default-extensions: NondecreasingIndentation--benchmark text-benchmarks- type: exitcode-stdio-1.0-- ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A32m"- if impl(ghc >= 8.6)- ghc-options: -fproc-alignment=64- if flag(ExtendedBenchmarks)- cpp-options: -DExtendedBenchmarks-- build-depends: base,- bytestring >= 0.10.4,- containers,- deepseq,- directory,- filepath,- tasty-bench >= 0.2,- text,- transformers-- hs-source-dirs: benchmarks/haskell- main-is: Benchmarks.hs- other-modules:- Benchmarks.Builder- Benchmarks.Concat- Benchmarks.DecodeUtf8- Benchmarks.EncodeUtf8- Benchmarks.Equality- Benchmarks.FileRead- Benchmarks.FileWrite- Benchmarks.FoldLines- Benchmarks.Micro- Benchmarks.Multilang- Benchmarks.Programs.BigTable- Benchmarks.Programs.Cut- Benchmarks.Programs.Fold- Benchmarks.Programs.Sort- Benchmarks.Programs.StripTags- Benchmarks.Programs.Throughput- Benchmarks.Pure- Benchmarks.ReadNumbers- Benchmarks.Replace- Benchmarks.Search- Benchmarks.Stream- Benchmarks.WordFrequencies-- default-language: Haskell2010- default-extensions: NondecreasingIndentation- other-extensions: DeriveGeneric+cabal-version: 2.2 +name: text +version: 2.1.3 + +homepage: https://github.com/haskell/text +bug-reports: https://github.com/haskell/text/issues +synopsis: An efficient packed Unicode text type. +description: + . + An efficient packed, immutable Unicode text type (both strict and + lazy). + . + The 'Text' type represents Unicode character strings, in a time and + space-efficient manner. This package provides text processing + capabilities that are optimized for performance critical use, both + in terms of large data quantities and high speed. + . + The 'Text' type provides character-encoding, type-safe case + conversion via whole-string case conversion functions (see "Data.Text"). + It also provides a range of functions for converting 'Text' values to + and from 'ByteStrings', using several standard encodings + (see "Data.Text.Encoding"). + . + Efficient locale-sensitive support for text IO is also supported + (see "Data.Text.IO"). + . + These modules are intended to be imported qualified, to avoid name + clashes with Prelude functions, e.g. + . + > import qualified Data.Text as T + . + == ICU Support + . + To use an extended and very rich family of functions for working + with Unicode text (including normalization, regular expressions, + non-standard encodings, text breaking, and locales), see + the [text-icu package](https://hackage.haskell.org/package/text-icu) + based on the well-respected and liberally + licensed [ICU library](http://site.icu-project.org/). + +license: BSD-2-Clause +license-file: LICENSE +author: Bryan O'Sullivan <bos@serpentine.com> +maintainer: Haskell Text Team <andrew.lelechenko@gmail.com>, Core Libraries Committee +copyright: 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper, 2021 Andrew Lelechenko +category: Data, Text +build-type: Simple +tested-with: + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.8 + GHC == 9.4.8 + GHC == 9.6.7 + GHC == 9.8.4 + GHC == 9.10.1 + GHC == 9.12.2 + +extra-source-files: + -- scripts/CaseFolding.txt + -- scripts/SpecialCasing.txt + README.md + changelog.md + scripts/*.hs + simdutf/LICENSE-APACHE + simdutf/LICENSE-MIT + simdutf/simdutf.h + tests/literal-rule-test.sh + tests/LiteralRuleTest.hs + +flag developer + description: operate in developer mode + default: False + manual: True + +flag simdutf + description: use simdutf library, causes Data.Text.Internal.Validate.Simd to be exposed + default: True + manual: True + +flag pure-haskell + description: Don't use text's standard C routines + NB: This feature is not fully implemented. Several C routines are still in + use. + + When this flag is true, text will use pure Haskell variants of the + routines. This is not recommended except for use with GHC's JavaScript + backend. + + This flag also disables simdutf. + + default: False + manual: True + +flag ExtendedBenchmarks + description: Runs extra benchmarks which can be very slow. + default: False + manual: True + +library + if arch(javascript) || flag(pure-haskell) + cpp-options: -DPURE_HASKELL + else + c-sources: cbits/is_ascii.c + cbits/reverse.c + cbits/utils.c + if (arch(aarch64)) + c-sources: cbits/aarch64/measure_off.c + else + c-sources: cbits/measure_off.c + + hs-source-dirs: src + + if flag(simdutf) && !(arch(javascript) || flag(pure-haskell)) + exposed-modules: Data.Text.Internal.Validate.Simd + include-dirs: simdutf + cxx-sources: simdutf/simdutf.cpp + cbits/validate_utf8.cpp + cxx-options: -std=c++17 + cpp-options: -DSIMDUTF + if impl(ghc >= 9.4) + build-depends: system-cxx-std-lib == 1.0 + elif os(darwin) || os(freebsd) + extra-libraries: c++ + elif os(openbsd) + extra-libraries: c++ c++abi pthread + elif os(windows) + -- GHC's Windows toolchain is based on clang/libc++ in GHC 9.4 and later + if impl(ghc < 9.3) + extra-libraries: stdc++ + else + extra-libraries: c++ c++abi + elif arch(wasm32) + cpp-options: -DSIMDUTF_NO_THREADS + cxx-options: -fno-exceptions + extra-libraries: c++ c++abi + else + extra-libraries: stdc++ + + -- Certain version of GHC crash on Windows, when TemplateHaskell encounters C++. + -- https://gitlab.haskell.org/ghc/ghc/-/issues/19417 + if flag(simdutf) && os(windows) && impl(ghc >= 8.8 && < 8.10.5 || == 9.0.1) + build-depends: base < 0 + + -- For GHC 8.2, 8.6.3 and 8.10.1 even TH + C crash Windows linker. + if os(windows) && impl(ghc >= 8.2 && < 8.4 || == 8.6.3 || == 8.10.1) + build-depends: base < 0 + + -- GHC 8.10 has linking issues (probably TH-related) on ARM. + if (arch(aarch64) || arch(arm)) && impl(ghc == 8.10.*) + build-depends: base < 0 + + -- Subword primitives in GHC 9.2.1 are broken on ARM platforms. + if (arch(aarch64) || arch(arm)) && impl(ghc == 9.2.1) + build-depends: base < 0 + + -- NetBSD + GHC 9.2.1 + TH + C++ does not work together. + -- https://gitlab.haskell.org/ghc/ghc/-/issues/22577 + if flag(simdutf) && os(netbsd) && impl(ghc < 9.4) + build-depends: base < 0 + + exposed-modules: + Data.Text + Data.Text.Array + Data.Text.Encoding + Data.Text.Encoding.Error + Data.Text.Foreign + Data.Text.IO + Data.Text.IO.Utf8 + Data.Text.Internal + Data.Text.Internal.ArrayUtils + Data.Text.Internal.Builder + Data.Text.Internal.Builder.Functions + Data.Text.Internal.Builder.Int.Digits + Data.Text.Internal.Builder.RealFloat.Functions + Data.Text.Internal.ByteStringCompat + Data.Text.Internal.PrimCompat + Data.Text.Internal.Encoding + Data.Text.Internal.Encoding.Fusion + Data.Text.Internal.Encoding.Fusion.Common + Data.Text.Internal.Encoding.Utf16 + Data.Text.Internal.Encoding.Utf32 + Data.Text.Internal.Encoding.Utf8 + Data.Text.Internal.Fusion + Data.Text.Internal.Fusion.CaseMapping + Data.Text.Internal.Fusion.Common + Data.Text.Internal.Fusion.Size + Data.Text.Internal.Fusion.Types + Data.Text.Internal.IO + Data.Text.Internal.Lazy + Data.Text.Internal.Lazy.Encoding.Fusion + Data.Text.Internal.Lazy.Fusion + Data.Text.Internal.Lazy.Search + Data.Text.Internal.Private + Data.Text.Internal.Read + Data.Text.Internal.Search + Data.Text.Internal.StrictBuilder + Data.Text.Internal.Unsafe + Data.Text.Internal.Unsafe.Char + Data.Text.Internal.Validate + Data.Text.Internal.Validate.Native + Data.Text.Lazy + Data.Text.Lazy.Builder + Data.Text.Lazy.Builder.Int + Data.Text.Lazy.Builder.RealFloat + Data.Text.Lazy.Encoding + Data.Text.Lazy.IO + Data.Text.Lazy.Internal + Data.Text.Lazy.Read + Data.Text.Read + Data.Text.Unsafe + + other-modules: + Data.Text.Show + Data.Text.Internal.Measure + Data.Text.Internal.Reverse + Data.Text.Internal.Transformation + Data.Text.Internal.IsAscii + + build-depends: + array >= 0.3 && < 0.6, + base >= 4.11 && < 5, + binary >= 0.5 && < 0.9, + bytestring >= 0.10.4 && < 0.13, + deepseq >= 1.1 && < 1.6, + ghc-prim >= 0.2 && < 0.15, + template-haskell >= 2.5 && < 2.25 + + if impl(ghc < 9.4) + build-depends: data-array-byte >= 0.1 && < 0.2 + + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + if flag(developer) + ghc-options: -fno-ignore-asserts + cpp-options: -DASSERTS + if impl(ghc >= 9.2.2) + ghc-options: -fcheck-prim-bounds + + default-language: Haskell2010 + default-extensions: + NondecreasingIndentation + other-extensions: + BangPatterns + CPP + DeriveDataTypeable + ExistentialQuantification + ForeignFunctionInterface + GeneralizedNewtypeDeriving + MagicHash + OverloadedStrings + Rank2Types + RankNTypes + RecordWildCards + Safe + ScopedTypeVariables + TemplateHaskellQuotes + Trustworthy + TypeFamilies + UnboxedTuples + UnliftedFFITypes + +source-repository head + type: git + location: https://github.com/haskell/text + +test-suite tests + type: exitcode-stdio-1.0 + ghc-options: + -Wall -threaded -rtsopts -with-rtsopts=-N + + hs-source-dirs: tests + main-is: Tests.hs + other-modules: + Tests.Lift + Tests.Properties + Tests.Properties.Basics + Tests.Properties.Builder + Tests.Properties.Folds + Tests.Properties.Instances + Tests.Properties.LowLevel + Tests.Properties.Read + Tests.Properties.Substrings + Tests.Properties.Text + Tests.Properties.Transcoding + Tests.Properties.CornerCases + Tests.Properties.Validate + Tests.QuickCheckUtils + Tests.RebindableSyntaxTest + Tests.Regressions + Tests.SlowFunctions + Tests.ShareEmpty + Tests.Utils + + build-depends: + QuickCheck >= 2.12.6 && < 2.17, + base <5, + binary, + bytestring, + deepseq, + ghc-prim, + tasty, + tasty-hunit, + tasty-quickcheck, + template-haskell, + temporary, + transformers, + text + if impl(ghc < 9.4) + build-depends: data-array-byte >= 0.1 && < 0.2 + + -- Plugin infrastructure does not work properly in 8.6.1, and + -- ghc-9.2.1 library depends on parsec, which causes a circular dependency. + if impl(ghc >= 8.2.1 && < 8.6 || >= 8.6.2 && < 9.2 || >= 9.2.2) + build-depends: tasty-inspection-testing + + -- https://github.com/haskellari/splitmix/issues/101 + if os(openbsd) + build-depends: splitmix < 0.1.3 || > 0.1.3.1 + + default-language: Haskell2010 + default-extensions: NondecreasingIndentation + +benchmark text-benchmarks + type: exitcode-stdio-1.0 + + ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A32m" + if impl(ghc >= 8.6) + ghc-options: -fproc-alignment=64 + if flag(ExtendedBenchmarks) + cpp-options: -DExtendedBenchmarks + + build-depends: base, + bytestring >= 0.10.4, + containers, + deepseq, + directory, + filepath, + tasty-bench >= 0.2, + temporary, + text, + transformers + + hs-source-dirs: benchmarks/haskell + main-is: Benchmarks.hs + other-modules: + Benchmarks.Builder + Benchmarks.Concat + Benchmarks.DecodeUtf8 + Benchmarks.EncodeUtf8 + Benchmarks.Equality + Benchmarks.FileRead + Benchmarks.FileWrite + Benchmarks.FoldLines + Benchmarks.Micro + Benchmarks.Multilang + Benchmarks.Programs.BigTable + Benchmarks.Programs.Cut + Benchmarks.Programs.Fold + Benchmarks.Programs.Sort + Benchmarks.Programs.StripTags + Benchmarks.Programs.Throughput + Benchmarks.Pure + Benchmarks.ReadNumbers + Benchmarks.Replace + Benchmarks.Search + Benchmarks.Stream + Benchmarks.WordFrequencies + + default-language: Haskell2010 + default-extensions: NondecreasingIndentation + other-extensions: DeriveGeneric