text 1.2.4.1 → 1.2.5.0
raw patch · 103 files changed
+3217/−3711 lines, 103 filesdep +QuickCheckdep +bytestring-lexingdep +containersdep −bytestring-builderdep −ghc-bignumdep −integer-gmpdep ~basedep ~binarydep ~bytestringnew-uploader
Dependencies added: QuickCheck, bytestring-lexing, containers, directory, filepath, quickcheck-unicode, random, stringsearch, tasty, tasty-bench, tasty-hunit, tasty-inspection-testing, tasty-quickcheck, text, transformers, vector
Dependencies removed: bytestring-builder, ghc-bignum, integer-gmp, integer-simple
Dependency ranges changed: base, binary, bytestring, deepseq, ghc-prim, template-haskell
Files
- README.markdown +11/−10
- benchmarks/Setup.hs +0/−2
- benchmarks/haskell/Benchmarks.hs +7/−3
- benchmarks/haskell/Benchmarks/Builder.hs +4/−6
- benchmarks/haskell/Benchmarks/Concat.hs +1/−1
- benchmarks/haskell/Benchmarks/DecodeUtf8.hs +15/−7
- benchmarks/haskell/Benchmarks/EncodeUtf8.hs +5/−5
- benchmarks/haskell/Benchmarks/Equality.hs +4/−13
- benchmarks/haskell/Benchmarks/FileRead.hs +5/−6
- benchmarks/haskell/Benchmarks/FoldLines.hs +1/−17
- benchmarks/haskell/Benchmarks/Mul.hs +1/−1
- benchmarks/haskell/Benchmarks/Multilang.hs +18/−0
- benchmarks/haskell/Benchmarks/Programs/BigTable.hs +2/−3
- benchmarks/haskell/Benchmarks/Programs/Cut.hs +3/−31
- benchmarks/haskell/Benchmarks/Programs/Fold.hs +2/−3
- benchmarks/haskell/Benchmarks/Programs/Sort.hs +4/−20
- benchmarks/haskell/Benchmarks/Programs/StripTags.hs +3/−13
- benchmarks/haskell/Benchmarks/Programs/Throughput.hs +3/−6
- benchmarks/haskell/Benchmarks/Pure.hs +15/−188
- benchmarks/haskell/Benchmarks/ReadNumbers.hs +1/−1
- benchmarks/haskell/Benchmarks/Replace.hs +1/−1
- benchmarks/haskell/Benchmarks/Search.hs +1/−1
- benchmarks/haskell/Benchmarks/Stream.hs +6/−4
- benchmarks/haskell/Benchmarks/WordFrequencies.hs +1/−1
- benchmarks/haskell/Multilang.hs +0/−32
- benchmarks/haskell/Timer.hs +0/−30
- benchmarks/python/cut.py +0/−12
- benchmarks/python/multilang.py +0/−49
- benchmarks/python/sort.py +0/−13
- benchmarks/python/strip_tags.py +0/−25
- benchmarks/python/utils.py +0/−18
- benchmarks/ruby/cut.rb +0/−16
- benchmarks/ruby/fold.rb +0/−50
- benchmarks/ruby/sort.rb +0/−15
- benchmarks/ruby/strip_tags.rb +0/−22
- benchmarks/ruby/utils.rb +0/−14
- benchmarks/text-benchmarks.cabal +0/−155
- cbits/cbits.c +78/−32
- changelog.md +12/−4
- scripts/CaseMapping.hs +1/−1
- src/Data/Text.hs +30/−44
- src/Data/Text/Array.hs +44/−79
- src/Data/Text/Encoding.hs +95/−57
- src/Data/Text/Encoding/Error.hs +0/−4
- src/Data/Text/Foreign.hs +4/−7
- src/Data/Text/IO.hs +1/−3
- src/Data/Text/Internal.hs +36/−15
- src/Data/Text/Internal/Builder.hs +14/−12
- src/Data/Text/Internal/Builder/RealFloat/Functions.hs +0/−22
- src/Data/Text/Internal/ByteStringCompat.hs +1/−0
- src/Data/Text/Internal/Encoding/Fusion.hs +17/−10
- src/Data/Text/Internal/Encoding/Fusion/Common.hs +23/−20
- src/Data/Text/Internal/Encoding/Utf16.hs +10/−3
- src/Data/Text/Internal/Encoding/Utf8.hs +35/−34
- src/Data/Text/Internal/Functions.hs +19/−1
- src/Data/Text/Internal/Fusion.hs +27/−7
- src/Data/Text/Internal/Fusion/CaseMapping.hs +10/−256
- src/Data/Text/Internal/Fusion/Common.hs +5/−1
- src/Data/Text/Internal/Lazy/Encoding/Fusion.hs +28/−21
- src/Data/Text/Internal/Lazy/Fusion.hs +19/−4
- src/Data/Text/Internal/Lazy/Search.hs +25/−8
- src/Data/Text/Internal/PrimCompat.hs +37/−0
- src/Data/Text/Internal/Private.hs +10/−2
- src/Data/Text/Internal/Search.hs +8/−2
- src/Data/Text/Internal/Unsafe.hs +1/−8
- src/Data/Text/Internal/Unsafe/Char.hs +17/−35
- src/Data/Text/Internal/Unsafe/Shift.hs +10/−34
- src/Data/Text/Lazy.hs +91/−87
- src/Data/Text/Lazy/Builder.hs +0/−2
- src/Data/Text/Lazy/Builder/Int.hs +21/−46
- src/Data/Text/Lazy/Builder/RealFloat.hs +5/−4
- src/Data/Text/Lazy/Encoding.hs +7/−6
- src/Data/Text/Lazy/IO.hs +0/−2
- src/Data/Text/Lazy/Read.hs +8/−9
- src/Data/Text/Read.hs +4/−6
- src/Data/Text/Show.hs +20/−9
- src/Data/Text/Unsafe.hs +6/−1
- tests-and-benchmarks.markdown +0/−68
- tests/.ghci +0/−1
- tests/Makefile +0/−45
- tests/Tests.hs +12/−2
- tests/Tests/IO.hs +0/−34
- tests/Tests/Inspection/Lazy.hs +181/−0
- tests/Tests/Inspection/Strict.hs +210/−0
- tests/Tests/Lift.hs +22/−0
- tests/Tests/Properties.hs +29/−1457
- tests/Tests/Properties/Basics.hs +139/−0
- tests/Tests/Properties/Builder.hs +146/−0
- tests/Tests/Properties/Folds.hs +225/−0
- tests/Tests/Properties/Instances.hs +72/−0
- tests/Tests/Properties/LowLevel.hs +128/−0
- tests/Tests/Properties/Mul.hs +0/−40
- tests/Tests/Properties/Read.hs +71/−0
- tests/Tests/Properties/Substrings.hs +348/−0
- tests/Tests/Properties/Text.hs +308/−0
- tests/Tests/Properties/Transcoding.hs +231/−0
- tests/Tests/QuickCheckUtils.hs +22/−24
- tests/Tests/Regressions.hs +40/−8
- tests/cabal.config +0/−6
- tests/literal-rule-test.sh +29/−0
- tests/scripts/cover-stdio.sh +0/−62
- tests/text-tests.cabal +0/−201
- text.cabal +111/−71
README.markdown view
@@ -1,25 +1,26 @@-# `text`: Fast, packed Unicode strings, using stream fusion+# `text`: Fast, packed Unicode strings, using stream fusion [](https://hackage.haskell.org/package/text) This package provides the Data.Text library, a library for the space- and time-efficient manipulation of Unicode text in Haskell. -**Please refer to the [package description on Hackage](https://hackage.haskell.org/package/text#description) for more information.**- # Get involved! Please report bugs via the [github issue tracker](https://github.com/haskell/text/issues). -Master [git repository](https://github.com/haskell/text):--* `git clone git://github.com/haskell/text.git`--There's also a [Mercurial mirror](https://bitbucket.org/bos/text):+The main repo: -* `hg clone https://bitbucket.org/bos/text`+```bash+git clone git://github.com/haskell/text.git+``` -(You can create and contribute changes using either Mercurial or git.)+To run benchmarks please clone and unpack test files: +```bash+git clone https://github.com/bos/text-test-data benchmarks/text-test-data+cd benchmarks/text-test-data+make+``` # Authors
− benchmarks/Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
benchmarks/haskell/Benchmarks.hs view
@@ -5,7 +5,7 @@ ( main ) where -import Criterion.Main (defaultMain, bgroup, env)+import Test.Tasty.Bench (defaultMain, bgroup, env) import System.FilePath ((</>)) import System.IO (IOMode (WriteMode), openFile, hSetEncoding, utf8) @@ -17,6 +17,7 @@ import qualified Benchmarks.FileRead as FileRead import qualified Benchmarks.FoldLines as FoldLines import qualified Benchmarks.Mul as Mul+import qualified Benchmarks.Multilang as Multilang import qualified Benchmarks.Pure as Pure import qualified Benchmarks.ReadNumbers as ReadNumbers import qualified Benchmarks.Replace as Replace@@ -43,11 +44,14 @@ , env (DecodeUtf8.initEnv (tf "ascii.txt")) (DecodeUtf8.benchmark "ascii") , env (DecodeUtf8.initEnv (tf "russian.txt")) (DecodeUtf8.benchmark "russian") , env (DecodeUtf8.initEnv (tf "japanese.txt")) (DecodeUtf8.benchmark "japanese")- , EncodeUtf8.benchmark "επανάληψη 竺法蘭共譯"+ , env (DecodeUtf8.initEnv (tf "ascii.txt")) (DecodeUtf8.benchmarkASCII)+ , EncodeUtf8.benchmark "non-ASCII" "επανάληψη 竺法蘭共譯"+ , EncodeUtf8.benchmark "ASCII" "lorem ipsum" , env (Equality.initEnv (tf "japanese.txt")) Equality.benchmark , FileRead.benchmark (tf "russian.txt") , FoldLines.benchmark (tf "russian.txt") , env Mul.initEnv Mul.benchmark+ , Multilang.benchmark , env (Pure.initEnv (tf "tiny.txt")) (Pure.benchmark "tiny") , env (Pure.initEnv (tf "ascii-small.txt")) (Pure.benchmark "ascii-small") , env (Pure.initEnv (tf "ascii.txt")) (Pure.benchmark "ascii")@@ -70,4 +74,4 @@ ] where -- Location of a test file- tf = ("../tests/text-test-data" </>)+ tf = ("benchmarks/text-test-data" </>)
benchmarks/haskell/Benchmarks/Builder.hs view
@@ -4,17 +4,15 @@ -- -- * Concatenating many small strings using a builder ---{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Benchmarks.Builder ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, nf)+import Test.Tasty.Bench (Benchmark, bgroup, bench, nf) import Data.Binary.Builder as B import Data.ByteString.Char8 ()-import Data.Monoid (mconcat, mempty)-import qualified Blaze.ByteString.Builder as Blaze-import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze+import qualified Data.ByteString.Builder as Blaze import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import qualified Data.Text as T@@ -32,7 +30,7 @@ (LB.length . B.toLazyByteString . mconcat . map B.fromByteString) byteStrings , bench "Blaze" $ nf- (LB.length . Blaze.toLazyByteString . mconcat . map Blaze.fromString)+ (LB.length . Blaze.toLazyByteString . mconcat . map Blaze.stringUtf8) strings ] , bgroup "Int"
benchmarks/haskell/Benchmarks/Concat.hs view
@@ -3,7 +3,7 @@ module Benchmarks.Concat (benchmark) where import Control.Monad.Trans.Writer-import Criterion (Benchmark, bgroup, bench, whnf)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnf) import Data.Text as T benchmark :: Benchmark
benchmarks/haskell/Benchmarks/DecodeUtf8.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} -- | Test decoding of UTF-8 --@@ -17,6 +18,7 @@ module Benchmarks.DecodeUtf8 ( initEnv , benchmark+ , benchmarkASCII ) where import Foreign.C.Types@@ -25,9 +27,8 @@ import Foreign.Ptr (Ptr, plusPtr) import Foreign.ForeignPtr (withForeignPtr) import Data.Word (Word8)-import qualified Criterion as C-import Criterion (Benchmark, bgroup, nf, whnfIO)-import qualified Codec.Binary.UTF8.Generic as U8+import qualified Test.Tasty.Bench as C+import Test.Tasty.Bench (Benchmark, bgroup, nf, whnfIO) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T@@ -61,10 +62,17 @@ , bench "Lazy" $ nf TL.decodeUtf8 lbs , bench "LazyLength" $ nf (TL.length . TL.decodeUtf8) lbs , bench "LazyInitLength" $ nf (TL.length . TL.init . TL.decodeUtf8) lbs- , bench "StrictStringUtf8" $ nf U8.toString bs- , bench "StrictStringUtf8Length" $ nf (length . U8.toString) bs- , bench "LazyStringUtf8" $ nf U8.toString lbs- , bench "LazyStringUtf8Length" $ nf (length . U8.toString) lbs+ ]++benchmarkASCII :: Env -> Benchmark+benchmarkASCII ~(bs, lbs) =+ bgroup "DecodeASCII"+ [ C.bench "strict decodeUtf8" $ nf T.decodeUtf8 bs+ , C.bench "strict decodeLatin1" $ nf T.decodeLatin1 bs+ , C.bench "strict decodeASCII" $ nf T.decodeASCII bs+ , C.bench "lazy decodeUtf8" $ nf TL.decodeUtf8 lbs+ , C.bench "lazy decodeLatin1" $ nf TL.decodeLatin1 lbs+ , C.bench "lazy decodeASCII" $ nf TL.decodeASCII lbs ] iconv :: B.ByteString -> IO CInt
benchmarks/haskell/Benchmarks/EncodeUtf8.hs view
@@ -10,7 +10,7 @@ ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnf)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnf) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T@@ -18,11 +18,11 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -benchmark :: String -> Benchmark-benchmark string =+benchmark :: String -> String -> Benchmark+benchmark name string = bgroup "EncodeUtf8"- [ bench "Text" $ whnf (B.length . T.encodeUtf8) text- , bench "LazyText" $ whnf (BL.length . TL.encodeUtf8) lazyText+ [ bench ("Text (" ++ name ++ ")") $ whnf (B.length . T.encodeUtf8) text+ , bench ("LazyText (" ++ name ++ ")") $ whnf (BL.length . TL.encodeUtf8) lazyText ] where -- The string in different formats
benchmarks/haskell/Benchmarks/Equality.hs view
@@ -10,7 +10,7 @@ , benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnf)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnf) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Text as T@@ -18,26 +18,17 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -type Env = (T.Text, TL.Text, B.ByteString, BL.ByteString, BL.ByteString, String)+type Env = (T.Text, TL.Text) initEnv :: FilePath -> IO Env initEnv fp = do b <- B.readFile fp bl1 <- BL.readFile fp- -- A lazy bytestring is a list of chunks. When we do not explicitly create two- -- different lazy bytestrings at a different address, the bytestring library- -- will compare the chunk addresses instead of the chunk contents. This is why- -- we read the lazy bytestring twice here.- bl2 <- BL.readFile fp- l <- readFile fp- return (T.decodeUtf8 b, TL.decodeUtf8 bl1, b, bl1, bl2, l)+ return (T.decodeUtf8 b, TL.decodeUtf8 bl1) benchmark :: Env -> Benchmark-benchmark ~(t, tl, b, bl1, bl2, l) =+benchmark ~(t, tl) = bgroup "Equality" [ bench "Text" $ whnf (== T.init t `T.snoc` '\xfffd') t , bench "LazyText" $ whnf (== TL.init tl `TL.snoc` '\xfffd') tl- , bench "ByteString" $ whnf (== B.init b `B.snoc` '\xfffd') b- , bench "LazyByteString" $ whnf (== BL.init bl2 `BL.snoc` '\xfffd') bl1- , bench "String" $ whnf (== init l ++ "\xfffd") l ]
benchmarks/haskell/Benchmarks/FileRead.hs view
@@ -4,12 +4,14 @@ -- -- * Reading a file from the disk --++{-# LANGUAGE CPP #-}+ module Benchmarks.FileRead ( benchmark ) where -import Control.Applicative ((<$>))-import Criterion (Benchmark, bgroup, bench, whnfIO)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnfIO) import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import qualified Data.Text as T@@ -21,10 +23,7 @@ benchmark :: FilePath -> Benchmark benchmark p = bgroup "FileRead"- [ bench "String" $ whnfIO $ length <$> readFile p- , bench "ByteString" $ whnfIO $ SB.length <$> SB.readFile p- , bench "LazyByteString" $ whnfIO $ LB.length <$> LB.readFile p- , bench "Text" $ whnfIO $ T.length <$> T.readFile p+ [ bench "Text" $ whnfIO $ T.length <$> T.readFile p , bench "LazyText" $ whnfIO $ LT.length <$> LT.readFile p , bench "TextByteString" $ whnfIO $ (T.length . T.decodeUtf8) <$> SB.readFile p
benchmarks/haskell/Benchmarks/FoldLines.hs view
@@ -10,16 +10,14 @@ ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnfIO)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnfIO) import System.IO-import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.IO as T benchmark :: FilePath -> Benchmark benchmark fp = bgroup "ReadLines" [ bench "Text" $ withHandle $ foldLinesT (\n _ -> n + 1) (0 :: Int)- , bench "ByteString" $ withHandle $ foldLinesB (\n _ -> n + 1) (0 :: Int) ] where withHandle f = whnfIO $ do@@ -42,17 +40,3 @@ l <- T.hGetLine h let z' = f z l in go z' {-# INLINE foldLinesT #-}---- | ByteString line fold----foldLinesB :: (a -> B.ByteString -> a) -> a -> Handle -> IO a-foldLinesB f z0 h = go z0- where- go !z = do- eof <- hIsEOF h- if eof- then return z- else do- l <- B.hGetLine h- let z' = f z l in go z'-{-# INLINE foldLinesB #-}
benchmarks/haskell/Benchmarks/Mul.hs view
@@ -4,7 +4,7 @@ ) where import Control.Exception (evaluate)-import Criterion.Main+import Test.Tasty.Bench import Data.Int (Int32, Int64) import Data.Text.Internal (mul32, mul64) import qualified Data.Vector.Unboxed as U
+ benchmarks/haskell/Benchmarks/Multilang.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE BangPatterns, OverloadedStrings, RankNTypes #-}++module Benchmarks.Multilang (benchmark) where++import qualified Data.ByteString as B+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8)+import Data.Text (Text)+import Test.Tasty.Bench (Benchmark, bgroup, bench, env, nf)++readYiwiki :: IO Text+readYiwiki = decodeUtf8 `fmap` B.readFile "benchmarks/text-test-data/yiwiki.xml"++benchmark :: Benchmark+benchmark = env readYiwiki $ \content -> bgroup "Multilang"+ [ bench "find_first" $ nf (Text.isInfixOf "en:Benin") content+ , bench "find_index" $ nf (Text.findIndex (=='c')) content+ ]
benchmarks/haskell/Benchmarks/Programs/BigTable.hs view
@@ -6,13 +6,12 @@ -- -- * Writing to a handle ---{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Benchmarks.Programs.BigTable ( benchmark ) where -import Criterion (Benchmark, bench, whnfIO)-import Data.Monoid (mappend, mconcat)+import Test.Tasty.Bench (Benchmark, bench, whnfIO) import Data.Text.Lazy.Builder (Builder, fromText, toLazyText) import Data.Text.Lazy.IO (hPutStr) import System.IO (Handle)
benchmarks/haskell/Benchmarks/Programs/Cut.hs view
@@ -16,12 +16,10 @@ ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnfIO)-import System.IO (Handle, hPutStr)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnfIO)+import System.IO (Handle) import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T@@ -31,39 +29,13 @@ benchmark :: FilePath -> Handle -> Int -> Int -> Benchmark benchmark p sink from to = bgroup "Cut"- [ bench' "String" string- , bench' "ByteString" byteString- , bench' "LazyByteString" lazyByteString- , bench' "Text" text+ [ bench' "Text" text , bench' "LazyText" lazyText , bench' "TextByteString" textByteString , bench' "LazyTextByteString" lazyTextByteString ] where bench' n s = bench n $ whnfIO (s p sink from to)--string :: FilePath -> Handle -> Int -> Int -> IO ()-string fp sink from to = do- s <- readFile fp- hPutStr sink $ cut s- where- cut = unlines . map (take (to - from) . drop from) . lines--byteString :: FilePath -> Handle -> Int -> Int -> IO ()-byteString fp sink from to = do- bs <- B.readFile fp- B.hPutStr sink $ cut bs- where- cut = BC.unlines . map (B.take (to - from) . B.drop from) . BC.lines--lazyByteString :: FilePath -> Handle -> Int -> Int -> IO ()-lazyByteString fp sink from to = do- bs <- BL.readFile fp- BL.hPutStr sink $ cut bs- where- cut = BLC.unlines . map (BL.take (to' - from') . BL.drop from') . BLC.lines- from' = fromIntegral from- to' = fromIntegral to text :: FilePath -> Handle -> Int -> Int -> IO () text fp sink from to = do
benchmarks/haskell/Benchmarks/Programs/Fold.hs view
@@ -12,16 +12,15 @@ -- -- * Writing back to a handle ---{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Benchmarks.Programs.Fold ( benchmark ) where import Data.List (foldl') import Data.List (intersperse)-import Data.Monoid (mempty, mappend, mconcat) import System.IO (Handle)-import Criterion (Benchmark, bench, whnfIO)+import Test.Tasty.Bench (Benchmark, bench, whnfIO) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy.Builder as TLB
benchmarks/haskell/Benchmarks/Programs/Sort.hs view
@@ -12,18 +12,15 @@ -- -- * Writing back to a handle ---{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Benchmarks.Programs.Sort ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnfIO)-import Data.Monoid (mconcat)-import System.IO (Handle, hPutStr)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnfIO)+import System.IO (Handle) import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -35,11 +32,7 @@ benchmark :: FilePath -> Handle -> Benchmark benchmark i o = bgroup "Sort"- [ bench "String" $ whnfIO $ readFile i >>= hPutStr o . string- , bench "ByteString" $ whnfIO $ B.readFile i >>= B.hPutStr o . byteString- , bench "LazyByteString" $ whnfIO $- BL.readFile i >>= BL.hPutStr o . lazyByteString- , bench "Text" $ whnfIO $ T.readFile i >>= T.hPutStr o . text+ [ bench "Text" $ whnfIO $ T.readFile i >>= T.hPutStr o . text , bench "LazyText" $ whnfIO $ TL.readFile i >>= TL.hPutStr o . lazyText , bench "TextByteString" $ whnfIO $ B.readFile i >>= B.hPutStr o . T.encodeUtf8 . text . T.decodeUtf8@@ -48,15 +41,6 @@ , bench "TextBuilder" $ whnfIO $ B.readFile i >>= BL.hPutStr o . TL.encodeUtf8 . textBuilder . T.decodeUtf8 ]--string :: String -> String-string = unlines . L.sort . lines--byteString :: B.ByteString -> B.ByteString-byteString = BC.unlines . L.sort . BC.lines--lazyByteString :: BL.ByteString -> BL.ByteString-lazyByteString = BLC.unlines . L.sort . BLC.lines text :: T.Text -> T.Text text = T.unlines . L.sort . T.lines
benchmarks/haskell/Benchmarks/Programs/StripTags.hs view
@@ -15,32 +15,22 @@ ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnfIO)-import Data.List (mapAccumL)-import System.IO (Handle, hPutStr)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnfIO)+import System.IO (Handle) import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T benchmark :: FilePath -> Handle -> Benchmark benchmark i o = bgroup "StripTags"- [ bench "String" $ whnfIO $ readFile i >>= hPutStr o . string- , bench "ByteString" $ whnfIO $ B.readFile i >>= B.hPutStr o . byteString- , bench "Text" $ whnfIO $ T.readFile i >>= T.hPutStr o . text+ [ bench "Text" $ whnfIO $ T.readFile i >>= T.hPutStr o . text , bench "TextByteString" $ whnfIO $ B.readFile i >>= B.hPutStr o . T.encodeUtf8 . text . T.decodeUtf8 ] -string :: String -> String-string = snd . mapAccumL step 0- text :: T.Text -> T.Text text = snd . T.mapAccumL step 0--byteString :: B.ByteString -> B.ByteString-byteString = snd . BC.mapAccumL step 0 step :: Int -> Char -> (Int, Char) step d c
benchmarks/haskell/Benchmarks/Programs/Throughput.hs view
@@ -18,8 +18,8 @@ ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnfIO)-import System.IO (Handle, hPutStr)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnfIO)+import System.IO (Handle) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Encoding as T@@ -29,10 +29,7 @@ benchmark :: FilePath -> Handle -> Benchmark benchmark fp sink = bgroup "Throughput"- [ bench "String" $ whnfIO $ readFile fp >>= hPutStr sink- , bench "ByteString" $ whnfIO $ B.readFile fp >>= B.hPutStr sink- , bench "LazyByteString" $ whnfIO $ BL.readFile fp >>= BL.hPutStr sink- , bench "Text" $ whnfIO $ T.readFile fp >>= T.hPutStr sink+ [ bench "Text" $ whnfIO $ T.readFile fp >>= T.hPutStr sink , bench "LazyText" $ whnfIO $ TL.readFile fp >>= TL.hPutStr sink , bench "TextByteString" $ whnfIO $ B.readFile fp >>= B.hPutStr sink . T.encodeUtf8 . T.decodeUtf8
benchmarks/haskell/Benchmarks/Pure.hs view
@@ -5,7 +5,7 @@ -- * Most pure functions defined the string types -- {-# LANGUAGE BangPatterns, CPP, GADTs, MagicHash #-}-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, RecordWildCards #-}+{-# LANGUAGE DeriveGeneric, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Benchmarks.Pure ( initEnv@@ -14,15 +14,12 @@ import Control.DeepSeq (NFData (..)) import Control.Exception (evaluate)-import Criterion (Benchmark, bgroup, bench, nf)-import Data.Char (toLower, toUpper)-import Data.Monoid (mappend, mempty)+import Test.Tasty.Bench (Benchmark, bgroup, bench, nf) import GHC.Base (Char (..), Int (..), chr#, ord#, (+#)) import GHC.Generics (Generic) import GHC.Int (Int64) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -36,23 +33,16 @@ , tb :: !T.Text , tla :: !TL.Text , tlb :: !TL.Text- , bsb :: !BS.ByteString , bla :: !BL.ByteString- , blb :: !BL.ByteString- , sa :: !String- , sb :: !String , bsa_len :: !Int , ta_len :: !Int , bla_len :: !Int64 , tla_len :: !Int64- , sa_len :: !Int- , bsl :: [BS.ByteString]- , bll :: [BL.ByteString] , tl :: [T.Text] , tll :: [TL.Text]- , sl :: [String]- } deriving (Generic, NFData)+ } deriving (Generic) +instance NFData Env initEnv :: FilePath -> IO Env initEnv fp = do@@ -68,28 +58,17 @@ tla <- evaluate $ TL.fromChunks (T.chunksOf 16376 ta) tlb <- evaluate $ TL.fromChunks (T.chunksOf 16376 tb) - -- ByteString B, LazyByteString A/B- bsb <- evaluate $ T.encodeUtf8 tb bla <- evaluate $ BL.fromChunks (chunksOf 16376 bsa)- blb <- evaluate $ BL.fromChunks (chunksOf 16376 bsb) - -- String A/B- sa <- evaluate $ UTF8.toString bsa- sb <- evaluate $ T.unpack tb- -- Lengths bsa_len <- evaluate $ BS.length bsa ta_len <- evaluate $ T.length ta bla_len <- evaluate $ BL.length bla tla_len <- evaluate $ TL.length tla- sa_len <- evaluate $ L.length sa -- Lines- bsl <- evaluate $ BS.lines bsa- bll <- evaluate $ BL.lines bla tl <- evaluate $ T.lines ta tll <- evaluate $ TL.lines tla- sl <- evaluate $ L.lines sa return Env{..} @@ -99,37 +78,23 @@ [ bgroup "append" [ benchT $ nf (T.append tb) ta , benchTL $ nf (TL.append tlb) tla- , benchBS $ nf (BS.append bsb) bsa- , benchBSL $ nf (BL.append blb) bla- , benchS $ nf ((++) sb) sa ] , bgroup "concat" [ benchT $ nf T.concat tl , benchTL $ nf TL.concat tll- , benchBS $ nf BS.concat bsl- , benchBSL $ nf BL.concat bll- , benchS $ nf L.concat sl ] , bgroup "cons" [ benchT $ nf (T.cons c) ta , benchTL $ nf (TL.cons c) tla- , benchBS $ nf (BS.cons c) bsa- , benchBSL $ nf (BL.cons c) bla- , benchS $ nf (c:) sa ]- , bgroup "concatMap"- [ benchT $ nf (T.concatMap (T.replicate 3 . T.singleton)) ta- , benchTL $ nf (TL.concatMap (TL.replicate 3 . TL.singleton)) tla- , benchBS $ nf (BS.concatMap (BS.replicate 3)) bsa- , benchBSL $ nf (BL.concatMap (BL.replicate 3)) bla- , benchS $ nf (L.concatMap (L.replicate 3 . (:[]))) sa- ]+ -- concatMap exceeds 4G heap size on current test data+ -- , bgroup "concatMap"+ -- [ benchT $ nf (T.concatMap (T.replicate 3 . T.singleton)) ta+ -- , benchTL $ nf (TL.concatMap (TL.replicate 3 . TL.singleton)) tla+ -- ] , bgroup "decode" [ benchT $ nf T.decodeUtf8 bsa , benchTL $ nf TL.decodeUtf8 bla- , benchBS $ nf BS.unpack bsa- , benchBSL $ nf BL.unpack bla- , benchS $ nf UTF8.toString bsa ] , bgroup "decode'" [ benchT $ nf T.decodeUtf8' bsa@@ -138,342 +103,204 @@ , bgroup "drop" [ benchT $ nf (T.drop (ta_len `div` 3)) ta , benchTL $ nf (TL.drop (tla_len `div` 3)) tla- , benchBS $ nf (BS.drop (bsa_len `div` 3)) bsa- , benchBSL $ nf (BL.drop (bla_len `div` 3)) bla- , benchS $ nf (L.drop (sa_len `div` 3)) sa ] , bgroup "encode" [ benchT $ nf T.encodeUtf8 ta , benchTL $ nf TL.encodeUtf8 tla- , benchBS $ nf BS.pack sa- , benchBSL $ nf BL.pack sa- , benchS $ nf UTF8.fromString sa ] , bgroup "filter" [ benchT $ nf (T.filter p0) ta , benchTL $ nf (TL.filter p0) tla- , benchBS $ nf (BS.filter p0) bsa- , benchBSL $ nf (BL.filter p0) bla- , benchS $ nf (L.filter p0) sa ] , bgroup "filter.filter" [ benchT $ nf (T.filter p1 . T.filter p0) ta , benchTL $ nf (TL.filter p1 . TL.filter p0) tla- , benchBS $ nf (BS.filter p1 . BS.filter p0) bsa- , benchBSL $ nf (BL.filter p1 . BL.filter p0) bla- , benchS $ nf (L.filter p1 . L.filter p0) sa ] , bgroup "foldl'" [ benchT $ nf (T.foldl' len 0) ta , benchTL $ nf (TL.foldl' len 0) tla- , benchBS $ nf (BS.foldl' len 0) bsa- , benchBSL $ nf (BL.foldl' len 0) bla- , benchS $ nf (L.foldl' len 0) sa ] , bgroup "foldr" [ benchT $ nf (L.length . T.foldr (:) []) ta , benchTL $ nf (L.length . TL.foldr (:) []) tla- , benchBS $ nf (L.length . BS.foldr (:) []) bsa- , benchBSL $ nf (L.length . BL.foldr (:) []) bla- , benchS $ nf (L.length . L.foldr (:) []) sa ] , bgroup "head" [ benchT $ nf T.head ta , benchTL $ nf TL.head tla- , benchBS $ nf BS.head bsa- , benchBSL $ nf BL.head bla- , benchS $ nf L.head sa ] , bgroup "init" [ benchT $ nf T.init ta , benchTL $ nf TL.init tla- , benchBS $ nf BS.init bsa- , benchBSL $ nf BL.init bla- , benchS $ nf L.init sa ] , bgroup "intercalate" [ benchT $ nf (T.intercalate tsw) tl , benchTL $ nf (TL.intercalate tlw) tll- , benchBS $ nf (BS.intercalate bsw) bsl- , benchBSL $ nf (BL.intercalate blw) bll- , benchS $ nf (L.intercalate lw) sl ] , bgroup "intersperse" [ benchT $ nf (T.intersperse c) ta , benchTL $ nf (TL.intersperse c) tla- , benchBS $ nf (BS.intersperse c) bsa- , benchBSL $ nf (BL.intersperse c) bla- , benchS $ nf (L.intersperse c) sa ] , bgroup "isInfixOf" [ benchT $ nf (T.isInfixOf tsw) ta , benchTL $ nf (TL.isInfixOf tlw) tla- , benchBS $ nf (BS.isInfixOf bsw) bsa- -- no isInfixOf for lazy bytestrings- , benchS $ nf (L.isInfixOf lw) sa ] , bgroup "last" [ benchT $ nf T.last ta , benchTL $ nf TL.last tla- , benchBS $ nf BS.last bsa- , benchBSL $ nf BL.last bla- , benchS $ nf L.last sa ] , bgroup "map" [ benchT $ nf (T.map f) ta , benchTL $ nf (TL.map f) tla- , benchBS $ nf (BS.map f) bsa- , benchBSL $ nf (BL.map f) bla- , benchS $ nf (L.map f) sa ] , bgroup "mapAccumL" [ benchT $ nf (T.mapAccumL g 0) ta , benchTL $ nf (TL.mapAccumL g 0) tla- , benchBS $ nf (BS.mapAccumL g 0) bsa- , benchBSL $ nf (BL.mapAccumL g 0) bla- , benchS $ nf (L.mapAccumL g 0) sa ] , bgroup "mapAccumR" [ benchT $ nf (T.mapAccumR g 0) ta , benchTL $ nf (TL.mapAccumR g 0) tla- , benchBS $ nf (BS.mapAccumR g 0) bsa- , benchBSL $ nf (BL.mapAccumR g 0) bla- , benchS $ nf (L.mapAccumR g 0) sa ] , bgroup "map.map" [ benchT $ nf (T.map f . T.map f) ta , benchTL $ nf (TL.map f . TL.map f) tla- , benchBS $ nf (BS.map f . BS.map f) bsa- , benchBSL $ nf (BL.map f . BL.map f) bla- , benchS $ nf (L.map f . L.map f) sa ] , bgroup "replicate char" [ benchT $ nf (T.replicate bsa_len) (T.singleton c) , benchTL $ nf (TL.replicate (fromIntegral bsa_len)) (TL.singleton c)- , benchBS $ nf (BS.replicate bsa_len) c- , benchBSL $ nf (BL.replicate (fromIntegral bsa_len)) c- , benchS $ nf (L.replicate bsa_len) c ] , bgroup "replicate string" [ benchT $ nf (T.replicate (bsa_len `div` T.length tsw)) tsw , benchTL $ nf (TL.replicate (fromIntegral bsa_len `div` TL.length tlw)) tlw- , benchS $ nf (replicat (bsa_len `div` T.length tsw)) lw ] , bgroup "reverse" [ benchT $ nf T.reverse ta , benchTL $ nf TL.reverse tla- , benchBS $ nf BS.reverse bsa- , benchBSL $ nf BL.reverse bla- , benchS $ nf L.reverse sa ] , bgroup "take" [ benchT $ nf (T.take (ta_len `div` 3)) ta , benchTL $ nf (TL.take (tla_len `div` 3)) tla- , benchBS $ nf (BS.take (bsa_len `div` 3)) bsa- , benchBSL $ nf (BL.take (bla_len `div` 3)) bla- , benchS $ nf (L.take (sa_len `div` 3)) sa ] , bgroup "tail" [ benchT $ nf T.tail ta , benchTL $ nf TL.tail tla- , benchBS $ nf BS.tail bsa- , benchBSL $ nf BL.tail bla- , benchS $ nf L.tail sa ] , bgroup "toLower" [ benchT $ nf T.toLower ta , benchTL $ nf TL.toLower tla- , benchBS $ nf (BS.map toLower) bsa- , benchBSL $ nf (BL.map toLower) bla- , benchS $ nf (L.map toLower) sa ] , bgroup "toUpper" [ benchT $ nf T.toUpper ta , benchTL $ nf TL.toUpper tla- , benchBS $ nf (BS.map toUpper) bsa- , benchBSL $ nf (BL.map toUpper) bla- , benchS $ nf (L.map toUpper) sa ] , bgroup "uncons" [ benchT $ nf T.uncons ta , benchTL $ nf TL.uncons tla- , benchBS $ nf BS.uncons bsa- , benchBSL $ nf BL.uncons bla- , benchS $ nf L.uncons sa ] , bgroup "words" [ benchT $ nf T.words ta , benchTL $ nf TL.words tla- , benchBS $ nf BS.words bsa- , benchBSL $ nf BL.words bla- , benchS $ nf L.words sa ] , bgroup "zipWith" [ benchT $ nf (T.zipWith min tb) ta , benchTL $ nf (TL.zipWith min tlb) tla- , benchBS $ nf (BS.zipWith min bsb) bsa- , benchBSL $ nf (BL.zipWith min blb) bla- , benchS $ nf (L.zipWith min sb) sa ] , bgroup "length" [ bgroup "cons" [ benchT $ nf (T.length . T.cons c) ta , benchTL $ nf (TL.length . TL.cons c) tla- , benchBS $ nf (BS.length . BS.cons c) bsa- , benchBSL $ nf (BL.length . BL.cons c) bla- , benchS $ nf (L.length . (:) c) sa ] , bgroup "decode" [ benchT $ nf (T.length . T.decodeUtf8) bsa , benchTL $ nf (TL.length . TL.decodeUtf8) bla- , benchBS $ nf (L.length . BS.unpack) bsa- , benchBSL $ nf (L.length . BL.unpack) bla- , bench "StringUTF8" $ nf (L.length . UTF8.toString) bsa ] , bgroup "drop" [ benchT $ nf (T.length . T.drop (ta_len `div` 3)) ta , benchTL $ nf (TL.length . TL.drop (tla_len `div` 3)) tla- , benchBS $ nf (BS.length . BS.drop (bsa_len `div` 3)) bsa- , benchBSL $ nf (BL.length . BL.drop (bla_len `div` 3)) bla- , benchS $ nf (L.length . L.drop (sa_len `div` 3)) sa ] , bgroup "filter" [ benchT $ nf (T.length . T.filter p0) ta , benchTL $ nf (TL.length . TL.filter p0) tla- , benchBS $ nf (BS.length . BS.filter p0) bsa- , benchBSL $ nf (BL.length . BL.filter p0) bla- , benchS $ nf (L.length . L.filter p0) sa ] , bgroup "filter.filter" [ benchT $ nf (T.length . T.filter p1 . T.filter p0) ta , benchTL $ nf (TL.length . TL.filter p1 . TL.filter p0) tla- , benchBS $ nf (BS.length . BS.filter p1 . BS.filter p0) bsa- , benchBSL $ nf (BL.length . BL.filter p1 . BL.filter p0) bla- , benchS $ nf (L.length . L.filter p1 . L.filter p0) sa ] , bgroup "init" [ benchT $ nf (T.length . T.init) ta , benchTL $ nf (TL.length . TL.init) tla- , benchBS $ nf (BS.length . BS.init) bsa- , benchBSL $ nf (BL.length . BL.init) bla- , benchS $ nf (L.length . L.init) sa ] , bgroup "intercalate" [ benchT $ nf (T.length . T.intercalate tsw) tl , benchTL $ nf (TL.length . TL.intercalate tlw) tll- , benchBS $ nf (BS.length . BS.intercalate bsw) bsl- , benchBSL $ nf (BL.length . BL.intercalate blw) bll- , benchS $ nf (L.length . L.intercalate lw) sl ] , bgroup "intersperse" [ benchT $ nf (T.length . T.intersperse c) ta , benchTL $ nf (TL.length . TL.intersperse c) tla- , benchBS $ nf (BS.length . BS.intersperse c) bsa- , benchBSL $ nf (BL.length . BL.intersperse c) bla- , benchS $ nf (L.length . L.intersperse c) sa ] , bgroup "map" [ benchT $ nf (T.length . T.map f) ta , benchTL $ nf (TL.length . TL.map f) tla- , benchBS $ nf (BS.length . BS.map f) bsa- , benchBSL $ nf (BL.length . BL.map f) bla- , benchS $ nf (L.length . L.map f) sa ] , bgroup "map.map" [ benchT $ nf (T.length . T.map f . T.map f) ta , benchTL $ nf (TL.length . TL.map f . TL.map f) tla- , benchBS $ nf (BS.length . BS.map f . BS.map f) bsa- , benchS $ nf (L.length . L.map f . L.map f) sa ] , bgroup "replicate char" [ benchT $ nf (T.length . T.replicate bsa_len) (T.singleton c) , benchTL $ nf (TL.length . TL.replicate (fromIntegral bsa_len)) (TL.singleton c)- , benchBS $ nf (BS.length . BS.replicate bsa_len) c- , benchBSL $ nf (BL.length . BL.replicate (fromIntegral bsa_len)) c- , benchS $ nf (L.length . L.replicate bsa_len) c ] , bgroup "replicate string" [ benchT $ nf (T.length . T.replicate (bsa_len `div` T.length tsw)) tsw , benchTL $ nf (TL.length . TL.replicate (fromIntegral bsa_len `div` TL.length tlw)) tlw- , benchS $ nf (L.length . replicat (bsa_len `div` T.length tsw)) lw ] , bgroup "take" [ benchT $ nf (T.length . T.take (ta_len `div` 3)) ta , benchTL $ nf (TL.length . TL.take (tla_len `div` 3)) tla- , benchBS $ nf (BS.length . BS.take (bsa_len `div` 3)) bsa- , benchBSL $ nf (BL.length . BL.take (bla_len `div` 3)) bla- , benchS $ nf (L.length . L.take (sa_len `div` 3)) sa ] , bgroup "tail" [ benchT $ nf (T.length . T.tail) ta , benchTL $ nf (TL.length . TL.tail) tla- , benchBS $ nf (BS.length . BS.tail) bsa- , benchBSL $ nf (BL.length . BL.tail) bla- , benchS $ nf (L.length . L.tail) sa ] , bgroup "toLower" [ benchT $ nf (T.length . T.toLower) ta , benchTL $ nf (TL.length . TL.toLower) tla- , benchBS $ nf (BS.length . BS.map toLower) bsa- , benchBSL $ nf (BL.length . BL.map toLower) bla- , benchS $ nf (L.length . L.map toLower) sa ] , bgroup "toUpper" [ benchT $ nf (T.length . T.toUpper) ta , benchTL $ nf (TL.length . TL.toUpper) tla- , benchBS $ nf (BS.length . BS.map toUpper) bsa- , benchBSL $ nf (BL.length . BL.map toUpper) bla- , benchS $ nf (L.length . L.map toUpper) sa ] , bgroup "words" [ benchT $ nf (L.length . T.words) ta , benchTL $ nf (L.length . TL.words) tla- , benchBS $ nf (L.length . BS.words) bsa- , benchBSL $ nf (L.length . BL.words) bla- , benchS $ nf (L.length . L.words) sa ] , bgroup "zipWith" [ benchT $ nf (T.length . T.zipWith min tb) ta , benchTL $ nf (TL.length . TL.zipWith min tlb) tla- , benchBS $ nf (L.length . BS.zipWith min bsb) bsa- , benchBSL $ nf (L.length . BL.zipWith min blb) bla- , benchS $ nf (L.length . L.zipWith min sb) sa ] ] , bgroup "Builder"- [ bench "mappend char" $ nf (TL.length . TB.toLazyText . mappendNChar 'a') 10000- , bench "mappend 8 char" $ nf (TL.length . TB.toLazyText . mappend8Char) 'a'- , bench "mappend text" $ nf (TL.length . TB.toLazyText . mappendNText short) 10000+ [ bench ("mappend char+" ++ kind) $+ nf (TL.length . TB.toLazyText . mappendNChar 'a') 10000+ , bench ("mappend 8 char+" ++ kind) $+ nf (TL.length . TB.toLazyText . mappend8Char) 'a'+ , bench ("mappend text+" ++ kind) $+ nf (TL.length . TB.toLazyText . mappendNText short) 10000 ] ] where- benchS = bench ("String+" ++ kind) benchT = bench ("Text+" ++ kind) benchTL = bench ("LazyText+" ++ kind)- benchBS = bench ("ByteString+" ++ kind)- benchBSL = bench ("LazyByteString+" ++ kind) c = 'й' p0 = (== c) p1 = (/= 'д') lw = "право"- bsw = UTF8.fromString lw- blw = BL.fromChunks [bsw] tsw = T.pack lw tlw = TL.fromChunks [tsw] f (C# c#) = C# (chr# (ord# c# +# 1#)) g (I# i#) (C# c#) = (I# (i# +# 1#), C# (chr# (ord# c# +# i#))) len l _ = l + (1::Int)- replicat n = concat . L.replicate n short = T.pack "short"--#if !MIN_VERSION_bytestring(0,10,0)-instance NFData BS.ByteString--instance NFData BL.ByteString where- rnf BL.Empty = ()- rnf (BL.Chunk _ ts) = rnf ts-#endif data B where B :: NFData a => a -> B
benchmarks/haskell/Benchmarks/ReadNumbers.hs view
@@ -21,7 +21,7 @@ , benchmark ) where -import Criterion (Benchmark, bgroup, bench, whnf)+import Test.Tasty.Bench (Benchmark, bgroup, bench, whnf) import Data.List (foldl') import Numeric (readDec, readFloat, readHex) import qualified Data.ByteString.Char8 as B
benchmarks/haskell/Benchmarks/Replace.hs view
@@ -10,7 +10,7 @@ , initEnv ) where -import Criterion (Benchmark, bgroup, bench, nf)+import Test.Tasty.Bench (Benchmark, bgroup, bench, nf) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Search as BL
benchmarks/haskell/Benchmarks/Search.hs view
@@ -9,7 +9,7 @@ , benchmark ) where -import Criterion (Benchmark, bench, bgroup, whnf)+import Test.Tasty.Bench (Benchmark, bench, bgroup, whnf) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Search as BL
benchmarks/haskell/Benchmarks/Stream.hs view
@@ -6,7 +6,7 @@ -- * Most streaming functions -- {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, RecordWildCards #-}+{-# LANGUAGE DeriveGeneric, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Benchmarks.Stream ( initEnv@@ -14,7 +14,7 @@ ) where import Control.DeepSeq (NFData (..))-import Criterion (Benchmark, bgroup, bench, nf)+import Test.Tasty.Bench (Benchmark, bgroup, bench, nf) import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.Text.Lazy as TL@@ -55,10 +55,12 @@ , utf32leL :: !BL.ByteString , utf32beL :: !BL.ByteString , s :: T.Stream Char- } deriving (Generic, NFData)+ } deriving (Generic) +instance NFData Env+ initEnv :: FilePath -> IO Env-initEnv fp = do +initEnv fp = do -- Different formats t <- T.readFile fp let !utf8 = T.encodeUtf8 t
benchmarks/haskell/Benchmarks/WordFrequencies.hs view
@@ -13,7 +13,7 @@ , benchmark ) where -import Criterion (Benchmark, bench, bgroup, whnf)+import Test.Tasty.Bench (Benchmark, bench, bgroup, whnf) import Data.Char (toLower) import Data.List (foldl') import Data.Map (Map)
− benchmarks/haskell/Multilang.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE BangPatterns, OverloadedStrings, RankNTypes #-}--module Main (- main- ) where--import Control.Monad (forM_)-import qualified Data.ByteString as B-import qualified Data.Text as Text-import Data.Text.Encoding (decodeUtf8)-import Data.Text (Text)-import System.IO (hFlush, stdout)-import Timer (timer)--type BM = Text -> ()--bm :: forall a. (Text -> a) -> BM-bm f t = f t `seq` ()--benchmarks :: [(String, Text.Text -> ())]-benchmarks = [- ("find_first", bm $ Text.isInfixOf "en:Benin")- , ("find_index", bm $ Text.findIndex (=='c'))- ]--main :: IO ()-main = do- !contents <- decodeUtf8 `fmap` B.readFile "../tests/text-test-data/yiwiki.xml"- forM_ benchmarks $ \(name, bmark) -> do- putStr $ name ++ " "- hFlush stdout- putStrLn =<< (timer 100 contents bmark)
− benchmarks/haskell/Timer.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Timer (timer) where--import Control.Exception (evaluate)-import Data.Time.Clock.POSIX (getPOSIXTime)-import GHC.Float (FFFormat(..), formatRealFloat)--ickyRound :: Int -> Double -> String-ickyRound k = formatRealFloat FFFixed (Just k)--timer :: Int -> a -> (a -> b) -> IO String-timer count a0 f = do- let loop !k !fastest- | k <= 0 = return fastest- | otherwise = do- start <- getPOSIXTime- let inner a i- | i <= 0 = return ()- | otherwise = evaluate (f a) >> inner a (i-1)- inner a0 count- end <- getPOSIXTime- let elapsed = end - start- loop (k-1) (min fastest (elapsed / fromIntegral count))- t <- loop (3::Int) 1e300- let log10 x = log x / log 10- ft = realToFrac t- prec = round (log10 (fromIntegral count) - log10 ft)- return $! ickyRound prec ft-{-# NOINLINE timer #-}
− benchmarks/python/cut.py
@@ -1,12 +0,0 @@-#!/usr/bin/env python3--import utils, sys, codecs--def cut(filename, l, r):- content = open(filename, encoding='utf-8')- for line in content:- print(line[l:r])--for f in sys.argv[1:]:- t = utils.benchmark(lambda: cut(f, 20, 40))- sys.stderr.write('{0}: {1}\n'.format(f, t))
− benchmarks/python/multilang.py
@@ -1,49 +0,0 @@-#!/usr/bin/env python3--import math-import sys-import time--def find_first():- cf = contents.find- return timer(lambda: cf("en:Benin"))--def timer(f, count=100):- a = 1e300- def g():- return- for i in range(3):- start = time.time()- for j in range(count):- g()- a = min(a, (time.time() - start) / count)-- b = 1e300- for i in range(3):- start = time.time()- for j in range(count):- f()- b = min(b, (time.time() - start) / count)-- return round(b - a, int(round(math.log(count, 10) - math.log(b - a, 10))))--contents = open('../../tests/text-test-data/yiwiki.xml', 'r').read()--benchmarks = (- find_first,- )--to_run = sys.argv[1:]-bms = []-if to_run:- for r in to_run:- for b in benchmarks:- if b.__name__.startswith(r):- bms.append(b)-else:- bms = benchmarks--for b in bms:- sys.stdout.write(b.__name__ + ' ')- sys.stdout.flush()- print(b())
− benchmarks/python/sort.py
@@ -1,13 +0,0 @@-#!/usr/bin/env python3--import utils, sys, codecs--def sort(filename):- content = open(filename, encoding='utf-8').read()- lines = content.splitlines()- lines.sort()- print('\n'.join(lines))--for f in sys.argv[1:]:- t = utils.benchmark(lambda: sort(f))- sys.stderr.write('{0}: {1}\n'.format(f, t))
− benchmarks/python/strip_tags.py
@@ -1,25 +0,0 @@-#!/usr/bin/env python3--import utils, sys--def strip_tags(filename):- string = open(filename, encoding='utf-8').read()-- d = 0- out = []-- for c in string:- if c == '<': d += 1-- if d > 0:- out += ' '- else:- out += c-- if c == '>': d -= 1-- print(''.join(out))--for f in sys.argv[1:]:- t = utils.benchmark(lambda: strip_tags(f))- sys.stderr.write('{0}: {1}\n'.format(f, t))
− benchmarks/python/utils.py
@@ -1,18 +0,0 @@-#!/usr/bin/env python3--import sys, time--def benchmark_once(f):- start = time.time()- f()- end = time.time()- return end - start--def benchmark(f):- runs = 100- total = 0.0- for i in range(runs):- result = benchmark_once(f)- sys.stderr.write('Run {0}: {1}\n'.format(i, result))- total += result- return total / runs
− benchmarks/ruby/cut.rb
@@ -1,16 +0,0 @@-#!/usr/bin/env ruby--require './utils.rb'--def cut(filename, l, r)- File.open(filename, 'r:utf-8') do |file|- file.each_line do |line|- puts line[l, r - l]- end- end-end--ARGV.each do |f|- t = benchmark { cut(f, 20, 40) }- STDERR.puts "#{f}: #{t}"-end
− benchmarks/ruby/fold.rb
@@ -1,50 +0,0 @@-#!/usr/bin/env ruby--require './utils.rb'--def fold(filename, max_width)- File.open(filename, 'r:utf-8') do |file|- # Words in this paragraph- paragraph = []-- file.each_line do |line|- # If we encounter an empty line, we reformat and dump the current- # paragraph- if line.strip.empty?- puts fold_paragraph(paragraph, max_width)- puts- paragraph = []- # Otherwise, we append the words found in the line to the paragraph- else- paragraph.concat line.split- end- end-- # Last paragraph- puts fold_paragraph(paragraph, max_width) unless paragraph.empty?- end-end--# Fold a single paragraph to the desired width-def fold_paragraph(paragraph, max_width)- # Gradually build our output- str, *rest = paragraph- width = str.length-- rest.each do |word|- if width + word.length + 1 <= max_width- str << ' ' << word- width += word.length + 1- else- str << "\n" << word- width = word.length- end- end-- str-end--ARGV.each do |f|- t = benchmark { fold(f, 80) }- STDERR.puts "#{f}: #{t}"-end
− benchmarks/ruby/sort.rb
@@ -1,15 +0,0 @@-#!/usr/bin/env ruby--require './utils.rb'--def sort(filename)- File.open(filename, 'r:utf-8') do |file|- content = file.read- puts content.lines.sort.join- end-end--ARGV.each do |f|- t = benchmark { sort(f) }- STDERR.puts "#{f}: #{t}"-end
− benchmarks/ruby/strip_tags.rb
@@ -1,22 +0,0 @@-#!/usr/bin/env ruby--require './utils.rb'--def strip_tags(filename)- File.open(filename, 'r:utf-8') do |file|- str = file.read-- d = 0-- str.each_char do |c|- d += 1 if c == '<'- putc(if d > 0 then ' ' else c end)- d -= 1 if c == '>'- end- end-end--ARGV.each do |f|- t = benchmark { strip_tags(f) }- STDERR.puts "#{f}: #{t}"-end
− benchmarks/ruby/utils.rb
@@ -1,14 +0,0 @@-require 'benchmark'--def benchmark(&block)- runs = 100- total = 0-- runs.times do |i|- result = Benchmark.measure(&block).total- $stderr.puts "Run #{i}: #{result}"- total += result- end-- total / runs -end
− benchmarks/text-benchmarks.cabal
@@ -1,155 +0,0 @@-cabal-version: 1.12-name: text-benchmarks-version: 0.0.0.0-synopsis: Benchmarks for the text package-description: Benchmarks for the text package.-homepage: https://bitbucket.org/bos/text-license: BSD2-license-file: LICENSE-author: Jasper Van der Jeugt <jaspervdj@gmail.com>,- Bryan O'Sullivan <bos@serpentine.com>,- Tom Harper <rtomharper@googlemail.com>,- Duncan Coutts <duncan@haskell.org>-maintainer: jaspervdj@gmail.com-category: Text-build-type: Simple-tested-with: GHC==8.10.2, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4,- GHC==8.2.2, GHC==8.0.2, GHC==7.10.3--extra-source-files:- include/*.h--flag bytestring-builder- description: Depend on the bytestring-builder package for backwards compatibility.- default: False- manual: False--flag llvm- description: use LLVM- default: False- manual: True--executable text-benchmarks- ghc-options: -Wall -O2 -rtsopts- if flag(llvm)- ghc-options: -fllvm- cpp-options: -DINTEGER_GMP- build-depends: array,- base == 4.*,- binary,- blaze-builder,- bytestring-lexing >= 0.5.0,- containers,- criterion >= 0.10.0.0,- deepseq,- directory,- filepath,- ghc-prim,- integer-gmp,- stringsearch,- template-haskell,- transformers,- utf8-string,- vector-- if flag(bytestring-builder)- build-depends: bytestring >= 0.9 && < 0.10.4,- bytestring-builder >= 0.10.4- else- build-depends: bytestring >= 0.10.4-- -- modules for benchmark proper- c-sources: cbits-bench/time_iconv.c- hs-source-dirs: haskell- main-is: Benchmarks.hs- other-modules:- Benchmarks.Builder- Benchmarks.Concat- Benchmarks.DecodeUtf8- Benchmarks.EncodeUtf8- Benchmarks.Equality- Benchmarks.FileRead- Benchmarks.FoldLines- Benchmarks.Mul- 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-- -- Source code for IUT (implementation under test)- -- "borrowed" from parent folder- include-dirs: include- c-sources: cbits/cbits.c- hs-source-dirs: src- other-modules:- Data.Text- Data.Text.Array- Data.Text.Encoding- Data.Text.Encoding.Error- Data.Text.Foreign- Data.Text.IO- Data.Text.Internal- 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.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.Functions- 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.Unsafe- Data.Text.Internal.Unsafe.Char- Data.Text.Internal.Unsafe.Shift- 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- Data.Text.Show-- default-language: Haskell2010- default-extensions: NondecreasingIndentation- other-extensions: DeriveAnyClass---executable text-multilang- hs-source-dirs: haskell- main-is: Multilang.hs- other-modules: Timer- ghc-options: -Wall -O2- build-depends: base == 4.*,- bytestring,- text,- time-- default-language: Haskell2010- default-extensions: NondecreasingIndentation
cbits/cbits.c view
@@ -9,6 +9,11 @@ #include <string.h> #include <stdint.h> #include <stdio.h>+#if defined(__x86_64__)+#include <emmintrin.h>+#include <xmmintrin.h>+#endif+ #include "text_cbits.h" void _hs_text_memcpy(void *dest, size_t doff, const void *src, size_t soff,@@ -82,6 +87,23 @@ while (p != srcend && (uintptr_t)p & 0x3) *dest++ = *p++; +#if defined(__x86_64__)+ /* All the intrinsics used here are from SSE2,+ * so every x86_64 CPU supports them.+ */+ const __m128i zeros = _mm_set1_epi32(0);+ while (p < srcend - 7) {+ /* Load 8 bytes of ASCII data */+ const __m128i ascii = _mm_cvtsi64_si128(*((const uint64_t *)p));+ /* Interleave with zeros */+ const __m128i utf16 = _mm_unpacklo_epi8(ascii, zeros);+ /* Store the resulting 16 bytes into destination */+ _mm_storeu_si128((__m128i *)dest, utf16);++ dest += 8;+ p += 8;+ }+#else /* iterate over 32-bit aligned loads */ while (p < srcend - 3) { const uint32_t w = *((const uint32_t *)p);@@ -94,6 +116,7 @@ p += 4; } #endif+#endif /* handle unaligned suffix */ while (p != srcend)@@ -157,24 +180,40 @@ */ if (state == UTF8_ACCEPT) {- while (s < srcend - 4) {- codepoint = *((uint32_t *) s);- if ((codepoint & 0x80808080) != 0)- break;- s += 4;-- /*- * Tried 32-bit stores here, but the extra bit-twiddling- * slowed the code down.- */+#if defined(__x86_64__)+ const __m128i zeros = _mm_set1_epi32(0);+ while (s < srcend - 8) {+ const uint64_t hopefully_eight_ascii_chars = *((uint64_t *) s);+ if ((hopefully_eight_ascii_chars & 0x8080808080808080LL) != 0LL)+ break;+ s += 8; - *d++ = (uint16_t) (codepoint & 0xff);- *d++ = (uint16_t) ((codepoint >> 8) & 0xff);- *d++ = (uint16_t) ((codepoint >> 16) & 0xff);- *d++ = (uint16_t) ((codepoint >> 24) & 0xff);+ /* Load 8 bytes of ASCII data */+ const __m128i eight_ascii_chars = _mm_cvtsi64_si128(hopefully_eight_ascii_chars);+ /* Interleave with zeros */+ const __m128i eight_utf16_chars = _mm_unpacklo_epi8(eight_ascii_chars, zeros);+ /* Store the resulting 16 bytes into destination */+ _mm_storeu_si128((__m128i *)d, eight_utf16_chars);+ d += 8; }+#else + while (s < srcend - 4) {+ codepoint = *((uint32_t *) s);+ if ((codepoint & 0x80808080) != 0)+ break;+ s += 4;+ /*+ * Tried 32-bit stores here, but the extra bit-twiddling+ * slowed the code down.+ */+ *d++ = (uint16_t) (codepoint & 0xff);+ *d++ = (uint16_t) ((codepoint >> 8) & 0xff);+ *d++ = (uint16_t) ((codepoint >> 16) & 0xff);+ *d++ = (uint16_t) ((codepoint >> 24) & 0xff);+ }+#endif last = s;- }+ } /* end if (state == UTF8_ACCEPT) */ #endif if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {@@ -237,29 +276,36 @@ ascii: #if defined(__x86_64__)- while (srcend - src >= 4) {- uint64_t w = *((uint64_t *) src);+ while (srcend - src >= 8) {+ union { uint64_t halves[2]; __m128i whole; } eight_chars;+ eight_chars.whole = _mm_loadu_si128((__m128i *) src); + const uint64_t w = eight_chars.halves[0]; if (w & 0xFF80FF80FF80FF80ULL) { if (!(w & 0x000000000000FF80ULL)) {- *dest++ = w & 0xFFFF;- src++;- if (!(w & 0x00000000FF800000ULL)) {- *dest++ = (w >> 16) & 0xFFFF;- src++;- if (!(w & 0x0000FF8000000000ULL)) {- *dest++ = (w >> 32) & 0xFFFF;- src++;- }- }+ *dest++ = w & 0xFFFF;+ src++;+ if (!(w & 0x00000000FF800000ULL)) {+ *dest++ = (w >> 16) & 0xFFFF;+ src++;+ if (!(w & 0x0000FF8000000000ULL)) {+ *dest++ = (w >> 32) & 0xFFFF;+ src++;+ }+ } } break; }- *dest++ = w & 0xFFFF;- *dest++ = (w >> 16) & 0xFFFF;- *dest++ = (w >> 32) & 0xFFFF;- *dest++ = w >> 48;- src += 4;++ if (eight_chars.halves[1] & 0xFF80FF80FF80FF80ULL) {+ break;+ }++ const __m128i eight_ascii_chars = _mm_packus_epi16(eight_chars.whole, eight_chars.whole);+ _mm_storel_epi64((__m128i *)dest, eight_ascii_chars);++ dest += 8;+ src += 8; } #endif
changelog.md view
@@ -1,11 +1,19 @@-See also http://pvp.haskell.org/faq+### 1.2.5.0 -#### 1.2.4.1+* [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-* Add doctest examples for `span` and `break` ### 1.2.4.0 @@ -18,7 +26,7 @@ * Support `base-4.13.0.0` -#### 1.2.3.1+### 1.2.3.1 * Make `decodeUtf8With` fail explicitly for unsupported non-BMP replacement characters instead silent undefined behaviour (gh-213)
scripts/CaseMapping.hs view
@@ -8,7 +8,7 @@ main = do args <- getArgs let oname = case args of- [] -> "../Data/Text/Internal/Fusion/CaseMapping.hs"+ [] -> "../src/Data/Text/Internal/Fusion/CaseMapping.hs" [o] -> o psc <- parseSC "SpecialCasing.txt" pcf <- parseCF "CaseFolding.txt"
src/Data/Text.hs view
@@ -1,20 +1,9 @@ {-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--- Using TemplateHaskell in text unconditionally is unacceptable, as--- it's a GHC boot library. TemplateHaskellQuotes was added in 8.0, so--- this would seem to be a problem. However, GHC's policy of only--- needing to be able to compile itself from the last few releases--- allows us to use full-fat TH on older versions, while using THQ for--- GHC versions that may be used for bootstrapping.-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-}-#else-{-# LANGUAGE TemplateHaskell #-}-#endif+{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | -- Module : Data.Text -- Copyright : (c) 2009, 2010, 2011, 2012 Bryan O'Sullivan,@@ -185,6 +174,7 @@ , filter , breakOnAll , find+ , elem , partition -- , findSubstring@@ -215,6 +205,7 @@ import Control.DeepSeq (NFData(rnf)) #if defined(ASSERTS) import Control.Exception (assert)+import GHC.Stack (HasCallStack) #endif import Data.Char (isSpace) import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf), constrIndex,@@ -225,9 +216,7 @@ import qualified Data.List as L import Data.Binary (Binary(get, put)) import Data.Monoid (Monoid(..))-#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..))-#endif import Data.String (IsString(..)) import qualified Data.Text.Internal.Fusion as S import qualified Data.Text.Internal.Fusion.Common as S@@ -250,14 +239,10 @@ import Data.Int (Int64) #endif import GHC.Base (eqInt, neInt, gtInt, geInt, ltInt, leInt)-#if MIN_VERSION_base(4,7,0) import qualified GHC.Exts as Exts-#endif import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH-#if MIN_VERSION_base(4,7,0) import Text.Printf (PrintfArg, formatArg, formatString)-#endif -- $setup -- >>> import Data.Text@@ -363,37 +348,23 @@ instance Read Text where readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str] -#if MIN_VERSION_base(4,9,0)--- | Non-orphan 'Semigroup' instance only defined for--- @base-4.9.0.0@ and later; orphan instances for older GHCs are--- provided by--- the [semigroups](http://hackage.haskell.org/package/semigroups)--- package------ @since 1.2.2.0+-- | @since 1.2.2.0 instance Semigroup Text where (<>) = append-#endif instance Monoid Text where mempty = empty-#if MIN_VERSION_base(4,9,0)- mappend = (<>) -- future-proof definition-#else- mappend = append-#endif+ mappend = (<>) mconcat = concat instance IsString Text where fromString = pack -#if MIN_VERSION_base(4,7,0) -- | @since 1.2.0.0 instance Exts.IsList Text where type Item Text = Char fromList = pack toList = unpack-#endif instance NFData Text where rnf !_ = () @@ -441,13 +412,9 @@ liftTyped = TH.unsafeTExpCoerce . TH.lift #endif -#if MIN_VERSION_base(4,7,0)--- | Only defined for @base-4.7.0.0@ and later------ @since 1.2.2.0+-- | @since 1.2.2.0 instance PrintfArg Text where formatArg txt = formatString $ unpack txt-#endif packConstr :: Constr packConstr = mkConstr textDataType "pack" [] Prefix@@ -631,7 +598,11 @@ -- | /O(n)/ Returns the number of characters in a 'Text'. -- Subject to fusion.-length :: Text -> Int+length ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> Int length t = S.length (stream t) {-# INLINE [1] length #-} -- length needs to be phased after the compareN/length rules otherwise@@ -731,7 +702,11 @@ -- "reversed" -- -- Subject to fusion (fuses with its argument).-reverse :: Text -> Text+reverse ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> Text reverse t = S.reverse (stream t) {-# INLINE reverse #-} @@ -1503,6 +1478,13 @@ ------------------------------------------------------------------------------- -- ** Searching with a predicate +-- | /O(n)/ The 'elem' function takes a character and a 'Text', and+-- returns 'True' if the element is found in the given 'Text', or+-- 'False' otherwise.+elem :: Char -> Text -> Bool+elem c t = S.any (== c) (stream t)+{-# INLINE elem #-}+ -- | /O(n)/ The 'find' function takes a predicate and a 'Text', and -- returns the first element matching the predicate, or 'Nothing' if -- there is no such element. Subject to fusion.@@ -1764,7 +1746,11 @@ -- -- In (unlikely) bad cases, this function's time complexity degrades -- towards /O(n*m)/.-isInfixOf :: Text -> Text -> Bool+isInfixOf ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> Text -> Bool isInfixOf needle haystack | null needle = True | isSingleton needle = S.elem (unsafeHead needle) . S.stream $ haystack
src/Data/Text/Array.hs view
@@ -24,17 +24,13 @@ module Data.Text.Array ( -- * Types- Array(Array, aBA)- , MArray(MArray, maBA)-+ Array(..)+ , MArray(..) -- * Functions , copyM , copyI , empty , equal-#if defined(ASSERTS)- , length-#endif , run , run2 , toList@@ -45,32 +41,15 @@ ) where #if defined(ASSERTS)--- This fugly hack is brought by GHC's apparent reluctance to deal--- with MagicHash and UnboxedTuples when inferring types. Eek!-# define CHECK_BOUNDS(_func_,_len_,_k_) \-if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.Text.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else-#else-# define CHECK_BOUNDS(_func_,_len_,_k_)-#endif--#include "MachDeps.h"--#if defined(ASSERTS) import Control.Exception (assert)+import GHC.Base (sizeofByteArray#, sizeofMutableByteArray#)+import GHC.Stack (HasCallStack) #endif-#if MIN_VERSION_base(4,4,0) import Control.Monad.ST.Unsafe (unsafeIOToST)-#else-import Control.Monad.ST (unsafeIOToST)-#endif import Data.Bits ((.&.), xor) import Data.Text.Internal.Unsafe (inlinePerformIO) import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)-#if MIN_VERSION_base(4,5,0) import Foreign.C.Types (CInt(CInt), CSize(CSize))-#else-import Foreign.C.Types (CInt, CSize)-#endif import GHC.Base (ByteArray#, MutableByteArray#, Int(..), indexWord16Array#, newByteArray#, unsafeFreezeByteArray#, writeWord16Array#)@@ -81,37 +60,12 @@ -- | Immutable array type. -- -- The 'Array' constructor is exposed since @text-1.1.1.3@-data Array = Array {- aBA :: ByteArray#-#if defined(ASSERTS)- , aLen :: {-# UNPACK #-} !Int -- length (in units of Word16, not bytes)-#endif- }+data Array = Array { aBA :: ByteArray# } -- | Mutable array type, for use in the ST monad. -- -- The 'MArray' constructor is exposed since @text-1.1.1.3@-data MArray s = MArray {- maBA :: MutableByteArray# s-#if defined(ASSERTS)- , maLen :: {-# UNPACK #-} !Int -- length (in units of Word16, not bytes)-#endif- }--#if defined(ASSERTS)--- | Operations supported by all arrays.-class IArray a where- -- | Return the length of an array.- length :: a -> Int--instance IArray Array where- length = aLen- {-# INLINE length #-}--instance IArray (MArray s) where- length = maLen- {-# INLINE length #-}-#endif+data MArray s = MArray { maBA :: MutableByteArray# s } -- | Create an uninitialized mutable array. new :: forall s. Int -> ST s (MArray s)@@ -119,11 +73,7 @@ | n < 0 || n .&. highBit /= 0 = array_size_error | otherwise = ST $ \s1# -> case newByteArray# len# s1# of- (# s2#, marr# #) -> (# s2#, MArray marr#-#if defined(ASSERTS)- n-#endif- #)+ (# s2#, marr# #) -> (# s2#, MArray marr# #) where !(I# len#) = bytesInArray n highBit = maxBound `xor` (maxBound `shiftR` 1) {-# INLINE new #-}@@ -135,11 +85,7 @@ unsafeFreeze :: MArray s -> ST s Array unsafeFreeze MArray{..} = ST $ \s1# -> case unsafeFreezeByteArray# maBA s1# of- (# s2#, ba# #) -> (# s2#, Array ba#-#if defined(ASSERTS)- maLen-#endif- #)+ (# s2#, ba# #) -> (# s2#, Array ba# #) {-# INLINE unsafeFreeze #-} -- | Indicate how many bytes would be used for an array of the given@@ -150,17 +96,33 @@ -- | Unchecked read of an immutable array. May return garbage or -- crash on an out-of-bounds access.-unsafeIndex :: Array -> Int -> Word16-unsafeIndex Array{..} i@(I# i#) =- CHECK_BOUNDS("unsafeIndex",aLen,i)- case indexWord16Array# aBA i# of r# -> (W16# r#)+unsafeIndex ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Array -> Int -> Word16+unsafeIndex a@Array{..} i@(I# i#) =+#if defined(ASSERTS)+ let word16len = I# (sizeofByteArray# aBA) `quot` 2 in+ if i < 0 || i >= word16len+ then error ("Data.Text.Array.unsafeIndex: bounds error, offset " ++ show i ++ ", length " ++ show word16len)+ else+#endif+ case indexWord16Array# aBA i# of r# -> (W16# r#) {-# INLINE unsafeIndex #-} -- | Unchecked write of a mutable array. May return garbage or crash -- on an out-of-bounds access.-unsafeWrite :: MArray s -> Int -> Word16 -> ST s ()-unsafeWrite MArray{..} i@(I# i#) (W16# e#) = ST $ \s1# ->- CHECK_BOUNDS("unsafeWrite",maLen,i)+unsafeWrite ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ MArray s -> Int -> Word16 -> ST s ()+unsafeWrite ma@MArray{..} i@(I# i#) (W16# e#) = ST $ \s1# ->+#if defined(ASSERTS)+ let word16len = I# (sizeofMutableByteArray# maBA) `quot` 2 in+ if i < 0 || i >= word16len then error ("Data.Text.Array.unsafeWrite: bounds error, offset " ++ show i ++ ", length " ++ show word16len) else+#endif case writeWord16Array# maBA i# e# s1# of s2# -> (# s2#, () #) {-# INLINE unsafeWrite #-}@@ -200,12 +162,12 @@ | count <= 0 = return () | otherwise = #if defined(ASSERTS)- assert (sidx + count <= length src) .- assert (didx + count <= length dest) .+ assert (sidx + count <= I# (sizeofMutableByteArray# (maBA src)) `quot` 2) .+ assert (didx + count <= I# (sizeofMutableByteArray# (maBA dest)) `quot` 2) . #endif- unsafeIOToST $ memcpyM (maBA dest) (fromIntegral didx)- (maBA src) (fromIntegral sidx)- (fromIntegral count)+ unsafeIOToST $ memcpyM (maBA dest) (intToCSize didx)+ (maBA src) (intToCSize sidx)+ (intToCSize count) {-# INLINE copyM #-} -- | Copy some elements of an immutable array.@@ -219,9 +181,9 @@ copyI dest i0 src j0 top | i0 >= top = return () | otherwise = unsafeIOToST $- memcpyI (maBA dest) (fromIntegral i0)- (aBA src) (fromIntegral j0)- (fromIntegral (top-i0))+ memcpyI (maBA dest) (intToCSize i0)+ (aBA src) (intToCSize j0)+ (intToCSize (top-i0)) {-# INLINE copyI #-} -- | Compare portions of two arrays for equality. No bounds checking@@ -233,10 +195,13 @@ -> Int -- ^ Count -> Bool equal arrA offA arrB offB count = inlinePerformIO $ do- i <- memcmp (aBA arrA) (fromIntegral offA)- (aBA arrB) (fromIntegral offB) (fromIntegral count)+ i <- memcmp (aBA arrA) (intToCSize offA)+ (aBA arrB) (intToCSize offB) (intToCSize count) return $! i == 0 {-# INLINE equal #-}++intToCSize :: Int -> CSize+intToCSize = fromIntegral foreign import ccall unsafe "_hs_text_memcpy" memcpyI :: MutableByteArray# s -> CSize -> ByteArray# -> CSize -> CSize -> IO ()
src/Data/Text/Encoding.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, MagicHash, UnliftedFFITypes #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Text.Encoding -- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,@@ -59,31 +58,24 @@ , encodeUtf8BuilderEscaped ) where -#if MIN_VERSION_base(4,4,0) import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)-#else-import Control.Monad.ST (unsafeIOToST, unsafeSTToIO)-#endif import Control.Exception (evaluate, try, throwIO, ErrorCall(ErrorCall)) import Control.Monad.ST (runST) import Data.Bits ((.&.)) import Data.ByteString as B-import Data.ByteString.Internal as B hiding (c2w)+import qualified Data.ByteString.Internal as B+import Data.Foldable (traverse_) import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode) import Data.Text.Internal (Text(..), safe, text)+import Data.Text.Internal.Functions import Data.Text.Internal.Private (runText) import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite) import Data.Text.Internal.Unsafe.Shift (shiftR) import Data.Text.Show () import Data.Text.Unsafe (unsafeDupablePerformIO)-import Data.Word (Word8, Word32)-#if MIN_VERSION_base(4,5,0)+import Data.Word (Word8, Word16, Word32) import Foreign.C.Types (CSize(CSize))-#else-import Foreign.C.Types (CSize)-#endif-import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Utils (with) import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr) import Foreign.Storable (Storable, peek, poke)@@ -97,6 +89,9 @@ import qualified Data.Text.Internal.Encoding.Utf16 as U16 import qualified Data.Text.Internal.Fusion as F import Data.Text.Internal.ByteStringCompat+#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif #include "text_cbits.h" @@ -123,12 +118,16 @@ -- -- 'decodeLatin1' is semantically equivalent to -- @Data.Text.pack . Data.ByteString.Char8.unpack@-decodeLatin1 :: ByteString -> Text+decodeLatin1 ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ ByteString -> Text decodeLatin1 bs = withBS bs aux where aux fp len = text a 0 len where a = A.run (A.new len >>= unsafeIOToST . go)- go dest = withForeignPtr fp $ \ptr -> do+ go dest = unsafeWithForeignPtr fp $ \ptr -> do c_decode_latin1 (A.maBA dest) ptr (ptr `plusPtr` len) return dest @@ -140,11 +139,15 @@ -- (/since 0.11.3.0/), whereas code points beyond the BMP will throw an -- 'error' (/since 1.2.3.1/); For earlier versions of @text@ using -- those unsupported code points would result in undefined behavior.-decodeUtf8With :: OnDecodeError -> ByteString -> Text+decodeUtf8With ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ OnDecodeError -> ByteString -> Text decodeUtf8With onErr bs = withBS bs aux where aux fp len = runText $ \done -> do- let go dest = withForeignPtr fp $ \ptr ->+ let go dest = unsafeWithForeignPtr fp $ \ptr -> with (0::CSize) $ \destOffPtr -> do let end = ptr `plusPtr` len loop curPtr = do@@ -152,7 +155,7 @@ if curPtr' == end then do n <- peek destOffPtr- unsafeSTToIO (done dest (fromIntegral n))+ unsafeSTToIO (done dest (cSizeToInt n)) else do x <- peek curPtr' case onErr desc (Just x) of@@ -162,9 +165,9 @@ | otherwise -> do destOff <- peek destOffPtr w <- unsafeSTToIO $- unsafeWrite dest (fromIntegral destOff)+ unsafeWrite dest (cSizeToInt destOff) (safe c)- poke destOffPtr (destOff + fromIntegral w)+ poke destOffPtr (destOff + intToCSize w) loop $ curPtr' `plusPtr` 1 loop ptr (unsafeIOToST . go) =<< A.new len@@ -282,48 +285,68 @@ -- data, use 'streamDecodeUtf8With'. -- -- @since 1.0.0.0-streamDecodeUtf8 :: ByteString -> Decoding+streamDecodeUtf8 ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ ByteString -> Decoding streamDecodeUtf8 = streamDecodeUtf8With strictDecode --- | Decode, in a stream oriented way, a 'ByteString' containing UTF-8+-- | Decode, in a stream oriented way, a lazy 'ByteString' containing UTF-8 -- encoded text. -- -- @since 1.0.0.0-streamDecodeUtf8With :: OnDecodeError -> ByteString -> Decoding+streamDecodeUtf8With ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ OnDecodeError -> ByteString -> Decoding streamDecodeUtf8With onErr = decodeChunk B.empty 0 0 where -- We create a slightly larger than necessary buffer to accommodate a- -- potential surrogate pair started in the last buffer+ -- potential surrogate pair started in the last buffer (@undecoded0@), or+ -- replacement characters for each byte in @undecoded0@ if the+ -- sequence turns out to be invalid. There can be up to three bytes there,+ -- hence we allocate @len+3@ 16-bit words. decodeChunk :: ByteString -> CodePoint -> DecoderState -> ByteString -> Decoding decodeChunk undecoded0 codepoint0 state0 bs = withBS bs aux where- aux fp len = runST $ (unsafeIOToST . decodeChunkToBuffer) =<< A.new (len+1)+ aux fp len = runST $ (unsafeIOToST . decodeChunkToBuffer) =<< A.new (len+3) where decodeChunkToBuffer :: A.MArray s -> IO Decoding- decodeChunkToBuffer dest = withForeignPtr fp $ \ptr ->+ decodeChunkToBuffer dest = unsafeWithForeignPtr fp $ \ptr -> with (0::CSize) $ \destOffPtr -> with codepoint0 $ \codepointPtr -> with state0 $ \statePtr -> with nullPtr $ \curPtrPtr -> let end = ptr `plusPtr` len loop curPtr = do+ prevState <- peek statePtr poke curPtrPtr curPtr- curPtr' <- c_decode_utf8_with_state (A.maBA dest) destOffPtr+ lastPtr <- c_decode_utf8_with_state (A.maBA dest) destOffPtr curPtrPtr end codepointPtr statePtr state <- peek statePtr case state of UTF8_REJECT -> do -- We encountered an encoding error- x <- peek curPtr' poke statePtr 0- case onErr desc (Just x) of- Nothing -> loop $ curPtr' `plusPtr` 1- Just c -> do- destOff <- peek destOffPtr- w <- unsafeSTToIO $- unsafeWrite dest (fromIntegral destOff) (safe c)- poke destOffPtr (destOff + fromIntegral w)- loop $ curPtr' `plusPtr` 1+ let skipByte x = case onErr desc (Just x) of+ Nothing -> return ()+ Just c -> do+ destOff <- peek destOffPtr+ w <- unsafeSTToIO $+ unsafeWrite dest (cSizeToInt destOff) (safe c)+ poke destOffPtr (destOff + intToCSize w)+ if ptr == lastPtr && prevState /= UTF8_ACCEPT then do+ -- If we can't complete the sequence @undecoded0@ from+ -- the previous chunk, we invalidate the bytes from+ -- @undecoded0@ and retry decoding the current chunk from+ -- the initial state.+ traverse_ skipByte (B.unpack undecoded0 )+ loop lastPtr+ else do+ peek lastPtr >>= skipByte+ loop (lastPtr `plusPtr` 1) _ -> do -- We encountered the end of the buffer while decoding@@ -331,12 +354,12 @@ codepoint <- peek codepointPtr chunkText <- unsafeSTToIO $ do arr <- A.unsafeFreeze dest- return $! text arr 0 (fromIntegral n)- lastPtr <- peek curPtrPtr- let left = lastPtr `minusPtr` curPtr+ return $! text arr 0 (cSizeToInt n)+ let left = lastPtr `minusPtr` ptr !undecoded = case state of UTF8_ACCEPT -> B.empty- _ -> B.append undecoded0 (B.drop left bs)+ _ | left == 0 && prevState /= UTF8_ACCEPT -> B.append undecoded0 bs+ | otherwise -> B.drop left bs return $ Some chunkText undecoded (decodeChunk undecoded codepoint state) in loop ptr@@ -359,7 +382,11 @@ -- -- If the input contains any invalid UTF-8 data, the relevant -- exception will be returned, otherwise the decoded text.-decodeUtf8' :: ByteString -> Either UnicodeException Text+decodeUtf8' ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ ByteString -> Either UnicodeException Text decodeUtf8' = unsafeDupablePerformIO . try . evaluate . decodeUtf8With strictDecode {-# INLINE decodeUtf8' #-} @@ -406,26 +433,28 @@ go !i !op | i < iendTmp = case A.unsafeIndex arr i of w | w <= 0x7F -> do- BP.runB be (fromIntegral w) op >>= go (i + 1)+ BP.runB be (word16ToWord8 w) op >>= go (i + 1) | w <= 0x7FF -> do- poke8 0 $ (w `shiftR` 6) + 0xC0- poke8 1 $ (w .&. 0x3f) + 0x80+ poke8 @Word16 0 $ (w `shiftR` 6) + 0xC0+ poke8 @Word16 1 $ (w .&. 0x3f) + 0x80 go (i + 1) (op `plusPtr` 2) | 0xD800 <= w && w <= 0xDBFF -> do let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))- poke8 0 $ (c `shiftR` 18) + 0xF0- poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80- poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80- poke8 3 $ (c .&. 0x3F) + 0x80+ poke8 @Int 0 $ (c `shiftR` 18) + 0xF0+ poke8 @Int 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80+ poke8 @Int 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80+ poke8 @Int 3 $ (c .&. 0x3F) + 0x80 go (i + 2) (op `plusPtr` 4) | otherwise -> do- poke8 0 $ (w `shiftR` 12) + 0xE0- poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80- poke8 2 $ (w .&. 0x3F) + 0x80+ poke8 @Word16 0 $ (w `shiftR` 12) + 0xE0+ poke8 @Word16 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80+ poke8 @Word16 2 $ (w .&. 0x3F) + 0x80 go (i + 1) (op `plusPtr` 3) | otherwise = outerLoop i (B.BufferRange op ope) where+ -- Take care, a is either Word16 or Int above+ poke8 :: Integral a => Int -> a -> IO () poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8) -- | Encode text using UTF-8 encoding.@@ -433,18 +462,18 @@ encodeUtf8 (Text arr off len) | len == 0 = B.empty | otherwise = unsafeDupablePerformIO $ do- fp <- mallocByteString (len*3) -- see https://github.com/haskell/text/issues/194 for why len*3 is enough- withForeignPtr fp $ \ptr ->+ fp <- B.mallocByteString (len*3) -- see https://github.com/haskell/text/issues/194 for why len*3 is enough+ unsafeWithForeignPtr fp $ \ptr -> with ptr $ \destPtr -> do- c_encode_utf8 destPtr (A.aBA arr) (fromIntegral off) (fromIntegral len)+ c_encode_utf8 destPtr (A.aBA arr) (intToCSize off) (intToCSize len) newDest <- peek destPtr let utf8len = newDest `minusPtr` ptr if utf8len >= len `shiftR` 1 then return (mkBS fp utf8len) else do- fp' <- mallocByteString utf8len- withForeignPtr fp' $ \ptr' -> do- memcpy ptr' ptr (fromIntegral utf8len)+ fp' <- B.mallocByteString utf8len+ unsafeWithForeignPtr fp' $ \ptr' -> do+ B.memcpy ptr' ptr utf8len return (mkBS fp' utf8len) -- | Decode text from little endian UTF-16 encoding.@@ -522,6 +551,15 @@ encodeUtf32BE :: Text -> ByteString encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt)) {-# INLINE encodeUtf32BE #-}++cSizeToInt :: CSize -> Int+cSizeToInt = fromIntegral++intToCSize :: Int -> CSize+intToCSize = fromIntegral++word16ToWord8 :: Word16 -> Word8+word16ToWord8 = fromIntegral foreign import ccall unsafe "_hs_text_decode_utf8" c_decode_utf8 :: MutableByteArray# s -> Ptr CSize
src/Data/Text/Encoding/Error.hs view
@@ -1,9 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable #-}-#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif -- | -- Module : Data.Text.Encoding.Error -- Copyright : (c) Bryan O'Sullivan 2009
src/Data/Text/Foreign.hs view
@@ -34,18 +34,15 @@ #if defined(ASSERTS) import Control.Exception (assert) #endif-#if MIN_VERSION_base(4,4,0) import Control.Monad.ST.Unsafe (unsafeIOToST)-#else-import Control.Monad.ST (unsafeIOToST)-#endif import Data.ByteString.Unsafe (unsafePackCStringLen, unsafeUseAsCStringLen) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Internal (Text(..), empty)+import Data.Text.Internal.Functions (unsafeWithForeignPtr) import Data.Text.Unsafe (lengthWord16) import Data.Word (Word16) import Foreign.C.String (CStringLen)-import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray, withForeignPtr)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (peek, poke)@@ -144,13 +141,13 @@ useAsPtr t@(Text _arr _off len) action = allocaBytes (len * 2) $ \buf -> do unsafeCopyToPtr t buf- action (castPtr buf) (fromIntegral len)+ action (castPtr buf) (I16 len) -- | /O(n)/ Make a mutable copy of a 'Text'. asForeignPtr :: Text -> IO (ForeignPtr Word16, I16) asForeignPtr t@(Text _arr _off len) = do fp <- mallocForeignPtrArray len- withForeignPtr fp $ unsafeCopyToPtr t+ unsafeWithForeignPtr fp $ unsafeCopyToPtr t return (fp, I16 len) -- | /O(n)/ Decode a C string with explicit length, which is assumed
src/Data/Text/IO.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -- | -- Module : Data.Text.IO -- Copyright : (c) 2009, 2010 Bryan O'Sullivan,@@ -169,7 +167,7 @@ if ioe_type e == InappropriateType then return 16384 -- faster than the 2KB default else E.throwIO e- when (d > 0) . hSetBuffering h . BlockBuffering . Just . fromIntegral $ d+ when (d > 0) . hSetBuffering h . BlockBuffering . Just . fromInteger $ d _ -> return () -- | Read a single line from a handle.
src/Data/Text/Internal.hs view
@@ -20,10 +20,6 @@ -- with the internals, as the functions here do just about nothing to -- preserve data invariants. You have been warned! -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-#include "MachDeps.h"-#endif- module Data.Text.Internal ( -- * Types@@ -49,6 +45,7 @@ #if defined(ASSERTS) import Control.Exception (assert)+import GHC.Stack (HasCallStack) #endif import Data.Bits import Data.Int (Int32, Int64)@@ -64,14 +61,16 @@ deriving (Typeable) -- | Smart constructor.-text_ :: A.Array -> Int -> Int -> Text+text_ ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ A.Array -> Int -> Int -> Text text_ arr off len = #if defined(ASSERTS) let c = A.unsafeIndex arr off- alen = A.length arr in assert (len >= 0) . assert (off >= 0) .- assert (alen == 0 || len == 0 || off < alen) . assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $ #endif Text arr off len@@ -89,7 +88,11 @@ -- | Construct a 'Text' without invisibly pinning its byte array in -- memory if its length has dwindled to zero.-text :: A.Array -> Int -> Int -> Text+text ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ A.Array -> Int -> Int -> Text text arr off len | len == 0 = empty | otherwise = text_ arr off len {-# INLINE text #-}@@ -126,11 +129,11 @@ -- | Checked multiplication. Calls 'error' if the result would -- overflow. mul :: Int -> Int -> Int-#if WORD_SIZE_IN_BITS == 64-mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b-#else-mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b-#endif+mul a b+ | finiteBitSize (0 :: Word) == 64+ = int64ToInt $ intToInt64 a `mul64` intToInt64 b+ | otherwise+ = int32ToInt $ intToInt32 a `mul32` intToInt32 b {-# INLINE mul #-} infixl 7 `mul` @@ -160,13 +163,31 @@ -- | Checked multiplication. Calls 'error' if the result would -- overflow. mul32 :: Int32 -> Int32 -> Int32-mul32 a b = case fromIntegral a * fromIntegral b of+mul32 a b = case int32ToInt64 a * int32ToInt64 b of ab | ab < min32 || ab > max32 -> error "overflow"- | otherwise -> fromIntegral ab+ | otherwise -> int64ToInt32 ab where min32 = -0x80000000 :: Int64 max32 = 0x7fffffff {-# INLINE mul32 #-} infixl 7 `mul32`++intToInt64 :: Int -> Int64+intToInt64 = fromIntegral++int64ToInt :: Int64 -> Int+int64ToInt = fromIntegral++intToInt32 :: Int -> Int32+intToInt32 = fromIntegral++int32ToInt :: Int32 -> Int+int32ToInt = fromIntegral++int32ToInt64 :: Int32 -> Int64+int32ToInt64 = fromIntegral++int64ToInt32 :: Int64 -> Int32+int64ToInt32 = fromIntegral -- $internals --
src/Data/Text/Internal/Builder.hs view
@@ -59,10 +59,10 @@ import Control.Monad.ST (ST, runST) import Data.Monoid (Monoid(..))-#if !MIN_VERSION_base(4,11,0) && MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup(..)) #endif-import Data.Text.Internal (Text(..))+import Data.Text.Internal (Text(..), safe) import Data.Text.Internal.Lazy (smallChunkSize) import Data.Text.Unsafe (inlineInterleaveST) import Data.Text.Internal.Unsafe.Char (unsafeWrite)@@ -73,6 +73,10 @@ import qualified Data.Text.Array as A import qualified Data.Text.Lazy as L +#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif+ ------------------------------------------------------------------------ -- | A @Builder@ is an efficient way to build lazy @Text@ values.@@ -92,20 +96,14 @@ -> ST s [S.Text] } -#if MIN_VERSION_base(4,9,0) instance Semigroup Builder where (<>) = append {-# INLINE (<>) #-}-#endif instance Monoid Builder where mempty = empty {-# INLINE mempty #-}-#if MIN_VERSION_base(4,9,0)- mappend = (<>) -- future-proof definition-#else- mappend = append-#endif+ mappend = (<>) {-# INLINE mappend #-} mconcat = foldr mappend Data.Monoid.mempty {-# INLINE mconcat #-}@@ -137,8 +135,12 @@ -- -- * @'toLazyText' ('singleton' c) = 'L.singleton' c@ ---singleton :: Char -> Builder-singleton c = writeAtMost 2 $ \ marr o -> unsafeWrite marr o c+singleton ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Char -> Builder+singleton c = writeAtMost 2 $ \ marr o -> unsafeWrite marr o (safe c) {-# INLINE singleton #-} ------------------------------------------------------------------------@@ -190,7 +192,7 @@ ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s) return $ t : ts | otherwise = do- n <- unsafeWrite marr (o+u) c+ n <- unsafeWrite marr (o+u) (safe c) loop marr o (u+n) (l-n) cs in loop p0 o0 u0 l0 str where
src/Data/Text/Internal/Builder/RealFloat/Functions.hs view
@@ -15,9 +15,6 @@ ) where roundTo :: Int -> [Int] -> (Int,[Int])--#if MIN_VERSION_base(4,6,0)- roundTo d is = case f d True is of x@(0,_) -> x@@ -36,22 +33,3 @@ (c,ds) = f (n-1) (even i) xs i' = c + i base = 10--#else--roundTo d is =- case f d is of- x@(0,_) -> x- (1,xs) -> (1, 1:xs)- _ -> error "roundTo: bad Value"- where- f n [] = (0, replicate n 0)- f 0 (x:_) = (if x >= 5 then 1 else 0, [])- f n (i:xs)- | i' == 10 = (1,0:ds)- | otherwise = (0,i':ds)- where- (c,ds) = f (n-1) xs- i' = c + i--#endif
src/Data/Text/Internal/ByteStringCompat.hs view
@@ -53,3 +53,4 @@ #-} #endif #endif+
src/Data/Text/Internal/Encoding/Fusion.hs view
@@ -44,8 +44,9 @@ import Data.Text.Internal.Encoding.Fusion.Common import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32) import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)+import Data.Text.Internal.Functions (unsafeWithForeignPtr) import Data.Word (Word8, Word16, Word32)-import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)+import Foreign.ForeignPtr (ForeignPtr) import Foreign.Storable (pokeByteOff) import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B@@ -104,7 +105,7 @@ where x1 = idx i + (idx (i + 1) `shiftL` 8) x2 = idx (i + 2) + (idx (i + 3) `shiftL` 8)- idx = fromIntegral . B.unsafeIndex bs :: Int -> Word16+ idx = word8ToWord16 . B.unsafeIndex bs :: Int -> Word16 {-# INLINE [0] streamUtf16LE #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big@@ -122,7 +123,7 @@ where x1 = (idx i `shiftL` 8) + idx (i + 1) x2 = (idx (i + 2) `shiftL` 8) + idx (i + 3)- idx = fromIntegral . B.unsafeIndex bs :: Int -> Word16+ idx = word8ToWord16 . B.unsafeIndex bs :: Int -> Word16 {-# INLINE [0] streamUtf16BE #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big@@ -142,7 +143,7 @@ x2 = idx (i+1) x3 = idx (i+2) x4 = idx (i+3)- idx = fromIntegral . B.unsafeIndex bs :: Int -> Word32+ idx = word8ToWord32 . B.unsafeIndex bs :: Int -> Word32 {-# INLINE [0] streamUtf32BE #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little@@ -162,7 +163,7 @@ x2 = idx $ i+1 x3 = idx $ i+2 x4 = idx $ i+3- idx = fromIntegral . B.unsafeIndex bs :: Int -> Word32+ idx = word8ToWord32 . B.unsafeIndex bs :: Int -> Word32 {-# INLINE [0] streamUtf32LE #-} -- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.@@ -177,13 +178,13 @@ Yield x s' | off == n -> realloc fp n off s' x | otherwise -> do- withForeignPtr fp $ \p -> pokeByteOff p off x+ unsafeWithForeignPtr fp $ \p -> pokeByteOff p off x loop n (off+1) s' fp {-# NOINLINE realloc #-} realloc fp n off s x = do let n' = n+n fp' <- copy0 fp n n'- withForeignPtr fp' $ \p -> pokeByteOff p off x+ unsafeWithForeignPtr fp' $ \p -> pokeByteOff p off x loop n' (off+1) s fp' {-# NOINLINE trimUp #-} trimUp fp _ off = return $! mkBS fp off@@ -194,9 +195,9 @@ #endif do dest <- mallocByteString destLen- withForeignPtr src $ \src' ->- withForeignPtr dest $ \dest' ->- memcpy dest' src' (fromIntegral srcLen)+ unsafeWithForeignPtr src $ \src' ->+ unsafeWithForeignPtr dest $ \dest' ->+ memcpy dest' src' srcLen return dest decodeError :: forall s. String -> String -> OnDecodeError -> Maybe Word8@@ -207,3 +208,9 @@ Just c -> Yield c i where desc = "Data.Text.Internal.Encoding.Fusion." ++ func ++ ": Invalid " ++ kind ++ " stream"++word8ToWord16 :: Word8 -> Word16+word8ToWord16 = fromIntegral++word8ToWord32 :: Word8 -> Word32+word8ToWord32 = fromIntegral
src/Data/Text/Internal/Encoding/Fusion/Common.hs view
@@ -43,17 +43,17 @@ Done -> Done Skip s' -> Skip (RS0 s') Yield x s'- | n < 0x10000 -> Yield (fromIntegral $ n `shiftR` 8) $- RS1 s' (fromIntegral n)+ | n < 0x10000 -> Yield (intToWord8 $ n `shiftR` 8) $+ RS1 s' (intToWord8 n) | otherwise -> Yield c1 $ RS3 s' c2 c3 c4 where n = ord x n1 = n - 0x10000- c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)- c2 = fromIntegral (n1 `shiftR` 10)+ c1 = intToWord8 (n1 `shiftR` 18 + 0xD8)+ c2 = intToWord8 (n1 `shiftR` 10) n2 = n1 .&. 0x3FF- c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)- c4 = fromIntegral n2+ c3 = intToWord8 (n2 `shiftR` 8 + 0xDC)+ c4 = intToWord8 n2 next (RS1 s x2) = Yield x2 (RS0 s) next (RS2 s x2 x3) = Yield x2 (RS1 s x3) next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4)@@ -67,17 +67,17 @@ Done -> Done Skip s' -> Skip (RS0 s') Yield x s'- | n < 0x10000 -> Yield (fromIntegral n) $- RS1 s' (fromIntegral $ shiftR n 8)+ | n < 0x10000 -> Yield (intToWord8 n) $+ RS1 s' (intToWord8 $ shiftR n 8) | otherwise -> Yield c1 $ RS3 s' c2 c3 c4 where n = ord x n1 = n - 0x10000- c2 = fromIntegral (shiftR n1 18 + 0xD8)- c1 = fromIntegral (shiftR n1 10)+ c2 = intToWord8 (shiftR n1 18 + 0xD8)+ c1 = intToWord8 (shiftR n1 10) n2 = n1 .&. 0x3FF- c4 = fromIntegral (shiftR n2 8 + 0xDC)- c3 = fromIntegral n2+ c4 = intToWord8 (shiftR n2 8 + 0xDC)+ c3 = intToWord8 n2 next (RS1 s x2) = Yield x2 (RS0 s) next (RS2 s x2 x3) = Yield x2 (RS1 s x3) next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4)@@ -93,10 +93,10 @@ Yield x s' -> Yield c1 (RS3 s' c2 c3 c4) where n = ord x- c1 = fromIntegral $ shiftR n 24- c2 = fromIntegral $ shiftR n 16- c3 = fromIntegral $ shiftR n 8- c4 = fromIntegral n+ c1 = intToWord8 $ shiftR n 24+ c2 = intToWord8 $ shiftR n 16+ c3 = intToWord8 $ shiftR n 8+ c4 = intToWord8 n next (RS1 s x2) = Yield x2 (RS0 s) next (RS2 s x2 x3) = Yield x2 (RS1 s x3) next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4)@@ -112,12 +112,15 @@ Yield x s' -> Yield c1 (RS3 s' c2 c3 c4) where n = ord x- c4 = fromIntegral $ shiftR n 24- c3 = fromIntegral $ shiftR n 16- c2 = fromIntegral $ shiftR n 8- c1 = fromIntegral n+ c4 = intToWord8 $ shiftR n 24+ c3 = intToWord8 $ shiftR n 16+ c2 = intToWord8 $ shiftR n 8+ c1 = intToWord8 n next (RS1 s x2) = Yield x2 (RS0 s) next (RS2 s x2 x3) = Yield x2 (RS1 s x3) next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4) {-# INLINE next #-} {-# INLINE restreamUtf32LE #-}++intToWord8 :: Int -> Word8+intToWord8 = fromIntegral
src/Data/Text/Internal/Encoding/Utf16.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE MagicHash, BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-} -- | -- Module : Data.Text.Internal.Encoding.Utf16@@ -26,11 +28,16 @@ import GHC.Exts import GHC.Word (Word16(..)) +#if !MIN_VERSION_base(4,16,0)+-- harmless to import, except for warnings that it is unused.+import Data.Text.Internal.PrimCompat ( word16ToWord# )+#endif+ chr2 :: Word16 -> Word16 -> Char chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#)) where- !x# = word2Int# a#- !y# = word2Int# b#+ !x# = word2Int# (word16ToWord# a#)+ !y# = word2Int# (word16ToWord# b#) !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10# !lower# = y# -# 0xDC00# {-# INLINE chr2 #-}
src/Data/Text/Internal/Encoding/Utf8.hs view
@@ -33,19 +33,17 @@ , validate4 ) where -#if defined(TEST_SUITE)-# undef ASSERTS-#endif--#if defined(ASSERTS)-import Control.Exception (assert)-#endif import Data.Bits ((.&.)) import Data.Text.Internal.Unsafe.Char (ord) import Data.Text.Internal.Unsafe.Shift (shiftR) import GHC.Exts import GHC.Word (Word8(..)) +#if !MIN_VERSION_base(4,16,0)+-- harmless to import, except for warnings that it is unused.+import Data.Text.Internal.PrimCompat (word8ToWord#)+#endif+ default(Int) between :: Word8 -- ^ byte to check@@ -57,45 +55,45 @@ ord2 :: Char -> (Word8,Word8) ord2 c =-#if defined(ASSERTS)- assert (n >= 0x80 && n <= 0x07ff)-#endif+ -- ord2 is used only in test suite to construct a deliberately invalid ByteString,+ -- actually violating the assertion, so it is commented out+ -- assert (n >= 0x80 && n <= 0x07ff) (x1,x2) where n = ord c- x1 = fromIntegral $ (n `shiftR` 6) + 0xC0- x2 = fromIntegral $ (n .&. 0x3F) + 0x80+ x1 = intToWord8 $ (n `shiftR` 6) + 0xC0+ x2 = intToWord8 $ (n .&. 0x3F) + 0x80 ord3 :: Char -> (Word8,Word8,Word8) ord3 c =-#if defined(ASSERTS)- assert (n >= 0x0800 && n <= 0xffff)-#endif+ -- ord3 is used only in test suite to construct a deliberately invalid ByteString,+ -- actually violating the assertion, so it is commented out+ -- assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3) where n = ord c- x1 = fromIntegral $ (n `shiftR` 12) + 0xE0- x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80- x3 = fromIntegral $ (n .&. 0x3F) + 0x80+ x1 = intToWord8 $ (n `shiftR` 12) + 0xE0+ x2 = intToWord8 $ ((n `shiftR` 6) .&. 0x3F) + 0x80+ x3 = intToWord8 $ (n .&. 0x3F) + 0x80 ord4 :: Char -> (Word8,Word8,Word8,Word8) ord4 c =-#if defined(ASSERTS)- assert (n >= 0x10000)-#endif+ -- ord4 is used only in test suite to construct a deliberately invalid ByteString,+ -- actually violating the assertion, so it is commented out+ -- assert (n >= 0x10000) (x1,x2,x3,x4) where n = ord c- x1 = fromIntegral $ (n `shiftR` 18) + 0xF0- x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80- x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80- x4 = fromIntegral $ (n .&. 0x3F) + 0x80+ x1 = intToWord8 $ (n `shiftR` 18) + 0xF0+ x2 = intToWord8 $ ((n `shiftR` 12) .&. 0x3F) + 0x80+ x3 = intToWord8 $ ((n `shiftR` 6) .&. 0x3F) + 0x80+ x4 = intToWord8 $ (n .&. 0x3F) + 0x80 chr2 :: Word8 -> Word8 -> Char chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#)) where- !y1# = word2Int# x1#- !y2# = word2Int# x2#+ !y1# = word2Int# (word8ToWord# x1#)+ !y2# = word2Int# (word8ToWord# x2#) !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6# !z2# = y2# -# 0x80# {-# INLINE chr2 #-}@@ -103,9 +101,9 @@ chr3 :: Word8 -> Word8 -> Word8 -> Char chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#)) where- !y1# = word2Int# x1#- !y2# = word2Int# x2#- !y3# = word2Int# x3#+ !y1# = word2Int# (word8ToWord# x1#)+ !y2# = word2Int# (word8ToWord# x2#)+ !y3# = word2Int# (word8ToWord# x3#) !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12# !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6# !z3# = y3# -# 0x80#@@ -115,10 +113,10 @@ chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = C# (chr# (z1# +# z2# +# z3# +# z4#)) where- !y1# = word2Int# x1#- !y2# = word2Int# x2#- !y3# = word2Int# x3#- !y4# = word2Int# x4#+ !y1# = word2Int# (word8ToWord# x1#)+ !y2# = word2Int# (word8ToWord# x2#)+ !y3# = word2Int# (word8ToWord# x3#)+ !y4# = word2Int# (word8ToWord# x4#) !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18# !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12# !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#@@ -166,3 +164,6 @@ between x2 0x80 0x8F && between x3 0x80 0xBF && between x4 0x80 0xBF++intToWord8 :: Int -> Word8+intToWord8 = fromIntegral
src/Data/Text/Internal/Functions.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | -- Module : Data.Text.Internal.Functions -- Copyright : 2010 Bryan O'Sullivan@@ -15,9 +17,18 @@ module Data.Text.Internal.Functions (- intersperse+ intersperse,+ unsafeWithForeignPtr ) where +import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (ForeignPtr)+#if MIN_VERSION_base(4,15,0)+import qualified GHC.ForeignPtr (unsafeWithForeignPtr)+#else+import qualified Foreign.ForeignPtr (withForeignPtr)+#endif+ -- | A lazier version of Data.List.intersperse. The other version -- causes space leaks! intersperse :: a -> [a] -> [a]@@ -27,3 +38,10 @@ go [] = [] go (y:ys) = sep : y: go ys {-# INLINE intersperse #-}++unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+#if MIN_VERSION_base(4,15,0)+unsafeWithForeignPtr = GHC.ForeignPtr.unsafeWithForeignPtr+#else+unsafeWithForeignPtr = Foreign.ForeignPtr.withForeignPtr+#endif
src/Data/Text/Internal/Fusion.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, MagicHash #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash #-} -- | -- Module : Data.Text.Internal.Fusion@@ -63,11 +63,20 @@ import Data.Text.Internal.Fusion.Size import qualified Data.Text.Internal as I import qualified Data.Text.Internal.Encoding.Utf16 as U16+import Data.Word (Word16) +#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif+ default(Int) -- | /O(n)/ Convert a 'Text' into a 'Stream Char'.-stream :: Text -> Stream Char+stream ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> Stream Char stream (Text arr off len) = Stream next off (betweenSize (len `shiftR` 1) len) where !end = off+len@@ -139,7 +148,11 @@ {-# INLINE[0] length #-} -- | /O(n)/ Reverse the characters of a string.-reverse :: Stream Char -> Text+reverse ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Stream Char -> Text reverse (Stream next s len0) | isEmpty len0 = I.empty | otherwise = I.text arr off' len'@@ -161,11 +174,11 @@ least | n < 0x10000 = 0 | otherwise = 1 m = n - 0x10000- lo = fromIntegral $ (m `shiftR` 10) + 0xD800- hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00+ lo = intToWord16 $ (m `shiftR` 10) + 0xD800+ hi = intToWord16 $ (m .&. 0x3FF) + 0xDC00 write t j l mar | n < 0x10000 = do- A.unsafeWrite mar j (fromIntegral n)+ A.unsafeWrite mar j (intToWord16 n) loop t (j-1) l mar | otherwise = do A.unsafeWrite mar (j-1) lo@@ -219,7 +232,11 @@ -- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a -- function to each element of a 'Text', passing an accumulating -- parameter from left to right, and returns a final 'Text'.-mapAccumL :: (a -> Char -> (a,Char)) -> a -> Stream Char -> (a, Text)+mapAccumL ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ (a -> Char -> (a,Char)) -> a -> Stream Char -> (a, Text) mapAccumL f z0 (Stream next0 s0 len) = (nz, I.text na 0 nl) where (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0)@@ -242,3 +259,6 @@ j | ord c < 0x10000 = i | otherwise = i + 1 {-# INLINE [0] mapAccumL #-}++intToWord16 :: Int -> Word16+intToWord16 = fromIntegral
src/Data/Text/Internal/Fusion/CaseMapping.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE Rank2Types #-} -- AUTOMATICALLY GENERATED - DO NOT EDIT -- Generated by scripts/CaseMapping.hs--- CaseFolding-9.0.0.txt--- Date: 2016-03-02, 18:54:54 GMT--- SpecialCasing-9.0.0.txt--- Date: 2016-03-02, 18:55:13 GMT+-- CaseFolding-13.0.0.txt+-- Date: 2019-09-08, 23:30:59 GMT+-- SpecialCasing-13.0.0.txt+-- Date: 2019-09-08, 23:31:24 GMT module Data.Text.Internal.Fusion.CaseMapping where import Data.Char@@ -563,16 +563,12 @@ foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9') -- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')--- LATIN CAPITAL LETTER SMALL CAPITAL I-foldMapping '\xa7ae' s = Yield '\x026a' (CC s '\x0000' '\x0000')--- LATIN CAPITAL LETTER J WITH CROSSED-TAIL-foldMapping '\xa7b2' s = Yield '\x029d' (CC s '\x0000' '\x0000')--- LATIN CAPITAL LETTER CHI-foldMapping '\xa7b3' s = Yield '\xab53' (CC s '\x0000' '\x0000')--- LATIN CAPITAL LETTER BETA-foldMapping '\xa7b4' s = Yield '\xa7b5' (CC s '\x0000' '\x0000')--- LATIN CAPITAL LETTER OMEGA-foldMapping '\xa7b6' s = Yield '\xa7b7' (CC s '\x0000' '\x0000')+-- LATIN CAPITAL LETTER D WITH SHORT STROKE OVERLAY+foldMapping '\xa7c7' s = Yield '\xa7c8' (CC s '\x0000' '\x0000')+-- LATIN CAPITAL LETTER S WITH SHORT STROKE OVERLAY+foldMapping '\xa7c9' s = Yield '\xa7ca' (CC s '\x0000' '\x0000')+-- LATIN CAPITAL LETTER REVERSED HALF H+foldMapping '\xa7f5' s = Yield '\xa7f6' (CC s '\x0000' '\x0000') -- CHEROKEE SMALL LETTER A foldMapping '\xab70' s = Yield '\x13a0' (CC s '\x0000' '\x0000') -- CHEROKEE SMALL LETTER E@@ -757,246 +753,4 @@ foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000') -- ARMENIAN SMALL LIGATURE MEN XEH foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')--- OSAGE CAPITAL LETTER A-foldMapping '\x104b0' s = Yield '\x104d8' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER AI-foldMapping '\x104b1' s = Yield '\x104d9' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER AIN-foldMapping '\x104b2' s = Yield '\x104da' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER AH-foldMapping '\x104b3' s = Yield '\x104db' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER BRA-foldMapping '\x104b4' s = Yield '\x104dc' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER CHA-foldMapping '\x104b5' s = Yield '\x104dd' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER EHCHA-foldMapping '\x104b6' s = Yield '\x104de' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER E-foldMapping '\x104b7' s = Yield '\x104df' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER EIN-foldMapping '\x104b8' s = Yield '\x104e0' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER HA-foldMapping '\x104b9' s = Yield '\x104e1' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER HYA-foldMapping '\x104ba' s = Yield '\x104e2' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER I-foldMapping '\x104bb' s = Yield '\x104e3' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER KA-foldMapping '\x104bc' s = Yield '\x104e4' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER EHKA-foldMapping '\x104bd' s = Yield '\x104e5' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER KYA-foldMapping '\x104be' s = Yield '\x104e6' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER LA-foldMapping '\x104bf' s = Yield '\x104e7' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER MA-foldMapping '\x104c0' s = Yield '\x104e8' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER NA-foldMapping '\x104c1' s = Yield '\x104e9' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER O-foldMapping '\x104c2' s = Yield '\x104ea' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER OIN-foldMapping '\x104c3' s = Yield '\x104eb' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER PA-foldMapping '\x104c4' s = Yield '\x104ec' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER EHPA-foldMapping '\x104c5' s = Yield '\x104ed' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER SA-foldMapping '\x104c6' s = Yield '\x104ee' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER SHA-foldMapping '\x104c7' s = Yield '\x104ef' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER TA-foldMapping '\x104c8' s = Yield '\x104f0' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER EHTA-foldMapping '\x104c9' s = Yield '\x104f1' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER TSA-foldMapping '\x104ca' s = Yield '\x104f2' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER EHTSA-foldMapping '\x104cb' s = Yield '\x104f3' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER TSHA-foldMapping '\x104cc' s = Yield '\x104f4' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER DHA-foldMapping '\x104cd' s = Yield '\x104f5' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER U-foldMapping '\x104ce' s = Yield '\x104f6' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER WA-foldMapping '\x104cf' s = Yield '\x104f7' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER KHA-foldMapping '\x104d0' s = Yield '\x104f8' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER GHA-foldMapping '\x104d1' s = Yield '\x104f9' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER ZA-foldMapping '\x104d2' s = Yield '\x104fa' (CC s '\x0000' '\x0000')--- OSAGE CAPITAL LETTER ZHA-foldMapping '\x104d3' s = Yield '\x104fb' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER A-foldMapping '\x10c80' s = Yield '\x10cc0' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER AA-foldMapping '\x10c81' s = Yield '\x10cc1' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EB-foldMapping '\x10c82' s = Yield '\x10cc2' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER AMB-foldMapping '\x10c83' s = Yield '\x10cc3' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EC-foldMapping '\x10c84' s = Yield '\x10cc4' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ENC-foldMapping '\x10c85' s = Yield '\x10cc5' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ECS-foldMapping '\x10c86' s = Yield '\x10cc6' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ED-foldMapping '\x10c87' s = Yield '\x10cc7' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER AND-foldMapping '\x10c88' s = Yield '\x10cc8' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER E-foldMapping '\x10c89' s = Yield '\x10cc9' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER CLOSE E-foldMapping '\x10c8a' s = Yield '\x10cca' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EE-foldMapping '\x10c8b' s = Yield '\x10ccb' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EF-foldMapping '\x10c8c' s = Yield '\x10ccc' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EG-foldMapping '\x10c8d' s = Yield '\x10ccd' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EGY-foldMapping '\x10c8e' s = Yield '\x10cce' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EH-foldMapping '\x10c8f' s = Yield '\x10ccf' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER I-foldMapping '\x10c90' s = Yield '\x10cd0' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER II-foldMapping '\x10c91' s = Yield '\x10cd1' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EJ-foldMapping '\x10c92' s = Yield '\x10cd2' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EK-foldMapping '\x10c93' s = Yield '\x10cd3' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER AK-foldMapping '\x10c94' s = Yield '\x10cd4' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER UNK-foldMapping '\x10c95' s = Yield '\x10cd5' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EL-foldMapping '\x10c96' s = Yield '\x10cd6' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ELY-foldMapping '\x10c97' s = Yield '\x10cd7' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EM-foldMapping '\x10c98' s = Yield '\x10cd8' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EN-foldMapping '\x10c99' s = Yield '\x10cd9' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ENY-foldMapping '\x10c9a' s = Yield '\x10cda' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER O-foldMapping '\x10c9b' s = Yield '\x10cdb' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER OO-foldMapping '\x10c9c' s = Yield '\x10cdc' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG OE-foldMapping '\x10c9d' s = Yield '\x10cdd' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA OE-foldMapping '\x10c9e' s = Yield '\x10cde' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER OEE-foldMapping '\x10c9f' s = Yield '\x10cdf' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EP-foldMapping '\x10ca0' s = Yield '\x10ce0' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EMP-foldMapping '\x10ca1' s = Yield '\x10ce1' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ER-foldMapping '\x10ca2' s = Yield '\x10ce2' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER SHORT ER-foldMapping '\x10ca3' s = Yield '\x10ce3' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ES-foldMapping '\x10ca4' s = Yield '\x10ce4' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ESZ-foldMapping '\x10ca5' s = Yield '\x10ce5' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ET-foldMapping '\x10ca6' s = Yield '\x10ce6' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ENT-foldMapping '\x10ca7' s = Yield '\x10ce7' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ETY-foldMapping '\x10ca8' s = Yield '\x10ce8' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ECH-foldMapping '\x10ca9' s = Yield '\x10ce9' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER U-foldMapping '\x10caa' s = Yield '\x10cea' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER UU-foldMapping '\x10cab' s = Yield '\x10ceb' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG UE-foldMapping '\x10cac' s = Yield '\x10cec' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA UE-foldMapping '\x10cad' s = Yield '\x10ced' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EV-foldMapping '\x10cae' s = Yield '\x10cee' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EZ-foldMapping '\x10caf' s = Yield '\x10cef' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER EZS-foldMapping '\x10cb0' s = Yield '\x10cf0' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER ENT-SHAPED SIGN-foldMapping '\x10cb1' s = Yield '\x10cf1' (CC s '\x0000' '\x0000')--- OLD HUNGARIAN CAPITAL LETTER US-foldMapping '\x10cb2' s = Yield '\x10cf2' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER ALIF-foldMapping '\x1e900' s = Yield '\x1e922' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER DAALI-foldMapping '\x1e901' s = Yield '\x1e923' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER LAAM-foldMapping '\x1e902' s = Yield '\x1e924' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER MIIM-foldMapping '\x1e903' s = Yield '\x1e925' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER BA-foldMapping '\x1e904' s = Yield '\x1e926' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER SINNYIIYHE-foldMapping '\x1e905' s = Yield '\x1e927' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER PE-foldMapping '\x1e906' s = Yield '\x1e928' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER BHE-foldMapping '\x1e907' s = Yield '\x1e929' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER RA-foldMapping '\x1e908' s = Yield '\x1e92a' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER E-foldMapping '\x1e909' s = Yield '\x1e92b' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER FA-foldMapping '\x1e90a' s = Yield '\x1e92c' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER I-foldMapping '\x1e90b' s = Yield '\x1e92d' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER O-foldMapping '\x1e90c' s = Yield '\x1e92e' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER DHA-foldMapping '\x1e90d' s = Yield '\x1e92f' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER YHE-foldMapping '\x1e90e' s = Yield '\x1e930' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER WAW-foldMapping '\x1e90f' s = Yield '\x1e931' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER NUN-foldMapping '\x1e910' s = Yield '\x1e932' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER KAF-foldMapping '\x1e911' s = Yield '\x1e933' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER YA-foldMapping '\x1e912' s = Yield '\x1e934' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER U-foldMapping '\x1e913' s = Yield '\x1e935' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER JIIM-foldMapping '\x1e914' s = Yield '\x1e936' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER CHI-foldMapping '\x1e915' s = Yield '\x1e937' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER HA-foldMapping '\x1e916' s = Yield '\x1e938' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER QAAF-foldMapping '\x1e917' s = Yield '\x1e939' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER GA-foldMapping '\x1e918' s = Yield '\x1e93a' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER NYA-foldMapping '\x1e919' s = Yield '\x1e93b' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER TU-foldMapping '\x1e91a' s = Yield '\x1e93c' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER NHA-foldMapping '\x1e91b' s = Yield '\x1e93d' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER VA-foldMapping '\x1e91c' s = Yield '\x1e93e' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER KHA-foldMapping '\x1e91d' s = Yield '\x1e93f' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER GBE-foldMapping '\x1e91e' s = Yield '\x1e940' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER ZAL-foldMapping '\x1e91f' s = Yield '\x1e941' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER KPO-foldMapping '\x1e920' s = Yield '\x1e942' (CC s '\x0000' '\x0000')--- ADLAM CAPITAL LETTER SHA-foldMapping '\x1e921' s = Yield '\x1e943' (CC s '\x0000' '\x0000') foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
src/Data/Text/Internal/Fusion/Common.hs view
@@ -322,6 +322,7 @@ -- Note that @len@ tracks code units whereas we want to compare the length -- in code points. Specifically, a stream with hint @len@ may consist of -- anywhere from @len/2@ to @len@ code points.+ | n < 0 = GT | Just r <- compareSize len n' = r | otherwise = loop_cmp 0 s0 where@@ -687,7 +688,7 @@ replicateI :: Int64 -> Stream Char -> Stream Char replicateI n (Stream next0 s0 len) =- Stream next (RI s0 0) (fromIntegral (max 0 n) * len)+ Stream next (RI s0 0) (int64ToSize (max 0 n) * len) where next (RI s k) | k >= n = Done@@ -947,3 +948,6 @@ internalError :: String -> a internalError func = streamError func "Internal error"++int64ToSize :: Int64 -> Size+int64ToSize = fromIntegral
src/Data/Text/Internal/Lazy/Encoding/Fusion.hs view
@@ -35,24 +35,25 @@ import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B+import Data.Text.Internal.ByteStringCompat import Data.Text.Internal.Encoding.Fusion.Common import Data.Text.Encoding.Error import Data.Text.Internal.Fusion (Step(..), Stream(..)) import Data.Text.Internal.Fusion.Size import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32) import Data.Text.Internal.Unsafe.Shift (shiftL)+import Data.Text.Internal.Functions (unsafeWithForeignPtr) import Data.Word (Word8, Word16, Word32) import qualified Data.Text.Internal.Encoding.Utf8 as U8 import qualified Data.Text.Internal.Encoding.Utf16 as U16 import qualified Data.Text.Internal.Encoding.Utf32 as U32 import Data.Text.Unsafe (unsafeDupablePerformIO)-import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)+import Foreign.ForeignPtr (ForeignPtr) import Foreign.Storable (pokeByteOff) import Data.ByteString.Internal (mallocByteString, memcpy) #if defined(ASSERTS) import Control.Exception (assert) #endif-import Data.Text.Internal.ByteStringCompat data S = S0 | S1 {-# UNPACK #-} !Word8@@ -118,7 +119,7 @@ x1 = c (idx i) (idx (i + 1)) x2 = c (idx (i + 2)) (idx (i + 3)) c w1 w2 = w1 + (w2 `shiftL` 8)- idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16+ idx = word8ToWord16 . B.unsafeIndex ps :: Int -> Word16 next st@(T bs s i) = case s of S2 w1 w2 | U16.validate1 (c w1 w2) ->@@ -128,7 +129,7 @@ _ -> consume st where es = T bs S0 i c :: Word8 -> Word8 -> Word16- c w1 w2 = fromIntegral w1 + (fromIntegral w2 `shiftL` 8)+ c w1 w2 = word8ToWord16 w1 + (word8ToWord16 w2 `shiftL` 8) consume (T bs@(Chunk ps rest) s i) | i >= B.length ps = consume (T rest s 0) | otherwise =@@ -158,7 +159,7 @@ x1 = c (idx i) (idx (i + 1)) x2 = c (idx (i + 2)) (idx (i + 3)) c w1 w2 = (w1 `shiftL` 8) + w2- idx = fromIntegral . B.unsafeIndex ps :: Int -> Word16+ idx = word8ToWord16 . B.unsafeIndex ps :: Int -> Word16 next st@(T bs s i) = case s of S2 w1 w2 | U16.validate1 (c w1 w2) ->@@ -168,7 +169,7 @@ _ -> consume st where es = T bs S0 i c :: Word8 -> Word8 -> Word16- c w1 w2 = (fromIntegral w1 `shiftL` 8) + fromIntegral w2+ c w1 w2 = (word8ToWord16 w1 `shiftL` 8) + word8ToWord16 w2 consume (T bs@(Chunk ps rest) s i) | i >= B.length ps = consume (T rest s 0) | otherwise =@@ -198,7 +199,7 @@ x2 = idx (i+1) x3 = idx (i+2) x4 = idx (i+3)- idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32+ idx = word8ToWord32 . B.unsafeIndex ps :: Int -> Word32 next st@(T bs s i) = case s of S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) ->@@ -209,10 +210,10 @@ c w1 w2 w3 w4 = shifted where shifted = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4- x1 = fromIntegral w1- x2 = fromIntegral w2- x3 = fromIntegral w3- x4 = fromIntegral w4+ x1 = word8ToWord32 w1+ x2 = word8ToWord32 w2+ x3 = word8ToWord32 w3+ x4 = word8ToWord32 w4 consume (T bs@(Chunk ps rest) s i) | i >= B.length ps = consume (T rest s 0) | otherwise =@@ -242,7 +243,7 @@ x2 = idx (i+1) x3 = idx (i+2) x4 = idx (i+3)- idx = fromIntegral . B.unsafeIndex ps :: Int -> Word32+ idx = word8ToWord32 . B.unsafeIndex ps :: Int -> Word32 next st@(T bs s i) = case s of S4 w1 w2 w3 w4 | U32.validate (c w1 w2 w3 w4) ->@@ -253,10 +254,10 @@ c w1 w2 w3 w4 = shifted where shifted = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1- x1 = fromIntegral w1- x2 = fromIntegral w2- x3 = fromIntegral w3- x4 = fromIntegral w4+ x1 = word8ToWord32 w1+ x2 = word8ToWord32 w2+ x3 = word8ToWord32 w3+ x4 = word8ToWord32 w4 consume (T bs@(Chunk ps rest) s i) | i >= B.length ps = consume (T rest s 0) | otherwise =@@ -289,13 +290,13 @@ return $! Chunk (trimUp fp off) (chunk s newLen) | off == n -> realloc fp n off s' x | otherwise -> do- withForeignPtr fp $ \p -> pokeByteOff p off x+ unsafeWithForeignPtr fp $ \p -> pokeByteOff p off x loop n (off+1) s' fp {-# NOINLINE realloc #-} realloc fp n off s x = do let n' = min (n+n) chunkSize fp' <- copy0 fp n n'- withForeignPtr fp' $ \p -> pokeByteOff p off x+ unsafeWithForeignPtr fp' $ \p -> pokeByteOff p off x loop n' (off+1) s fp' trimUp fp off = mkBS fp off copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)@@ -305,9 +306,9 @@ #endif do dest <- mallocByteString destLen- withForeignPtr src $ \src' ->- withForeignPtr dest $ \dest' ->- memcpy dest' src' (fromIntegral srcLen)+ unsafeWithForeignPtr src $ \src' ->+ unsafeWithForeignPtr dest $ \dest' ->+ memcpy dest' src' srcLen return dest -- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.@@ -322,3 +323,9 @@ Just c -> Yield c i where desc = "Data.Text.Lazy.Encoding.Fusion." ++ func ++ ": Invalid " ++ kind ++ " stream"++word8ToWord16 :: Word8 -> Word16+word8ToWord16 = fromIntegral++word8ToWord32 :: Word8 -> Word32+word8ToWord32 = fromIntegral
src/Data/Text/Internal/Lazy/Fusion.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, CPP #-} -- | -- Module : Data.Text.Lazy.Fusion -- Copyright : (c) 2009, 2010 Bryan O'Sullivan@@ -37,11 +37,18 @@ import Data.Text.Internal.Unsafe.Shift (shiftL) import Data.Text.Unsafe (Iter(..), iter) import Data.Int (Int64)+#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif default(Int64) -- | /O(n)/ Convert a 'Text' into a 'Stream Char'.-stream :: Text -> Stream Char+stream ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> Stream Char stream text = Stream next (text :*: 0) unknownSize where next (Empty :*: _) = Done@@ -53,7 +60,11 @@ -- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given -- chunk size.-unstreamChunks :: Int -> Stream Char -> Text+unstreamChunks ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Int -> Stream Char -> Text unstreamChunks !chunkSize (Stream next s0 len0) | isEmpty len0 = Empty | otherwise = outer s0@@ -88,7 +99,11 @@ -- | /O(n)/ Convert a 'Stream Char' into a 'Text', using -- 'defaultChunkSize'.-unstream :: Stream Char -> Text+unstream ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Stream Char -> Text unstream = unstreamChunks defaultChunkSize {-# INLINE [0] unstream #-}
src/Data/Text/Internal/Lazy/Search.hs view
@@ -57,7 +57,7 @@ | c == z && candidateMatch 0 = g : scan (g+nlen) (i+nlen) | otherwise = scan (g+delta) (i+delta) where- m = fromIntegral l+ m = intToInt64 l c = hindex (i + nlast) delta | nextInPattern = nlen + 1 | c == z = skip + 1@@ -74,7 +74,10 @@ z = foldlChunks fin 0 needle where fin _ (T.Text farr foff flen) = A.unsafeIndex farr (foff+flen-1) (mask :: Word64) :*: skip = buildTable n ns 0 0 0 (nlen-2)- swizzle w = 1 `shiftL` (fromIntegral w .&. 0x3f)++ swizzle :: Word16 -> Word64+ swizzle w = 1 `shiftL` (word16ToInt w .&. 0x3f)+ buildTable (T.Text xarr xoff xlen) xs = go where go !(g::Int64) !i !msk !skp@@ -87,14 +90,16 @@ skp' | c == z = nlen - g - 2 | otherwise = skp xlast = xlen - 1+ -- | Check whether an attempt to index into the haystack at the -- given offset would fail.+ lackingHay :: Int64 -> T.Text -> Text -> Bool lackingHay q = go 0 where go p (T.Text _ _ l) ps = p' < q && case ps of Empty -> True Chunk r rs -> go p' r rs- where p' = p + fromIntegral l+ where p' = p + intToInt64 l indices _ _ = [] -- | Fast index into a partly unpacked 'Text'. We take into account@@ -109,26 +114,38 @@ | j == len -> 0 -- should never happen, due to lackingHay above | otherwise -> emptyError "index"- Chunk c cs -> index c cs (i-fromIntegral len)- where j = fromIntegral i+ Chunk c cs -> index c cs (i-intToInt64 len)+ where j = int64ToInt i -- | A variant of 'indices' that scans linearly for a single 'Word16'. indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64] indicesOne c = chunk where+ chunk :: Int64 -> T.Text -> Text -> [Int64] chunk !i (T.Text oarr ooff olen) os = go 0 where go h | h >= olen = case os of Empty -> []- Chunk y ys -> chunk (i+fromIntegral olen) y ys- | on == c = i + fromIntegral h : go (h+1)+ Chunk y ys -> chunk (i+intToInt64 olen) y ys+ | on == c = i + intToInt64 h : go (h+1) | otherwise = go (h+1) where on = A.unsafeIndex oarr (ooff+h) -- | The number of 'Word16' values in a 'Text'. wordLength :: Text -> Int64 wordLength = foldlChunks sumLength 0- where sumLength i (T.Text _ _ l) = i + fromIntegral l+ where+ sumLength :: Int64 -> T.Text -> Int64+ sumLength i (T.Text _ _ l) = i + intToInt64 l emptyError :: String -> a emptyError fun = error ("Data.Text.Lazy.Search." ++ fun ++ ": empty input")++intToInt64 :: Int -> Int64+intToInt64 = fromIntegral++int64ToInt :: Int64 -> Int+int64ToInt = fromIntegral++word16ToInt :: Word16 -> Int+word16ToInt = fromIntegral
+ src/Data/Text/Internal/PrimCompat.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++module Data.Text.Internal.PrimCompat+ ( word8ToWord#+ , wordToWord8#++ , word16ToWord#+ , wordToWord16#++ , wordToWord32#+ , word32ToWord#+ ) where++#if MIN_VERSION_base(4,16,0)++import GHC.Base++#else++import GHC.Prim (Word#)++wordToWord8#, word8ToWord# :: Word# -> Word#+wordToWord16#, word16ToWord# :: Word# -> Word#+wordToWord32#, word32ToWord# :: Word# -> Word#+word8ToWord# w = w+word16ToWord# w = w+word32ToWord# w = w+wordToWord8# w = w+wordToWord16# w = w+wordToWord32# w = w+{-# INLINE wordToWord16# #-}+{-# INLINE word16ToWord# #-}+{-# INLINE wordToWord32# #-}+{-# INLINE word32ToWord# #-}++#endif
src/Data/Text/Internal/Private.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, Rank2Types, UnboxedTuples #-} -- | -- Module : Data.Text.Internal.Private@@ -20,6 +20,10 @@ import Data.Text.Unsafe (Iter(..), iter) import qualified Data.Text.Array as A +#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif+ span_ :: (Char -> Bool) -> Text -> (# Text, Text #) span_ p t@(Text arr off len) = (# hd,tl #) where hd = text arr off k@@ -30,7 +34,11 @@ where Iter c d = iter t i {-# INLINE span_ #-} -runText :: (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text+runText ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text runText act = runST (act $ \ !marr !len -> do arr <- A.unsafeFreeze marr return $! text arr 0 len)
src/Data/Text/Internal/Search.hs view
@@ -32,7 +32,7 @@ ) where import qualified Data.Text.Array as A-import Data.Word (Word64)+import Data.Word (Word64, Word16) import Data.Text.Internal (Text(..)) import Data.Bits ((.|.), (.&.)) import Data.Text.Internal.Unsafe.Shift (shiftL)@@ -67,7 +67,10 @@ where c = nindex i skp' | c == z = nlen - i - 2 | otherwise = skp- swizzle k = 1 `shiftL` (fromIntegral k .&. 0x3f)++ swizzle :: Word16 -> Word64+ swizzle k = 1 `shiftL` (word16ToInt k .&. 0x3f)+ scan !i | i > ldiff = [] | c == z && candidateMatch 0 = i : scan (i + nlen)@@ -87,3 +90,6 @@ | hindex i == c = i : loop (i+1) | otherwise = loop (i+1) {-# INLINE indices #-}++word16ToInt :: Word16 -> Int+word16ToInt = fromIntegral
src/Data/Text/Internal/Unsafe.hs view
@@ -22,24 +22,17 @@ ) where import GHC.ST (ST(..))-#if defined(__GLASGOW_HASKELL__) import GHC.IO (IO(IO)) import GHC.Base (realWorld#)-#endif - -- | Just like unsafePerformIO, but we inline it. Big performance gains as -- it exposes lots of things to further inlining. /Very unsafe/. In -- particular, you should do no memory allocation inside an--- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.+-- 'inlinePerformIO' block. -- {-# INLINE inlinePerformIO #-} inlinePerformIO :: IO a -> a-#if defined(__GLASGOW_HASKELL__) inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-#else-inlinePerformIO = unsafePerformIO-#endif -- | Allow an 'ST' computation to be deferred lazily. When passed an -- action of type 'ST' @s@ @a@, the action will only be performed when
src/Data/Text/Internal/Unsafe/Char.hs view
@@ -23,73 +23,55 @@ , unsafeChr8 , unsafeChr32 , unsafeWrite- -- , unsafeWriteRev ) where -#ifdef ASSERTS-import Control.Exception (assert)-#endif import Control.Monad.ST (ST) import Data.Bits ((.&.)) import Data.Text.Internal.Unsafe.Shift (shiftR) import GHC.Exts (Char(..), Int(..), chr#, ord#, word2Int#) import GHC.Word (Word8(..), Word16(..), Word32(..)) import qualified Data.Text.Array as A+import Data.Text.Internal.PrimCompat ( word8ToWord#, word16ToWord#, word32ToWord# )+#if defined(ASSERTS)+import GHC.Stack (HasCallStack)+#endif ord :: Char -> Int ord (C# c#) = I# (ord# c#) {-# INLINE ord #-} unsafeChr :: Word16 -> Char-unsafeChr (W16# w#) = C# (chr# (word2Int# w#))+unsafeChr (W16# w#) = C# (chr# (word2Int# (word16ToWord# w#))) {-# INLINE unsafeChr #-} unsafeChr8 :: Word8 -> Char-unsafeChr8 (W8# w#) = C# (chr# (word2Int# w#))+unsafeChr8 (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) {-# INLINE unsafeChr8 #-} unsafeChr32 :: Word32 -> Char-unsafeChr32 (W32# w#) = C# (chr# (word2Int# w#))+unsafeChr32 (W32# w#) = C# (chr# (word2Int# (word32ToWord# w#))) {-# INLINE unsafeChr32 #-} -- | Write a character into the array at the given offset. Returns -- the number of 'Word16's written.-unsafeWrite :: A.MArray s -> Int -> Char -> ST s Int-unsafeWrite marr i c- | n < 0x10000 = do+unsafeWrite :: #if defined(ASSERTS)- assert (i >= 0) . assert (i < A.length marr) $ return ()+ HasCallStack => #endif- A.unsafeWrite marr i (fromIntegral n)+ A.MArray s -> Int -> Char -> ST s Int+unsafeWrite marr i c+ | n < 0x10000 = do+ A.unsafeWrite marr i (intToWord16 n) return 1 | otherwise = do-#if defined(ASSERTS)- assert (i >= 0) . assert (i < A.length marr - 1) $ return ()-#endif A.unsafeWrite marr i lo A.unsafeWrite marr (i+1) hi return 2 where n = ord c m = n - 0x10000- lo = fromIntegral $ (m `shiftR` 10) + 0xD800- hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00+ lo = intToWord16 $ (m `shiftR` 10) + 0xD800+ hi = intToWord16 $ (m .&. 0x3FF) + 0xDC00 {-# INLINE unsafeWrite #-} -{--unsafeWriteRev :: A.MArray s Word16 -> Int -> Char -> ST s Int-unsafeWriteRev marr i c- | n < 0x10000 = do- assert (i >= 0) . assert (i < A.length marr) $- A.unsafeWrite marr i (fromIntegral n)- return (i-1)- | otherwise = do- assert (i >= 1) . assert (i < A.length marr) $- A.unsafeWrite marr (i-1) lo- A.unsafeWrite marr i hi- return (i-2)- where n = ord c- m = n - 0x10000- lo = fromIntegral $ (m `shiftR` 10) + 0xD800- hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00-{-# INLINE unsafeWriteRev #-}--}+intToWord16 :: Int -> Word16+intToWord16 = fromIntegral
src/Data/Text/Internal/Unsafe/Shift.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MagicHash #-} -- |@@ -20,9 +22,8 @@ UnsafeShift(..) ) where --- import qualified Data.Bits as Bits-import GHC.Base-import GHC.Word+import qualified Data.Bits as Bits+import Data.Word -- | This is a workaround for poor optimisation in GHC 6.8.2. It -- fails to notice constant-width shifts, and adds a test and branch@@ -32,41 +33,16 @@ -- greater than the size in bits of a machine Int#. class UnsafeShift a where shiftL :: a -> Int -> a- shiftR :: a -> Int -> a--instance UnsafeShift Word16 where {-# INLINE shiftL #-}- shiftL (W16# x#) (I# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` i#))+ default shiftL :: Bits.Bits a => a -> Int -> a+ shiftL = Bits.unsafeShiftL + shiftR :: a -> Int -> a {-# INLINE shiftR #-}- shiftR (W16# x#) (I# i#) = W16# (x# `uncheckedShiftRL#` i#)+ default shiftR :: Bits.Bits a => a -> Int -> a+ shiftR = Bits.unsafeShiftR +instance UnsafeShift Word16 where instance UnsafeShift Word32 where- {-# INLINE shiftL #-}- shiftL (W32# x#) (I# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` i#))-- {-# INLINE shiftR #-}- shiftR (W32# x#) (I# i#) = W32# (x# `uncheckedShiftRL#` i#)- instance UnsafeShift Word64 where- {-# INLINE shiftL #-}- shiftL (W64# x#) (I# i#) = W64# (x# `uncheckedShiftL64#` i#)-- {-# INLINE shiftR #-}- shiftR (W64# x#) (I# i#) = W64# (x# `uncheckedShiftRL64#` i#)- instance UnsafeShift Int where- {-# INLINE shiftL #-}- shiftL (I# x#) (I# i#) = I# (x# `iShiftL#` i#)-- {-# INLINE shiftR #-}- shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)--{--instance UnsafeShift Integer where- {-# INLINE shiftL #-}- shiftL = Bits.shiftL-- {-# INLINE shiftR #-}- shiftR = Bits.shiftR--}
src/Data/Text/Lazy.hs view
@@ -1,19 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns, MagicHash, CPP, TypeFamilies #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif--- Using TemplateHaskell in text unconditionally is unacceptable, as--- it's a GHC boot library. TemplateHaskellQuotes was added in 8.0, so--- this would seem to be a problem. However, GHC's policy of only--- needing to be able to compile itself from the last few releases--- allows us to use full-fat TH on older versions, while using THQ for--- GHC versions that may be used for bootstrapping.-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-}-#else-{-# LANGUAGE TemplateHaskell #-}-#endif -- | -- Module : Data.Text.Lazy@@ -191,6 +179,7 @@ -- * Searching , filter , find+ , elem , breakOnAll , partition @@ -221,9 +210,7 @@ Constr, mkConstr, DataType, mkDataType, Fixity(Prefix)) import Data.Binary (Binary(get, put)) import Data.Monoid (Monoid(..))-#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..))-#endif import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Text.Internal as T@@ -238,19 +225,15 @@ import Data.Text.Lazy.Encoding (decodeUtf8', encodeUtf8) import qualified Data.Text.Internal.Functions as F import Data.Text.Internal.Lazy.Search (indices)-#if __GLASGOW_HASKELL__ >= 702 import qualified GHC.CString as GHC-#else-import qualified GHC.Base as GHC-#endif-#if MIN_VERSION_base(4,7,0) import qualified GHC.Exts as Exts-#endif import GHC.Prim (Addr#) import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH-#if MIN_VERSION_base(4,7,0) import Text.Printf (PrintfArg, formatArg, formatString)++#if defined(ASSERTS)+import GHC.Stack (HasCallStack) #endif -- $fusion@@ -356,37 +339,23 @@ instance Read Text where readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str] -#if MIN_VERSION_base(4,9,0)--- | Non-orphan 'Semigroup' instance only defined for--- @base-4.9.0.0@ and later; orphan instances for older GHCs are--- provided by--- the [semigroups](http://hackage.haskell.org/package/semigroups)--- package------ @since 1.2.2.0+-- | @since 1.2.2.0 instance Semigroup Text where (<>) = append-#endif instance Monoid Text where mempty = empty-#if MIN_VERSION_base(4,9,0)- mappend = (<>) -- future-proof definition-#else- mappend = append-#endif+ mappend = (<>) mconcat = concat instance IsString Text where fromString = pack -#if MIN_VERSION_base(4,7,0) -- | @since 1.2.0.0 instance Exts.IsList Text where type Item Text = Char fromList = pack toList = unpack-#endif instance NFData Text where rnf Empty = ()@@ -426,13 +395,9 @@ liftTyped = TH.unsafeTExpCoerce . TH.lift #endif -#if MIN_VERSION_base(4,7,0)--- | Only defined for @base-4.7.0.0@ and later------ @since 1.2.2.0+-- | @since 1.2.2.0 instance PrintfArg Text where formatArg txt = formatString $ unpack txt-#endif packConstr :: Constr packConstr = mkConstr textDataType "pack" [] Prefix@@ -443,13 +408,21 @@ -- | /O(n)/ Convert a 'String' into a 'Text'. -- -- Subject to fusion. Performs replacement on invalid scalar values.-pack :: String -> Text+pack ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ String -> Text pack = unstream . S.streamList . L.map safe {-# INLINE [1] pack #-} -- | /O(n)/ Convert a 'Text' into a 'String'. -- Subject to fusion.-unpack :: Text -> String+unpack ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> String unpack t = S.unstreamList (stream t) {-# INLINE [1] unpack #-} @@ -643,7 +616,9 @@ -- Subject to fusion. length :: Text -> Int64 length = foldlChunks go 0- where go l t = l + fromIntegral (T.length t)+ where+ go :: Int64 -> T.Text -> Int64+ go l t = l + intToInt64 (T.length t) {-# INLINE [1] length #-} {-# RULES@@ -752,7 +727,11 @@ -- TODO: make this fast -- | /O(n)/ 'reverse' @t@ returns the elements of @t@ in reverse order.-reverse :: Text -> Text+reverse ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> Text reverse = rev Empty where rev a Empty = a rev a (Chunk t ts) = rev (Chunk (T.reverse t) a) ts@@ -1093,12 +1072,14 @@ take :: Int64 -> Text -> Text take i _ | i <= 0 = Empty take i t0 = take' i t0- where take' 0 _ = Empty- take' _ Empty = Empty- take' n (Chunk t ts)- | n < len = Chunk (T.take (fromIntegral n) t) Empty- | otherwise = Chunk t (take' (n - len) ts)- where len = fromIntegral (T.length t)+ where+ take' :: Int64 -> Text -> Text+ take' 0 _ = Empty+ take' _ Empty = Empty+ take' n (Chunk t ts)+ | n < len = Chunk (T.take (int64ToInt n) t) Empty+ | otherwise = Chunk t (take' (n - len) ts)+ where len = intToInt64 (T.length t) {-# INLINE [1] take #-} {-# RULES@@ -1120,11 +1101,13 @@ takeEnd n t0 | n <= 0 = empty | otherwise = takeChunk n empty . L.reverse . toChunks $ t0- where takeChunk _ acc [] = acc- takeChunk i acc (t:ts)- | i <= l = chunk (T.takeEnd (fromIntegral i) t) acc- | otherwise = takeChunk (i-l) (Chunk t acc) ts- where l = fromIntegral (T.length t)+ where+ takeChunk :: Int64 -> Text -> [T.Text] -> Text+ takeChunk _ acc [] = acc+ takeChunk i acc (t:ts)+ | i <= l = chunk (T.takeEnd (int64ToInt i) t) acc+ | otherwise = takeChunk (i-l) (Chunk t acc) ts+ where l = intToInt64 (T.length t) -- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the -- 'Text' after the first @n@ characters, or the empty 'Text' if @n@@@ -1133,12 +1116,14 @@ drop i t0 | i <= 0 = t0 | otherwise = drop' i t0- where drop' 0 ts = ts- drop' _ Empty = Empty- drop' n (Chunk t ts)- | n < len = Chunk (T.drop (fromIntegral n) t) ts- | otherwise = drop' (n - len) ts- where len = fromIntegral (T.length t)+ where+ drop' :: Int64 -> Text -> Text+ drop' 0 ts = ts+ drop' _ Empty = Empty+ drop' n (Chunk t ts)+ | n < len = Chunk (T.drop (int64ToInt n) t) ts+ | otherwise = drop' (n - len) ts+ where len = intToInt64 (T.length t) {-# INLINE [1] drop #-} {-# RULES@@ -1160,12 +1145,14 @@ dropEnd n t0 | n <= 0 = t0 | otherwise = dropChunk n . L.reverse . toChunks $ t0- where dropChunk _ [] = empty- dropChunk m (t:ts)- | m >= l = dropChunk (m-l) ts- | otherwise = fromChunks . L.reverse $- T.dropEnd (fromIntegral m) t : ts- where l = fromIntegral (T.length t)+ where+ dropChunk :: Int64 -> [T.Text] -> Text+ dropChunk _ [] = empty+ dropChunk m (t:ts)+ | m >= l = dropChunk (m-l) ts+ | otherwise = fromChunks . L.reverse $+ T.dropEnd (int64ToInt m) t : ts+ where l = intToInt64 (T.length t) -- | /O(n)/ 'dropWords' @n@ returns the suffix with @n@ 'Word16' -- values dropped, or the empty 'Text' if @n@ is greater than the@@ -1174,13 +1161,15 @@ dropWords i t0 | i <= 0 = t0 | otherwise = drop' i t0- where drop' 0 ts = ts- drop' _ Empty = Empty- drop' n (Chunk (T.Text arr off len) ts)- | n < len' = chunk (text arr (off+n') (len-n')) ts- | otherwise = drop' (n - len') ts- where len' = fromIntegral len- n' = fromIntegral n+ where+ drop' :: Int64 -> Text -> Text+ drop' 0 ts = ts+ drop' _ Empty = Empty+ drop' n (Chunk (T.Text arr off len) ts)+ | n < len' = chunk (text arr (off+n') (len-n')) ts+ | otherwise = drop' (n - len') ts+ where len' = intToInt64 len+ n' = int64ToInt n -- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text', -- returns the longest prefix (possibly empty) of elements that@@ -1290,14 +1279,16 @@ -- the string. It is equivalent to @('take' n t, 'drop' n t)@. splitAt :: Int64 -> Text -> (Text, Text) splitAt = loop- where loop _ Empty = (empty, empty)- loop n t | n <= 0 = (empty, t)- loop n (Chunk t ts)- | n < len = let (t',t'') = T.splitAt (fromIntegral n) t- in (Chunk t' Empty, Chunk t'' ts)- | otherwise = let (ts',ts'') = loop (n - len) ts- in (Chunk t ts', ts'')- where len = fromIntegral (T.length t)+ where+ loop :: Int64 -> Text -> (Text, Text)+ loop _ Empty = (empty, empty)+ loop n t | n <= 0 = (empty, t)+ loop n (Chunk t ts)+ | n < len = let (t',t'') = T.splitAt (int64ToInt n) t+ in (Chunk t' Empty, Chunk t'' ts)+ | otherwise = let (ts',ts'') = loop (n - len) ts+ in (Chunk t ts', ts'')+ where len = intToInt64 (T.length t) -- | /O(n)/ 'splitAtWord' @n t@ returns a strict pair whose first -- element is a prefix of @t@ whose chunks contain @n@ 'Word16'@@ -1305,11 +1296,11 @@ splitAtWord :: Int64 -> Text -> PairS Text Text splitAtWord _ Empty = empty :*: empty splitAtWord x (Chunk c@(T.Text arr off len) cs)- | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs+ | y >= len = let h :*: t = splitAtWord (x-intToInt64 len) cs in Chunk c h :*: t | otherwise = chunk (text arr off y) empty :*: chunk (text arr (off+y) (len-y)) cs- where y = fromIntegral x+ where y = int64ToInt x -- | /O(n+m)/ Find the first instance of @needle@ (which must be -- non-'null') in @haystack@. The first element of the returned tuple@@ -1495,7 +1486,7 @@ go _ [] cs = [cs] go !i (x:xs) cs = let h :*: t = splitAtWord (x-i) cs in h : go (x+l) xs (dropWords l t)- l = foldlChunks (\a (T.Text _ _ b) -> a + fromIntegral b) 0 pat+ l = foldlChunks (\a (T.Text _ _ b) -> a + intToInt64 b) 0 pat {-# INLINE [1] splitOn #-} {-# RULES@@ -1697,6 +1688,13 @@ find p t = S.findBy p (stream t) {-# INLINE find #-} +-- | /O(n)/ The 'elem' function takes a character and a 'Text', and+-- returns 'True' if the element is found in the given 'Text', or+-- 'False' otherwise.+elem :: Char -> Text -> Bool+elem c t = S.any (== c) (stream t)+{-# INLINE elem #-}+ -- | /O(n)/ The 'partition' function takes a predicate and a 'Text', -- and returns the pair of 'Text's with elements which do and do not -- satisfy the predicate, respectively; i.e.@@ -1760,3 +1758,9 @@ impossibleError :: String -> a impossibleError fun = P.error ("Data.Text.Lazy." ++ fun ++ ": impossible case")++intToInt64 :: Exts.Int -> Int64+intToInt64 = fromIntegral++int64ToInt :: Int64 -> Exts.Int+int64ToInt = fromIntegral
src/Data/Text/Lazy/Builder.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |
src/Data/Text/Lazy/Builder/Int.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, ScopedTypeVariables, UnboxedTuples #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -- Module: Data.Text.Lazy.Builder.Int -- Copyright: (c) 2013 Bryan O'Sullivan@@ -28,37 +26,11 @@ import Data.Text.Array import Data.Word (Word, Word8, Word16, Word32, Word64) import GHC.Base (quotInt, remInt)-import GHC.Types (Int(..)) import Control.Monad.ST #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif -#ifdef __GLASGOW_HASKELL__--#if __GLASGOW_HASKELL__ >= 811--import GHC.Num.Integer-#define HAS_INTEGER_CONSTR 1-#define quotRemInteger integerQuotRem#--#else--import GHC.Num (quotRemInteger)--# if defined(INTEGER_GMP)-import GHC.Integer.GMP.Internals (Integer(S#))-#define IS S#-#define HAS_INTEGER_CONSTR 1-# elif defined(INTEGER_SIMPLE)-import GHC.Integer ()-# else-# error "You need to use either GMP or integer-simple."-# endif-#endif--#endif- decimal :: Integral a => a -> Builder {-# RULES "decimal/Int8" decimal = boundedDecimal :: Int8 -> Builder #-} {-# RULES "decimal/Int" decimal = boundedDecimal :: Int -> Builder #-}@@ -130,7 +102,7 @@ let i = fromIntegral i0; j = i + i unsafeWrite marr off $ get (j + 1) unsafeWrite marr (off - 1) $ get j- get = fromIntegral . B.unsafeIndex digits+ get = word8ToWord16 . B.unsafeIndex digits minus, zero :: Word16 {-# INLINE minus #-}@@ -146,11 +118,11 @@ {-# INLINE countDigits #-} countDigits v0 | fromIntegral v64 == v0 = go 1 v64- | otherwise = goBig 1 (fromIntegral v0)+ | otherwise = goBig 1 (toInteger v0) where v64 = fromIntegral v0 goBig !k (v :: Integer) | v > big = goBig (k + 19) (v `quot` big)- | otherwise = go k (fromIntegral v)+ | otherwise = go k (fromInteger v) big = 10000000000000000000 go !k (v :: Word64) | v < 10 = k@@ -207,10 +179,10 @@ data T = T !Integer !Int integer :: Int -> Integer -> Builder-#ifdef HAS_INTEGER_CONSTR-integer 10 (IS i#) = decimal (I# i#)-integer 16 (IS i#) = hexadecimal (I# i#)-#endif+integer 10 i+ | i' <- fromInteger i, toInteger i' == i = decimal (i' :: Int)+integer 16 i+ | i' <- fromInteger i, toInteger i' == i = hexadecimal (i' :: Int) integer base i | i < 0 = singleton '-' <> go (-i) | otherwise = go i@@ -222,21 +194,21 @@ | p > n = [n] | otherwise = splith p (splitf (p*p) n) - splith p (n:ns) = case n `quotRemInteger` p of- (# q,r #) | q > 0 -> q : r : splitb p ns- | otherwise -> r : splitb p ns+ splith p (n:ns) = case n `quotRem` p of+ (q, r) | q > 0 -> q : r : splitb p ns+ | otherwise -> r : splitb p ns splith _ _ = error "splith: the impossible happened." - splitb p (n:ns) = case n `quotRemInteger` p of- (# q,r #) -> q : r : splitb p ns+ splitb p (n:ns) = case n `quotRem` p of+ (q, r) -> q : r : splitb p ns splitb _ _ = [] T maxInt10 maxDigits10 = until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)- where mi = fromIntegral (maxBound :: Int)+ where mi = toInteger (maxBound :: Int) T maxInt16 maxDigits16 = until ((>mi) . (*16) . fstT) (\(T n d) -> T (n*16) (d+1)) (T 16 1)- where mi = fromIntegral (maxBound :: Int)+ where mi = toInteger (maxBound :: Int) fstT (T a _) = a @@ -245,16 +217,16 @@ maxDigits | base == 10 = maxDigits10 | otherwise = maxDigits16 - putH (n:ns) = case n `quotRemInteger` maxInt of- (# x,y #)+ putH (n:ns) = case n `quotRem` maxInt of+ (x, y) | q > 0 -> int q <> pblock r <> putB ns | otherwise -> int r <> putB ns where q = fromInteger x r = fromInteger y putH _ = error "putH: the impossible happened" - putB (n:ns) = case n `quotRemInteger` maxInt of- (# x,y #) -> pblock q <> pblock r <> putB ns+ putB (n:ns) = case n `quotRem` maxInt of+ (x, y) -> pblock q <> pblock r <> putB ns where q = fromInteger x r = fromInteger y putB _ = Data.Monoid.mempty@@ -270,3 +242,6 @@ | otherwise = loop (d-1) q <> hexDigit r where q = n `quotInt` base r = n `remInt` base++word8ToWord16 :: Word8 -> Word16+word8ToWord16 = fromIntegral
src/Data/Text/Lazy/Builder/RealFloat.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, OverloadedStrings #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -- | -- Module: Data.Text.Lazy.Builder.RealFloat@@ -199,7 +197,7 @@ -- f :: Integer, log :: Float -> Float, -- ceiling :: Float -> Int ceiling ((log (fromInteger (f+1) :: Float) +- fromIntegral e * log (fromInteger b)) /+ intToFloat e * log (fromInteger b)) / log 10) --WAS: fromInt e * log (fromInteger b)) @@ -230,7 +228,7 @@ let bk = expt 10 (-k) in gen [] (r * bk) s (mUp * bk) (mDn * bk) in- (map fromIntegral (reverse rds), k)+ (map fromInteger (reverse rds), k) -- Exponentiation with a cache for the most common numbers. minExpt, maxExpt :: Int@@ -251,3 +249,6 @@ expts10 :: Array Int Integer expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]]++intToFloat :: Int -> Float+intToFloat = fromIntegral
src/Data/Text/Lazy/Encoding.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE BangPatterns,CPP #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -- | -- Module : Data.Text.Lazy.Encoding -- Copyright : (c) 2009, 2010 Bryan O'Sullivan@@ -61,7 +59,6 @@ import qualified Data.ByteString.Builder.Prim as BP import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Internal as B-import qualified Data.ByteString.Unsafe as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E@@ -102,9 +99,13 @@ TE.Some t l f -> chunk t (go f l bs) go _ l _ | S.null l = empty- | otherwise = case onErr desc (Just (B.unsafeHead l)) of- Nothing -> empty- Just c -> Chunk (T.singleton c) Empty+ | otherwise =+ let !t = T.pack (skipBytes l)+ skipBytes = S.foldr (\x s' ->+ case onErr desc (Just x) of+ Just c -> c : s'+ Nothing -> s') [] in+ Chunk t Empty desc = "Data.Text.Lazy.Encoding.decodeUtf8With: Invalid UTF-8 stream" decodeUtf8With _ _ = empty
src/Data/Text/Lazy/IO.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -- | -- Module : Data.Text.Lazy.IO -- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
src/Data/Text/Lazy/Read.hs view
@@ -1,9 +1,5 @@ {-# LANGUAGE OverloadedStrings, CPP #-}-#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif -- | -- Module : Data.Text.Lazy.Read@@ -149,8 +145,8 @@ -- function will lose precision at the 13th or 14th decimal place. double :: Reader Double double = floaty $ \real frac fracDenom ->- fromIntegral real +- fromIntegral frac / fromIntegral fracDenom+ fromInteger real ++ fromInteger frac / fromInteger fracDenom signa :: Num a => Parser a -> Parser a {-# SPECIALIZE signa :: Parser Int -> Parser Int #-}@@ -175,18 +171,21 @@ real <- P decimal T fraction fracDigits <- perhaps (T 0 0) $ do _ <- char (=='.')- digits <- P $ \t -> Right (fromIntegral . T.length $ T.takeWhile isDigit t, t)+ digits <- P $ \t -> Right (int64ToInt . T.length $ T.takeWhile isDigit t, t) n <- P decimal return $ T n digits let e c = c == 'e' || c == 'E' power <- perhaps 0 (char e >> signa (P decimal) :: Parser Int) let n = if fracDigits == 0 then if power == 0- then fromIntegral real- else fromIntegral real * (10 ^^ power)+ then fromInteger real+ else fromInteger real * (10 ^^ power) else if power == 0 then f real fraction (10 ^ fracDigits) else f real fraction (10 ^ fracDigits) * (10 ^^ power) return $! if sign == '+' then n else -n++int64ToInt :: Int64 -> Int+int64ToInt = fromIntegral
src/Data/Text/Read.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings, UnboxedTuples, CPP #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif -- | -- Module : Data.Text.Read@@ -157,8 +155,8 @@ -- function will lose precision at the 13th or 14th decimal place. double :: Reader Double double = floaty $ \real frac fracDenom ->- fromIntegral real +- fromIntegral frac / fromIntegral fracDenom+ fromInteger real ++ fromInteger frac / fromInteger fracDenom signa :: Num a => Parser a -> Parser a {-# SPECIALIZE signa :: Parser Int -> Parser Int #-}@@ -190,8 +188,8 @@ power <- perhaps 0 (char e >> signa (P decimal) :: Parser Int) let n = if fracDigits == 0 then if power == 0- then fromIntegral real- else fromIntegral real * (10 ^^ power)+ then fromInteger real+ else fromInteger real * (10 ^^ power) else if power == 0 then f real fraction (10 ^ fracDigits) else f real fraction (10 ^ fracDigits) * (10 ^^ power)
src/Data/Text/Show.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE CPP, MagicHash #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif +{-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | -- Module : Data.Text.Show -- Copyright : (c) 2009-2015 Bryan O'Sullivan@@ -28,17 +27,21 @@ import qualified Data.Text.Array as A import qualified Data.Text.Internal.Fusion.Common as S -#if __GLASGOW_HASKELL__ >= 702 import qualified GHC.CString as GHC-#else-import qualified GHC.Base as GHC++#if defined(ASSERTS)+import GHC.Stack (HasCallStack) #endif instance Show Text where showsPrec p ps r = showsPrec p (unpack ps) r -- | /O(n)/ Convert a 'Text' into a 'String'. Subject to fusion.-unpack :: Text -> String+unpack ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> String unpack = S.unstreamList . stream {-# INLINE [1] unpack #-} @@ -69,7 +72,11 @@ -- | /O(1)/ Convert a character into a Text. Subject to fusion. -- Performs replacement on invalid scalar values.-singleton :: Char -> Text+singleton ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Char -> Text singleton = unstream . S.singleton . safe {-# INLINE [1] singleton #-} @@ -78,7 +85,11 @@ = singleton_ a #-} -- This is intended to reduce inlining bloat.-singleton_ :: Char -> Text+singleton_ ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Char -> Text singleton_ c = Text (A.run x) 0 len where x :: ST s (A.MArray s) x = do arr <- A.new len
src/Data/Text/Unsafe.hs view
@@ -27,6 +27,7 @@ #if defined(ASSERTS) import Control.Exception (assert)+import GHC.Stack (HasCallStack) #endif import Data.Text.Internal.Encoding.Utf16 (chr2) import Data.Text.Internal (Text(..))@@ -63,7 +64,11 @@ -- | /O(1)/ Iterate (unsafely) one step forwards through a UTF-16 -- array, returning the current character and the delta to add to give -- the next offset to iterate at.-iter :: Text -> Int -> Iter+iter ::+#if defined(ASSERTS)+ HasCallStack =>+#endif+ Text -> Int -> Iter iter (Text arr off _len) i | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1 | otherwise = Iter (chr2 m n) 2
− tests-and-benchmarks.markdown
@@ -1,68 +0,0 @@-Tests and benchmarks-====================--Prerequisites----------------To run the tests and benchmarks, you will need the test data, which-you can clone from one of the following locations:--* Mercurial master repository:- [bitbucket.org/bos/text-test-data](https://bitbucket.org/bos/text-test-data)--* Git mirror repository:- [github.com/bos/text-test-data](https://github.com/bos/text-test-data)--You can clone either repository into the `tests` subdirectory using-- cd tests/- make text-test-data # to clone from mercurial, OR- make VCS=git text-test-data # to clone from git--Many tests and benchmarks will fail if the test files are missing.--Functional tests-------------------The functional tests are located in the `tests` subdirectory. An overview of-what's in that directory:-- Makefile Has targets for common tasks- Tests Source files of the testing code- scripts Various utility scripts- text-tests.cabal Cabal file that compiles all benchmarks--The `text-tests.cabal` builds:--- A copy of the text library, sharing the source code, but exposing all internal- modules, for testing purposes-- The different test suites--To compile, run all tests, and generate a coverage report, simply use `make`.--Benchmarks-------------The benchmarks are located in the `benchmarks` subdirectory. An overview of-what's in that directory:-- Makefile Has targets for common tasks- haskell Source files of the haskell benchmarks- python Python implementations of some benchmarks- ruby Ruby implementations of some benchmarks- text-benchmarks.cabal Cabal file which compiles all benchmarks--To compile the benchmarks, navigate to the `benchmarks` subdirectory and run-`cabal configure && cabal build`. Then, you can run the benchmarks using:-- ./dist/build/text-benchmarks/text-benchmarks--Or if you have a recent enough `cabal`, you can build and run the-benchmarks via-- cabal new-run exe:text-benchmarks -- --help--However, since there's quite a lot of benchmarks, you usually don't want to-run them all. Instead, use the `-l` flag to get a list of benchmarks-and run the ones you want to inspect. If you want to configure the benchmarks-further, the exact parameters can be changed in `Benchmarks.hs`.
− tests/.ghci
@@ -1,1 +0,0 @@-:set -isrc -i../..
− tests/Makefile
@@ -1,45 +0,0 @@-VCS = hg-count = 1000--all: coverage literal-rule-test--literal-rule-test:- ./literal-rule-test.sh--coverage: build coverage/hpc_index.html--build: text-test-data- cabal configure -fhpc- cabal build--text-test-data:-ifeq ($(VCS),git)- git clone https://github.com/bos/text-test-data.git-else- hg clone https://bitbucket.org/bos/text-test-data-endif- $(MAKE) -C text-test-data--coverage/text-tests.tix:- -mkdir -p coverage- ./dist/build/text-tests/text-tests -a $(count)- mv text-tests.tix $@--coverage/text-tests-stdio.tix:- -mkdir -p coverage- ./scripts/cover-stdio.sh ./dist/build/text-tests-stdio/text-tests-stdio- mv text-tests-stdio.tix $@--coverage/coverage.tix: coverage/text-tests.tix coverage/text-tests-stdio.tix- hpc combine --output=$@ \- --exclude=Main \- coverage/text-tests.tix \- coverage/text-tests-stdio.tix--coverage/hpc_index.html: coverage/coverage.tix- hpc markup --destdir=coverage coverage/coverage.tix--clean:- rm -rf dist coverage .hpc--.PHONY: all build clean coverage literal-rule-test
tests/Tests.hs view
@@ -4,10 +4,20 @@ ( main ) where -import Test.Framework (defaultMain)+import Test.Tasty (defaultMain, testGroup) +import qualified Tests.Lift as Lift import qualified Tests.Properties as Properties import qualified Tests.Regressions as Regressions +import qualified Tests.Inspection.Strict as InspectionStrict+import qualified Tests.Inspection.Lazy as InspectionLazy+ main :: IO ()-main = defaultMain [Properties.tests, Regressions.tests]+main = defaultMain $ testGroup "All"+ [ Lift.tests+ , Properties.tests+ , Regressions.tests+ , InspectionStrict.tests+ , InspectionLazy.tests+ ]
− tests/Tests/IO.hs
@@ -1,34 +0,0 @@--- | Program which exposes some haskell functions as an exutable. The results--- and coverage of this module is meant to be checked using a shell script.----module Main- (- main- ) where--import System.Environment (getArgs)-import System.Exit (exitFailure)-import System.IO (hPutStrLn, stderr)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.IO as TL--main :: IO ()-main = do- args <- getArgs- case args of- ["T.readFile", name] -> T.putStr =<< T.readFile name- ["T.writeFile", name, t] -> T.writeFile name (T.pack t)- ["T.appendFile", name, t] -> T.appendFile name (T.pack t)- ["T.interact"] -> T.interact id- ["T.getContents"] -> T.putStr =<< T.getContents- ["T.getLine"] -> T.putStrLn =<< T.getLine-- ["TL.readFile", name] -> TL.putStr =<< TL.readFile name- ["TL.writeFile", name, t] -> TL.writeFile name (TL.pack t)- ["TL.appendFile", name, t] -> TL.appendFile name (TL.pack t)- ["TL.interact"] -> TL.interact id- ["TL.getContents"] -> TL.putStr =<< TL.getContents- ["TL.getLine"] -> TL.putStrLn =<< TL.getLine- _ -> hPutStrLn stderr "invalid directive!" >> exitFailure
+ tests/Tests/Inspection/Lazy.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -O -fno-warn-unused-top-binds -fno-warn-missing-signatures -fno-warn-name-shadowing -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}++module Tests.Inspection.Lazy (tests) where++import Prelude hiding (all, any, drop, dropWhile, filter, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, maximum, minimum, null, replicate, reverse, scanl, scanl1, scanr, scanr1, tail, take, takeWhile)+import Data.Char (isAscii)++import qualified Data.Text.Lazy as T++import Test.Tasty+import Test.Tasty.Inspection++maximum_unfoldr = T.maximum . unfoldr+isPrefixOf_unfoldr = isPrefixOf . unfoldr+any_filter_init_pack = any . filter . T.init . T.pack+isPrefixOf_intersperse_unfoldr = isPrefixOf . intersperse . unfoldr+compareLength_take_pack = compareLength . take . T.pack+index_toCaseFold_singleton = index . T.toCaseFold . T.singleton+unpack_take_pack = T.unpack . take . T.pack+foldl_singleton = foldl . T.singleton+foldr_filter_singleton = foldr . filter . T.singleton+foldr1_stripStart_singleton = foldr1 . T.stripStart . T.singleton+foldl_drop_singleton = foldl . drop . T.singleton+all_toCaseFold_unfoldr = all . T.toCaseFold . unfoldr+foldl_pack = foldl . T.pack+last_toUpper_toLower_unfoldrN = T.last . T.toUpper . T.toLower . unfoldrN+null_map_unfoldr = T.null . map . unfoldr+any_toTitle_tail_unfoldrN = any . T.toTitle . T.tail . unfoldrN+head_filter_pack = T.head . filter . T.pack+foldr1_toTitle_stripStart_singleton = foldr1 . T.toTitle . T.stripStart . T.singleton+compareLength_snoc_unfoldr = compareLength . snoc . unfoldr+compareLength_intersperse_toUpper_unfoldr = compareLength . intersperse . T.toUpper . unfoldr+compareLength_takeWhile_intersperse_unfoldr = compareLength . takeWhile . intersperse . unfoldr+all_init_map_unfoldrN = all . T.init . map . unfoldrN+foldr_scanl_unfoldrN = foldr . scanl . unfoldrN+compareLength_pack = compareLength . T.pack+foldr_cons_singleton = foldr . cons . T.singleton+last_tail_unfoldrN = T.last . T.tail . unfoldrN+foldr1_take_unfoldr = foldr1 . take . unfoldr+null_unfoldrN = T.null . unfoldrN+foldr1_init_singleton = foldr1 . T.init . T.singleton+all_cons_dropWhile_singleton = all . cons . dropWhile . T.singleton+head_append_toTitle_singleton = T.head . append . T.toTitle . T.singleton+foldl1_tail_intersperse_unfoldr = foldl1 . T.tail . intersperse . unfoldr+foldr1_drop_singleton = foldr1 . drop . T.singleton+minimum_tail_pack = T.minimum . T.tail . T.pack+minimum_pack = T.minimum . T.pack+length_takeWhile_singleton = T.length . takeWhile . T.singleton+foldl_take_toCaseFold_unfoldr = foldl . take . T.toCaseFold . unfoldr+foldr_intersperse_singleton = foldr . intersperse . T.singleton+compareLength_cons_snoc_singleton = compareLength . cons . snoc . T.singleton+last_map_append_unfoldrN = T.last . map . append . unfoldrN+find_justifyLeft_takeWhile_pack = find . justifyLeft . takeWhile . T.pack+head_append_unfoldr = T.head . append . unfoldr+minimum_justifyLeft_drop_unfoldrN = T.minimum . justifyLeft . drop . unfoldrN+null_singleton = T.null . T.singleton+last_map_justifyLeft_pack = T.last . map . justifyLeft . T.pack+foldl1'_tail_unfoldrN = foldl1' . T.tail . unfoldrN+maximum_take_unfoldrN = T.maximum . take . unfoldrN+foldl'_unfoldrN = foldl' . unfoldrN+foldl1'_filter_intersperse_singleton = foldl1' . filter . intersperse . T.singleton+length_singleton = T.length . T.singleton+foldr1_pack = foldr1 . T.pack+foldl1'_singleton = foldl1' . T.singleton+foldr1_scanl_singleton = foldr1 . scanl . T.singleton+minimum_tail_singleton = T.minimum . T.tail . T.singleton+any_pack = any . T.pack+length_pack = T.length . T.pack+head_unfoldrN = T.head . unfoldrN+head_map_pack = T.head . map . T.pack+foldr_stripStart_toCaseFold_singleton = foldr . T.stripStart . T.toCaseFold . T.singleton+any_append_pack = any . append . T.pack+all_drop_toUpper_unfoldrN = all . drop . T.toUpper . unfoldrN+foldl1'_filter_filter_unfoldr = foldl1' . filter . filter . unfoldr+any_singleton = any . T.singleton+any_toTitle_scanl_unfoldr = any . T.toTitle . scanl . unfoldr+foldr1_cons_pack = foldr1 . cons . T.pack+foldl1'_toTitle_dropWhile_singleton = foldl1' . T.toTitle . dropWhile . T.singleton+length_justifyLeft_unfoldr = T.length . justifyLeft . unfoldr+foldl1'_justifyLeft_pack = foldl1' . justifyLeft . T.pack+foldr_map_toTitle_unfoldrN = foldr . map . T.toTitle . unfoldrN+head_singleton = T.head . T.singleton+foldl'_singleton = foldl' . T.singleton+foldr1_dropWhile_intersperse_pack = foldr1 . dropWhile . intersperse . T.pack+foldl1'_pack = foldl1' . T.pack+head_replicate_singleton = T.head . replicate . T.singleton+unpack_toUpper_snoc_singleton = T.unpack . T.toUpper . snoc . T.singleton+null_empty = T.null . empty+maximum_singleton = T.maximum . T.singleton+isPrefixOf_init_singleton = isPrefixOf . T.init . T.singleton+minimum_unfoldr = T.minimum . unfoldr+foldl_stripStart_snoc_singleton = foldl . T.stripStart . snoc . T.singleton+any_toUpper_unfoldr = any . T.toUpper . unfoldr+all_unfoldr = all . unfoldr+minimum_toLower_unfoldrN = T.minimum . T.toLower . unfoldrN+null_pack = T.null . T.pack+index_dropWhile_unfoldr = index . dropWhile . unfoldr+minimum_filter_toUpper_singleton = T.minimum . filter . T.toUpper . T.singleton+head_pack = T.head . T.pack+foldl1'_toTitle_singleton = foldl1' . T.toTitle . T.singleton+find_unfoldr = find . unfoldr+isPrefixOf_unfoldrN = isPrefixOf . unfoldrN+unpack_append_pack = T.unpack . append . T.pack+any_unfoldr = any . unfoldr+length_unfoldrN = T.length . unfoldrN+minimum_singleton = T.minimum . T.singleton+head_snoc_toUpper_singleton = T.head . snoc . T.toUpper . T.singleton+maximum_unfoldrN = T.maximum . unfoldrN+all_take_pack = all . take . T.pack+isPrefixOf_pack = isPrefixOf . T.pack+foldr_init_pack = foldr . T.init . T.pack+foldl1'_filter_pack = foldl1' . filter . T.pack++tests :: TestTree+tests = testGroup "Lazy fusion" [$(inspectNames (`hasNoType` ''T.Text)+ ['maximum_unfoldr, 'isPrefixOf_unfoldr, 'any_filter_init_pack, 'isPrefixOf_intersperse_unfoldr, 'compareLength_take_pack, 'index_toCaseFold_singleton, 'unpack_take_pack, 'foldl_singleton, 'foldr_filter_singleton, 'foldr1_stripStart_singleton, 'foldl_drop_singleton, 'all_toCaseFold_unfoldr, 'foldl_pack, 'last_toUpper_toLower_unfoldrN, 'null_map_unfoldr, 'any_toTitle_tail_unfoldrN, 'head_filter_pack, 'foldr1_toTitle_stripStart_singleton, 'compareLength_snoc_unfoldr, 'compareLength_intersperse_toUpper_unfoldr, 'compareLength_takeWhile_intersperse_unfoldr, 'all_init_map_unfoldrN, 'foldr_scanl_unfoldrN, 'compareLength_pack, 'foldr_cons_singleton, 'last_tail_unfoldrN, 'foldr1_take_unfoldr, 'null_unfoldrN, 'foldr1_init_singleton, 'all_cons_dropWhile_singleton, 'head_append_toTitle_singleton, 'foldl1_tail_intersperse_unfoldr, 'foldr1_drop_singleton, 'minimum_tail_pack, 'minimum_pack, 'length_takeWhile_singleton, 'foldl_take_toCaseFold_unfoldr, 'foldr_intersperse_singleton, 'compareLength_cons_snoc_singleton, 'last_map_append_unfoldrN, 'find_justifyLeft_takeWhile_pack, 'head_append_unfoldr, 'minimum_justifyLeft_drop_unfoldrN, 'null_singleton, 'last_map_justifyLeft_pack, 'foldl1'_tail_unfoldrN, 'maximum_take_unfoldrN, 'foldl'_unfoldrN, 'foldl1'_filter_intersperse_singleton, 'length_singleton, 'foldr1_pack, 'foldl1'_singleton, 'foldr1_scanl_singleton, 'minimum_tail_singleton, 'any_pack, 'length_pack, 'head_unfoldrN, 'head_map_pack, 'foldr_stripStart_toCaseFold_singleton, 'any_append_pack, 'all_drop_toUpper_unfoldrN, 'foldl1'_filter_filter_unfoldr, 'any_singleton, 'any_toTitle_scanl_unfoldr, 'foldr1_cons_pack, 'foldl1'_toTitle_dropWhile_singleton, 'length_justifyLeft_unfoldr, 'foldl1'_justifyLeft_pack, 'foldr_map_toTitle_unfoldrN, 'head_singleton, 'foldl'_singleton, 'foldr1_dropWhile_intersperse_pack, 'foldl1'_pack, 'head_replicate_singleton, 'unpack_toUpper_snoc_singleton, 'null_empty, 'maximum_singleton, 'isPrefixOf_init_singleton, 'minimum_unfoldr, 'foldl_stripStart_snoc_singleton, 'any_toUpper_unfoldr, 'all_unfoldr, 'minimum_toLower_unfoldrN, 'null_pack, 'index_dropWhile_unfoldr, 'minimum_filter_toUpper_singleton, 'head_pack, 'foldl1'_toTitle_singleton, 'find_unfoldr, 'isPrefixOf_unfoldrN, 'unpack_append_pack, 'any_unfoldr, 'length_unfoldrN, 'minimum_singleton, 'head_snoc_toUpper_singleton, 'maximum_unfoldrN, 'all_take_pack, 'isPrefixOf_pack, 'foldr_init_pack, 'foldl1'_filter_pack])]++---------------------------------------------------------------------------------+-- Definitions below are from inspection-testing package by Joachim Breitner.+--++i = 42+{-# NOINLINE i #-}++empty _ = T.empty+{-# INLINE empty #-}+take x = T.take i x+{-# INLINE take #-}+drop x = T.drop i x+{-# INLINE drop #-}+cons x = 'x' `T.cons` x+{-# INLINE cons #-}+snoc x = x `T.snoc` 'x'+{-# INLINE snoc #-}+map x = T.map succ x+{-# INLINE map #-}+justifyLeft x = T.justifyLeft 42 'x' x+{-# INLINE justifyLeft #-}+intersperse x = T.intersperse 'x' x+{-# INLINE intersperse #-}+append x = unfoldrN 'y' `T.append` x+{-# INLINE append #-}+isPrefixOf x = unfoldrN 'a' `T.isPrefixOf` x+{-# INLINE isPrefixOf #-}+compareLength x = x `T.compareLength` i+{-# INLINE compareLength #-}+foldl x = T.foldl (\x c -> x + fromEnum c) 0 x+{-# INLINE foldl #-}+foldl' x = T.foldl' (\x c -> x + fromEnum c) 0 x+{-# INLINE foldl' #-}+foldl1 x = T.foldl1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE foldl1 #-}+foldl1' x = T.foldl1' (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE foldl1' #-}+foldr x = T.foldr (\c x -> x + fromEnum c) 0 x+{-# INLINE foldr #-}+foldr1 x = T.foldr1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE foldr1 #-}+any x = T.any isAscii x+{-# INLINE any #-}+all x = T.all isAscii x+{-# INLINE all #-}+scanl x = T.scanl (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) 'x' x+{-# INLINE scanl #-}+unfoldr x = T.unfoldr (\c -> if c == 'z' then Nothing else Just (c, succ c)) x+{-# INLINE unfoldr #-}+unfoldrN x = T.unfoldrN i (\c -> if c == 'z' then Nothing else Just (c, succ c)) x+{-# INLINE unfoldrN #-}+takeWhile x = T.takeWhile isAscii x+{-# INLINE takeWhile #-}+dropWhile x = T.dropWhile isAscii x+{-# INLINE dropWhile #-}+filter x = T.filter isAscii x+{-# INLINE filter #-}+find x = T.find isAscii x+{-# INLINE find #-}+replicate x = T.replicate i x+{-# INLINE replicate #-}+index x = x `T.index` i+{-# INLINE index #-}
+ tests/Tests/Inspection/Strict.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -O -fno-warn-unused-top-binds -fno-warn-missing-signatures -fno-warn-name-shadowing -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}++module Tests.Inspection.Strict (tests) where++import Prelude hiding (all, any, drop, dropWhile, filter, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, maximum, minimum, null, reverse, scanl, scanl1, scanr, scanr1, tail, take, takeWhile)+import Data.Char (isAscii)++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Test.Tasty+import Test.Tasty.Inspection++all_cons_pack = all . cons . T.pack+all_drop_pack = all . drop . T.pack+all_dropWhileEnd_singleton = all . dropWhileEnd . T.singleton+all_justifyRight_singleton = all . justifyRight . T.singleton+all_scanl_init_unfoldrN = all . scanl . T.init . unfoldrN+all_stripEnd_stripStart_singleton = all . T.stripEnd . T.stripStart . T.singleton+any_filter_init_pack = any . filter . T.init . T.pack+any_justifyRight_dropEnd_singleton = any . justifyRight . dropEnd . T.singleton+any_singleton = any . T.singleton+any_stripStart_singleton = any . T.stripStart . T.singleton+any_toCaseFold_unfoldr = any . T.toCaseFold . unfoldr+any_unfoldrN = any . unfoldrN+compareLength_cons_snoc_singleton = compareLength . cons . snoc . T.singleton+compareLength_drop_unfoldr = compareLength . drop . unfoldr+compareLength_empty = compareLength . empty+compareLength_pack = compareLength . T.pack+compareLength_singleton = compareLength . T.singleton+compareLength_snoc_unfoldr = compareLength . snoc . unfoldr+compareLength_takeWhile_intersperse_unfoldr = compareLength . takeWhile . intersperse . unfoldr+compareLength_toTitle_singleton = compareLength . T.toTitle . T.singleton+compareLength_toTitle_unfoldrN = compareLength . T.toTitle . unfoldrN+compareLength_unfoldr = compareLength . unfoldr+find_decodeUtf8 = find . T.decodeUtf8+find_take_unfoldrN = find . take . unfoldrN+foldl'_cons_pack = foldl' . cons . T.pack+foldl'_scanr1_singleton = foldl' . scanr1 . T.singleton+foldl'_toCaseFold_intersperse_unfoldrN = foldl' . T.toCaseFold . intersperse . unfoldrN+foldl_center_empty = foldl . center . empty+foldl_justifyLeft_cons_empty = foldl . justifyLeft . cons . empty+foldl_justifyLeft_decodeUtf8 = foldl . justifyLeft . T.decodeUtf8+foldl_pack = foldl . T.pack+foldl_scanl_dropWhile_empty = foldl . scanl . dropWhile . empty+foldl1'_append_append_decodeUtf8 = foldl1' . append . append . T.decodeUtf8+foldl1'_dropWhile_dropWhileEnd_singleton = foldl1' . dropWhile . dropWhileEnd . T.singleton+foldl1'_scanl_decodeUtf8 = foldl1' . scanl . T.decodeUtf8+foldl1'_scanl_justifyLeft_unfoldr = foldl1' . scanl . justifyLeft . unfoldr+foldl1'_singleton = foldl1' . T.singleton+foldl1'_take_unfoldr = foldl1' . take . unfoldr+foldl1_intersperse_empty = foldl1 . intersperse . empty+foldl1_scanr_singleton = foldl1 . scanr . T.singleton+foldl1_tail_singleton = foldl1 . T.tail . T.singleton+foldr_append_singleton = foldr . append . T.singleton+foldr_empty = foldr . empty+foldr_intersperse_dropWhile_unfoldr = foldr . intersperse . dropWhile . unfoldr+foldr_intersperse_singleton = foldr . intersperse . T.singleton+foldr_scanl_unfoldr = foldr . scanl . unfoldr+foldr1_dropWhile_intersperse_pack = foldr1 . dropWhile . intersperse . T.pack+foldr1_justifyLeft_scanl1_empty = foldr1 . justifyLeft . scanl1 . empty+foldr1_reverse_unfoldrN = foldr1 . T.reverse . unfoldrN+foldr1_singleton = foldr1 . T.singleton+foldr1_take_drop_pack = foldr1 . take . drop . T.pack+foldr1_unfoldrN = foldr1 . unfoldrN+head_append_toTitle_singleton = T.head . append . T.toTitle . T.singleton+head_cons_unfoldr = T.head . cons . unfoldr+head_drop_decodeUtf8 = T.head . drop . T.decodeUtf8+head_singleton = T.head . T.singleton+head_strip_take_empty = T.head . T.strip . take . empty+head_takeEnd_take_singleton = T.head . takeEnd . take . T.singleton+index_dropWhile_unfoldr = index . dropWhile . unfoldr+index_dropWhileEnd_empty = index . dropWhileEnd . empty+index_justifyLeft_stripEnd_singleton = index . justifyLeft . T.stripEnd . T.singleton+isPrefixOf_dropWhile_dropWhile_pack = isPrefixOf . dropWhile . dropWhile . T.pack+isPrefixOf_init_take_unfoldrN = isPrefixOf . T.init . take . unfoldrN+isPrefixOf_snoc_stripStart_pack = isPrefixOf . snoc . T.stripStart . T.pack+isPrefixOf_take_empty = isPrefixOf . take . empty+isPrefixOf_take_singleton = isPrefixOf . take . T.singleton+last_dropWhile_unfoldrN = T.last . dropWhile . unfoldrN+last_map_take_pack = T.last . map . take . T.pack+last_tail_unfoldrN = T.last . T.tail . unfoldrN+last_toUpper_stripStart_singleton = T.last . T.toUpper . T.stripStart . T.singleton+last_toUpper_toLower_unfoldrN = T.last . T.toUpper . T.toLower . unfoldrN+length_empty = T.length . empty+length_intersperse_center_singleton = T.length . intersperse . center . T.singleton+length_justifyLeft_decodeUtf8 = T.length . justifyLeft . T.decodeUtf8+length_pack = T.length . T.pack+length_reverse_singleton = T.length . T.reverse . T.singleton+length_takeWhile_intersperse_singleton = T.length . takeWhile . intersperse . T.singleton+length_takeWhile_singleton = T.length . takeWhile . T.singleton+length_toTitle_empty = T.length . T.toTitle . empty+maximum_justifyLeft_filter_singleton = T.maximum . justifyLeft . filter . T.singleton+maximum_justifyRight_singleton = T.maximum . justifyRight . T.singleton+maximum_take_unfoldrN = T.maximum . take . unfoldrN+maximum_toLower_empty = T.maximum . T.toLower . empty+minimum_init_singleton = T.minimum . T.init . T.singleton+minimum_intersperse_toTitle_singleton = T.minimum . intersperse . T.toTitle . T.singleton+minimum_map_singleton = T.minimum . map . T.singleton+minimum_scanl1_takeWhile_singleton = T.minimum . scanl1 . takeWhile . T.singleton+minimum_tail_map_singleton = T.minimum . T.tail . map . T.singleton+minimum_unfoldrN = T.minimum . unfoldrN+null_cons_singleton = T.null . cons . T.singleton+null_init_drop_decodeUtf8 = T.null . T.init . drop . T.decodeUtf8+null_map_empty = T.null . map . empty+null_toCaseFold_dropAround_singleton = T.null . T.toCaseFold . dropAround . T.singleton+unpack_empty = T.unpack . empty+unpack_justifyLeft_take_empty = T.unpack . justifyLeft . take . empty+unpack_map_pack = T.unpack . map . T.pack+unpack_stripEnd_takeWhileEnd_singleton = T.unpack . T.stripEnd . takeWhileEnd . T.singleton+unpack_toCaseFold_scanr_singleton = T.unpack . T.toCaseFold . scanr . T.singleton+unpack_toUpper_snoc_singleton = T.unpack . T.toUpper . snoc . T.singleton+unpack_unfoldr = T.unpack . unfoldr++tests :: TestTree+tests = testGroup "Strict fusion" [$(inspectNames (`hasNoType` ''T.Text)+ [+#if __GLASGOW_HASKELL__ >= 806+ 'all_cons_pack, 'all_drop_pack, 'all_scanl_init_unfoldrN, 'any_filter_init_pack, 'any_toCaseFold_unfoldr, 'any_unfoldrN, 'compareLength_drop_unfoldr, 'compareLength_empty, 'compareLength_pack, 'compareLength_snoc_unfoldr, 'compareLength_takeWhile_intersperse_unfoldr, 'compareLength_toTitle_unfoldrN, 'compareLength_unfoldr, 'find_decodeUtf8, 'find_take_unfoldrN, 'foldl'_cons_pack, 'foldl'_toCaseFold_intersperse_unfoldrN, 'foldl_justifyLeft_cons_empty, 'foldl_justifyLeft_decodeUtf8, 'foldl_pack, 'foldl_scanl_dropWhile_empty, 'foldl1'_append_append_decodeUtf8, 'foldl1'_scanl_decodeUtf8, 'foldl1'_scanl_justifyLeft_unfoldr, 'foldl1'_take_unfoldr, 'foldl1_intersperse_empty, 'foldr_empty, 'foldr_intersperse_dropWhile_unfoldr, 'foldr_scanl_unfoldr, 'foldr1_dropWhile_intersperse_pack, 'foldr1_justifyLeft_scanl1_empty, 'foldr1_reverse_unfoldrN, 'foldr1_take_drop_pack, 'foldr1_unfoldrN, 'head_cons_unfoldr, 'head_drop_decodeUtf8, 'head_strip_take_empty, 'index_dropWhile_unfoldr, 'index_dropWhileEnd_empty, 'isPrefixOf_dropWhile_dropWhile_pack, 'isPrefixOf_init_take_unfoldrN, 'isPrefixOf_snoc_stripStart_pack, 'isPrefixOf_take_empty, 'last_dropWhile_unfoldrN, 'last_map_take_pack, 'last_tail_unfoldrN, 'last_toUpper_toLower_unfoldrN, 'length_empty, 'length_justifyLeft_decodeUtf8, 'length_pack, 'length_toTitle_empty, 'maximum_take_unfoldrN, 'maximum_toLower_empty, 'minimum_unfoldrN, 'null_init_drop_decodeUtf8, 'null_map_empty, 'unpack_empty, 'unpack_justifyLeft_take_empty, 'unpack_map_pack, 'unpack_unfoldr+#endif+-- https://gitlab.haskell.org/ghc/ghc/-/issues/19822+#if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ < 900+ , 'foldl_center_empty -- the only non-singleton-related regression+ , 'all_dropWhileEnd_singleton, 'all_justifyRight_singleton, 'all_stripEnd_stripStart_singleton, 'any_justifyRight_dropEnd_singleton, 'any_singleton, 'any_stripStart_singleton, 'compareLength_cons_snoc_singleton, 'compareLength_singleton, 'compareLength_toTitle_singleton, 'foldl'_scanr1_singleton, 'foldl1'_dropWhile_dropWhileEnd_singleton, 'foldl1_scanr_singleton, 'foldl1_tail_singleton, 'foldr_append_singleton, 'foldl1'_singleton, 'foldr_intersperse_singleton, 'foldr1_singleton, 'head_append_toTitle_singleton, 'head_singleton, 'head_takeEnd_take_singleton, 'isPrefixOf_take_singleton, 'index_justifyLeft_stripEnd_singleton, 'last_toUpper_stripStart_singleton, 'length_intersperse_center_singleton, 'length_reverse_singleton, 'length_takeWhile_intersperse_singleton, 'length_takeWhile_singleton, 'maximum_justifyLeft_filter_singleton, 'maximum_justifyRight_singleton, 'minimum_init_singleton, 'minimum_intersperse_toTitle_singleton, 'minimum_map_singleton, 'minimum_scanl1_takeWhile_singleton, 'minimum_tail_map_singleton, 'null_cons_singleton, 'null_toCaseFold_dropAround_singleton, 'unpack_stripEnd_takeWhileEnd_singleton, 'unpack_toCaseFold_scanr_singleton, 'unpack_toUpper_snoc_singleton+#endif+ ])]++---------------------------------------------------------------------------------+-- Definitions below are from inspection-testing package by Joachim Breitner.+--++i = 42+{-# NOINLINE i #-}++empty _ = T.empty+{-# INLINE empty #-}+take x = T.take i x+{-# INLINE take #-}+takeEnd x = T.takeEnd i x+{-# INLINE takeEnd #-}+drop x = T.drop i x+{-# INLINE drop #-}+dropEnd x = T.dropEnd i x+{-# INLINE dropEnd #-}+cons x = 'x' `T.cons` x+{-# INLINE cons #-}+snoc x = x `T.snoc` 'x'+{-# INLINE snoc #-}+map x = T.map succ x+{-# INLINE map #-}+justifyLeft x = T.justifyLeft 42 'x' x+{-# INLINE justifyLeft #-}+justifyRight x = T.justifyRight 42 'x' x+{-# INLINE justifyRight #-}+center x = T.center i 'x' x+{-# INLINE center #-}+intersperse x = T.intersperse 'x' x+{-# INLINE intersperse #-}+append x = unfoldrN 'y' `T.append` x+{-# INLINE append #-}+isPrefixOf x = unfoldrN 'a' `T.isPrefixOf` x+{-# INLINE isPrefixOf #-}+compareLength x = x `T.compareLength` i+{-# INLINE compareLength #-}+foldl x = T.foldl (\x c -> x + fromEnum c) 0 x+{-# INLINE foldl #-}+foldl' x = T.foldl' (\x c -> x + fromEnum c) 0 x+{-# INLINE foldl' #-}+foldl1 x = T.foldl1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE foldl1 #-}+foldl1' x = T.foldl1' (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE foldl1' #-}+foldr x = T.foldr (\c x -> x + fromEnum c) 0 x+{-# INLINE foldr #-}+foldr1 x = T.foldr1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE foldr1 #-}+any x = T.any isAscii x+{-# INLINE any #-}+all x = T.all isAscii x+{-# INLINE all #-}+scanl x = T.scanl (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) 'x' x+{-# INLINE scanl #-}+scanl1 x = T.scanl1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE scanl1 #-}+scanr x = T.scanr (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) 'x' x+{-# INLINE scanr #-}+scanr1 x = T.scanr1 (\c1 c2 -> toEnum $ fromEnum c1 + fromEnum c2) x+{-# INLINE scanr1 #-}+unfoldr x = T.unfoldr (\c -> if c == 'z' then Nothing else Just (c, succ c)) x+{-# INLINE unfoldr #-}+unfoldrN x = T.unfoldrN i (\c -> if c == 'z' then Nothing else Just (c, succ c)) x+{-# INLINE unfoldrN #-}+takeWhile x = T.takeWhile isAscii x+{-# INLINE takeWhile #-}+dropWhile x = T.dropWhile isAscii x+{-# INLINE dropWhile #-}+takeWhileEnd x = T.takeWhileEnd isAscii x+{-# INLINE takeWhileEnd #-}+dropWhileEnd x = T.dropWhileEnd isAscii x+{-# INLINE dropWhileEnd #-}+dropAround x = T.dropAround isAscii x+{-# INLINE dropAround #-}+filter x = T.filter isAscii x+{-# INLINE filter #-}+find x = T.find isAscii x+{-# INLINE find #-}+index x = x `T.index` i+{-# INLINE index #-}
+ tests/Tests/Lift.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Tests.Lift+ ( tests+ )+ where++import qualified Data.Text as S+import qualified Data.Text.Lazy as L+import Language.Haskell.TH.Syntax (lift)+import Test.Tasty.HUnit (testCase, assertEqual)+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests = testGroup "TH lifting Text"+ [ testCase "strict" $ assertEqual "strict"+ $(lift ("foo" :: S.Text))+ ("foo" :: S.Text)+ , testCase "lazy" $ assertEqual "lazy"+ $(lift ("foo" :: L.Text))+ ("foo" :: L.Text)+ ]
tests/Tests/Properties.hs view
@@ -1,1460 +1,32 @@ -- | QuickCheck properties for the text library. -{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings,- ScopedTypeVariables, TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}-module Tests.Properties- (- tests- ) where--import Control.Applicative ((<$>), (<*>))-import Control.Arrow ((***), first, second)-import Data.Bits ((.&.))-import Data.Char (chr, isDigit, isHexDigit, isLower, isSpace, isLetter, isUpper, ord)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Monoid (Monoid(..))-import Data.String (IsString(fromString))-import Data.Text.Encoding.Error-import Data.Text.Foreign-import Data.Text.Internal.Encoding.Utf8-import Data.Text.Internal.Fusion.Size-import Data.Text.Internal.Search (indices)-import Data.Text.Lazy.Read as TL-import Data.Text.Read as T-import Data.Word (Word, Word8, Word16, Word32, Word64)-import Data.Maybe (mapMaybe)-import Numeric (showEFloat, showFFloat, showGFloat, showHex)-import Prelude hiding (replicate)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Monadic-import Test.QuickCheck.Property (Property(..))-import Test.QuickCheck.Unicode (char)-import Tests.QuickCheckUtils-import Tests.Utils-import Text.Show.Functions ()-import qualified Control.Exception as Exception-import qualified Data.Bits as Bits (shiftL, shiftR)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Char as C-import qualified Data.List as L-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import qualified Data.Text.IO as T-import qualified Data.Text.Internal.Fusion as S-import qualified Data.Text.Internal.Fusion.Common as S-import qualified Data.Text.Internal.Lazy.Fusion as SL-import qualified Data.Text.Internal.Lazy.Search as S (indices)-import qualified Data.Text.Internal.Unsafe.Shift as U-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Lazy.Builder.Int as TB-import qualified Data.Text.Lazy.Builder.RealFloat as TB-import qualified Data.Text.Lazy.Encoding as EL-import qualified Data.Text.Lazy.IO as TL-import qualified System.IO as IO-import qualified Tests.Properties.Mul as Mul-import qualified Tests.SlowFunctions as Slow--t_pack_unpack = (T.unpack . T.pack) `eq` id-tl_pack_unpack = (TL.unpack . TL.pack) `eq` id-t_stream_unstream = (S.unstream . S.stream) `eq` id-tl_stream_unstream = (SL.unstream . SL.stream) `eq` id-t_reverse_stream t = (S.reverse . S.reverseStream) t === t-t_singleton c = [c] === (T.unpack . T.singleton) c-tl_singleton c = [c] === (TL.unpack . TL.singleton) c-tl_unstreamChunks x = f 11 x === f 1000 x- where f n = SL.unstreamChunks n . S.streamList-tl_chunk_unchunk = (TL.fromChunks . TL.toChunks) `eq` id-tl_from_to_strict = (TL.fromStrict . TL.toStrict) `eq` id---- Note: this silently truncates code-points > 255 to 8-bit due to 'B.pack'-encodeL1 :: T.Text -> B.ByteString-encodeL1 = B.pack . map (fromIntegral . fromEnum) . T.unpack-encodeLazyL1 :: TL.Text -> BL.ByteString-encodeLazyL1 = BL.fromChunks . map encodeL1 . TL.toChunks--t_ascii t = E.decodeASCII (E.encodeUtf8 a) === a- where a = T.map (\c -> chr (ord c `mod` 128)) t-tl_ascii t = EL.decodeASCII (EL.encodeUtf8 a) === a- where a = TL.map (\c -> chr (ord c `mod` 128)) t-t_latin1 t = E.decodeLatin1 (encodeL1 a) === a- where a = T.map (\c -> chr (ord c `mod` 256)) t-tl_latin1 t = EL.decodeLatin1 (encodeLazyL1 a) === a- where a = TL.map (\c -> chr (ord c `mod` 256)) t-t_utf8 = forAll genUnicode $ (E.decodeUtf8 . E.encodeUtf8) `eq` id-t_utf8' = forAll genUnicode $ (E.decodeUtf8' . E.encodeUtf8) `eq` (id . Right)-tl_utf8 = forAll genUnicode $ (EL.decodeUtf8 . EL.encodeUtf8) `eq` id-tl_utf8' = forAll genUnicode $ (EL.decodeUtf8' . EL.encodeUtf8) `eq` (id . Right)-t_utf16LE = forAll genUnicode $ (E.decodeUtf16LE . E.encodeUtf16LE) `eq` id-tl_utf16LE = forAll genUnicode $ (EL.decodeUtf16LE . EL.encodeUtf16LE) `eq` id-t_utf16BE = forAll genUnicode $ (E.decodeUtf16BE . E.encodeUtf16BE) `eq` id-tl_utf16BE = forAll genUnicode $ (EL.decodeUtf16BE . EL.encodeUtf16BE) `eq` id-t_utf32LE = forAll genUnicode $ (E.decodeUtf32LE . E.encodeUtf32LE) `eq` id-tl_utf32LE = forAll genUnicode $ (EL.decodeUtf32LE . EL.encodeUtf32LE) `eq` id-t_utf32BE = forAll genUnicode $ (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id-tl_utf32BE = forAll genUnicode $ (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id--t_utf8_incr = forAll genUnicode $ \s (Positive n) -> (recode n `eq` id) s- where recode n = T.concat . map fst . feedChunksOf n E.streamDecodeUtf8 .- E.encodeUtf8--feedChunksOf :: Int -> (B.ByteString -> E.Decoding) -> B.ByteString- -> [(T.Text, B.ByteString)]-feedChunksOf n f bs- | B.null bs = []- | otherwise = let (x,y) = B.splitAt n bs- E.Some t b f' = f x- in (t,b) : feedChunksOf n f' y--t_utf8_undecoded = forAll genUnicode $ \t ->- let b = E.encodeUtf8 t- ls = concatMap (leftover . E.encodeUtf8 . T.singleton) . T.unpack $ t- leftover = (++ [B.empty]) . init . tail . B.inits- in (map snd . feedChunksOf 1 E.streamDecodeUtf8) b === ls--data Badness = Solo | Leading | Trailing- deriving (Eq, Show)--instance Arbitrary Badness where- arbitrary = elements [Solo, Leading, Trailing]--t_utf8_err :: Badness -> Maybe DecodeErr -> Property-t_utf8_err bad mde = do- let gen = case bad of- Solo -> genInvalidUTF8- Leading -> B.append <$> genInvalidUTF8 <*> genUTF8- Trailing -> B.append <$> genUTF8 <*> genInvalidUTF8- genUTF8 = E.encodeUtf8 <$> genUnicode- forAll gen $ \bs -> MkProperty $- case mde of- -- generate an invalid character- Nothing -> do- c <- choose ('\x10000', maxBound)- let onErr _ _ = Just c- unProperty . monadicIO $ do- l <- run $ let len = T.length (E.decodeUtf8With onErr bs)- in (len `seq` return (Right len)) `Exception.catch`- (\(e::Exception.SomeException) -> return (Left e))- assert $ case l of- Left err ->- "non-BMP replacement characters not supported" `T.isInfixOf` T.pack (show err)- Right _ -> False-- -- generate a valid onErr- Just de -> do- onErr <- genDecodeErr de- unProperty . monadicIO $ do- l <- run $ let len = T.length (E.decodeUtf8With onErr bs)- in (len `seq` return (Right len)) `Exception.catch`- (\(e::UnicodeException) -> return (Left e))- assert $ case l of- Left err -> length (show err) >= 0- Right _ -> de /= Strict--t_utf8_err' :: B.ByteString -> Property-t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of- Left err -> length (show err) >= 0- Right t -> T.length t >= 0--genInvalidUTF8 :: Gen B.ByteString-genInvalidUTF8 = B.pack <$> oneof [- -- invalid leading byte of a 2-byte sequence- (:) <$> choose (0xC0, 0xC1) <*> upTo 1 contByte- -- invalid leading byte of a 4-byte sequence- , (:) <$> choose (0xF5, 0xFF) <*> upTo 3 contByte- -- 4-byte sequence greater than U+10FFFF- , do k <- choose (0x11, 0x13)- let w0 = 0xF0 + (k `Bits.shiftR` 2)- w1 = 0x80 + ((k .&. 3) `Bits.shiftL` 4)- ([w0,w1]++) <$> vectorOf 2 contByte- -- continuation bytes without a start byte- , listOf1 contByte- -- short 2-byte sequence- , (:[]) <$> choose (0xC2, 0xDF)- -- short 3-byte sequence- , (:) <$> choose (0xE0, 0xEF) <*> upTo 1 contByte- -- short 4-byte sequence- , (:) <$> choose (0xF0, 0xF4) <*> upTo 2 contByte- -- overlong encoding- , do k <- choose (0,0xFFFF)- let c = chr k- case k of- _ | k < 0x80 -> oneof [ let (w,x) = ord2 c in return [w,x]- , let (w,x,y) = ord3 c in return [w,x,y]- , let (w,x,y,z) = ord4 c in return [w,x,y,z] ]- | k < 0x7FF -> oneof [ let (w,x,y) = ord3 c in return [w,x,y]- , let (w,x,y,z) = ord4 c in return [w,x,y,z] ]- | otherwise -> let (w,x,y,z) = ord4 c in return [w,x,y,z]- ]- where- contByte = (0x80 +) <$> choose (0, 0x3f)- upTo n gen = do- k <- choose (0,n)- vectorOf k gen---- See http://unicode.org/faq/utf_bom.html#gen8--- A sequence such as <110xxxxx2 0xxxxxxx2> is illegal ...--- When faced with this illegal byte sequence ... a UTF-8 conformant process--- must treat the first byte 110xxxxx2 as an illegal termination error--- (e.g. filter it out or replace by 0xFFFD) ...--- ... and continue processing at the second byte 0xxxxxxx2-t_decode_with_error2 =- E.decodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97]) === "xa"-t_decode_with_error3 =- E.decodeUtf8With (\_ _ -> Just 'x') (B.pack [0xE0, 97, 97]) === "xaa"-t_decode_with_error4 =- E.decodeUtf8With (\_ _ -> Just 'x') (B.pack [0xF0, 97, 97, 97]) === "xaaa"--t_decode_with_error2' =- case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97]) of- E.Some x _ _ -> x === "xa"-t_decode_with_error3' =- case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97]) of- E.Some x _ _ -> x === "xaa"-t_decode_with_error4' =- case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97, 97]) of- E.Some x _ _ -> x === "xaaa"--t_infix_concat bs1 text bs2 =- forAll (genDecodeErr Replace) $ \onErr ->- text `T.isInfixOf`- E.decodeUtf8With onErr (B.concat [bs1, E.encodeUtf8 text, bs2])--s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList)- where _types = s :: String-sf_Eq p s =- ((L.filter p s==) . L.filter p) `eq`- (((S.filter p $ S.streamList s)==) . S.filter p . S.streamList)-t_Eq s = (s==) `eq` ((T.pack s==) . T.pack)-tl_Eq s = (s==) `eq` ((TL.pack s==) . TL.pack)-s_Ord s = (compare s) `eq` (compare (S.streamList s) . S.streamList)- where _types = s :: String-sf_Ord p s =- ((compare $ L.filter p s) . L.filter p) `eq`- (compare (S.filter p $ S.streamList s) . S.filter p . S.streamList)-t_Ord s = (compare s) `eq` (compare (T.pack s) . T.pack)-tl_Ord s = (compare s) `eq` (compare (TL.pack s) . TL.pack)-t_Read = id `eq` (T.unpack . read . show)-tl_Read = id `eq` (TL.unpack . read . show)-t_Show = show `eq` (show . T.pack)-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_mconcat = unsquare $- mconcat `eq` (unpackS . mconcat . L.map T.pack)-tl_mconcat = unsquare $- mconcat `eq` (unpackS . mconcat . L.map TL.pack)-t_mempty = mempty === (unpackS (mempty :: T.Text))-tl_mempty = mempty === (unpackS (mempty :: TL.Text))-t_IsString = fromString `eqP` (T.unpack . fromString)-tl_IsString = fromString `eqP` (TL.unpack . fromString)--s_cons x = (x:) `eqP` (unpackS . S.cons x)-s_cons_s x = (x:) `eqP` (unpackS . S.unstream . S.cons x)-sf_cons p x = ((x:) . L.filter p) `eqP` (unpackS . S.cons x . S.filter p)-t_cons x = (x:) `eqP` (unpackS . T.cons x)-tl_cons x = (x:) `eqP` (unpackS . TL.cons x)-s_snoc x = (++ [x]) `eqP` (unpackS . (flip S.snoc) x)-t_snoc x = (++ [x]) `eqP` (unpackS . (flip T.snoc) x)-tl_snoc x = (++ [x]) `eqP` (unpackS . (flip TL.snoc) x)-s_append s = (s++) `eqP` (unpackS . S.append (S.streamList s))-s_append_s s = (s++) `eqP`- (unpackS . S.unstream . S.append (S.streamList s))-sf_append p s = (L.filter p s++) `eqP`- (unpackS . S.append (S.filter p $ S.streamList s))-t_append s = (s++) `eqP` (unpackS . T.append (packS s))--uncons (x:xs) = Just (x,xs)-uncons _ = Nothing--s_uncons = uncons `eqP` (fmap (second unpackS) . S.uncons)-sf_uncons p = (uncons . L.filter p) `eqP`- (fmap (second unpackS) . S.uncons . S.filter p)-t_uncons = uncons `eqP` (fmap (second unpackS) . T.uncons)-tl_uncons = uncons `eqP` (fmap (second unpackS) . TL.uncons)--unsnoc xs@(_:_) = Just (init xs, last xs)-unsnoc [] = Nothing--t_unsnoc = unsnoc `eqP` (fmap (first unpackS) . T.unsnoc)-tl_unsnoc = unsnoc `eqP` (fmap (first unpackS) . TL.unsnoc)--s_head = head `eqP` S.head-sf_head p = (head . L.filter p) `eqP` (S.head . S.filter p)-t_head = head `eqP` T.head-tl_head = head `eqP` TL.head-s_last = last `eqP` S.last-sf_last p = (last . L.filter p) `eqP` (S.last . S.filter p)-t_last = last `eqP` T.last-tl_last = last `eqP` TL.last-s_tail = tail `eqP` (unpackS . S.tail)-s_tail_s = tail `eqP` (unpackS . S.unstream . S.tail)-sf_tail p = (tail . L.filter p) `eqP` (unpackS . S.tail . S.filter p)-t_tail = tail `eqP` (unpackS . T.tail)-tl_tail = tail `eqP` (unpackS . TL.tail)-s_init = init `eqP` (unpackS . S.init)-s_init_s = init `eqP` (unpackS . S.unstream . S.init)-sf_init p = (init . L.filter p) `eqP` (unpackS . S.init . S.filter p)-t_init = init `eqP` (unpackS . T.init)-tl_init = init `eqP` (unpackS . TL.init)-s_null = null `eqP` S.null-sf_null p = (null . L.filter p) `eqP` (S.null . S.filter p)-t_null = null `eqP` T.null-tl_null = null `eqP` TL.null-s_length = length `eqP` S.length-sf_length p = (length . L.filter p) `eqP` (S.length . S.filter p)-sl_length = (fromIntegral . length) `eqP` SL.length-t_length = length `eqP` T.length-tl_length = L.genericLength `eqP` TL.length-t_compareLength t = (compare (T.length t)) `eq` T.compareLength t-tl_compareLength t= (compare (TL.length t)) `eq` TL.compareLength t--s_map f = map f `eqP` (unpackS . S.map f)-s_map_s f = map f `eqP` (unpackS . S.unstream . S.map f)-sf_map p f = (map f . L.filter p) `eqP` (unpackS . S.map f . S.filter p)-t_map f = map f `eqP` (unpackS . T.map f)-tl_map f = map f `eqP` (unpackS . TL.map f)-s_intercalate c = unsquare $- L.intercalate c `eq`- (unpackS . S.intercalate (packS c) . map packS)-t_intercalate c = unsquare $- L.intercalate c `eq`- (unpackS . T.intercalate (packS c) . map packS)-tl_intercalate c = unsquare $- L.intercalate c `eq`- (unpackS . TL.intercalate (TL.pack c) . map TL.pack)-s_intersperse c = L.intersperse c `eqP`- (unpackS . S.intersperse c)-s_intersperse_s c = L.intersperse c `eqP`- (unpackS . S.unstream . S.intersperse c)-sf_intersperse p c= (L.intersperse c . L.filter p) `eqP`- (unpackS . S.intersperse c . S.filter p)-t_intersperse c = unsquare $- L.intersperse c `eqP` (unpackS . T.intersperse c)-tl_intersperse c = unsquare $- L.intersperse c `eqP` (unpackS . TL.intersperse c)-t_transpose = unsquare $- L.transpose `eq` (map unpackS . T.transpose . map packS)-tl_transpose = unsquare $- L.transpose `eq` (map unpackS . TL.transpose . map TL.pack)-t_reverse = L.reverse `eqP` (unpackS . T.reverse)-tl_reverse = L.reverse `eqP` (unpackS . TL.reverse)-t_reverse_short n = L.reverse `eqP` (unpackS . S.reverse . shorten n . S.stream)--t_replace s d = (L.intercalate d . splitOn s) `eqP`- (unpackS . T.replace (T.pack s) (T.pack d))-tl_replace s d = (L.intercalate d . splitOn s) `eqP`- (unpackS . TL.replace (TL.pack s) (TL.pack d))--splitOn :: (Eq a) => [a] -> [a] -> [[a]]-splitOn pat src0- | l == 0 = error "splitOn: empty"- | otherwise = go src0- where- l = length pat- go src = search 0 src- where- search _ [] = [src]- search !n s@(_:s')- | pat `L.isPrefixOf` s = take n src : go (drop l s)- | otherwise = search (n+1) s'--s_toCaseFold_length xs = S.length (S.toCaseFold s) >= length xs- where s = S.streamList xs-sf_toCaseFold_length p xs =- (S.length . S.toCaseFold . S.filter p $ s) >= (length . L.filter p $ xs)- where s = S.streamList xs-t_toCaseFold_length t = T.length (T.toCaseFold t) >= T.length t-tl_toCaseFold_length t = TL.length (TL.toCaseFold t) >= TL.length t-t_toLower_length t = T.length (T.toLower t) >= T.length t-t_toLower_lower t = p (T.toLower t) >= p t- where p = T.length . T.filter isLower-tl_toLower_lower t = p (TL.toLower t) >= p t- where p = TL.length . TL.filter isLower-t_toUpper_length t = T.length (T.toUpper t) >= T.length t-t_toUpper_upper t = p (T.toUpper t) >= p t- where p = T.length . T.filter isUpper-tl_toUpper_upper t = p (TL.toUpper t) >= p t- where p = TL.length . TL.filter isUpper-t_toTitle_title t = all (<= 1) (caps w)- where caps = fmap (T.length . T.filter isUpper) . T.words . T.toTitle- -- TIL: there exist uppercase-only letters- w = T.filter (\c -> if C.isUpper c then C.toLower c /= c else True) t-t_toTitle_1stNotLower = and . notLow . T.toTitle . T.filter stable- where notLow = mapMaybe (fmap (not . isLower) . (T.find isLetter)) . T.words- -- Surprise! The Spanish/Portuguese ordinal indicators changed- -- from category Ll (letter, lowercase) to Lo (letter, other)- -- in Unicode 7.0- -- Oh, and there exist lowercase-only letters (see previous test)- stable c = if isLower c- then C.toUpper c /= c- else c /= '\170' && c /= '\186'--justifyLeft k c xs = xs ++ L.replicate (k - length xs) c-justifyRight m n xs = L.replicate (m - length xs) n ++ xs-center k c xs- | len >= k = xs- | otherwise = L.replicate l c ++ xs ++ L.replicate r c- where len = length xs- d = k - len- r = d `div` 2- l = d - r--s_justifyLeft k c = justifyLeft j c `eqP` (unpackS . S.justifyLeftI j c)- where j = fromIntegral (k :: Word8)-s_justifyLeft_s k c = justifyLeft j c `eqP`- (unpackS . S.unstream . S.justifyLeftI j c)- where j = fromIntegral (k :: Word8)-sf_justifyLeft p k c = (justifyLeft j c . L.filter p) `eqP`- (unpackS . S.justifyLeftI j c . S.filter p)- where j = fromIntegral (k :: Word8)-t_justifyLeft k c = justifyLeft j c `eqP` (unpackS . T.justifyLeft j c)- where j = fromIntegral (k :: Word8)-tl_justifyLeft k c = justifyLeft j c `eqP`- (unpackS . TL.justifyLeft (fromIntegral j) c)- where j = fromIntegral (k :: Word8)-t_justifyRight k c = justifyRight j c `eqP` (unpackS . T.justifyRight j c)- where j = fromIntegral (k :: Word8)-tl_justifyRight k c = justifyRight j c `eqP`- (unpackS . TL.justifyRight (fromIntegral j) c)- where j = fromIntegral (k :: Word8)-t_center k c = center j c `eqP` (unpackS . T.center j c)- where j = fromIntegral (k :: Word8)-tl_center k c = center j c `eqP` (unpackS . TL.center (fromIntegral j) c)- where j = fromIntegral (k :: Word8)--sf_foldl p f z = (L.foldl f z . L.filter p) `eqP` (S.foldl f z . S.filter p)- where _types = f :: Char -> Char -> Char-t_foldl f z = L.foldl f z `eqP` (T.foldl f z)- where _types = f :: Char -> Char -> Char-tl_foldl f z = L.foldl f z `eqP` (TL.foldl f z)- where _types = f :: Char -> Char -> Char-sf_foldl' p f z = (L.foldl' f z . L.filter p) `eqP`- (S.foldl' f z . S.filter p)- where _types = f :: Char -> Char -> Char-t_foldl' f z = L.foldl' f z `eqP` T.foldl' f z- where _types = f :: Char -> Char -> Char-tl_foldl' f z = L.foldl' f z `eqP` TL.foldl' f z- where _types = f :: Char -> Char -> Char-sf_foldl1 p f = (L.foldl1 f . L.filter p) `eqP` (S.foldl1 f . S.filter p)-t_foldl1 f = L.foldl1 f `eqP` T.foldl1 f-tl_foldl1 f = L.foldl1 f `eqP` TL.foldl1 f-sf_foldl1' p f = (L.foldl1' f . L.filter p) `eqP` (S.foldl1' f . S.filter p)-t_foldl1' f = L.foldl1' f `eqP` T.foldl1' f-tl_foldl1' f = L.foldl1' f `eqP` TL.foldl1' f-sf_foldr p f z = (L.foldr f z . L.filter p) `eqP` (S.foldr f z . S.filter p)- where _types = f :: Char -> Char -> Char-t_foldr f z = L.foldr f z `eqP` T.foldr f z- where _types = f :: Char -> Char -> Char-tl_foldr f z = unsquare $- L.foldr f z `eqP` TL.foldr f z- where _types = f :: Char -> Char -> Char-sf_foldr1 p f = unsquare $- (L.foldr1 f . L.filter p) `eqP` (S.foldr1 f . S.filter p)-t_foldr1 f = L.foldr1 f `eqP` T.foldr1 f-tl_foldr1 f = unsquare $- L.foldr1 f `eqP` TL.foldr1 f--s_concat_s = unsquare $- L.concat `eq` (unpackS . S.unstream . S.concat . map packS)-sf_concat p = unsquare $- (L.concat . map (L.filter p)) `eq`- (unpackS . S.concat . map (S.filter p . packS))-t_concat = unsquare $- L.concat `eq` (unpackS . T.concat . map packS)-tl_concat = unsquare $- L.concat `eq` (unpackS . TL.concat . map TL.pack)-sf_concatMap p f = unsquare $ (L.concatMap f . L.filter p) `eqP`- (unpackS . S.concatMap (packS . f) . S.filter p)-t_concatMap f = unsquare $- L.concatMap f `eqP` (unpackS . T.concatMap (packS . f))-tl_concatMap f = unsquare $- L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f))-sf_any q p = (L.any p . L.filter q) `eqP` (S.any p . S.filter q)-t_any p = L.any p `eqP` T.any p-tl_any p = L.any p `eqP` TL.any p-sf_all q p = (L.all p . L.filter q) `eqP` (S.all p . S.filter q)-t_all p = L.all p `eqP` T.all p-tl_all p = L.all p `eqP` TL.all p-sf_maximum p = (L.maximum . L.filter p) `eqP` (S.maximum . S.filter p)-t_maximum = L.maximum `eqP` T.maximum-tl_maximum = L.maximum `eqP` TL.maximum-sf_minimum p = (L.minimum . L.filter p) `eqP` (S.minimum . S.filter p)-t_minimum = L.minimum `eqP` T.minimum-tl_minimum = L.minimum `eqP` TL.minimum--sf_scanl p f z = (L.scanl f z . L.filter p) `eqP`- (unpackS . S.scanl f z . S.filter p)-t_scanl f z = L.scanl f z `eqP` (unpackS . T.scanl f z)-tl_scanl f z = L.scanl f z `eqP` (unpackS . TL.scanl f z)-t_scanl1 f = L.scanl1 f `eqP` (unpackS . T.scanl1 f)-tl_scanl1 f = L.scanl1 f `eqP` (unpackS . TL.scanl1 f)-t_scanr f z = L.scanr f z `eqP` (unpackS . T.scanr f z)-tl_scanr f z = L.scanr f z `eqP` (unpackS . TL.scanr f z)-t_scanr1 f = L.scanr1 f `eqP` (unpackS . T.scanr1 f)-tl_scanr1 f = L.scanr1 f `eqP` (unpackS . TL.scanr1 f)--t_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . T.mapAccumL f z)- where _types = f :: Int -> Char -> (Int,Char)-tl_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . TL.mapAccumL f z)- where _types = f :: Int -> Char -> (Int,Char)-t_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . T.mapAccumR f z)- where _types = f :: Int -> Char -> (Int,Char)-tl_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . TL.mapAccumR f z)- where _types = f :: Int -> Char -> (Int,Char)--tl_repeat n = (L.take m . L.repeat) `eq`- (unpackS . TL.take (fromIntegral m) . TL.repeat)- where m = fromIntegral (n :: Word8)--replicate n l = concat (L.replicate n l)--s_replicate n = replicate m `eq`- (unpackS . S.replicateI (fromIntegral m) . packS)- where m = fromIntegral (n :: Word8)-t_replicate n = replicate m `eq` (unpackS . T.replicate m . packS)- where m = fromIntegral (n :: Word8)-tl_replicate n = replicate m `eq`- (unpackS . TL.replicate (fromIntegral m) . packS)- where m = fromIntegral (n :: Word8)--tl_cycle n = (L.take m . L.cycle) `eq`- (unpackS . TL.take (fromIntegral m) . TL.cycle . packS)- where m = fromIntegral (n :: Word8)--tl_iterate f n = (L.take m . L.iterate f) `eq`- (unpackS . TL.take (fromIntegral m) . TL.iterate f)- where m = fromIntegral (n :: Word8)--unf :: Int -> Char -> Maybe (Char, Char)-unf n c | fromEnum c * 100 > n = Nothing- | otherwise = Just (c, succ c)--t_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . T.unfoldr (unf m))- where m = fromIntegral (n :: Word16)-tl_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . TL.unfoldr (unf m))- where m = fromIntegral (n :: Word16)-t_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`- (unpackS . T.unfoldrN i (unf j))- where i = fromIntegral (n :: Word16)- j = fromIntegral (m :: Word16)-tl_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`- (unpackS . TL.unfoldrN (fromIntegral i) (unf j))- where i = fromIntegral (n :: Word16)- j = fromIntegral (m :: Word16)--unpack2 :: (Stringy s) => (s,s) -> (String,String)-unpack2 = unpackS *** unpackS--s_take n = L.take n `eqP` (unpackS . S.take n)-s_take_s m = L.take n `eqP` (unpackS . S.unstream . S.take n)- where n = small m-sf_take p n = (L.take n . L.filter p) `eqP`- (unpackS . S.take n . S.filter p)-t_take n = L.take n `eqP` (unpackS . T.take n)-t_takeEnd n = (L.reverse . L.take n . L.reverse) `eqP`- (unpackS . T.takeEnd n)-tl_take n = L.take n `eqP` (unpackS . TL.take (fromIntegral n))-tl_takeEnd n = (L.reverse . L.take (fromIntegral n) . L.reverse) `eqP`- (unpackS . TL.takeEnd n)-s_drop n = L.drop n `eqP` (unpackS . S.drop n)-s_drop_s m = L.drop n `eqP` (unpackS . S.unstream . S.drop n)- where n = small m-sf_drop p n = (L.drop n . L.filter p) `eqP`- (unpackS . S.drop n . S.filter p)-t_drop n = L.drop n `eqP` (unpackS . T.drop n)-t_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`- (unpackS . T.dropEnd n)-tl_drop n = L.drop n `eqP` (unpackS . TL.drop (fromIntegral n))-tl_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`- (unpackS . TL.dropEnd (fromIntegral n))-s_take_drop m = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)- where n = small m-s_take_drop_s m = (L.take n . L.drop n) `eqP`- (unpackS . S.unstream . S.take n . S.drop n)- where n = small m-s_takeWhile p = L.takeWhile p `eqP` (unpackS . S.takeWhile p)-s_takeWhile_s p = L.takeWhile p `eqP` (unpackS . S.unstream . S.takeWhile p)-sf_takeWhile q p = (L.takeWhile p . L.filter q) `eqP`- (unpackS . S.takeWhile p . S.filter q)-noMatch = do- c <- char- d <- suchThat char (/= c)- return (c,d)-t_takeWhile p = L.takeWhile p `eqP` (unpackS . T.takeWhile p)-tl_takeWhile p = L.takeWhile p `eqP` (unpackS . TL.takeWhile p)-t_takeWhileEnd p = (L.reverse . L.takeWhile p . L.reverse) `eqP`- (unpackS . T.takeWhileEnd p)-t_takeWhileEnd_null t = forAll noMatch $ \(c,d) -> T.null $- T.takeWhileEnd (==d) (T.snoc t c)-tl_takeWhileEnd p = (L.reverse . L.takeWhile p . L.reverse) `eqP`- (unpackS . TL.takeWhileEnd p)-tl_takeWhileEnd_null t = forAll noMatch $ \(c,d) -> TL.null $- TL.takeWhileEnd (==d) (TL.snoc t c)-s_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)-s_dropWhile_s p = L.dropWhile p `eqP` (unpackS . S.unstream . S.dropWhile p)-sf_dropWhile q p = (L.dropWhile p . L.filter q) `eqP`- (unpackS . S.dropWhile p . S.filter q)-t_dropWhile p = L.dropWhile p `eqP` (unpackS . T.dropWhile p)-tl_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)-t_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`- (unpackS . T.dropWhileEnd p)-tl_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`- (unpackS . TL.dropWhileEnd p)-t_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)- `eqP` (unpackS . T.dropAround p)-tl_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)- `eqP` (unpackS . TL.dropAround p)-t_stripStart = T.dropWhile isSpace `eq` T.stripStart-tl_stripStart = TL.dropWhile isSpace `eq` TL.stripStart-t_stripEnd = T.dropWhileEnd isSpace `eq` T.stripEnd-tl_stripEnd = TL.dropWhileEnd isSpace `eq` TL.stripEnd-t_strip = T.dropAround isSpace `eq` T.strip-tl_strip = TL.dropAround isSpace `eq` TL.strip-t_splitAt n = L.splitAt n `eqP` (unpack2 . T.splitAt n)-tl_splitAt n = L.splitAt n `eqP` (unpack2 . TL.splitAt (fromIntegral n))-t_span p = L.span p `eqP` (unpack2 . T.span p)-tl_span p = L.span p `eqP` (unpack2 . TL.span p)--t_breakOn_id s = squid `eq` (uncurry T.append . T.breakOn s)- where squid t | T.null s = error "empty"- | otherwise = t-tl_breakOn_id s = squid `eq` (uncurry TL.append . TL.breakOn s)- where squid t | TL.null s = error "empty"- | otherwise = t-t_breakOn_start (NotEmpty s) t =- let (k,m) = T.breakOn s t- in k `T.isPrefixOf` t && (T.null m || s `T.isPrefixOf` m)-tl_breakOn_start (NotEmpty s) t =- let (k,m) = TL.breakOn s t- in k `TL.isPrefixOf` t && TL.null m || s `TL.isPrefixOf` m-t_breakOnEnd_end (NotEmpty s) t =- let (m,k) = T.breakOnEnd s t- in k `T.isSuffixOf` t && (T.null m || s `T.isSuffixOf` m)-tl_breakOnEnd_end (NotEmpty s) t =- let (m,k) = TL.breakOnEnd s t- in k `TL.isSuffixOf` t && (TL.null m || s `TL.isSuffixOf` m)-t_break p = L.break p `eqP` (unpack2 . T.break p)-tl_break p = L.break p `eqP` (unpack2 . TL.break p)-t_group = L.group `eqP` (map unpackS . T.group)-tl_group = L.group `eqP` (map unpackS . TL.group)-t_groupBy p = L.groupBy p `eqP` (map unpackS . T.groupBy p)-tl_groupBy p = L.groupBy p `eqP` (map unpackS . TL.groupBy p)-t_inits = L.inits `eqP` (map unpackS . T.inits)-tl_inits = L.inits `eqP` (map unpackS . TL.inits)-t_tails = L.tails `eqP` (map unpackS . T.tails)-tl_tails = unsquare $- L.tails `eqP` (map unpackS . TL.tails)-t_findAppendId = unsquare $ \(NotEmpty s) ts ->- let t = T.intercalate s ts- in all (==t) $ map (uncurry T.append) (T.breakOnAll s t)-tl_findAppendId = unsquare $ \(NotEmpty s) ts ->- let t = TL.intercalate s ts- in all (==t) $ map (uncurry TL.append) (TL.breakOnAll s t)-t_findContains = unsquare $ \(NotEmpty s) ->- all (T.isPrefixOf s . snd) . T.breakOnAll s . T.intercalate s-tl_findContains = unsquare $ \(NotEmpty s) -> all (TL.isPrefixOf s . snd) .- TL.breakOnAll s . TL.intercalate s-sl_filterCount c = (L.genericLength . L.filter (==c)) `eqP` SL.countChar c-t_findCount s = (L.length . T.breakOnAll s) `eq` T.count s-tl_findCount s = (L.genericLength . TL.breakOnAll s) `eq` TL.count s--t_splitOn_split s = unsquare $- (T.splitOn s `eq` Slow.splitOn s) . T.intercalate s-tl_splitOn_split s = unsquare $- ((TL.splitOn (TL.fromStrict s) . TL.fromStrict) `eq`- (map TL.fromStrict . T.splitOn s)) . T.intercalate s-t_splitOn_i (NotEmpty t) = id `eq` (T.intercalate t . T.splitOn t)-tl_splitOn_i (NotEmpty t) = id `eq` (TL.intercalate t . TL.splitOn t)--t_split p = split p `eqP` (map unpackS . T.split p)-t_split_count c = (L.length . T.split (==c)) `eq`- ((1+) . T.count (T.singleton c))-t_split_splitOn c = T.split (==c) `eq` T.splitOn (T.singleton c)-tl_split p = split p `eqP` (map unpackS . TL.split p)--split :: (a -> Bool) -> [a] -> [[a]]-split _ [] = [[]]-split p xs = loop xs- where loop s | null s' = [l]- | otherwise = l : loop (tail s')- where (l, s') = break p s--t_chunksOf_same_lengths k = all ((==k) . T.length) . ini . T.chunksOf k- where ini [] = []- ini xs = init xs--t_chunksOf_length k t = len == T.length t || (k <= 0 && len == 0)- where len = L.sum . L.map T.length $ T.chunksOf k t--tl_chunksOf k = T.chunksOf k `eq` (map (T.concat . TL.toChunks) .- TL.chunksOf (fromIntegral k) . TL.fromStrict)--t_lines = L.lines `eqP` (map unpackS . T.lines)-tl_lines = L.lines `eqP` (map unpackS . TL.lines)-{--t_lines' = lines' `eqP` (map unpackS . T.lines')- where lines' "" = []- lines' s = let (l, s') = break eol s- in l : case s' of- [] -> []- ('\r':'\n':s'') -> lines' s''- (_:s'') -> lines' s''- eol c = c == '\r' || c == '\n'--}-t_words = L.words `eqP` (map unpackS . T.words)--tl_words = L.words `eqP` (map unpackS . TL.words)-t_unlines = unsquare $- L.unlines `eq` (unpackS . T.unlines . map packS)-tl_unlines = unsquare $- L.unlines `eq` (unpackS . TL.unlines . map packS)-t_unwords = unsquare $- L.unwords `eq` (unpackS . T.unwords . map packS)-tl_unwords = unsquare $- L.unwords `eq` (unpackS . TL.unwords . map packS)--s_isPrefixOf s = L.isPrefixOf s `eqP`- (S.isPrefixOf (S.stream $ packS s) . S.stream)-sf_isPrefixOf p s = (L.isPrefixOf s . L.filter p) `eqP`- (S.isPrefixOf (S.stream $ packS s) . S.filter p . S.stream)-t_isPrefixOf s = L.isPrefixOf s`eqP` T.isPrefixOf (packS s)-tl_isPrefixOf s = L.isPrefixOf s`eqP` TL.isPrefixOf (packS s)-t_isSuffixOf s = L.isSuffixOf s`eqP` T.isSuffixOf (packS s)-tl_isSuffixOf s = L.isSuffixOf s`eqP` TL.isSuffixOf (packS s)-t_isInfixOf s = L.isInfixOf s `eqP` T.isInfixOf (packS s)-tl_isInfixOf s = L.isInfixOf s `eqP` TL.isInfixOf (packS s)--t_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` T.stripPrefix (packS s)-tl_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` TL.stripPrefix (packS s)--stripSuffix p t = reverse `fmap` L.stripPrefix (reverse p) (reverse t)--t_stripSuffix s = (fmap packS . stripSuffix s) `eqP` T.stripSuffix (packS s)-tl_stripSuffix s = (fmap packS . stripSuffix s) `eqP` TL.stripSuffix (packS s)--commonPrefixes a0@(_:_) b0@(_:_) = Just (go a0 b0 [])- where go (a:as) (b:bs) ps- | a == b = go as bs (a:ps)- go as bs ps = (reverse ps,as,bs)-commonPrefixes _ _ = Nothing--t_commonPrefixes a b (NonEmpty p)- = commonPrefixes pa pb ==- repack `fmap` T.commonPrefixes (packS pa) (packS pb)- where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)- pa = p ++ a- pb = p ++ b--tl_commonPrefixes a b (NonEmpty p)- = commonPrefixes pa pb ==- repack `fmap` TL.commonPrefixes (packS pa) (packS pb)- where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)- pa = p ++ a- pb = p ++ b--sf_elem p c = (L.elem c . L.filter p) `eqP` (S.elem c . S.filter p)-sf_filter q p = (L.filter p . L.filter q) `eqP`- (unpackS . S.filter p . S.filter q)-t_filter p = L.filter p `eqP` (unpackS . T.filter p)-tl_filter p = L.filter p `eqP` (unpackS . TL.filter p)-sf_findBy q p = (L.find p . L.filter q) `eqP` (S.findBy p . S.filter q)-t_find p = L.find p `eqP` T.find p-tl_find p = L.find p `eqP` TL.find p-t_partition p = L.partition p `eqP` (unpack2 . T.partition p)-tl_partition p = L.partition p `eqP` (unpack2 . TL.partition p)--sf_index p s = forAll (choose (-l,l*2))- ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))- where l = L.length s-t_index s = forAll (choose (-l,l*2)) ((s L.!!) `eq` T.index (packS s))- where l = L.length s--tl_index s = forAll (choose (-l,l*2))- ((s L.!!) `eq` (TL.index (packS s) . fromIntegral))- where l = L.length s--t_findIndex p = L.findIndex p `eqP` T.findIndex p-t_count (NotEmpty t) = (subtract 1 . L.length . T.splitOn t) `eq` T.count t-tl_count (NotEmpty t) = (subtract 1 . L.genericLength . TL.splitOn t) `eq`- TL.count t-t_zip s = L.zip s `eqP` T.zip (packS s)-tl_zip s = L.zip s `eqP` TL.zip (packS s)-sf_zipWith p c s = (L.zipWith c (L.filter p s) . L.filter p) `eqP`- (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p)-t_zipWith c s = L.zipWith c s `eqP` (unpackS . T.zipWith c (packS s))-tl_zipWith c s = L.zipWith c s `eqP` (unpackS . TL.zipWith c (packS s))--t_indices (NotEmpty s) = Slow.indices s `eq` indices s-tl_indices (NotEmpty s) = lazyIndices s `eq` S.indices s- where lazyIndices ss t = map fromIntegral $ Slow.indices (conc ss) (conc t)- conc = T.concat . TL.toChunks-t_indices_occurs = unsquare $ \(NotEmpty t) ts ->- let s = T.intercalate t ts- in Slow.indices t s === indices t s---- Bit shifts.-shiftL w = forAll (choose (0,width-1)) $ \k -> Bits.shiftL w k == U.shiftL w k- where width = round (log (fromIntegral m) / log 2 :: Double)- (m,_) = (maxBound, m == w)-shiftR w = forAll (choose (0,width-1)) $ \k -> Bits.shiftR w k == U.shiftR w k- where width = round (log (fromIntegral m) / log 2 :: Double)- (m,_) = (maxBound, m == w)--shiftL_Int = shiftL :: Int -> Property-shiftL_Word16 = shiftL :: Word16 -> Property-shiftL_Word32 = shiftL :: Word32 -> Property-shiftR_Int = shiftR :: Int -> Property-shiftR_Word16 = shiftR :: Word16 -> Property-shiftR_Word32 = shiftR :: Word32 -> Property---- Builder.--tb_singleton = id `eqP`- (unpackS . TB.toLazyText . mconcat . map TB.singleton)-tb_fromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat .- map (TB.fromText . packS))-tb_associative s1 s2 s3 =- TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==- TB.toLazyText ((b1 `mappend` b2) `mappend` b3)- where b1 = TB.fromText (packS s1)- b2 = TB.fromText (packS s2)- b3 = TB.fromText (packS s3)---- Numeric builder stuff.--tb_decimal :: (Integral a, Show a) => a -> Bool-tb_decimal = (TB.toLazyText . TB.decimal) `eq` (TL.pack . show)--tb_decimal_integer (a::Integer) = tb_decimal a-tb_decimal_integer_big (Big a) = tb_decimal a-tb_decimal_int (a::Int) = tb_decimal a-tb_decimal_int8 (a::Int8) = tb_decimal a-tb_decimal_int16 (a::Int16) = tb_decimal a-tb_decimal_int32 (a::Int32) = tb_decimal a-tb_decimal_int64 (a::Int64) = tb_decimal a-tb_decimal_word (a::Word) = tb_decimal a-tb_decimal_word8 (a::Word8) = tb_decimal a-tb_decimal_word16 (a::Word16) = tb_decimal a-tb_decimal_word32 (a::Word32) = tb_decimal a-tb_decimal_word64 (a::Word64) = tb_decimal a--tb_decimal_big_int (BigBounded (a::Int)) = tb_decimal a-tb_decimal_big_int64 (BigBounded (a::Int64)) = tb_decimal a-tb_decimal_big_word (BigBounded (a::Word)) = tb_decimal a-tb_decimal_big_word64 (BigBounded (a::Word64)) = tb_decimal a--tb_hex :: (Integral a, Show a) => a -> Bool-tb_hex = (TB.toLazyText . TB.hexadecimal) `eq` (TL.pack . flip showHex "")--tb_hexadecimal_integer (a::Integer) = tb_hex a-tb_hexadecimal_int (a::Int) = tb_hex a-tb_hexadecimal_int8 (a::Int8) = tb_hex a-tb_hexadecimal_int16 (a::Int16) = tb_hex a-tb_hexadecimal_int32 (a::Int32) = tb_hex a-tb_hexadecimal_int64 (a::Int64) = tb_hex a-tb_hexadecimal_word (a::Word) = tb_hex a-tb_hexadecimal_word8 (a::Word8) = tb_hex a-tb_hexadecimal_word16 (a::Word16) = tb_hex a-tb_hexadecimal_word32 (a::Word32) = tb_hex a-tb_hexadecimal_word64 (a::Word64) = tb_hex a--tb_realfloat :: (RealFloat a, Show a) => a -> Bool-tb_realfloat = (TB.toLazyText . TB.realFloat) `eq` (TL.pack . show)--tb_realfloat_float (a::Float) = tb_realfloat a-tb_realfloat_double (a::Double) = tb_realfloat a--showFloat :: (RealFloat a) => TB.FPFormat -> Maybe Int -> a -> ShowS-showFloat TB.Exponent (Just 0) = showEFloat (Just 1) -- see gh-231-showFloat TB.Exponent p = showEFloat p-showFloat TB.Fixed p = showFFloat p-showFloat TB.Generic p = showGFloat p--tb_formatRealFloat :: (RealFloat a, Show a) =>- a -> TB.FPFormat -> Precision a -> Property-tb_formatRealFloat a fmt prec = cond ==>- TB.formatRealFloat fmt p a ===- TB.fromString (showFloat fmt p a "")- where p = precision a prec- cond = case (p,fmt) of-#if MIN_VERSION_base(4,12,0)- (Just 0, TB.Generic) -> False -- skipping due to gh-231-#endif- _ -> True--tb_formatRealFloat_float (a::Float) = tb_formatRealFloat a-tb_formatRealFloat_double (a::Double) = tb_formatRealFloat a---- Reading.--t_decimal (n::Int) s =- T.signed T.decimal (T.pack (show n) `T.append` t) === Right (n,t)- where t = T.dropWhile isDigit s-tl_decimal (n::Int) s =- TL.signed TL.decimal (TL.pack (show n) `TL.append` t) === Right (n,t)- where t = TL.dropWhile isDigit s-t_hexadecimal m s ox =- T.hexadecimal (T.concat [p, T.pack (showHex n ""), t]) === Right (n,t)- where t = T.dropWhile isHexDigit s- p = if ox then "0x" else ""- n = getPositive m :: Int-tl_hexadecimal m s ox =- TL.hexadecimal (TL.concat [p, TL.pack (showHex n ""), t]) === Right (n,t)- where t = TL.dropWhile isHexDigit s- p = if ox then "0x" else ""- n = getPositive m :: Int--isFloaty c = c `elem` ("+-.0123456789eE" :: String)--t_read_rational p tol (n::Double) s =- case p (T.pack (show n) `T.append` t) of- Left _err -> False- Right (n',t') -> t == t' && abs (n-n') <= tol- where t = T.dropWhile isFloaty s--tl_read_rational p tol (n::Double) s =- case p (TL.pack (show n) `TL.append` t) of- Left _err -> False- Right (n',t') -> t == t' && abs (n-n') <= tol- where t = TL.dropWhile isFloaty s--t_double = t_read_rational T.double 1e-13-tl_double = tl_read_rational TL.double 1e-13-t_rational = t_read_rational T.rational 1e-16-tl_rational = tl_read_rational TL.rational 1e-16---- 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-tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents--t_write_read_line e m b t = write_read head T.filter T.hPutStrLn- T.hGetLine e m b [t]-tl_write_read_line e m b t = write_read head TL.filter TL.hPutStrLn- TL.hGetLine e m b [t]---- Low-level.--t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t-t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t-t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) === t- where n = small m-t_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)--t_copy t = T.copy t === t---- Regression tests.-s_filter_eq s = S.filter p t == S.streamList (filter p s)- where p = (/= S.last t)- t = S.streamList s---- Make a stream appear shorter than it really is, to ensure that--- functions that consume inaccurately sized streams behave--- themselves.-shorten :: Int -> S.Stream a -> S.Stream a-shorten n t@(S.Stream arr off len)- | n > 0 = S.Stream arr off (smaller (exactSize n) len)- | otherwise = t--tests :: Test-tests =- testGroup "Properties" [- testGroup "creation/elimination" [- testProperty "t_pack_unpack" t_pack_unpack,- testProperty "tl_pack_unpack" tl_pack_unpack,- testProperty "t_stream_unstream" t_stream_unstream,- testProperty "tl_stream_unstream" tl_stream_unstream,- testProperty "t_reverse_stream" t_reverse_stream,- testProperty "t_singleton" t_singleton,- testProperty "tl_singleton" tl_singleton,- testProperty "tl_unstreamChunks" tl_unstreamChunks,- testProperty "tl_chunk_unchunk" tl_chunk_unchunk,- testProperty "tl_from_to_strict" tl_from_to_strict- ],-- testGroup "transcoding" [- testProperty "t_ascii" t_ascii,- testProperty "tl_ascii" tl_ascii,- testProperty "t_latin1" t_latin1,- testProperty "tl_latin1" tl_latin1,- testProperty "t_utf8" t_utf8,- testProperty "t_utf8'" t_utf8',- testProperty "t_utf8_incr" t_utf8_incr,- testProperty "t_utf8_undecoded" t_utf8_undecoded,- testProperty "tl_utf8" tl_utf8,- testProperty "tl_utf8'" tl_utf8',- testProperty "t_utf16LE" t_utf16LE,- testProperty "tl_utf16LE" tl_utf16LE,- testProperty "t_utf16BE" t_utf16BE,- testProperty "tl_utf16BE" tl_utf16BE,- testProperty "t_utf32LE" t_utf32LE,- testProperty "tl_utf32LE" tl_utf32LE,- testProperty "t_utf32BE" t_utf32BE,- testProperty "tl_utf32BE" tl_utf32BE,- testGroup "errors" [- testProperty "t_utf8_err" t_utf8_err,- testProperty "t_utf8_err'" t_utf8_err'- ],- testGroup "error recovery" [- testProperty "t_decode_with_error2" t_decode_with_error2,- testProperty "t_decode_with_error3" t_decode_with_error3,- testProperty "t_decode_with_error4" t_decode_with_error4,- testProperty "t_decode_with_error2'" t_decode_with_error2',- testProperty "t_decode_with_error3'" t_decode_with_error3',- testProperty "t_decode_with_error4'" t_decode_with_error4',- testProperty "t_infix_concat" t_infix_concat- ]- ],-- testGroup "instances" [- testProperty "s_Eq" s_Eq,- testProperty "sf_Eq" sf_Eq,- testProperty "t_Eq" t_Eq,- testProperty "tl_Eq" tl_Eq,- testProperty "s_Ord" s_Ord,- testProperty "sf_Ord" sf_Ord,- testProperty "t_Ord" t_Ord,- testProperty "tl_Ord" tl_Ord,- testProperty "t_Read" t_Read,- testProperty "tl_Read" tl_Read,- testProperty "t_Show" t_Show,- testProperty "tl_Show" tl_Show,- testProperty "t_mappend" t_mappend,- testProperty "tl_mappend" tl_mappend,- testProperty "t_mconcat" t_mconcat,- testProperty "tl_mconcat" tl_mconcat,- testProperty "t_mempty" t_mempty,- testProperty "tl_mempty" tl_mempty,- testProperty "t_IsString" t_IsString,- testProperty "tl_IsString" tl_IsString- ],-- testGroup "basics" [- testProperty "s_cons" s_cons,- testProperty "s_cons_s" s_cons_s,- testProperty "sf_cons" sf_cons,- testProperty "t_cons" t_cons,- testProperty "tl_cons" tl_cons,- testProperty "s_snoc" s_snoc,- testProperty "t_snoc" t_snoc,- testProperty "tl_snoc" tl_snoc,- testProperty "s_append" s_append,- testProperty "s_append_s" s_append_s,- testProperty "sf_append" sf_append,- testProperty "t_append" t_append,- testProperty "s_uncons" s_uncons,- testProperty "sf_uncons" sf_uncons,- testProperty "t_uncons" t_uncons,- testProperty "tl_uncons" tl_uncons,- testProperty "t_unsnoc" t_unsnoc,- testProperty "tl_unsnoc" tl_unsnoc,- testProperty "s_head" s_head,- testProperty "sf_head" sf_head,- testProperty "t_head" t_head,- testProperty "tl_head" tl_head,- testProperty "s_last" s_last,- testProperty "sf_last" sf_last,- testProperty "t_last" t_last,- testProperty "tl_last" tl_last,- testProperty "s_tail" s_tail,- testProperty "s_tail_s" s_tail_s,- testProperty "sf_tail" sf_tail,- testProperty "t_tail" t_tail,- testProperty "tl_tail" tl_tail,- testProperty "s_init" s_init,- testProperty "s_init_s" s_init_s,- testProperty "sf_init" sf_init,- testProperty "t_init" t_init,- testProperty "tl_init" tl_init,- testProperty "s_null" s_null,- testProperty "sf_null" sf_null,- testProperty "t_null" t_null,- testProperty "tl_null" tl_null,- testProperty "s_length" s_length,- testProperty "sf_length" sf_length,- testProperty "sl_length" sl_length,- testProperty "t_length" t_length,- testProperty "tl_length" tl_length,- testProperty "t_compareLength" t_compareLength,- testProperty "tl_compareLength" tl_compareLength- ],-- testGroup "transformations" [- testProperty "s_map" s_map,- testProperty "s_map_s" s_map_s,- testProperty "sf_map" sf_map,- testProperty "t_map" t_map,- testProperty "tl_map" tl_map,- testProperty "s_intercalate" s_intercalate,- testProperty "t_intercalate" t_intercalate,- testProperty "tl_intercalate" tl_intercalate,- testProperty "s_intersperse" s_intersperse,- testProperty "s_intersperse_s" s_intersperse_s,- testProperty "sf_intersperse" sf_intersperse,- testProperty "t_intersperse" t_intersperse,- testProperty "tl_intersperse" tl_intersperse,- testProperty "t_transpose" t_transpose,- testProperty "tl_transpose" tl_transpose,- testProperty "t_reverse" t_reverse,- testProperty "tl_reverse" tl_reverse,- testProperty "t_reverse_short" t_reverse_short,- testProperty "t_replace" t_replace,- testProperty "tl_replace" tl_replace,-- testGroup "case conversion" [- testProperty "s_toCaseFold_length" s_toCaseFold_length,- testProperty "sf_toCaseFold_length" sf_toCaseFold_length,- testProperty "t_toCaseFold_length" t_toCaseFold_length,- testProperty "tl_toCaseFold_length" tl_toCaseFold_length,- testProperty "t_toLower_length" t_toLower_length,- testProperty "t_toLower_lower" t_toLower_lower,- testProperty "tl_toLower_lower" tl_toLower_lower,- testProperty "t_toUpper_length" t_toUpper_length,- testProperty "t_toUpper_upper" t_toUpper_upper,- testProperty "tl_toUpper_upper" tl_toUpper_upper,- testProperty "t_toTitle_title" t_toTitle_title,- testProperty "t_toTitle_1stNotLower" t_toTitle_1stNotLower- ],-- testGroup "justification" [- testProperty "s_justifyLeft" s_justifyLeft,- testProperty "s_justifyLeft_s" s_justifyLeft_s,- testProperty "sf_justifyLeft" sf_justifyLeft,- testProperty "t_justifyLeft" t_justifyLeft,- testProperty "tl_justifyLeft" tl_justifyLeft,- testProperty "t_justifyRight" t_justifyRight,- testProperty "tl_justifyRight" tl_justifyRight,- testProperty "t_center" t_center,- testProperty "tl_center" tl_center- ]- ],-- testGroup "folds" [- testProperty "sf_foldl" sf_foldl,- testProperty "t_foldl" t_foldl,- testProperty "tl_foldl" tl_foldl,- testProperty "sf_foldl'" sf_foldl',- testProperty "t_foldl'" t_foldl',- testProperty "tl_foldl'" tl_foldl',- testProperty "sf_foldl1" sf_foldl1,- testProperty "t_foldl1" t_foldl1,- testProperty "tl_foldl1" tl_foldl1,- testProperty "t_foldl1'" t_foldl1',- testProperty "sf_foldl1'" sf_foldl1',- testProperty "tl_foldl1'" tl_foldl1',- testProperty "sf_foldr" sf_foldr,- testProperty "t_foldr" t_foldr,- testProperty "tl_foldr" tl_foldr,- testProperty "sf_foldr1" sf_foldr1,- testProperty "t_foldr1" t_foldr1,- testProperty "tl_foldr1" tl_foldr1,-- testGroup "special" [- testProperty "s_concat_s" s_concat_s,- testProperty "sf_concat" sf_concat,- testProperty "t_concat" t_concat,- testProperty "tl_concat" tl_concat,- testProperty "sf_concatMap" sf_concatMap,- testProperty "t_concatMap" t_concatMap,- testProperty "tl_concatMap" tl_concatMap,- testProperty "sf_any" sf_any,- testProperty "t_any" t_any,- testProperty "tl_any" tl_any,- testProperty "sf_all" sf_all,- testProperty "t_all" t_all,- testProperty "tl_all" tl_all,- testProperty "sf_maximum" sf_maximum,- testProperty "t_maximum" t_maximum,- testProperty "tl_maximum" tl_maximum,- testProperty "sf_minimum" sf_minimum,- testProperty "t_minimum" t_minimum,- testProperty "tl_minimum" tl_minimum- ]- ],-- testGroup "construction" [- testGroup "scans" [- testProperty "sf_scanl" sf_scanl,- testProperty "t_scanl" t_scanl,- testProperty "tl_scanl" tl_scanl,- testProperty "t_scanl1" t_scanl1,- testProperty "tl_scanl1" tl_scanl1,- testProperty "t_scanr" t_scanr,- testProperty "tl_scanr" tl_scanr,- testProperty "t_scanr1" t_scanr1,- testProperty "tl_scanr1" tl_scanr1- ],-- testGroup "mapAccum" [- testProperty "t_mapAccumL" t_mapAccumL,- testProperty "tl_mapAccumL" tl_mapAccumL,- testProperty "t_mapAccumR" t_mapAccumR,- testProperty "tl_mapAccumR" tl_mapAccumR- ],-- testGroup "unfolds" [- testProperty "tl_repeat" tl_repeat,- testProperty "s_replicate" s_replicate,- testProperty "t_replicate" t_replicate,- testProperty "tl_replicate" tl_replicate,- testProperty "tl_cycle" tl_cycle,- testProperty "tl_iterate" tl_iterate,- testProperty "t_unfoldr" t_unfoldr,- testProperty "tl_unfoldr" tl_unfoldr,- testProperty "t_unfoldrN" t_unfoldrN,- testProperty "tl_unfoldrN" tl_unfoldrN- ]- ],-- testGroup "substrings" [- testGroup "breaking" [- testProperty "s_take" s_take,- testProperty "s_take_s" s_take_s,- testProperty "sf_take" sf_take,- testProperty "t_take" t_take,- testProperty "t_takeEnd" t_takeEnd,- testProperty "tl_take" tl_take,- testProperty "tl_takeEnd" tl_takeEnd,- testProperty "s_drop" s_drop,- testProperty "s_drop_s" s_drop_s,- testProperty "sf_drop" sf_drop,- testProperty "t_drop" t_drop,- testProperty "t_dropEnd" t_dropEnd,- testProperty "tl_drop" tl_drop,- testProperty "tl_dropEnd" tl_dropEnd,- testProperty "s_take_drop" s_take_drop,- testProperty "s_take_drop_s" s_take_drop_s,- testProperty "s_takeWhile" s_takeWhile,- testProperty "s_takeWhile_s" s_takeWhile_s,- testProperty "sf_takeWhile" sf_takeWhile,- testProperty "t_takeWhile" t_takeWhile,- testProperty "tl_takeWhile" tl_takeWhile,- testProperty "t_takeWhileEnd" t_takeWhileEnd,- testProperty "t_takeWhileEnd_null" t_takeWhileEnd_null,- testProperty "tl_takeWhileEnd" tl_takeWhileEnd,- testProperty "tl_takeWhileEnd_null" tl_takeWhileEnd_null,- testProperty "sf_dropWhile" sf_dropWhile,- testProperty "s_dropWhile" s_dropWhile,- testProperty "s_dropWhile_s" s_dropWhile_s,- testProperty "t_dropWhile" t_dropWhile,- testProperty "tl_dropWhile" tl_dropWhile,- testProperty "t_dropWhileEnd" t_dropWhileEnd,- testProperty "tl_dropWhileEnd" tl_dropWhileEnd,- testProperty "t_dropAround" t_dropAround,- testProperty "tl_dropAround" tl_dropAround,- testProperty "t_stripStart" t_stripStart,- testProperty "tl_stripStart" tl_stripStart,- testProperty "t_stripEnd" t_stripEnd,- testProperty "tl_stripEnd" tl_stripEnd,- testProperty "t_strip" t_strip,- testProperty "tl_strip" tl_strip,- testProperty "t_splitAt" t_splitAt,- testProperty "tl_splitAt" tl_splitAt,- testProperty "t_span" t_span,- testProperty "tl_span" tl_span,- testProperty "t_breakOn_id" t_breakOn_id,- testProperty "tl_breakOn_id" tl_breakOn_id,- testProperty "t_breakOn_start" t_breakOn_start,- testProperty "tl_breakOn_start" tl_breakOn_start,- testProperty "t_breakOnEnd_end" t_breakOnEnd_end,- testProperty "tl_breakOnEnd_end" tl_breakOnEnd_end,- testProperty "t_break" t_break,- testProperty "tl_break" tl_break,- testProperty "t_group" t_group,- testProperty "tl_group" tl_group,- testProperty "t_groupBy" t_groupBy,- testProperty "tl_groupBy" tl_groupBy,- testProperty "t_inits" t_inits,- testProperty "tl_inits" tl_inits,- testProperty "t_tails" t_tails,- testProperty "tl_tails" tl_tails- ],-- testGroup "breaking many" [- testProperty "t_findAppendId" t_findAppendId,- testProperty "tl_findAppendId" tl_findAppendId,- testProperty "t_findContains" t_findContains,- testProperty "tl_findContains" tl_findContains,- testProperty "sl_filterCount" sl_filterCount,- testProperty "t_findCount" t_findCount,- testProperty "tl_findCount" tl_findCount,- testProperty "t_splitOn_split" t_splitOn_split,- testProperty "tl_splitOn_split" tl_splitOn_split,- testProperty "t_splitOn_i" t_splitOn_i,- testProperty "tl_splitOn_i" tl_splitOn_i,- testProperty "t_split" t_split,- testProperty "t_split_count" t_split_count,- testProperty "t_split_splitOn" t_split_splitOn,- testProperty "tl_split" tl_split,- testProperty "t_chunksOf_same_lengths" t_chunksOf_same_lengths,- testProperty "t_chunksOf_length" t_chunksOf_length,- testProperty "tl_chunksOf" tl_chunksOf- ],-- testGroup "lines and words" [- testProperty "t_lines" t_lines,- testProperty "tl_lines" tl_lines,- --testProperty "t_lines'" t_lines',- testProperty "t_words" t_words,- testProperty "tl_words" tl_words,- testProperty "t_unlines" t_unlines,- testProperty "tl_unlines" tl_unlines,- testProperty "t_unwords" t_unwords,- testProperty "tl_unwords" tl_unwords- ]- ],-- testGroup "predicates" [- testProperty "s_isPrefixOf" s_isPrefixOf,- testProperty "sf_isPrefixOf" sf_isPrefixOf,- testProperty "t_isPrefixOf" t_isPrefixOf,- testProperty "tl_isPrefixOf" tl_isPrefixOf,- testProperty "t_isSuffixOf" t_isSuffixOf,- testProperty "tl_isSuffixOf" tl_isSuffixOf,- testProperty "t_isInfixOf" t_isInfixOf,- testProperty "tl_isInfixOf" tl_isInfixOf,-- testGroup "view" [- testProperty "t_stripPrefix" t_stripPrefix,- testProperty "tl_stripPrefix" tl_stripPrefix,- testProperty "t_stripSuffix" t_stripSuffix,- testProperty "tl_stripSuffix" tl_stripSuffix,- testProperty "t_commonPrefixes" t_commonPrefixes,- testProperty "tl_commonPrefixes" tl_commonPrefixes- ]- ],-- testGroup "searching" [- testProperty "sf_elem" sf_elem,- testProperty "sf_filter" sf_filter,- testProperty "t_filter" t_filter,- testProperty "tl_filter" tl_filter,- testProperty "sf_findBy" sf_findBy,- testProperty "t_find" t_find,- testProperty "tl_find" tl_find,- testProperty "t_partition" t_partition,- testProperty "tl_partition" tl_partition- ],-- testGroup "indexing" [- testProperty "sf_index" sf_index,- testProperty "t_index" t_index,- testProperty "tl_index" tl_index,- testProperty "t_findIndex" t_findIndex,- testProperty "t_count" t_count,- testProperty "tl_count" tl_count,- testProperty "t_indices" t_indices,- testProperty "tl_indices" tl_indices,- testProperty "t_indices_occurs" t_indices_occurs- ],-- testGroup "zips" [- testProperty "t_zip" t_zip,- testProperty "tl_zip" tl_zip,- testProperty "sf_zipWith" sf_zipWith,- testProperty "t_zipWith" t_zipWith,- testProperty "tl_zipWith" tl_zipWith- ],-- testGroup "regressions" [- testProperty "s_filter_eq" s_filter_eq- ],-- testGroup "shifts" [- testProperty "shiftL_Int" shiftL_Int,- testProperty "shiftL_Word16" shiftL_Word16,- testProperty "shiftL_Word32" shiftL_Word32,- testProperty "shiftR_Int" shiftR_Int,- testProperty "shiftR_Word16" shiftR_Word16,- testProperty "shiftR_Word32" shiftR_Word32- ],-- testGroup "builder" [- testProperty "tb_associative" tb_associative,- testGroup "decimal" [- testProperty "tb_decimal_int" tb_decimal_int,- testProperty "tb_decimal_int8" tb_decimal_int8,- testProperty "tb_decimal_int16" tb_decimal_int16,- testProperty "tb_decimal_int32" tb_decimal_int32,- testProperty "tb_decimal_int64" tb_decimal_int64,- testProperty "tb_decimal_integer" tb_decimal_integer,- testProperty "tb_decimal_integer_big" tb_decimal_integer_big,- testProperty "tb_decimal_word" tb_decimal_word,- testProperty "tb_decimal_word8" tb_decimal_word8,- testProperty "tb_decimal_word16" tb_decimal_word16,- testProperty "tb_decimal_word32" tb_decimal_word32,- testProperty "tb_decimal_word64" tb_decimal_word64,- testProperty "tb_decimal_big_int" tb_decimal_big_int,- testProperty "tb_decimal_big_word" tb_decimal_big_word,- testProperty "tb_decimal_big_int64" tb_decimal_big_int64,- testProperty "tb_decimal_big_word64" tb_decimal_big_word64- ],- testGroup "hexadecimal" [- testProperty "tb_hexadecimal_int" tb_hexadecimal_int,- testProperty "tb_hexadecimal_int8" tb_hexadecimal_int8,- testProperty "tb_hexadecimal_int16" tb_hexadecimal_int16,- testProperty "tb_hexadecimal_int32" tb_hexadecimal_int32,- testProperty "tb_hexadecimal_int64" tb_hexadecimal_int64,- testProperty "tb_hexadecimal_integer" tb_hexadecimal_integer,- testProperty "tb_hexadecimal_word" tb_hexadecimal_word,- testProperty "tb_hexadecimal_word8" tb_hexadecimal_word8,- testProperty "tb_hexadecimal_word16" tb_hexadecimal_word16,- testProperty "tb_hexadecimal_word32" tb_hexadecimal_word32,- testProperty "tb_hexadecimal_word64" tb_hexadecimal_word64- ],- testGroup "realfloat" [- testProperty "tb_realfloat_double" tb_realfloat_double,- testProperty "tb_realfloat_float" tb_realfloat_float,- testProperty "tb_formatRealFloat_float" tb_formatRealFloat_float,- testProperty "tb_formatRealFloat_double" tb_formatRealFloat_double- ],- testProperty "tb_fromText" tb_fromText,- testProperty "tb_singleton" tb_singleton- ],-- testGroup "read" [- testProperty "t_decimal" t_decimal,- testProperty "tl_decimal" tl_decimal,- testProperty "t_hexadecimal" t_hexadecimal,- testProperty "tl_hexadecimal" tl_hexadecimal,- testProperty "t_double" t_double,- testProperty "tl_double" tl_double,- testProperty "t_rational" t_rational,- testProperty "tl_rational" tl_rational- ],-- {-- testGroup "input-output" [- testProperty "t_write_read" t_write_read,- testProperty "tl_write_read" tl_write_read,- testProperty "t_write_read_line" t_write_read_line,- testProperty "tl_write_read_line" tl_write_read_line- -- These tests are subject to I/O race conditions when run under- -- test-framework-quickcheck2.- -- testProperty "t_put_get" t_put_get- -- testProperty "tl_put_get" tl_put_get- ],- -}-- testGroup "lowlevel" [- testProperty "t_dropWord16" t_dropWord16,- testProperty "t_takeWord16" t_takeWord16,- testProperty "t_take_drop_16" t_take_drop_16,- testProperty "t_use_from" t_use_from,- testProperty "t_copy" t_copy- ],-- testGroup "mul" Mul.tests+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties+ (+ tests+ ) where++import Test.Tasty (TestTree, testGroup)+import Tests.Properties.Basics (testBasics)+import Tests.Properties.Builder (testBuilder)+import Tests.Properties.Folds (testFolds)+import Tests.Properties.LowLevel (testLowLevel)+import Tests.Properties.Instances (testInstances)+import Tests.Properties.Substrings (testSubstrings)+import Tests.Properties.Read (testRead)+import Tests.Properties.Text (testText)+import Tests.Properties.Transcoding (testTranscoding)++tests :: TestTree+tests =+ testGroup "Properties" [+ testTranscoding,+ testInstances,+ testBasics,+ testFolds,+ testText,+ testSubstrings,+ testBuilder,+ testLowLevel,+ testRead ]
+ tests/Tests/Properties/Basics.hs view
@@ -0,0 +1,139 @@+-- | Test basic text functions++{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties.Basics+ ( testBasics+ ) where++import Control.Arrow (first, second)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Tests.QuickCheckUtils+import Text.Show.Functions ()+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Text.Internal.Fusion as S+import qualified Data.Text.Internal.Fusion.Common as S+import qualified Data.Text.Internal.Lazy.Fusion as SL+import qualified Data.Text.Lazy as TL++s_cons x = (x:) `eqP` (unpackS . S.cons x)+s_cons_s x = (x:) `eqP` (unpackS . S.unstream . S.cons x)+sf_cons p x = ((x:) . L.filter p) `eqP` (unpackS . S.cons x . S.filter p)+t_cons x = (x:) `eqP` (unpackS . T.cons x)+tl_cons x = (x:) `eqP` (unpackS . TL.cons x)+s_snoc x = (++ [x]) `eqP` (unpackS . (flip S.snoc) x)+t_snoc x = (++ [x]) `eqP` (unpackS . (flip T.snoc) x)+tl_snoc x = (++ [x]) `eqP` (unpackS . (flip TL.snoc) x)+s_append s = (s++) `eqP` (unpackS . S.append (S.streamList s))+s_append_s s = (s++) `eqP`+ (unpackS . S.unstream . S.append (S.streamList s))+sf_append p s = (L.filter p s++) `eqP`+ (unpackS . S.append (S.filter p $ S.streamList s))+t_append s = (s++) `eqP` (unpackS . T.append (packS s))++uncons (x:xs) = Just (x,xs)+uncons _ = Nothing++s_uncons = uncons `eqP` (fmap (second unpackS) . S.uncons)+sf_uncons p = (uncons . L.filter p) `eqP`+ (fmap (second unpackS) . S.uncons . S.filter p)+t_uncons = uncons `eqP` (fmap (second unpackS) . T.uncons)+tl_uncons = uncons `eqP` (fmap (second unpackS) . TL.uncons)++unsnoc xs@(_:_) = Just (init xs, last xs)+unsnoc [] = Nothing++t_unsnoc = unsnoc `eqP` (fmap (first unpackS) . T.unsnoc)+tl_unsnoc = unsnoc `eqP` (fmap (first unpackS) . TL.unsnoc)++s_head = head `eqP` S.head+sf_head p = (head . L.filter p) `eqP` (S.head . S.filter p)+t_head = head `eqP` T.head+tl_head = head `eqP` TL.head+s_last = last `eqP` S.last+sf_last p = (last . L.filter p) `eqP` (S.last . S.filter p)+t_last = last `eqP` T.last+tl_last = last `eqP` TL.last+s_tail = tail `eqP` (unpackS . S.tail)+s_tail_s = tail `eqP` (unpackS . S.unstream . S.tail)+sf_tail p = (tail . L.filter p) `eqP` (unpackS . S.tail . S.filter p)+t_tail = tail `eqP` (unpackS . T.tail)+tl_tail = tail `eqP` (unpackS . TL.tail)+s_init = init `eqP` (unpackS . S.init)+s_init_s = init `eqP` (unpackS . S.unstream . S.init)+sf_init p = (init . L.filter p) `eqP` (unpackS . S.init . S.filter p)+t_init = init `eqP` (unpackS . T.init)+tl_init = init `eqP` (unpackS . TL.init)+s_null = null `eqP` S.null+sf_null p = (null . L.filter p) `eqP` (S.null . S.filter p)+t_null = null `eqP` T.null+tl_null = null `eqP` TL.null+s_length = length `eqP` S.length+sf_length p = (length . L.filter p) `eqP` (S.length . S.filter p)+sl_length = (fromIntegral . length) `eqP` SL.length+t_length = length `eqP` T.length+tl_length = L.genericLength `eqP` TL.length+t_compareLength t = (compare (T.length t)) `eq` T.compareLength t+tl_compareLength t= (compare (TL.length t)) `eq` TL.compareLength t++-- Regression tests.+s_filter_eq s = S.filter p t == S.streamList (filter p s)+ where p = (/= S.last t)+ t = S.streamList s++testBasics :: TestTree+testBasics =+ testGroup "basics" [+ testProperty "s_cons" s_cons,+ testProperty "s_cons_s" s_cons_s,+ testProperty "sf_cons" sf_cons,+ testProperty "t_cons" t_cons,+ testProperty "tl_cons" tl_cons,+ testProperty "s_snoc" s_snoc,+ testProperty "t_snoc" t_snoc,+ testProperty "tl_snoc" tl_snoc,+ testProperty "s_append" s_append,+ testProperty "s_append_s" s_append_s,+ testProperty "sf_append" sf_append,+ testProperty "t_append" t_append,+ testProperty "s_uncons" s_uncons,+ testProperty "sf_uncons" sf_uncons,+ testProperty "t_uncons" t_uncons,+ testProperty "tl_uncons" tl_uncons,+ testProperty "t_unsnoc" t_unsnoc,+ testProperty "tl_unsnoc" tl_unsnoc,+ testProperty "s_head" s_head,+ testProperty "sf_head" sf_head,+ testProperty "t_head" t_head,+ testProperty "tl_head" tl_head,+ testProperty "s_last" s_last,+ testProperty "sf_last" sf_last,+ testProperty "t_last" t_last,+ testProperty "tl_last" tl_last,+ testProperty "s_tail" s_tail,+ testProperty "s_tail_s" s_tail_s,+ testProperty "sf_tail" sf_tail,+ testProperty "t_tail" t_tail,+ testProperty "tl_tail" tl_tail,+ testProperty "s_init" s_init,+ testProperty "s_init_s" s_init_s,+ testProperty "sf_init" sf_init,+ testProperty "t_init" t_init,+ testProperty "tl_init" tl_init,+ testProperty "s_null" s_null,+ testProperty "sf_null" sf_null,+ testProperty "t_null" t_null,+ testProperty "tl_null" tl_null,+ testProperty "s_length" s_length,+ testProperty "sf_length" sf_length,+ testProperty "sl_length" sl_length,+ testProperty "t_length" t_length,+ testProperty "tl_length" tl_length,+ testProperty "t_compareLength" t_compareLength,+ testProperty "tl_compareLength" tl_compareLength,++ testGroup "regressions" [+ testProperty "s_filter_eq" s_filter_eq+ ]+ ]
+ tests/Tests/Properties/Builder.hs view
@@ -0,0 +1,146 @@+-- | Test @Builder@++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties.Builder+ ( testBuilder+ ) where++import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word+import Numeric (showEFloat, showFFloat, showGFloat, showHex)+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Tests.QuickCheckUtils+import Text.Show.Functions ()+import qualified Data.List as L+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Lazy.Builder.Int as TB+import qualified Data.Text.Lazy.Builder.RealFloat as TB++-- Builder.++tb_singleton = id `eqP`+ (unpackS . TB.toLazyText . mconcat . map TB.singleton)+tb_fromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat .+ map (TB.fromText . packS))++tb_associative s1 s2 s3 =+ TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==+ TB.toLazyText ((b1 `mappend` b2) `mappend` b3)+ where b1 = TB.fromText (packS s1)+ b2 = TB.fromText (packS s2)+ b3 = TB.fromText (packS s3)++-- Numeric builder stuff.++tb_decimal :: (Integral a, Show a) => a -> Bool+tb_decimal = (TB.toLazyText . TB.decimal) `eq` (TL.pack . show)++tb_decimal_integer (a::Integer) = tb_decimal a+tb_decimal_integer_big (Big a) = tb_decimal a+tb_decimal_int (a::Int) = tb_decimal a+tb_decimal_int8 (a::Int8) = tb_decimal a+tb_decimal_int16 (a::Int16) = tb_decimal a+tb_decimal_int32 (a::Int32) = tb_decimal a+tb_decimal_int64 (a::Int64) = tb_decimal a+tb_decimal_word (a::Word) = tb_decimal a+tb_decimal_word8 (a::Word8) = tb_decimal a+tb_decimal_word16 (a::Word16) = tb_decimal a+tb_decimal_word32 (a::Word32) = tb_decimal a+tb_decimal_word64 (a::Word64) = tb_decimal a++tb_decimal_big_int (BigBounded (a::Int)) = tb_decimal a+tb_decimal_big_int64 (BigBounded (a::Int64)) = tb_decimal a+tb_decimal_big_word (BigBounded (a::Word)) = tb_decimal a+tb_decimal_big_word64 (BigBounded (a::Word64)) = tb_decimal a++tb_hex :: (Integral a, Show a) => a -> Bool+tb_hex = (TB.toLazyText . TB.hexadecimal) `eq` (TL.pack . flip showHex "")++tb_hexadecimal_integer (a::Integer) = tb_hex a+tb_hexadecimal_int (a::Int) = tb_hex a+tb_hexadecimal_int8 (a::Int8) = tb_hex a+tb_hexadecimal_int16 (a::Int16) = tb_hex a+tb_hexadecimal_int32 (a::Int32) = tb_hex a+tb_hexadecimal_int64 (a::Int64) = tb_hex a+tb_hexadecimal_word (a::Word) = tb_hex a+tb_hexadecimal_word8 (a::Word8) = tb_hex a+tb_hexadecimal_word16 (a::Word16) = tb_hex a+tb_hexadecimal_word32 (a::Word32) = tb_hex a+tb_hexadecimal_word64 (a::Word64) = tb_hex a++tb_realfloat :: (RealFloat a, Show a) => a -> Bool+tb_realfloat = (TB.toLazyText . TB.realFloat) `eq` (TL.pack . show)++tb_realfloat_float (a::Float) = tb_realfloat a+tb_realfloat_double (a::Double) = tb_realfloat a++showFloat :: (RealFloat a) => TB.FPFormat -> Maybe Int -> a -> ShowS+showFloat TB.Exponent (Just 0) = showEFloat (Just 1) -- see gh-231+showFloat TB.Exponent p = showEFloat p+showFloat TB.Fixed p = showFFloat p+showFloat TB.Generic p = showGFloat p++tb_formatRealFloat :: (RealFloat a, Show a) =>+ a -> TB.FPFormat -> Precision a -> Property+tb_formatRealFloat a fmt prec = cond ==>+ TB.formatRealFloat fmt p a ===+ TB.fromString (showFloat fmt p a "")+ where p = precision a prec+ cond = case (p,fmt) of+#if MIN_VERSION_base(4,12,0)+ (Just 0, TB.Generic) -> False -- skipping due to gh-231+#endif+ _ -> True++tb_formatRealFloat_float (a::Float) = tb_formatRealFloat a+tb_formatRealFloat_double (a::Double) = tb_formatRealFloat a++testBuilder :: TestTree+testBuilder =+ testGroup "builder" [+ testProperty "tb_fromText" tb_fromText,+ testProperty "tb_singleton" tb_singleton,+ testProperty "tb_associative" tb_associative,+ testGroup "decimal" [+ testProperty "tb_decimal_int" tb_decimal_int,+ testProperty "tb_decimal_int8" tb_decimal_int8,+ testProperty "tb_decimal_int16" tb_decimal_int16,+ testProperty "tb_decimal_int32" tb_decimal_int32,+ testProperty "tb_decimal_int64" tb_decimal_int64,+ testProperty "tb_decimal_integer" tb_decimal_integer,+ testProperty "tb_decimal_integer_big" tb_decimal_integer_big,+ testProperty "tb_decimal_word" tb_decimal_word,+ testProperty "tb_decimal_word8" tb_decimal_word8,+ testProperty "tb_decimal_word16" tb_decimal_word16,+ testProperty "tb_decimal_word32" tb_decimal_word32,+ testProperty "tb_decimal_word64" tb_decimal_word64,+ testProperty "tb_decimal_big_int" tb_decimal_big_int,+ testProperty "tb_decimal_big_word" tb_decimal_big_word,+ testProperty "tb_decimal_big_int64" tb_decimal_big_int64,+ testProperty "tb_decimal_big_word64" tb_decimal_big_word64+ ],+ testGroup "hexadecimal" [+ testProperty "tb_hexadecimal_int" tb_hexadecimal_int,+ testProperty "tb_hexadecimal_int8" tb_hexadecimal_int8,+ testProperty "tb_hexadecimal_int16" tb_hexadecimal_int16,+ testProperty "tb_hexadecimal_int32" tb_hexadecimal_int32,+ testProperty "tb_hexadecimal_int64" tb_hexadecimal_int64,+ testProperty "tb_hexadecimal_integer" tb_hexadecimal_integer,+ testProperty "tb_hexadecimal_word" tb_hexadecimal_word,+ testProperty "tb_hexadecimal_word8" tb_hexadecimal_word8,+ testProperty "tb_hexadecimal_word16" tb_hexadecimal_word16,+ testProperty "tb_hexadecimal_word32" tb_hexadecimal_word32,+ testProperty "tb_hexadecimal_word64" tb_hexadecimal_word64+ ],+ testGroup "realfloat" [+ testProperty "tb_realfloat_double" tb_realfloat_double,+ testProperty "tb_realfloat_float" tb_realfloat_float,+ testProperty "tb_formatRealFloat_float" tb_formatRealFloat_float,+ testProperty "tb_formatRealFloat_double" tb_formatRealFloat_double+ ]+ ]
+ tests/Tests/Properties/Folds.hs view
@@ -0,0 +1,225 @@+-- | Test folds, scans, and unfolds++{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties.Folds+ ( testFolds+ ) where++import Control.Arrow (second)+import Data.Word (Word8, Word16)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Tests.QuickCheckUtils+import Text.Show.Functions ()+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Text.Internal.Fusion as S+import qualified Data.Text.Internal.Fusion.Common as S+import qualified Data.Text.Lazy as TL++-- Folds++sf_foldl p f z = (L.foldl f z . L.filter p) `eqP` (S.foldl f z . S.filter p)+ where _types = f :: Char -> Char -> Char+t_foldl f z = L.foldl f z `eqP` (T.foldl f z)+ where _types = f :: Char -> Char -> Char+tl_foldl f z = L.foldl f z `eqP` (TL.foldl f z)+ where _types = f :: Char -> Char -> Char+sf_foldl' p f z = (L.foldl' f z . L.filter p) `eqP`+ (S.foldl' f z . S.filter p)+ where _types = f :: Char -> Char -> Char+t_foldl' f z = L.foldl' f z `eqP` T.foldl' f z+ where _types = f :: Char -> Char -> Char+tl_foldl' f z = L.foldl' f z `eqP` TL.foldl' f z+ where _types = f :: Char -> Char -> Char+sf_foldl1 p f = (L.foldl1 f . L.filter p) `eqP` (S.foldl1 f . S.filter p)+t_foldl1 f = L.foldl1 f `eqP` T.foldl1 f+tl_foldl1 f = L.foldl1 f `eqP` TL.foldl1 f+sf_foldl1' p f = (L.foldl1' f . L.filter p) `eqP` (S.foldl1' f . S.filter p)+t_foldl1' f = L.foldl1' f `eqP` T.foldl1' f+tl_foldl1' f = L.foldl1' f `eqP` TL.foldl1' f+sf_foldr p f z = (L.foldr f z . L.filter p) `eqP` (S.foldr f z . S.filter p)+ where _types = f :: Char -> Char -> Char+t_foldr f z = L.foldr f z `eqP` T.foldr f z+ where _types = f :: Char -> Char -> Char+tl_foldr f z = unsquare $+ L.foldr f z `eqP` TL.foldr f z+ where _types = f :: Char -> Char -> Char+sf_foldr1 p f = unsquare $+ (L.foldr1 f . L.filter p) `eqP` (S.foldr1 f . S.filter p)+t_foldr1 f = L.foldr1 f `eqP` T.foldr1 f+tl_foldr1 f = unsquare $+ L.foldr1 f `eqP` TL.foldr1 f++-- Special folds++s_concat_s = unsquare $+ L.concat `eq` (unpackS . S.unstream . S.concat . map packS)+sf_concat p = unsquare $+ (L.concat . map (L.filter p)) `eq`+ (unpackS . S.concat . map (S.filter p . packS))+t_concat = unsquare $+ L.concat `eq` (unpackS . T.concat . map packS)+tl_concat = unsquare $+ L.concat `eq` (unpackS . TL.concat . map TL.pack)+sf_concatMap p f = unsquare $ (L.concatMap f . L.filter p) `eqP`+ (unpackS . S.concatMap (packS . f) . S.filter p)+t_concatMap f = unsquare $+ L.concatMap f `eqP` (unpackS . T.concatMap (packS . f))+tl_concatMap f = unsquare $+ L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f))+sf_any q p = (L.any p . L.filter q) `eqP` (S.any p . S.filter q)+t_any p = L.any p `eqP` T.any p+tl_any p = L.any p `eqP` TL.any p+sf_all q p = (L.all p . L.filter q) `eqP` (S.all p . S.filter q)+t_all p = L.all p `eqP` T.all p+tl_all p = L.all p `eqP` TL.all p+sf_maximum p = (L.maximum . L.filter p) `eqP` (S.maximum . S.filter p)+t_maximum = L.maximum `eqP` T.maximum+tl_maximum = L.maximum `eqP` TL.maximum+sf_minimum p = (L.minimum . L.filter p) `eqP` (S.minimum . S.filter p)+t_minimum = L.minimum `eqP` T.minimum+tl_minimum = L.minimum `eqP` TL.minimum++-- Scans++sf_scanl p f z = (L.scanl f z . L.filter p) `eqP`+ (unpackS . S.scanl f z . S.filter p)+t_scanl f z = L.scanl f z `eqP` (unpackS . T.scanl f z)+tl_scanl f z = L.scanl f z `eqP` (unpackS . TL.scanl f z)+t_scanl1 f = L.scanl1 f `eqP` (unpackS . T.scanl1 f)+tl_scanl1 f = L.scanl1 f `eqP` (unpackS . TL.scanl1 f)+t_scanr f z = L.scanr f z `eqP` (unpackS . T.scanr f z)+tl_scanr f z = L.scanr f z `eqP` (unpackS . TL.scanr f z)+t_scanr1 f = L.scanr1 f `eqP` (unpackS . T.scanr1 f)+tl_scanr1 f = L.scanr1 f `eqP` (unpackS . TL.scanr1 f)++t_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . T.mapAccumL f z)+ where _types = f :: Int -> Char -> (Int,Char)+tl_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . TL.mapAccumL f z)+ where _types = f :: Int -> Char -> (Int,Char)+t_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . T.mapAccumR f z)+ where _types = f :: Int -> Char -> (Int,Char)+tl_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . TL.mapAccumR f z)+ where _types = f :: Int -> Char -> (Int,Char)++-- Unfolds++tl_repeat n = (L.take m . L.repeat) `eq`+ (unpackS . TL.take (fromIntegral m) . TL.repeat)+ where m = fromIntegral (n :: Word8)++any_replicate n l = concat (L.replicate n l)++s_replicate n = any_replicate m `eq`+ (unpackS . S.replicateI (fromIntegral m) . packS)+ where m = fromIntegral (n :: Word8)+t_replicate n = any_replicate m `eq` (unpackS . T.replicate m . packS)+ where m = fromIntegral (n :: Word8)+tl_replicate n = any_replicate m `eq`+ (unpackS . TL.replicate (fromIntegral m) . packS)+ where m = fromIntegral (n :: Word8)++tl_cycle n = (L.take m . L.cycle) `eq`+ (unpackS . TL.take (fromIntegral m) . TL.cycle . packS)+ where m = fromIntegral (n :: Word8)++tl_iterate f n = (L.take m . L.iterate f) `eq`+ (unpackS . TL.take (fromIntegral m) . TL.iterate f)+ where m = fromIntegral (n :: Word8)++unf :: Int -> Char -> Maybe (Char, Char)+unf n c | fromEnum c * 100 > n = Nothing+ | otherwise = Just (c, succ c)++t_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . T.unfoldr (unf m))+ where m = fromIntegral (n :: Word16)+tl_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . TL.unfoldr (unf m))+ where m = fromIntegral (n :: Word16)+t_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`+ (unpackS . T.unfoldrN i (unf j))+ where i = fromIntegral (n :: Word16)+ j = fromIntegral (m :: Word16)+tl_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`+ (unpackS . TL.unfoldrN (fromIntegral i) (unf j))+ where i = fromIntegral (n :: Word16)+ j = fromIntegral (m :: Word16)++testFolds :: TestTree+testFolds =+ testGroup "folds-unfolds" [+ testGroup "folds" [+ testProperty "sf_foldl" sf_foldl,+ testProperty "t_foldl" t_foldl,+ testProperty "tl_foldl" tl_foldl,+ testProperty "sf_foldl'" sf_foldl',+ testProperty "t_foldl'" t_foldl',+ testProperty "tl_foldl'" tl_foldl',+ testProperty "sf_foldl1" sf_foldl1,+ testProperty "t_foldl1" t_foldl1,+ testProperty "tl_foldl1" tl_foldl1,+ testProperty "t_foldl1'" t_foldl1',+ testProperty "sf_foldl1'" sf_foldl1',+ testProperty "tl_foldl1'" tl_foldl1',+ testProperty "sf_foldr" sf_foldr,+ testProperty "t_foldr" t_foldr,+ testProperty "tl_foldr" tl_foldr,+ testProperty "sf_foldr1" sf_foldr1,+ testProperty "t_foldr1" t_foldr1,+ testProperty "tl_foldr1" tl_foldr1,++ testGroup "special" [+ testProperty "s_concat_s" s_concat_s,+ testProperty "sf_concat" sf_concat,+ testProperty "t_concat" t_concat,+ testProperty "tl_concat" tl_concat,+ testProperty "sf_concatMap" sf_concatMap,+ testProperty "t_concatMap" t_concatMap,+ testProperty "tl_concatMap" tl_concatMap,+ testProperty "sf_any" sf_any,+ testProperty "t_any" t_any,+ testProperty "tl_any" tl_any,+ testProperty "sf_all" sf_all,+ testProperty "t_all" t_all,+ testProperty "tl_all" tl_all,+ testProperty "sf_maximum" sf_maximum,+ testProperty "t_maximum" t_maximum,+ testProperty "tl_maximum" tl_maximum,+ testProperty "sf_minimum" sf_minimum,+ testProperty "t_minimum" t_minimum,+ testProperty "tl_minimum" tl_minimum+ ]+ ],++ testGroup "scans" [+ testProperty "sf_scanl" sf_scanl,+ testProperty "t_scanl" t_scanl,+ testProperty "tl_scanl" tl_scanl,+ testProperty "t_scanl1" t_scanl1,+ testProperty "tl_scanl1" tl_scanl1,+ testProperty "t_scanr" t_scanr,+ testProperty "tl_scanr" tl_scanr,+ testProperty "t_scanr1" t_scanr1,+ testProperty "tl_scanr1" tl_scanr1+ ],++ testGroup "mapAccum" [+ testProperty "t_mapAccumL" t_mapAccumL,+ testProperty "tl_mapAccumL" tl_mapAccumL,+ testProperty "t_mapAccumR" t_mapAccumR,+ testProperty "tl_mapAccumR" tl_mapAccumR+ ],++ testGroup "unfolds" [+ testProperty "tl_repeat" tl_repeat,+ testProperty "s_replicate" s_replicate,+ testProperty "t_replicate" t_replicate,+ testProperty "tl_replicate" tl_replicate,+ testProperty "tl_cycle" tl_cycle,+ testProperty "tl_iterate" tl_iterate,+ testProperty "t_unfoldr" t_unfoldr,+ testProperty "tl_unfoldr" tl_unfoldr,+ testProperty "t_unfoldrN" t_unfoldrN,+ testProperty "tl_unfoldrN" tl_unfoldrN+ ]+ ]
+ tests/Tests/Properties/Instances.hs view
@@ -0,0 +1,72 @@+-- | Test instances++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties.Instances+ ( testInstances+ ) where++import Data.String (IsString(fromString))+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Tests.QuickCheckUtils+import Text.Show.Functions ()+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Text.Internal.Fusion.Common as S+import qualified Data.Text.Lazy as TL++s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList)+ where _types = s :: String+sf_Eq p s =+ ((L.filter p s==) . L.filter p) `eq`+ (((S.filter p $ S.streamList s)==) . S.filter p . S.streamList)+t_Eq s = (s==) `eq` ((T.pack s==) . T.pack)+tl_Eq s = (s==) `eq` ((TL.pack s==) . TL.pack)+s_Ord s = (compare s) `eq` (compare (S.streamList s) . S.streamList)+ where _types = s :: String+sf_Ord p s =+ ((compare $ L.filter p s) . L.filter p) `eq`+ (compare (S.filter p $ S.streamList s) . S.filter p . S.streamList)+t_Ord s = (compare s) `eq` (compare (T.pack s) . T.pack)+tl_Ord s = (compare s) `eq` (compare (TL.pack s) . TL.pack)+t_Read = id `eq` (T.unpack . read . show)+tl_Read = id `eq` (TL.unpack . read . show)+t_Show = show `eq` (show . T.pack)+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_mconcat = unsquare $+ mconcat `eq` (unpackS . mconcat . L.map T.pack)+tl_mconcat = unsquare $+ mconcat `eq` (unpackS . mconcat . L.map TL.pack)+t_mempty = mempty === (unpackS (mempty :: T.Text))+tl_mempty = mempty === (unpackS (mempty :: TL.Text))+t_IsString = fromString `eqP` (T.unpack . fromString)+tl_IsString = fromString `eqP` (TL.unpack . fromString)++testInstances :: TestTree+testInstances =+ testGroup "instances" [+ testProperty "s_Eq" s_Eq,+ testProperty "sf_Eq" sf_Eq,+ testProperty "t_Eq" t_Eq,+ testProperty "tl_Eq" tl_Eq,+ testProperty "s_Ord" s_Ord,+ testProperty "sf_Ord" sf_Ord,+ testProperty "t_Ord" t_Ord,+ testProperty "tl_Ord" tl_Ord,+ testProperty "t_Read" t_Read,+ testProperty "tl_Read" tl_Read,+ testProperty "t_Show" t_Show,+ testProperty "tl_Show" tl_Show,+ testProperty "t_mappend" t_mappend,+ testProperty "tl_mappend" tl_mappend,+ testProperty "t_mconcat" t_mconcat,+ testProperty "tl_mconcat" tl_mconcat,+ testProperty "t_mempty" t_mempty,+ testProperty "tl_mempty" tl_mempty,+ testProperty "t_IsString" t_IsString,+ testProperty "tl_IsString" tl_IsString+ ]
+ tests/Tests/Properties/LowLevel.hs view
@@ -0,0 +1,128 @@+-- | Test low-level operations++{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures -fno-warn-unused-imports #-}+module Tests.Properties.LowLevel (testLowLevel) where++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 (mul, mul32, mul64)+import Data.Word (Word16, Word32)+import System.IO.Unsafe (unsafePerformIO)+import Test.QuickCheck.Monadic+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck hiding ((.&.))+import Tests.QuickCheckUtils+import Tests.Utils+import qualified Data.Bits as Bits (shiftL, shiftR)+import qualified Data.Text as T+import qualified Data.Text.Internal.Unsafe.Shift as U+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TL+import qualified System.IO as IO++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++-- Bit shifts.+shiftL w = forAll (choose (0,width-1)) $ \k -> Bits.shiftL w k == U.shiftL w k+ where width = round (log (fromIntegral m) / log 2 :: Double)+ (m,_) = (maxBound, m == w)+shiftR w = forAll (choose (0,width-1)) $ \k -> Bits.shiftR w k == U.shiftR w k+ where width = round (log (fromIntegral m) / log 2 :: Double)+ (m,_) = (maxBound, m == w)++shiftL_Int = shiftL :: Int -> Property+shiftL_Word16 = shiftL :: Word16 -> Property+shiftL_Word32 = shiftL :: Word32 -> Property+shiftR_Int = shiftR :: Int -> Property+shiftR_Word16 = shiftR :: Word16 -> Property+shiftR_Word32 = shiftR :: Word32 -> Property++-- Misc.++t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t+t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t+t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) === t+ where n = small m+t_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)++t_copy t = T.copy t === t++-- 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+tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents++t_write_read_line e m b t = write_read head T.filter T.hPutStrLn+ T.hGetLine e m b [t]+tl_write_read_line e m b t = write_read head TL.filter TL.hPutStrLn+ TL.hGetLine e m b [t]+++testLowLevel :: TestTree+testLowLevel =+ testGroup "lowlevel" [+ testGroup "mul" [+ testProperty "t_mul" t_mul,+ testProperty "t_mul32" t_mul32,+ testProperty "t_mul64" t_mul64+ ],++ testGroup "shifts" [+ testProperty "shiftL_Int" shiftL_Int,+ testProperty "shiftL_Word16" shiftL_Word16,+ testProperty "shiftL_Word32" shiftL_Word32,+ testProperty "shiftR_Int" shiftR_Int,+ testProperty "shiftR_Word16" shiftR_Word16,+ testProperty "shiftR_Word32" shiftR_Word32+ ],++ testGroup "misc" [+ testProperty "t_dropWord16" t_dropWord16,+ testProperty "t_takeWord16" t_takeWord16,+ testProperty "t_take_drop_16" t_take_drop_16,+ testProperty "t_use_from" t_use_from,+ testProperty "t_copy" t_copy+ ],++ testGroup "input-output" [+ testProperty "t_write_read" t_write_read,+ testProperty "tl_write_read" tl_write_read,+ testProperty "t_write_read_line" t_write_read_line,+ testProperty "tl_write_read_line" tl_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+ ]+ ]+
− tests/Tests/Properties/Mul.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Tests.Properties.Mul (tests) where--import Control.Applicative ((<$>), pure)-import Control.Exception as E (SomeException, catch, evaluate)-import Data.Int (Int32, Int64)-import Data.Text.Internal (mul, mul32, mul64)-import System.IO.Unsafe (unsafePerformIO)-import Test.Framework (Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck hiding ((.&.))--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--tests :: [Test]-tests = [- testProperty "t_mul" t_mul- , testProperty "t_mul32" t_mul32- , testProperty "t_mul64" t_mul64- ]
+ tests/Tests/Properties/Read.hs view
@@ -0,0 +1,71 @@+-- | Tests for readers++{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties.Read+ ( testRead+ ) where++import Data.Char (isDigit, isHexDigit)+import Numeric (showHex)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import Tests.QuickCheckUtils ()+import Text.Show.Functions ()+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Read as TL+import qualified Data.Text.Read as T++-- Reading.++t_decimal (n::Int) s =+ T.signed T.decimal (T.pack (show n) `T.append` t) === Right (n,t)+ where t = T.dropWhile isDigit s+tl_decimal (n::Int) s =+ TL.signed TL.decimal (TL.pack (show n) `TL.append` t) === Right (n,t)+ where t = TL.dropWhile isDigit s+t_hexadecimal m s ox =+ T.hexadecimal (T.concat [p, T.pack (showHex n ""), t]) === Right (n,t)+ where t = T.dropWhile isHexDigit s+ p = if ox then "0x" else ""+ n = getPositive m :: Int+tl_hexadecimal m s ox =+ TL.hexadecimal (TL.concat [p, TL.pack (showHex n ""), t]) === Right (n,t)+ where t = TL.dropWhile isHexDigit s+ p = if ox then "0x" else ""+ n = getPositive m :: Int++isFloaty c = c `elem` ("+-.0123456789eE" :: String)++t_read_rational p tol (n::Double) s =+ case p (T.pack (show n) `T.append` t) of+ Left _err -> False+ Right (n',t') -> t == t' && abs (n-n') <= tol+ where t = T.dropWhile isFloaty s++tl_read_rational p tol (n::Double) s =+ case p (TL.pack (show n) `TL.append` t) of+ Left _err -> False+ Right (n',t') -> t == t' && abs (n-n') <= tol+ where t = TL.dropWhile isFloaty s++t_double = t_read_rational T.double 1e-13+tl_double = tl_read_rational TL.double 1e-13+t_rational = t_read_rational T.rational 1e-16+tl_rational = tl_read_rational TL.rational 1e-16+++testRead :: TestTree+testRead =+ testGroup "read" [+ testProperty "t_decimal" t_decimal,+ testProperty "tl_decimal" tl_decimal,+ testProperty "t_hexadecimal" t_hexadecimal,+ testProperty "tl_hexadecimal" tl_hexadecimal,+ testProperty "t_double" t_double,+ testProperty "tl_double" tl_double,+ testProperty "t_rational" t_rational,+ testProperty "tl_rational" tl_rational+ ]
+ tests/Tests/Properties/Substrings.hs view
@@ -0,0 +1,348 @@+-- | Tests for substring functions (@take@, @split@, @isInfixOf@, etc.)++{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties.Substrings+ ( testSubstrings+ ) where++import Data.Char (isSpace)+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck.Unicode (char)+import Tests.QuickCheckUtils+import Text.Show.Functions ()+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Text.Internal.Fusion as S+import qualified Data.Text.Internal.Fusion.Common as S+import qualified Data.Text.Internal.Lazy.Fusion as SL+import qualified Data.Text.Lazy as TL+import qualified Tests.SlowFunctions as Slow++s_take n = L.take n `eqP` (unpackS . S.take n)+s_take_s m = L.take n `eqP` (unpackS . S.unstream . S.take n)+ where n = small m+sf_take p n = (L.take n . L.filter p) `eqP`+ (unpackS . S.take n . S.filter p)+t_take n = L.take n `eqP` (unpackS . T.take n)+t_takeEnd n = (L.reverse . L.take n . L.reverse) `eqP`+ (unpackS . T.takeEnd n)+tl_take n = L.take n `eqP` (unpackS . TL.take (fromIntegral n))+tl_takeEnd n = (L.reverse . L.take (fromIntegral n) . L.reverse) `eqP`+ (unpackS . TL.takeEnd n)+s_drop n = L.drop n `eqP` (unpackS . S.drop n)+s_drop_s m = L.drop n `eqP` (unpackS . S.unstream . S.drop n)+ where n = small m+sf_drop p n = (L.drop n . L.filter p) `eqP`+ (unpackS . S.drop n . S.filter p)+t_drop n = L.drop n `eqP` (unpackS . T.drop n)+t_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`+ (unpackS . T.dropEnd n)+tl_drop n = L.drop n `eqP` (unpackS . TL.drop (fromIntegral n))+tl_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`+ (unpackS . TL.dropEnd (fromIntegral n))+s_take_drop m = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)+ where n = small m+s_take_drop_s m = (L.take n . L.drop n) `eqP`+ (unpackS . S.unstream . S.take n . S.drop n)+ where n = small m+s_takeWhile p = L.takeWhile p `eqP` (unpackS . S.takeWhile p)+s_takeWhile_s p = L.takeWhile p `eqP` (unpackS . S.unstream . S.takeWhile p)+sf_takeWhile q p = (L.takeWhile p . L.filter q) `eqP`+ (unpackS . S.takeWhile p . S.filter q)+noMatch = do+ c <- char+ d <- suchThat char (/= c)+ return (c,d)+t_takeWhile p = L.takeWhile p `eqP` (unpackS . T.takeWhile p)+tl_takeWhile p = L.takeWhile p `eqP` (unpackS . TL.takeWhile p)+t_takeWhileEnd p = (L.reverse . L.takeWhile p . L.reverse) `eqP`+ (unpackS . T.takeWhileEnd p)+t_takeWhileEnd_null t = forAll noMatch $ \(c,d) -> T.null $+ T.takeWhileEnd (==d) (T.snoc t c)+tl_takeWhileEnd p = (L.reverse . L.takeWhile p . L.reverse) `eqP`+ (unpackS . TL.takeWhileEnd p)+tl_takeWhileEnd_null t = forAll noMatch $ \(c,d) -> TL.null $+ TL.takeWhileEnd (==d) (TL.snoc t c)+s_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)+s_dropWhile_s p = L.dropWhile p `eqP` (unpackS . S.unstream . S.dropWhile p)+sf_dropWhile q p = (L.dropWhile p . L.filter q) `eqP`+ (unpackS . S.dropWhile p . S.filter q)+t_dropWhile p = L.dropWhile p `eqP` (unpackS . T.dropWhile p)+tl_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)+t_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`+ (unpackS . T.dropWhileEnd p)+tl_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`+ (unpackS . TL.dropWhileEnd p)+t_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)+ `eqP` (unpackS . T.dropAround p)+tl_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)+ `eqP` (unpackS . TL.dropAround p)+t_stripStart = T.dropWhile isSpace `eq` T.stripStart+tl_stripStart = TL.dropWhile isSpace `eq` TL.stripStart+t_stripEnd = T.dropWhileEnd isSpace `eq` T.stripEnd+tl_stripEnd = TL.dropWhileEnd isSpace `eq` TL.stripEnd+t_strip = T.dropAround isSpace `eq` T.strip+tl_strip = TL.dropAround isSpace `eq` TL.strip+t_splitAt n = L.splitAt n `eqP` (unpack2 . T.splitAt n)+tl_splitAt n = L.splitAt n `eqP` (unpack2 . TL.splitAt (fromIntegral n))+t_span p = L.span p `eqP` (unpack2 . T.span p)+tl_span p = L.span p `eqP` (unpack2 . TL.span p)++t_breakOn_id s = squid `eq` (uncurry T.append . T.breakOn s)+ where squid t | T.null s = error "empty"+ | otherwise = t+tl_breakOn_id s = squid `eq` (uncurry TL.append . TL.breakOn s)+ where squid t | TL.null s = error "empty"+ | otherwise = t+t_breakOn_start (NotEmpty s) t =+ let (k,m) = T.breakOn s t+ in k `T.isPrefixOf` t && (T.null m || s `T.isPrefixOf` m)+tl_breakOn_start (NotEmpty s) t =+ let (k,m) = TL.breakOn s t+ in k `TL.isPrefixOf` t && TL.null m || s `TL.isPrefixOf` m+t_breakOnEnd_end (NotEmpty s) t =+ let (m,k) = T.breakOnEnd s t+ in k `T.isSuffixOf` t && (T.null m || s `T.isSuffixOf` m)+tl_breakOnEnd_end (NotEmpty s) t =+ let (m,k) = TL.breakOnEnd s t+ in k `TL.isSuffixOf` t && (TL.null m || s `TL.isSuffixOf` m)+t_break p = L.break p `eqP` (unpack2 . T.break p)+tl_break p = L.break p `eqP` (unpack2 . TL.break p)+t_group = L.group `eqP` (map unpackS . T.group)+tl_group = L.group `eqP` (map unpackS . TL.group)+t_groupBy p = L.groupBy p `eqP` (map unpackS . T.groupBy p)+tl_groupBy p = L.groupBy p `eqP` (map unpackS . TL.groupBy p)+t_inits = L.inits `eqP` (map unpackS . T.inits)+tl_inits = L.inits `eqP` (map unpackS . TL.inits)+t_tails = L.tails `eqP` (map unpackS . T.tails)+tl_tails = unsquare $+ L.tails `eqP` (map unpackS . TL.tails)+t_findAppendId = unsquare $ \(NotEmpty s) ts ->+ let t = T.intercalate s ts+ in all (==t) $ map (uncurry T.append) (T.breakOnAll s t)+tl_findAppendId = unsquare $ \(NotEmpty s) ts ->+ let t = TL.intercalate s ts+ in all (==t) $ map (uncurry TL.append) (TL.breakOnAll s t)+t_findContains = unsquare $ \(NotEmpty s) ->+ all (T.isPrefixOf s . snd) . T.breakOnAll s . T.intercalate s+tl_findContains = unsquare $ \(NotEmpty s) -> all (TL.isPrefixOf s . snd) .+ TL.breakOnAll s . TL.intercalate s+sl_filterCount c = (L.genericLength . L.filter (==c)) `eqP` SL.countChar c+t_findCount s = (L.length . T.breakOnAll s) `eq` T.count s+tl_findCount s = (L.genericLength . TL.breakOnAll s) `eq` TL.count s++t_splitOn_split s = unsquare $+ (T.splitOn s `eq` Slow.splitOn s) . T.intercalate s+tl_splitOn_split s = unsquare $+ ((TL.splitOn (TL.fromStrict s) . TL.fromStrict) `eq`+ (map TL.fromStrict . T.splitOn s)) . T.intercalate s+t_splitOn_i (NotEmpty t) = id `eq` (T.intercalate t . T.splitOn t)+tl_splitOn_i (NotEmpty t) = id `eq` (TL.intercalate t . TL.splitOn t)++t_split p = split p `eqP` (map unpackS . T.split p)+t_split_count c = (L.length . T.split (==c)) `eq`+ ((1+) . T.count (T.singleton c))+t_split_splitOn c = T.split (==c) `eq` T.splitOn (T.singleton c)+tl_split p = split p `eqP` (map unpackS . TL.split p)++split :: (a -> Bool) -> [a] -> [[a]]+split _ [] = [[]]+split p xs = loop xs+ where loop s | null s' = [l]+ | otherwise = l : loop (tail s')+ where (l, s') = break p s++t_chunksOf_same_lengths k = all ((==k) . T.length) . ini . T.chunksOf k+ where ini [] = []+ ini xs = init xs++t_chunksOf_length k t = len == T.length t || (k <= 0 && len == 0)+ where len = L.sum . L.map T.length $ T.chunksOf k t++tl_chunksOf k = T.chunksOf k `eq` (map (T.concat . TL.toChunks) .+ TL.chunksOf (fromIntegral k) . TL.fromStrict)++t_lines = L.lines `eqP` (map unpackS . T.lines)+tl_lines = L.lines `eqP` (map unpackS . TL.lines)+{-+t_lines' = lines' `eqP` (map unpackS . T.lines')+ where lines' "" = []+ lines' s = let (l, s') = break eol s+ in l : case s' of+ [] -> []+ ('\r':'\n':s'') -> lines' s''+ (_:s'') -> lines' s''+ eol c = c == '\r' || c == '\n'+-}+t_words = L.words `eqP` (map unpackS . T.words)++tl_words = L.words `eqP` (map unpackS . TL.words)+t_unlines = unsquare $+ L.unlines `eq` (unpackS . T.unlines . map packS)+tl_unlines = unsquare $+ L.unlines `eq` (unpackS . TL.unlines . map packS)+t_unwords = unsquare $+ L.unwords `eq` (unpackS . T.unwords . map packS)+tl_unwords = unsquare $+ L.unwords `eq` (unpackS . TL.unwords . map packS)++s_isPrefixOf s = L.isPrefixOf s `eqP`+ (S.isPrefixOf (S.stream $ packS s) . S.stream)+sf_isPrefixOf p s = (L.isPrefixOf s . L.filter p) `eqP`+ (S.isPrefixOf (S.stream $ packS s) . S.filter p . S.stream)+t_isPrefixOf s = L.isPrefixOf s`eqP` T.isPrefixOf (packS s)+tl_isPrefixOf s = L.isPrefixOf s`eqP` TL.isPrefixOf (packS s)+t_isSuffixOf s = L.isSuffixOf s`eqP` T.isSuffixOf (packS s)+tl_isSuffixOf s = L.isSuffixOf s`eqP` TL.isSuffixOf (packS s)+t_isInfixOf s = L.isInfixOf s `eqP` T.isInfixOf (packS s)+tl_isInfixOf s = L.isInfixOf s `eqP` TL.isInfixOf (packS s)++t_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` T.stripPrefix (packS s)+tl_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` TL.stripPrefix (packS s)++stripSuffix p t = reverse `fmap` L.stripPrefix (reverse p) (reverse t)++t_stripSuffix s = (fmap packS . stripSuffix s) `eqP` T.stripSuffix (packS s)+tl_stripSuffix s = (fmap packS . stripSuffix s) `eqP` TL.stripSuffix (packS s)++commonPrefixes a0@(_:_) b0@(_:_) = Just (go a0 b0 [])+ where go (a:as) (b:bs) ps+ | a == b = go as bs (a:ps)+ go as bs ps = (reverse ps,as,bs)+commonPrefixes _ _ = Nothing++t_commonPrefixes a b (NonEmpty p)+ = commonPrefixes pa pb ==+ repack `fmap` T.commonPrefixes (packS pa) (packS pb)+ where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)+ pa = p ++ a+ pb = p ++ b++tl_commonPrefixes a b (NonEmpty p)+ = commonPrefixes pa pb ==+ repack `fmap` TL.commonPrefixes (packS pa) (packS pb)+ where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)+ pa = p ++ a+ pb = p ++ b++testSubstrings :: TestTree+testSubstrings =+ testGroup "substrings" [+ testGroup "breaking" [+ testProperty "s_take" s_take,+ testProperty "s_take_s" s_take_s,+ testProperty "sf_take" sf_take,+ testProperty "t_take" t_take,+ testProperty "t_takeEnd" t_takeEnd,+ testProperty "tl_take" tl_take,+ testProperty "tl_takeEnd" tl_takeEnd,+ testProperty "s_drop" s_drop,+ testProperty "s_drop_s" s_drop_s,+ testProperty "sf_drop" sf_drop,+ testProperty "t_drop" t_drop,+ testProperty "t_dropEnd" t_dropEnd,+ testProperty "tl_drop" tl_drop,+ testProperty "tl_dropEnd" tl_dropEnd,+ testProperty "s_take_drop" s_take_drop,+ testProperty "s_take_drop_s" s_take_drop_s,+ testProperty "s_takeWhile" s_takeWhile,+ testProperty "s_takeWhile_s" s_takeWhile_s,+ testProperty "sf_takeWhile" sf_takeWhile,+ testProperty "t_takeWhile" t_takeWhile,+ testProperty "tl_takeWhile" tl_takeWhile,+ testProperty "t_takeWhileEnd" t_takeWhileEnd,+ testProperty "t_takeWhileEnd_null" t_takeWhileEnd_null,+ testProperty "tl_takeWhileEnd" tl_takeWhileEnd,+ testProperty "tl_takeWhileEnd_null" tl_takeWhileEnd_null,+ testProperty "sf_dropWhile" sf_dropWhile,+ testProperty "s_dropWhile" s_dropWhile,+ testProperty "s_dropWhile_s" s_dropWhile_s,+ testProperty "t_dropWhile" t_dropWhile,+ testProperty "tl_dropWhile" tl_dropWhile,+ testProperty "t_dropWhileEnd" t_dropWhileEnd,+ testProperty "tl_dropWhileEnd" tl_dropWhileEnd,+ testProperty "t_dropAround" t_dropAround,+ testProperty "tl_dropAround" tl_dropAround,+ testProperty "t_stripStart" t_stripStart,+ testProperty "tl_stripStart" tl_stripStart,+ testProperty "t_stripEnd" t_stripEnd,+ testProperty "tl_stripEnd" tl_stripEnd,+ testProperty "t_strip" t_strip,+ testProperty "tl_strip" tl_strip,+ testProperty "t_splitAt" t_splitAt,+ testProperty "tl_splitAt" tl_splitAt,+ testProperty "t_span" t_span,+ testProperty "tl_span" tl_span,+ testProperty "t_breakOn_id" t_breakOn_id,+ testProperty "tl_breakOn_id" tl_breakOn_id,+ testProperty "t_breakOn_start" t_breakOn_start,+ testProperty "tl_breakOn_start" tl_breakOn_start,+ testProperty "t_breakOnEnd_end" t_breakOnEnd_end,+ testProperty "tl_breakOnEnd_end" tl_breakOnEnd_end,+ testProperty "t_break" t_break,+ testProperty "tl_break" tl_break,+ testProperty "t_group" t_group,+ testProperty "tl_group" tl_group,+ testProperty "t_groupBy" t_groupBy,+ testProperty "tl_groupBy" tl_groupBy,+ testProperty "t_inits" t_inits,+ testProperty "tl_inits" tl_inits,+ testProperty "t_tails" t_tails,+ testProperty "tl_tails" tl_tails+ ],++ testGroup "breaking many" [+ testProperty "t_findAppendId" t_findAppendId,+ testProperty "tl_findAppendId" tl_findAppendId,+ testProperty "t_findContains" t_findContains,+ testProperty "tl_findContains" tl_findContains,+ testProperty "sl_filterCount" sl_filterCount,+ testProperty "t_findCount" t_findCount,+ testProperty "tl_findCount" tl_findCount,+ testProperty "t_splitOn_split" t_splitOn_split,+ testProperty "tl_splitOn_split" tl_splitOn_split,+ testProperty "t_splitOn_i" t_splitOn_i,+ testProperty "tl_splitOn_i" tl_splitOn_i,+ testProperty "t_split" t_split,+ testProperty "t_split_count" t_split_count,+ testProperty "t_split_splitOn" t_split_splitOn,+ testProperty "tl_split" tl_split,+ testProperty "t_chunksOf_same_lengths" t_chunksOf_same_lengths,+ testProperty "t_chunksOf_length" t_chunksOf_length,+ testProperty "tl_chunksOf" tl_chunksOf+ ],++ testGroup "lines and words" [+ testProperty "t_lines" t_lines,+ testProperty "tl_lines" tl_lines,+ --testProperty "t_lines'" t_lines',+ testProperty "t_words" t_words,+ testProperty "tl_words" tl_words,+ testProperty "t_unlines" t_unlines,+ testProperty "tl_unlines" tl_unlines,+ testProperty "t_unwords" t_unwords,+ testProperty "tl_unwords" tl_unwords+ ],++ testGroup "predicates" [+ testProperty "s_isPrefixOf" s_isPrefixOf,+ testProperty "sf_isPrefixOf" sf_isPrefixOf,+ testProperty "t_isPrefixOf" t_isPrefixOf,+ testProperty "tl_isPrefixOf" tl_isPrefixOf,+ testProperty "t_isSuffixOf" t_isSuffixOf,+ testProperty "tl_isSuffixOf" tl_isSuffixOf,+ testProperty "t_isInfixOf" t_isInfixOf,+ testProperty "tl_isInfixOf" tl_isInfixOf,++ testGroup "view" [+ testProperty "t_stripPrefix" t_stripPrefix,+ testProperty "tl_stripPrefix" tl_stripPrefix,+ testProperty "t_stripSuffix" t_stripSuffix,+ testProperty "tl_stripSuffix" tl_stripSuffix,+ testProperty "t_commonPrefixes" t_commonPrefixes,+ testProperty "tl_commonPrefixes" tl_commonPrefixes+ ]+ ]+ ]
+ tests/Tests/Properties/Text.hs view
@@ -0,0 +1,308 @@+-- | Tests for operations that don't fit in the other @Test.Properties.*@ modules.++{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}+module Tests.Properties.Text+ ( testText+ ) where++import Data.Char (isLower, isLetter, isUpper)+import Data.Maybe (mapMaybe)+import Data.Text.Internal.Fusion.Size+import Data.Word (Word8)+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Tests.QuickCheckUtils+import Text.Show.Functions ()+import qualified Data.Char as C+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Text.Internal.Fusion as S+import qualified Data.Text.Internal.Fusion.Common as S+import qualified Data.Text.Internal.Lazy.Fusion as SL+import qualified Data.Text.Internal.Lazy.Search as S (indices)+import qualified Data.Text.Internal.Search as T (indices)+import qualified Data.Text.Lazy as TL+import qualified Tests.SlowFunctions as Slow++t_pack_unpack = (T.unpack . T.pack) `eq` id+tl_pack_unpack = (TL.unpack . TL.pack) `eq` id+t_stream_unstream = (S.unstream . S.stream) `eq` id+tl_stream_unstream = (SL.unstream . SL.stream) `eq` id+t_reverse_stream t = (S.reverse . S.reverseStream) t === t+t_singleton c = [c] === (T.unpack . T.singleton) c+tl_singleton c = [c] === (TL.unpack . TL.singleton) c+tl_unstreamChunks x = f 11 x === f 1000 x+ where f n = SL.unstreamChunks n . S.streamList+tl_chunk_unchunk = (TL.fromChunks . TL.toChunks) `eq` id+tl_from_to_strict = (TL.fromStrict . TL.toStrict) `eq` id+++s_map f = map f `eqP` (unpackS . S.map f)+s_map_s f = map f `eqP` (unpackS . S.unstream . S.map f)+sf_map p f = (map f . L.filter p) `eqP` (unpackS . S.map f . S.filter p)+t_map f = map f `eqP` (unpackS . T.map f)+tl_map f = map f `eqP` (unpackS . TL.map f)+s_intercalate c = unsquare $+ L.intercalate c `eq`+ (unpackS . S.intercalate (packS c) . map packS)+t_intercalate c = unsquare $+ L.intercalate c `eq`+ (unpackS . T.intercalate (packS c) . map packS)+tl_intercalate c = unsquare $+ L.intercalate c `eq`+ (unpackS . TL.intercalate (TL.pack c) . map TL.pack)+s_intersperse c = L.intersperse c `eqP`+ (unpackS . S.intersperse c)+s_intersperse_s c = L.intersperse c `eqP`+ (unpackS . S.unstream . S.intersperse c)+sf_intersperse p c= (L.intersperse c . L.filter p) `eqP`+ (unpackS . S.intersperse c . S.filter p)+t_intersperse c = unsquare $+ L.intersperse c `eqP` (unpackS . T.intersperse c)+tl_intersperse c = unsquare $+ L.intersperse c `eqP` (unpackS . TL.intersperse c)+t_transpose = unsquare $+ L.transpose `eq` (map unpackS . T.transpose . map packS)+tl_transpose = unsquare $+ L.transpose `eq` (map unpackS . TL.transpose . map TL.pack)+t_reverse = L.reverse `eqP` (unpackS . T.reverse)+tl_reverse = L.reverse `eqP` (unpackS . TL.reverse)+t_reverse_short n = L.reverse `eqP` (unpackS . S.reverse . shorten n . S.stream)++t_replace s d = (L.intercalate d . splitOn s) `eqP`+ (unpackS . T.replace (T.pack s) (T.pack d))+tl_replace s d = (L.intercalate d . splitOn s) `eqP`+ (unpackS . TL.replace (TL.pack s) (TL.pack d))++splitOn :: (Eq a) => [a] -> [a] -> [[a]]+splitOn pat src0+ | l == 0 = error "splitOn: empty"+ | otherwise = go src0+ where+ l = length pat+ go src = search 0 src+ where+ search _ [] = [src]+ search !n s@(_:s')+ | pat `L.isPrefixOf` s = take n src : go (drop l s)+ | otherwise = search (n+1) s'++s_toCaseFold_length xs = S.length (S.toCaseFold s) >= length xs+ where s = S.streamList xs+sf_toCaseFold_length p xs =+ (S.length . S.toCaseFold . S.filter p $ s) >= (length . L.filter p $ xs)+ where s = S.streamList xs+t_toCaseFold_length t = T.length (T.toCaseFold t) >= T.length t+tl_toCaseFold_length t = TL.length (TL.toCaseFold t) >= TL.length t+t_toLower_length t = T.length (T.toLower t) >= T.length t+t_toLower_lower t = p (T.toLower t) >= p t+ where p = T.length . T.filter isLower+tl_toLower_lower t = p (TL.toLower t) >= p t+ where p = TL.length . TL.filter isLower+t_toUpper_length t = T.length (T.toUpper t) >= T.length t+t_toUpper_upper t = p (T.toUpper t) >= p t+ where p = T.length . T.filter isUpper+tl_toUpper_upper t = p (TL.toUpper t) >= p t+ where p = TL.length . TL.filter isUpper+t_toTitle_title t = all (<= 1) (caps w)+ where caps = fmap (T.length . T.filter isUpper) . T.words . T.toTitle+ -- TIL: there exist uppercase-only letters+ w = T.filter (\c -> if C.isUpper c then C.toLower c /= c else True) t+t_toTitle_1stNotLower = and . notLow . T.toTitle . T.filter stable . T.filter (not . isGeorgian)+ where notLow = mapMaybe (fmap (not . isLower) . (T.find isLetter)) . T.words+ -- Surprise! The Spanish/Portuguese ordinal indicators changed+ -- from category Ll (letter, lowercase) to Lo (letter, other)+ -- in Unicode 7.0+ -- Oh, and there exist lowercase-only letters (see previous test)+ stable c = if isLower c+ then C.toUpper c /= c+ else c /= '\170' && c /= '\186'+ -- Georgian text does not have a concept of title case+ -- https://en.wikipedia.org/wiki/Georgian_Extended+ isGeorgian c = c >= '\4256' && c < '\4352'++justifyLeft k c xs = xs ++ L.replicate (k - length xs) c+justifyRight m n xs = L.replicate (m - length xs) n ++ xs+center k c xs+ | len >= k = xs+ | otherwise = L.replicate l c ++ xs ++ L.replicate r c+ where len = length xs+ d = k - len+ r = d `div` 2+ l = d - r++s_justifyLeft k c = justifyLeft j c `eqP` (unpackS . S.justifyLeftI j c)+ where j = fromIntegral (k :: Word8)+s_justifyLeft_s k c = justifyLeft j c `eqP`+ (unpackS . S.unstream . S.justifyLeftI j c)+ where j = fromIntegral (k :: Word8)+sf_justifyLeft p k c = (justifyLeft j c . L.filter p) `eqP`+ (unpackS . S.justifyLeftI j c . S.filter p)+ where j = fromIntegral (k :: Word8)+t_justifyLeft k c = justifyLeft j c `eqP` (unpackS . T.justifyLeft j c)+ where j = fromIntegral (k :: Word8)+tl_justifyLeft k c = justifyLeft j c `eqP`+ (unpackS . TL.justifyLeft (fromIntegral j) c)+ where j = fromIntegral (k :: Word8)+t_justifyRight k c = justifyRight j c `eqP` (unpackS . T.justifyRight j c)+ where j = fromIntegral (k :: Word8)+tl_justifyRight k c = justifyRight j c `eqP`+ (unpackS . TL.justifyRight (fromIntegral j) c)+ where j = fromIntegral (k :: Word8)+t_center k c = center j c `eqP` (unpackS . T.center j c)+ where j = fromIntegral (k :: Word8)+tl_center k c = center j c `eqP` (unpackS . TL.center (fromIntegral j) c)+ where j = fromIntegral (k :: Word8)++t_elem c = L.elem c `eqP` T.elem c+tl_elem c = L.elem c `eqP` TL.elem c+sf_elem p c = (L.elem c . L.filter p) `eqP` (S.elem c . S.filter p)+sf_filter q p = (L.filter p . L.filter q) `eqP`+ (unpackS . S.filter p . S.filter q)+t_filter p = L.filter p `eqP` (unpackS . T.filter p)+tl_filter p = L.filter p `eqP` (unpackS . TL.filter p)+sf_findBy q p = (L.find p . L.filter q) `eqP` (S.findBy p . S.filter q)+t_find p = L.find p `eqP` T.find p+tl_find p = L.find p `eqP` TL.find p+t_partition p = L.partition p `eqP` (unpack2 . T.partition p)+tl_partition p = L.partition p `eqP` (unpack2 . TL.partition p)++sf_index p s = forAll (choose (-l,l*2))+ ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))+ where l = L.length s+t_index s = forAll (choose (-l,l*2)) ((s L.!!) `eq` T.index (packS s))+ where l = L.length s++tl_index s = forAll (choose (-l,l*2))+ ((s L.!!) `eq` (TL.index (packS s) . fromIntegral))+ where l = L.length s++t_findIndex p = L.findIndex p `eqP` T.findIndex p+t_count (NotEmpty t) = (subtract 1 . L.length . T.splitOn t) `eq` T.count t+tl_count (NotEmpty t) = (subtract 1 . L.genericLength . TL.splitOn t) `eq`+ TL.count t+t_zip s = L.zip s `eqP` T.zip (packS s)+tl_zip s = L.zip s `eqP` TL.zip (packS s)+sf_zipWith p c s = (L.zipWith c (L.filter p s) . L.filter p) `eqP`+ (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p)+t_zipWith c s = L.zipWith c s `eqP` (unpackS . T.zipWith c (packS s))+tl_zipWith c s = L.zipWith c s `eqP` (unpackS . TL.zipWith c (packS s))++t_indices (NotEmpty s) = Slow.indices s `eq` T.indices s+tl_indices (NotEmpty s) = lazyIndices s `eq` S.indices s+ where lazyIndices ss t = map fromIntegral $ Slow.indices (conc ss) (conc t)+ conc = T.concat . TL.toChunks+t_indices_occurs = unsquare $ \(NotEmpty t) ts ->+ let s = T.intercalate t ts+ in Slow.indices t s === T.indices t s++-- Make a stream appear shorter than it really is, to ensure that+-- functions that consume inaccurately sized streams behave+-- themselves.+shorten :: Int -> S.Stream a -> S.Stream a+shorten n t@(S.Stream arr off len)+ | n > 0 = S.Stream arr off (smaller (exactSize n) len)+ | otherwise = t++testText :: TestTree+testText =+ testGroup "Text" [+ testGroup "creation/elimination" [+ testProperty "t_pack_unpack" t_pack_unpack,+ testProperty "tl_pack_unpack" tl_pack_unpack,+ testProperty "t_stream_unstream" t_stream_unstream,+ testProperty "tl_stream_unstream" tl_stream_unstream,+ testProperty "t_reverse_stream" t_reverse_stream,+ testProperty "t_singleton" t_singleton,+ testProperty "tl_singleton" tl_singleton,+ testProperty "tl_unstreamChunks" tl_unstreamChunks,+ testProperty "tl_chunk_unchunk" tl_chunk_unchunk,+ testProperty "tl_from_to_strict" tl_from_to_strict+ ],++ testGroup "transformations" [+ testProperty "s_map" s_map,+ testProperty "s_map_s" s_map_s,+ testProperty "sf_map" sf_map,+ testProperty "t_map" t_map,+ testProperty "tl_map" tl_map,+ testProperty "s_intercalate" s_intercalate,+ testProperty "t_intercalate" t_intercalate,+ testProperty "tl_intercalate" tl_intercalate,+ testProperty "s_intersperse" s_intersperse,+ testProperty "s_intersperse_s" s_intersperse_s,+ testProperty "sf_intersperse" sf_intersperse,+ testProperty "t_intersperse" t_intersperse,+ testProperty "tl_intersperse" tl_intersperse,+ testProperty "t_transpose" t_transpose,+ testProperty "tl_transpose" tl_transpose,+ testProperty "t_reverse" t_reverse,+ testProperty "tl_reverse" tl_reverse,+ testProperty "t_reverse_short" t_reverse_short,+ testProperty "t_replace" t_replace,+ testProperty "tl_replace" tl_replace,++ testGroup "case conversion" [+ testProperty "s_toCaseFold_length" s_toCaseFold_length,+ testProperty "sf_toCaseFold_length" sf_toCaseFold_length,+ testProperty "t_toCaseFold_length" t_toCaseFold_length,+ testProperty "tl_toCaseFold_length" tl_toCaseFold_length,+ testProperty "t_toLower_length" t_toLower_length,+ testProperty "t_toLower_lower" t_toLower_lower,+ testProperty "tl_toLower_lower" tl_toLower_lower,+ testProperty "t_toUpper_length" t_toUpper_length,+ testProperty "t_toUpper_upper" t_toUpper_upper,+ testProperty "tl_toUpper_upper" tl_toUpper_upper,+ testProperty "t_toTitle_title" t_toTitle_title,+ testProperty "t_toTitle_1stNotLower" t_toTitle_1stNotLower+ ],++ testGroup "justification" [+ testProperty "s_justifyLeft" s_justifyLeft,+ testProperty "s_justifyLeft_s" s_justifyLeft_s,+ testProperty "sf_justifyLeft" sf_justifyLeft,+ testProperty "t_justifyLeft" t_justifyLeft,+ testProperty "tl_justifyLeft" tl_justifyLeft,+ testProperty "t_justifyRight" t_justifyRight,+ testProperty "tl_justifyRight" tl_justifyRight,+ testProperty "t_center" t_center,+ testProperty "tl_center" tl_center+ ]+ ],++ testGroup "searching" [+ testProperty "t_elem" t_elem,+ testProperty "tl_elem" tl_elem,+ testProperty "sf_elem" sf_elem,+ testProperty "sf_filter" sf_filter,+ testProperty "t_filter" t_filter,+ testProperty "tl_filter" tl_filter,+ testProperty "sf_findBy" sf_findBy,+ testProperty "t_find" t_find,+ testProperty "tl_find" tl_find,+ testProperty "t_partition" t_partition,+ testProperty "tl_partition" tl_partition+ ],++ testGroup "indexing" [+ testProperty "sf_index" sf_index,+ testProperty "t_index" t_index,+ testProperty "tl_index" tl_index,+ testProperty "t_findIndex" t_findIndex,+ testProperty "t_count" t_count,+ testProperty "tl_count" tl_count,+ testProperty "t_indices" t_indices,+ testProperty "tl_indices" tl_indices,+ testProperty "t_indices_occurs" t_indices_occurs+ ],++ testGroup "zips" [+ testProperty "t_zip" t_zip,+ testProperty "tl_zip" tl_zip,+ testProperty "sf_zipWith" sf_zipWith,+ testProperty "t_zipWith" t_zipWith,+ testProperty "tl_zipWith" tl_zipWith+ ]+ ]
+ tests/Tests/Properties/Transcoding.hs view
@@ -0,0 +1,231 @@+-- | Tests for encoding and decoding++{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures -fno-warn-unused-imports -fno-warn-deprecations #-}+module Tests.Properties.Transcoding+ ( testTranscoding+ ) where++import Control.Applicative ((<$>), (<*>))+import Data.Bits ((.&.))+import Data.Char (chr, ord)+import Data.Text.Encoding.Error (UnicodeException)+import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4)+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Property (Property(..))+import Test.QuickCheck.Monadic+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Tests.QuickCheckUtils+import Text.Show.Functions ()+import qualified Control.Exception as Exception+import qualified Data.Bits as Bits (shiftL, shiftR)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import qualified Data.Text.Encoding.Error as E+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as EL++-- Note: this silently truncates code-points > 255 to 8-bit due to 'B.pack'+encodeL1 :: T.Text -> B.ByteString+encodeL1 = B.pack . map (fromIntegral . fromEnum) . T.unpack+encodeLazyL1 :: TL.Text -> BL.ByteString+encodeLazyL1 = BL.fromChunks . map encodeL1 . TL.toChunks++t_ascii t = E.decodeASCII (E.encodeUtf8 a) === a+ where a = T.map (\c -> chr (ord c `mod` 128)) t+tl_ascii t = EL.decodeASCII (EL.encodeUtf8 a) === a+ where a = TL.map (\c -> chr (ord c `mod` 128)) t+t_latin1 t = E.decodeLatin1 (encodeL1 a) === a+ where a = T.map (\c -> chr (ord c `mod` 256)) t+tl_latin1 t = EL.decodeLatin1 (encodeLazyL1 a) === a+ where a = TL.map (\c -> chr (ord c `mod` 256)) t+t_utf8 = forAll genUnicode $ (E.decodeUtf8 . E.encodeUtf8) `eq` id+t_utf8' = forAll genUnicode $ (E.decodeUtf8' . E.encodeUtf8) `eq` (id . Right)+tl_utf8 = forAll genUnicode $ (EL.decodeUtf8 . EL.encodeUtf8) `eq` id+tl_utf8' = forAll genUnicode $ (EL.decodeUtf8' . EL.encodeUtf8) `eq` (id . Right)+t_utf16LE = forAll genUnicode $ (E.decodeUtf16LE . E.encodeUtf16LE) `eq` id+tl_utf16LE = forAll genUnicode $ (EL.decodeUtf16LE . EL.encodeUtf16LE) `eq` id+t_utf16BE = forAll genUnicode $ (E.decodeUtf16BE . E.encodeUtf16BE) `eq` id+tl_utf16BE = forAll genUnicode $ (EL.decodeUtf16BE . EL.encodeUtf16BE) `eq` id+t_utf32LE = forAll genUnicode $ (E.decodeUtf32LE . E.encodeUtf32LE) `eq` id+tl_utf32LE = forAll genUnicode $ (EL.decodeUtf32LE . EL.encodeUtf32LE) `eq` id+t_utf32BE = forAll genUnicode $ (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id+tl_utf32BE = forAll genUnicode $ (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id++t_utf8_incr = forAll genUnicode $ \s (Positive n) -> (recode n `eq` id) s+ where recode n = T.concat . map fst . feedChunksOf n E.streamDecodeUtf8 .+ E.encodeUtf8++feedChunksOf :: Int -> (B.ByteString -> E.Decoding) -> B.ByteString+ -> [(T.Text, B.ByteString)]+feedChunksOf n f bs+ | B.null bs = []+ | otherwise = let (x,y) = B.splitAt n bs+ E.Some t b f' = f x+ in (t,b) : feedChunksOf n f' y++t_utf8_undecoded = forAll genUnicode $ \t ->+ let b = E.encodeUtf8 t+ ls = concatMap (leftover . E.encodeUtf8 . T.singleton) . T.unpack $ t+ leftover = (++ [B.empty]) . init . tail . B.inits+ in (map snd . feedChunksOf 1 E.streamDecodeUtf8) b === ls++data Badness = Solo | Leading | Trailing+ deriving (Eq, Show)++instance Arbitrary Badness where+ arbitrary = elements [Solo, Leading, Trailing]++t_utf8_err :: Badness -> Maybe DecodeErr -> Property+t_utf8_err bad mde = do+ let gen = case bad of+ Solo -> genInvalidUTF8+ Leading -> B.append <$> genInvalidUTF8 <*> genUTF8+ Trailing -> B.append <$> genUTF8 <*> genInvalidUTF8+ genUTF8 = E.encodeUtf8 <$> genUnicode+ forAll gen $ \bs -> MkProperty $+ case mde of+ -- generate an invalid character+ Nothing -> do+ c <- choose ('\x10000', maxBound)+ let onErr _ _ = Just c+ unProperty . monadicIO $ do+ l <- run $ let len = T.length (E.decodeUtf8With onErr bs)+ in (len `seq` return (Right len)) `Exception.catch`+ (\(e::Exception.SomeException) -> return (Left e))+ assert $ case l of+ Left err ->+ "non-BMP replacement characters not supported" `T.isInfixOf` T.pack (show err)+ Right _ -> False++ -- generate a valid onErr+ Just de -> do+ onErr <- genDecodeErr de+ unProperty . monadicIO $ do+ l <- run $ let len = T.length (E.decodeUtf8With onErr bs)+ in (len `seq` return (Right len)) `Exception.catch`+ (\(e::UnicodeException) -> return (Left e))+ assert $ case l of+ Left err -> length (show err) >= 0+ Right _ -> de /= Strict++t_utf8_err' :: B.ByteString -> Property+t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of+ Left err -> length (show err) >= 0+ Right t -> T.length t >= 0++genInvalidUTF8 :: Gen B.ByteString+genInvalidUTF8 = B.pack <$> oneof [+ -- invalid leading byte of a 2-byte sequence+ (:) <$> choose (0xC0, 0xC1) <*> upTo 1 contByte+ -- invalid leading byte of a 4-byte sequence+ , (:) <$> choose (0xF5, 0xFF) <*> upTo 3 contByte+ -- 4-byte sequence greater than U+10FFFF+ , do k <- choose (0x11, 0x13)+ let w0 = 0xF0 + (k `Bits.shiftR` 2)+ w1 = 0x80 + ((k .&. 3) `Bits.shiftL` 4)+ ([w0,w1]++) <$> vectorOf 2 contByte+ -- continuation bytes without a start byte+ , listOf1 contByte+ -- short 2-byte sequence+ , (:[]) <$> choose (0xC2, 0xDF)+ -- short 3-byte sequence+ , (:) <$> choose (0xE0, 0xEF) <*> upTo 1 contByte+ -- short 4-byte sequence+ , (:) <$> choose (0xF0, 0xF4) <*> upTo 2 contByte+ -- overlong encoding+ , do k <- choose (0,0xFFFF)+ let c = chr k+ case k of+ _ | k < 0x80 -> oneof [ let (w,x) = ord2 c in return [w,x]+ , let (w,x,y) = ord3 c in return [w,x,y]+ , let (w,x,y,z) = ord4 c in return [w,x,y,z] ]+ | k < 0x7FF -> oneof [ let (w,x,y) = ord3 c in return [w,x,y]+ , let (w,x,y,z) = ord4 c in return [w,x,y,z] ]+ | otherwise -> let (w,x,y,z) = ord4 c in return [w,x,y,z]+ ]+ where+ contByte = (0x80 +) <$> choose (0, 0x3f)+ upTo n gen = do+ k <- choose (0,n)+ vectorOf k gen++decodeLL :: BL.ByteString -> TL.Text+decodeLL = EL.decodeUtf8With E.lenientDecode++decodeL :: B.ByteString -> T.Text+decodeL = E.decodeUtf8With E.lenientDecode++-- The lenient decoding of lazy bytestrings should not depend on how they are chunked,+-- and it should behave the same as decoding of strict bytestrings.+t_decode_utf8_lenient :: Property+t_decode_utf8_lenient = forAllShrinkShow arbitrary shrink (show . BL.toChunks) $ \bs ->+ decodeLL bs === (TL.fromStrict . decodeL . B.concat . BL.toChunks) bs++-- See http://unicode.org/faq/utf_bom.html#gen8+-- A sequence such as <110xxxxx2 0xxxxxxx2> is illegal ...+-- When faced with this illegal byte sequence ... a UTF-8 conformant process+-- must treat the first byte 110xxxxx2 as an illegal termination error+-- (e.g. filter it out or replace by 0xFFFD) ...+-- ... and continue processing at the second byte 0xxxxxxx2+t_decode_with_error2 =+ E.decodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97]) === "xa"+t_decode_with_error3 =+ E.decodeUtf8With (\_ _ -> Just 'x') (B.pack [0xE0, 97, 97]) === "xaa"+t_decode_with_error4 =+ E.decodeUtf8With (\_ _ -> Just 'x') (B.pack [0xF0, 97, 97, 97]) === "xaaa"++t_decode_with_error2' =+ case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97]) of+ E.Some x _ _ -> x === "xa"+t_decode_with_error3' =+ case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97]) of+ E.Some x _ _ -> x === "xaa"+t_decode_with_error4' =+ case E.streamDecodeUtf8With (\_ _ -> Just 'x') (B.pack [0xC2, 97, 97, 97]) of+ E.Some x _ _ -> x === "xaaa"++t_infix_concat bs1 text bs2 =+ forAll (genDecodeErr Replace) $ \onErr ->+ text `T.isInfixOf`+ E.decodeUtf8With onErr (B.concat [bs1, E.encodeUtf8 text, bs2])++testTranscoding :: TestTree+testTranscoding =+ testGroup "transcoding" [+ testProperty "t_ascii" t_ascii,+ testProperty "tl_ascii" tl_ascii,+ testProperty "t_latin1" t_latin1,+ testProperty "tl_latin1" tl_latin1,+ testProperty "t_utf8" t_utf8,+ testProperty "t_utf8'" t_utf8',+ testProperty "t_utf8_incr" t_utf8_incr,+ testProperty "t_utf8_undecoded" t_utf8_undecoded,+ testProperty "tl_utf8" tl_utf8,+ testProperty "tl_utf8'" tl_utf8',+ testProperty "t_utf16LE" t_utf16LE,+ testProperty "tl_utf16LE" tl_utf16LE,+ testProperty "t_utf16BE" t_utf16BE,+ testProperty "tl_utf16BE" tl_utf16BE,+ testProperty "t_utf32LE" t_utf32LE,+ testProperty "tl_utf32LE" tl_utf32LE,+ testProperty "t_utf32BE" t_utf32BE,+ testProperty "tl_utf32BE" tl_utf32BE,+ testGroup "errors" [+ testProperty "t_utf8_err" t_utf8_err,+ testProperty "t_utf8_err'" t_utf8_err'+ ],+ testGroup "error recovery" [+ testProperty "t_decode_utf8_lenient" t_decode_utf8_lenient,+ testProperty "t_decode_with_error2" t_decode_with_error2,+ testProperty "t_decode_with_error3" t_decode_with_error3,+ testProperty "t_decode_with_error4" t_decode_with_error4,+ testProperty "t_decode_with_error2'" t_decode_with_error2',+ testProperty "t_decode_with_error3'" t_decode_with_error3',+ testProperty "t_decode_with_error4'" t_decode_with_error4',+ testProperty "t_infix_concat" t_infix_concat+ ]+ ]
tests/Tests/QuickCheckUtils.hs view
@@ -26,6 +26,7 @@ , genDecodeErr , Stringy(..)+ , unpack2 , eq , eqP @@ -34,7 +35,6 @@ , write_read ) where -import Control.Applicative ((<$>)) import Control.Arrow (first, (***)) import Control.DeepSeq (NFData (..), deepseq) import Control.Exception (bracket)@@ -49,6 +49,7 @@ import Test.QuickCheck.Unicode (string) 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@@ -58,14 +59,12 @@ import qualified Data.Text.Lazy as TL import qualified System.IO as IO -#if !MIN_VERSION_base(4,4,0)-import Data.Int (Int64)-import Data.Word (Word, Word64)-#endif- genUnicode :: IsString a => Gen a genUnicode = fromString <$> string +genWord8 :: Gen Word8+genWord8 = chooseAny+ instance Random I16 where randomR = integralRandomR random = randomR (minBound,maxBound)@@ -75,26 +74,22 @@ shrink = shrinkIntegral instance Arbitrary B.ByteString where- arbitrary = B.pack `fmap` arbitrary+ arbitrary = B.pack `fmap` listOf genWord8 shrink = map B.pack . shrink . B.unpack -#if !MIN_VERSION_base(4,4,0)-instance Random Int64 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word8 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word64 where- randomR = integralRandomR- random = randomR (minBound,maxBound)-#endif+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.@@ -246,6 +241,9 @@ 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 -> Bool
tests/Tests/Regressions.hs view
@@ -1,6 +1,9 @@ -- | Regression tests for specific bugs. ---{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Tests.Regressions ( tests@@ -8,21 +11,25 @@ import Control.Exception (SomeException, handle) import Data.Char (isLetter)+import GHC.Exts (Int(..), sizeofByteArray#) import System.IO-import Test.HUnit (assertBool, assertEqual, assertFailure)+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.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.Framework as F-import qualified Test.Framework.Providers.HUnit as F+import qualified Test.Tasty as F+import qualified Test.Tasty.HUnit as F+import System.Directory (removeFile) import Tests.Utils (withTempFile) @@ -37,12 +44,15 @@ -- encoded file can result in a crash in the RTS (i.e. not merely an -- exception). hGetContents_crash :: IO ()-hGetContents_crash = withTempFile $ \ path h -> do+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@@ -97,6 +107,18 @@ (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@@ -105,8 +127,8 @@ t301 :: IO () t301 = do assertEqual "The length of the array remains the same despite slicing"- (TA.length originalArr)- (TA.length newArr)+ (I# (sizeofByteArray# (TA.aBA originalArr)))+ (I# (sizeofByteArray# (TA.aBA newArr))) assertEqual "The new array still contains the original value" (T.Text newArr originalOff originalLen)@@ -115,7 +137,14 @@ original@(T.Text originalArr originalOff originalLen) = T.pack "1234567890" T.Text newArr _off _len = T.take 1 $ T.drop 1 original -tests :: F.Test+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]]))++tests :: F.TestTree tests = F.testGroup "Regressions" [ F.testCase "hGetContents_crash" hGetContents_crash , F.testCase "lazy_encode_crash" lazy_encode_crash@@ -125,5 +154,8 @@ , 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 ]
− tests/cabal.config
@@ -1,6 +0,0 @@--- These flags help to speed up building the test suite.--documentation: False-executable-stripping: False-flags: developer-library-profiling: False
+ tests/literal-rule-test.sh view
@@ -0,0 +1,29 @@+#!/bin/bash -e++failed=0++function check_firings() {+ rule=$1+ expected=$2+ build="ghc -O -ddump-rule-firings LiteralRuleTest.hs"+ build="$build -i.. -I../include"+ touch LiteralRuleTest.hs+ echo -n "Want to see $expected firings of rule $rule... " >&2+ firings=$($build 2>&1 | grep "Rule fired: $rule\$" | wc -l)+ rm -f LiteralRuleTest.{o.hi}++ if [ $firings != $expected ]; then+ echo "failed, saw $firings" >&2+ failed=1+ else+ echo "pass" >&2+ fi+}++check_firings "TEXT literal" 8+check_firings "TEXT literal UTF8" 7+check_firings "TEXT empty literal" 4+# This is broken at the moment. "TEXT literal" rule fires instead.+#check_firings "TEXT singleton literal" 5++exit $failed
− tests/scripts/cover-stdio.sh
@@ -1,62 +0,0 @@-#!/bin/bash--if [[ $# < 1 ]]; then- echo "Usage: $0 <exe>"- exit 1-fi--exe=$1--rm -f $exe.tix--f=$(mktemp stdio-f.XXXXXX)-g=$(mktemp stdio-g.XXXXXX)--for t in T TL; do- echo $t.readFile > $f- $exe $t.readFile $f > $g- if ! diff -u $f $g; then- errs=$((errs+1))- echo FAIL: $t.readFile 1>&2- fi-- $exe $t.writeFile $f $t.writeFile- echo -n $t.writeFile > $g- if ! diff -u $f $g; then- errs=$((errs+1))- echo FAIL: $t.writeFile 1>&2- fi-- echo -n quux > $f- $exe $t.appendFile $f $t.appendFile- echo -n quux$t.appendFile > $g- if ! diff -u $f $g; then- errs=$((errs+1))- echo FAIL: $t.appendFile 1>&2- fi-- echo $t.interact | $exe $t.interact > $f- echo $t.interact > $g- if ! diff -u $f $g; then- errs=$((errs+1))- echo FAIL: $t.interact 1>&2- fi-- echo $t.getContents | $exe $t.getContents > $f- echo $t.getContents > $g- if ! diff -u $f $g; then- errs=$((errs+1))- echo FAIL: $t.getContents 1>&2- fi-- echo $t.getLine | $exe $t.getLine > $f- echo $t.getLine > $g- if ! diff -u $f $g; then- errs=$((errs+1))- echo FAIL: $t.getLine 1>&2- fi-done--rm -f $f $g--exit $errs
− tests/text-tests.cabal
@@ -1,201 +0,0 @@-cabal-version: >= 1.10-name: text-tests-version: 1.2.4.1--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), with a powerful loop fusion optimization framework.- .- 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/).- .- == Internal Representation: UTF-16 vs. UTF-8- .- Currently the @text@ library uses UTF-16 as its internal representation- which is [neither a fixed-width nor always the most dense representation](http://utf8everywhere.org/)- for Unicode text. We're currently investigating the feasibility- of [changing Text's internal representation to UTF-8](https://github.com/text-utf8)- and if you need such a 'Text' type right now you might be interested in using the spin-off- packages <https://hackage.haskell.org/package/text-utf8 text-utf8> and- <https://hackage.haskell.org/package/text-short text-short>.---license: BSD2-license-file: LICENSE-author: Bryan O'Sullivan <bos@serpentine.com>-maintainer: Bryan O'Sullivan <bos@serpentine.com>, Herbert Valerio Riedel <hvr@gnu.org>-copyright: 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper-category: Data, Text-build-type: Simple-tested-with: GHC==8.10.2, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4,- GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4,- GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4-extra-source-files:- include/*.h--flag bytestring-builder- description:- Depend on the [bytestring-builder](https://hackage.haskell.org/package/bytestring-builder)- package for backwards compatibility.- default: False- manual: False--flag integer-simple- description:- Use the [simple integer library](http://hackage.haskell.org/package/integer-simple)- instead of [integer-gmp](http://hackage.haskell.org/package/integer-gmp)- default: False- manual: False--test-suite tests- type: exitcode-stdio-1.0- c-sources: cbits/cbits.c- include-dirs: include- hs-source-dirs: src-- ghc-options:- -Wall -threaded -rtsopts-- cpp-options:- -DASSERTS -DTEST_SUITE-- -- modules specific to test-suite- hs-source-dirs: .- main-is: Tests.hs- other-modules:- Tests.Properties- Tests.Properties.Mul- Tests.QuickCheckUtils- Tests.Regressions- Tests.SlowFunctions- Tests.Utils-- -- This can be merged back to `text` package, when cabal- -- will support per-component solving. Otherwise we have loops.- --- -- Same as in `library` stanza; this is needed by cabal for accurate- -- file-monitoring as well as to avoid `-Wmissing-home-modules`- -- warnings We can't use an inter-package library dependency because- -- of different `ghc-options`/`cpp-options` (as a side-benefitt,- -- this enables per-component build parallelism in `cabal- -- new-build`!); We could, however, use cabal-version:2.2's `common`- -- blocks at some point in the future to reduce the duplication.- other-modules:- Data.Text- Data.Text.Array- Data.Text.Encoding- Data.Text.Encoding.Error- Data.Text.Foreign- Data.Text.IO- Data.Text.Internal- 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.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.Functions- 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.Unsafe- Data.Text.Internal.Unsafe.Char- Data.Text.Internal.Unsafe.Shift- 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- Data.Text.Show-- build-depends:- HUnit >= 1.2,- QuickCheck >= 2.14.1 && < 2.15,- array,- base <5,- binary,- deepseq,- directory,- ghc-prim,- quickcheck-unicode >= 1.0.1.0,- random,- template-haskell,- test-framework >= 0.4,- test-framework-hunit >= 0.2,- test-framework-quickcheck2 >= 0.2-- if flag(bytestring-builder)- build-depends: bytestring >= 0.9 && < 0.10.4,- bytestring-builder >= 0.10.4- else- build-depends: bytestring >= 0.10.4-- if impl(ghc >= 8.11)- build-depends: ghc-bignum-- if impl(ghc < 8.11)- if flag(integer-simple)- cpp-options: -DINTEGER_SIMPLE- build-depends: integer-simple >= 0.1 && < 0.5- else- cpp-options: -DINTEGER_GMP- build-depends: integer-gmp >= 0.2-- default-language: Haskell2010- default-extensions: NondecreasingIndentation--source-repository head- type: git- location: https://github.com/haskell/text--source-repository head- type: mercurial- location: https://bitbucket.org/bos/text
text.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: text-version: 1.2.4.1+version: 1.2.5.0 homepage: https://github.com/haskell/text bug-reports: https://github.com/haskell/text/issues@@ -52,57 +52,28 @@ license: BSD2 license-file: LICENSE author: Bryan O'Sullivan <bos@serpentine.com>-maintainer: Bryan O'Sullivan <bos@serpentine.com>, Herbert Valerio Riedel <hvr@gnu.org>+maintainer: Haskell Text Team <andrew.lelechenko@gmail.com>, Core Libraries Committee copyright: 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper category: Data, Text build-type: Simple-tested-with: GHC==8.10.2, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4,- GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4,- GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4+tested-with: GHC==9.0.1,+ GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4,+ GHC==8.2.2, GHC==8.0.2 extra-source-files: -- scripts/CaseFolding.txt -- scripts/SpecialCasing.txt README.markdown- benchmarks/Setup.hs- benchmarks/cbits-bench/*.c- benchmarks/haskell/*.hs- benchmarks/haskell/Benchmarks/*.hs- benchmarks/haskell/Benchmarks/Programs/*.hs- benchmarks/python/*.py- benchmarks/ruby/*.rb- benchmarks/text-benchmarks.cabal changelog.md include/*.h scripts/*.hs- tests-and-benchmarks.markdown- tests/*.hs- tests/.ghci- tests/Makefile- tests/Tests/*.hs- tests/Tests/Properties/*.hs- tests/cabal.config- tests/scripts/*.sh- tests/text-tests.cabal--flag bytestring-builder- description:- Depend on the [bytestring-builder](https://hackage.haskell.org/package/bytestring-builder)- package for backwards compatibility.- default: False- manual: False+ tests/literal-rule-test.sh+ tests/LiteralRuleTest.hs flag developer description: operate in developer mode default: False manual: True -flag integer-simple- description:- Use the [simple integer library](http://hackage.haskell.org/package/integer-simple)- instead of [integer-gmp](http://hackage.haskell.org/package/integer-gmp)- default: False- manual: False- library c-sources: cbits/cbits.c include-dirs: include@@ -121,6 +92,7 @@ Data.Text.Internal.Builder.Int.Digits Data.Text.Internal.Builder.RealFloat.Functions Data.Text.Internal.ByteStringCompat+ Data.Text.Internal.PrimCompat Data.Text.Internal.Encoding.Fusion Data.Text.Internal.Encoding.Fusion.Common Data.Text.Internal.Encoding.Utf16@@ -159,36 +131,18 @@ build-depends: array >= 0.3 && < 0.6,- base >= 4.3 && < 4.16,+ base >= 4.9 && < 5, binary >= 0.5 && < 0.9,+ bytestring >= 0.10.4 && < 0.12, deepseq >= 1.1 && < 1.5,- ghc-prim >= 0.2 && < 0.8,- template-haskell >= 2.5 && < 2.18-- if flag(bytestring-builder)- build-depends: bytestring >= 0.9 && < 0.10.4,- bytestring-builder >= 0.10.4.0.2 && < 0.11- else- build-depends: bytestring >= 0.10.4 && < 0.12+ ghc-prim >= 0.2 && < 0.9,+ template-haskell >= 2.5 && < 2.19 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 if flag(developer)- ghc-prof-options: -auto-all- ghc-options: -Werror+ ghc-options: -fno-ignore-asserts cpp-options: -DASSERTS - if impl(ghc >= 9.0)- build-depends: ghc-bignum >= 1.0 && < 1.1-- else- if flag(integer-simple)- cpp-options: -DINTEGER_SIMPLE- build-depends: integer-simple >= 0.1 && < 0.5- else- cpp-options: -DINTEGER_GMP- build-depends: integer-gmp >= 0.2 && < 1.1-- -- compiler specification default-language: Haskell2010 default-extensions: NondecreasingIndentation@@ -204,24 +158,110 @@ Rank2Types RankNTypes RecordWildCards+ Safe ScopedTypeVariables+ TemplateHaskellQuotes+ Trustworthy TypeFamilies UnboxedTuples UnliftedFFITypes - if impl(ghc >= 7.2)- other-extensions: Trustworthy- if impl(ghc >= 7.4)- other-extensions: Safe- if impl(ghc >= 8.0)- other-extensions: TemplateHaskellQuotes- else- other-extensions: TemplateHaskell- source-repository head type: git location: https://github.com/haskell/text -source-repository head- type: mercurial- location: https://bitbucket.org/bos/text+test-suite tests+ type: exitcode-stdio-1.0+ ghc-options:+ -Wall -threaded -rtsopts++ hs-source-dirs: tests+ main-is: Tests.hs+ other-modules:+ Tests.Inspection.Lazy+ Tests.Inspection.Strict+ 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.QuickCheckUtils+ Tests.Regressions+ Tests.SlowFunctions+ Tests.Utils++ build-depends:+ QuickCheck >= 2.14.1 && < 2.15,+ base <5,+ bytestring,+ deepseq,+ directory,+ quickcheck-unicode >= 1.0.1.0,+ random,+ tasty,+ tasty-hunit,+ tasty-inspection-testing,+ tasty-quickcheck,+ template-haskell,+ text++ default-language: Haskell2010+ default-extensions: NondecreasingIndentation++benchmark text-benchmarks+ type: exitcode-stdio-1.0++ ghc-options: -Wall -O2 -rtsopts+ if impl(ghc >= 8.10)+ ghc-options: "-with-rtsopts=-A32m --nonmoving-gc"+ else+ ghc-options: "-with-rtsopts=-A32m"++ build-depends: base,+ binary,+ bytestring >= 0.10.4,+ bytestring-lexing >= 0.5.0,+ containers,+ deepseq,+ filepath,+ stringsearch,+ tasty-bench >= 0.2,+ text,+ transformers,+ vector++ c-sources: benchmarks/cbits-bench/time_iconv.c+ hs-source-dirs: benchmarks/haskell+ main-is: Benchmarks.hs+ other-modules:+ Benchmarks.Builder+ Benchmarks.Concat+ Benchmarks.DecodeUtf8+ Benchmarks.EncodeUtf8+ Benchmarks.Equality+ Benchmarks.FileRead+ Benchmarks.FoldLines+ Benchmarks.Mul+ 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