git.iko.soy/text
on master help sign in
swap
bb3d862665 ahead, 0 behind
136 files changed+8850−4837
since splitsnapshots
unifiedsplit
.gitignore+3 .hgignore+10−3 .hgtags+45 Data/Text.hs+371−177 Data/Text/Array.hs+60−110 Data/Text/Encoding.hs+316−96 Data/Text/Encoding/Error.hs+16−7 Data/Text/Encoding/Fusion/Common.hs−162 Data/Text/Foreign.hs+31−4 Data/Text/Fusion/Size.hs−146 Data/Text/IO.hs+42−38 Data/Text/Internal.hs+102−17 Data/Text/Internal/Builder.hs+329 Data/Text/Internal/Builder/Functions.hs+40 Data/Text/Internal/Builder/Int/Digits.hs+26 Data/Text/Internal/Builder/RealFloat/Functions.hs+57 Data/Text/Encoding/Fusion.hs → Data/Text/Internal/Encoding/Fusion.hs+20−16 Data/Text/Internal/Encoding/Fusion/Common.hs+123 Data/Text/Encoding/Utf16.hs → Data/Text/Internal/Encoding/Utf16.hs+8−5 Data/Text/Encoding/Utf32.hs → Data/Text/Internal/Encoding/Utf32.hs+7−4 Data/Text/Encoding/Utf8.hs → Data/Text/Internal/Encoding/Utf8.hs+15−8 Data/Text/Util.hs → Data/Text/Internal/Functions.hs+6−2 Data/Text/Fusion.hs → Data/Text/Internal/Fusion.hs+58−45 Data/Text/Fusion/CaseMapping.hs → Data/Text/Internal/Fusion/CaseMapping.hs+392−6 Data/Text/Fusion/Common.hs → Data/Text/Internal/Fusion/Common.hs+153−89 Data/Text/Internal/Fusion/Size.hs+157 Data/Text/Fusion/Internal.hs → Data/Text/Internal/Fusion/Types.hs+24−23 Data/Text/IO/Internal.hs → Data/Text/Internal/IO.hs+13−12 Data/Text/Internal/Lazy.hs+119 Data/Text/Lazy/Encoding/Fusion.hs → Data/Text/Internal/Lazy/Encoding/Fusion.hs+17−14 Data/Text/Lazy/Fusion.hs → Data/Text/Internal/Lazy/Fusion.hs+38−31 Data/Text/Lazy/Search.hs → Data/Text/Internal/Lazy/Search.hs+13−9 Data/Text/Internal/Private.hs+37 Data/Text/Internal/Read.hs+62 Data/Text/Search.hs → Data/Text/Internal/Search.hs+12−11 Data/Text/Internal/Unsafe.hs+56 Data/Text/UnsafeChar.hs → Data/Text/Internal/Unsafe/Char.hs+8−5 Data/Text/UnsafeShift.hs → Data/Text/Internal/Unsafe/Shift.hs+7−4 Data/Text/Lazy.hs+277−60 Data/Text/Lazy/Builder.hs+19−261 Data/Text/Lazy/Builder/Int.hs+262 Data/Text/Lazy/Builder/RealFloat.hs+242 Data/Text/Lazy/Encoding.hs+87−49 Data/Text/Lazy/IO.hs+12−23 Data/Text/Lazy/Internal.hs+7−105 Data/Text/Lazy/Read.hs+40−39 Data/Text/Read.hs+48−39 Data/Text/Show.hs+89 Data/Text/Unsafe.hs+19−42 README.markdown+5−5 benchmarks/.gitignore+1 benchmarks/Setup.hs+2 benchmarks/cbits/time_iconv.c+35 benchmarks/haskell/Benchmarks.hs+79 benchmarks/haskell/Benchmarks/Builder.hs+75 benchmarks/haskell/Benchmarks/DecodeUtf8.hs+67 benchmarks/haskell/Benchmarks/EncodeUtf8.hs+33 benchmarks/haskell/Benchmarks/Equality.hs+38 benchmarks/haskell/Benchmarks/FileRead.hs+33 benchmarks/haskell/Benchmarks/FoldLines.hs+58 benchmarks/haskell/Benchmarks/Mul.hs+138 benchmarks/haskell/Benchmarks/Programs/BigTable.hs+42 benchmarks/haskell/Benchmarks/Programs/Cut.hs+98 benchmarks/haskell/Benchmarks/Programs/Fold.hs+68 benchmarks/haskell/Benchmarks/Programs/Sort.hs+71 benchmarks/haskell/Benchmarks/Programs/StripTags.hs+53 benchmarks/haskell/Benchmarks/Programs/Throughput.hs+41 benchmarks/haskell/Benchmarks/Pure.hs+486 benchmarks/haskell/Benchmarks/ReadNumbers.hs+93 benchmarks/haskell/Benchmarks/Replace.hs+43 benchmarks/haskell/Benchmarks/Search.hs+48 benchmarks/haskell/Benchmarks/Stream.hs+104 benchmarks/haskell/Benchmarks/WordFrequencies.hs+36 benchmarks/haskell/Multilang.hs+32 benchmarks/haskell/Timer.hs+30 benchmarks/python/.gitignore+2 benchmarks/python/cut.py+12 benchmarks/python/multilang.py+50 benchmarks/python/sort.py+13 benchmarks/python/strip_tags.py+25 benchmarks/python/utils.py+18 benchmarks/ruby/cut.rb+16 benchmarks/ruby/fold.rb+50 benchmarks/ruby/sort.rb+15 benchmarks/ruby/strip_tags.rb+22 benchmarks/ruby/utils.rb+14 benchmarks/text-benchmarks.cabal+66 cbits/cbits.c+311 changelog.md+164 include/text_cbits.h+11 scripts/Arsec.hs+4−9 scripts/CaseFolding.hs+11−7 scripts/CaseMapping.hs+11−5 scripts/SpecialCasing.hs+13−7 tests-and-benchmarks.markdown+63 tests/.ghci+1 tests/Benchmarks.hs−463 tests/Chartem.hs−153 tests/LiteralRuleTest.hs+21 tests/Makefile+29−86 tests/Properties.hs−1228 tests/QuickCheckUtils.hs−155 tests/README−2 tests/SearchBench.hs−115 tests/TestUtils.hs−31 tests/Tests.hs+13 tests/StdioCoverage.hs → tests/Tests/IO.hs+12−3 tests/Tests/Properties.hs+1363 tests/Tests/Properties/Mul.hs+40 tests/Tests/QuickCheckUtils.hs+360 tests/Regressions.hs → tests/Tests/Regressions.hs+42−11 tests/SlowFunctions.hs → tests/Tests/SlowFunctions.hs+1−2 tests/Tests/Utils.hs+52 tests/benchmarks/CaseMap.hs−21 tests/benchmarks/Cut.hs−60 tests/benchmarks/DecodeUtf8.hs−107 tests/benchmarks/EncodeUtf8.hs−55 tests/benchmarks/Equality.hs−31 tests/benchmarks/FileIndices.hs−25 tests/benchmarks/FileRead.hs−57 tests/benchmarks/FoldLines.hs−47 tests/benchmarks/HtmlCombinator.hs−24 tests/benchmarks/Makefile−18 tests/benchmarks/Ordering.hs−42 tests/benchmarks/ReadNumbers.hs−48 tests/benchmarks/Replace.hs−23 tests/benchmarks/ReplaceTags.hs−91 tests/benchmarks/StripBrackets.hs−21 tests/benchmarks/casemap.py−15 tests/benchmarks/fileread.py−41 tests/benchmarks/fileread_c.c−96 tests/cabal.config+6 tests/literal-rule-test.sh+29 tests/cover-stdio.sh → tests/scripts/cover-stdio.sh+6−1 tests/text-tests.cabal+143 text.cabal+137−70
.gitignorenew file+3
@@ -0,0 +1,3 @@
1+dist
2+cabal-dev
3+cabal.sandbox.config
.hgignore+10−3
@@ -1,7 +1,14 @@
1−^dist$
2−^tests/benchmarks/.*\.txt$
1+^(?:dist|benchmarks/dist|tests/coverage|tests/dist)$
2+^benchmarks/.*\.txt$
3+^tests/text-testdata.tar.bz2$
34^tests/(?:\.hpc|bm|qc|qc-hpc|stdio-hpc|text/test)$
4−\.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$
5+\.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp|tix)$
56~$
7+
68syntax: glob
79.\#*
10+cabal-dev
11+cabal.sandbox.config
12+\.cabal-sandbox
13+scripts/CaseFolding.txt
14+scripts/SpecialCasing.txt
.hgtags+45
@@ -19,3 +19,48 @@ a9d582a75dea9a4417883019d5110a35e4c07265 0.11.0.2
191936b2a3aa661892ea25101199220383ba6d579abb 0.11.0.3
202006e407bcdc9a3905abf9551062ecc6f92abcdde5 0.11.0.4
212194bcf16e812f6fb49b87598673e17270f48c2bf1 0.11.0.5
22+784a32ffbec0b77adb43e9a64328db0482007309 0.11.0.6
23+c808123a3d37f25004d2aad8f3a395acfcf9122f 0.11.0.7
24+679826e742b239c5dd0c1fa4ebe98aa4bfe02a00 0.11.0.8
25+b49eebfa5673da89a23939d523c9de9edbd410b0 0.11.1.0
26+9c820a2ecaea01bc614d8e6bccf90e57431bdcbb 0.11.1.1
27+ed3a60ec627af6ba8af321009aa00224b3296e47 0.11.1.2
28+b75d3041d275e8e76b26605b0d426a572ddf1249 0.11.1.3
29+53906ad0c7e64f6c9a5df569e7cc642579aab8fc 0.11.1.5
30+9d6d3a9690ade506897c072060eb92868e229d5c 0.11.1.6
31+5ac062eace36b333566d1676979a57039a188840 0.11.1.7
32+9f01361a73071936b6ab0bdb879f1a45cca6577a 0.11.1.8
33+5dce2a934be53e74310fedffb51d7bd3e61fa993 0.11.1.9
34+9f47a2cfc9e51fd622d7553f08ad2ac1faad0438 0.11.1.10
35+9f47a2cfc9e51fd622d7553f08ad2ac1faad0438 0.11.1.10
36+407937739e9e764f1ae0f1f9ca454c42dca38772 0.11.1.10
37+8b981edd27befa4c2dd334fcb7db22ac67e22b67 0.11.1.11
38+204da16b5098531bdf858c388e2620238ef2aa5e 0.11.1.12
39+6a3d847a56a69d0514a79cb212cb218271ad0917 0.11.1.13
40+1d2c6fa9092c6a4000b2abdd9d01f3efcd477be5 0.11.2.0
41+78219784cf3652cc662805bf2971bd62d80210a9 0.11.2.1
42+4297307ebc11ad677cfba6b40319e7e5e2c0cfee 0.11.2.3
43+7fa79662b66aade97fe49394977213fe6432942e 0.11.3.0
44+d99cd091cdf71ce807a4255f6cc509c3154f51ea 0.11.3.1
45+31f57612fd425d1bb56352ce6b79e41ce6699a45 1.0.0.0
46+7cba97c86467c1881dfced68613891f3c65561b0 1.0.0.1
47+62674a9bbc83145d1d7be28a05d456ab6bb5ff89 1.1.0.0
48+68a32d80c0829da164d1e6b3acedcc3efeda0957 1.1.0.1
49+6d863daafbf0e1289ec0a0eb9b4be2a0a9cb8d3d 1.1.1.0
50+fb7299f22449750c653ac64dee4bd63c13ea6e4c 1.1.1.1
51+eb170cb533b63534d166b5fd5344b36676adf140 1.1.1.2
52+e749e05f715d02445803f653cd3d97d5395d7c6f 1.1.1.3
53+b0dff8ca1142595bab489a768ca62e6a6805aac4 1.1.1.4
54+f8a60279237c1c28e094868740d9188dd94fcc9e 1.2.0.0
55+6231451979b2d33e28038b75f2dab19c9731f5c3 1.2.0.1
56+99a3503b4ad001fc1894e90286e96d7dea1e9195 1.2.0.2
57+47f138edf15576b9adaeed64784e30811099f202 1.2.0.3
58+0b064b0c69106bbcd13cb0099e72ae5fa2347bf0 1.2.0.4
59+8bbb3e222a0037035d893f731b0a23be449f7346 1.2.0.5
60+18c7f8e19872762b7e28ee1871e72f70ea54e3cd 1.2.0.6
61+42f751b87b4a187db93f595a8166d51746ff57d4 1.2.1.0
62+78227a84740b70dcd4cf7a65f3bcf603d87e48e2 1.2.1.1
63+40f268e6735749ef36f487e1d928eaa957bb431d 1.2.1.2
64+631fd055e27fa10983e17e9ad36d1b285b85c661 1.2.1.3
65+8221a68ed5ec37028357df9c6c25f52320e54ad9 1.2.2.0
66+ce1c5ac65eb9f5580114b4e380092b05a485e95d 1.2.2.1
Data/Text.hs+371−177
@@ -1,15 +1,20 @@
1−{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
1+{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}
22{-# OPTIONS_GHC -fno-warn-orphans #-}
3+#if __GLASGOW_HASKELL__ >= 702
4+{-# LANGUAGE Trustworthy #-}
5+#endif
6+#if __GLASGOW_HASKELL__ >= 708
7+{-# LANGUAGE TypeFamilies #-}
8+#endif
39
410-- |
511-- Module : Data.Text
6−-- Copyright : (c) 2008, 2009 Tom Harper,
7−-- (c) 2009, 2010 Bryan O'Sullivan,
8−-- (c) 2009 Duncan Coutts
12+-- Copyright : (c) 2009, 2010, 2011, 2012 Bryan O'Sullivan,
13+-- (c) 2009 Duncan Coutts,
14+-- (c) 2008, 2009 Tom Harper
915--
1016-- License : BSD-style
11−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
12−-- duncan@haskell.org
17+-- Maintainer : bos@serpentine.com
1318-- Stability : experimental
1419-- Portability : GHC
1520--
@@ -27,8 +32,8 @@
2732--
2833-- To use an extended and very rich family of functions for working
2934-- with Unicode text (including normalization, regular expressions,
30−-- non-standard encodings, text breaking, and locales), see the
31−-- @text-icu@ package: <http://hackage.haskell.org/package/text-icu>
35+-- non-standard encodings, text breaking, and locales), see
36+-- <http://hackage.haskell.org/package/text-icu the text-icu package >.
3237
3338module Data.Text
3439 (
@@ -76,6 +81,7 @@ module Data.Text
7681 , toCaseFold
7782 , toLower
7883 , toUpper
84+ , toTitle
7985
8086 -- ** Justification
8187 , justifyLeft
@@ -119,8 +125,11 @@ module Data.Text
119125
120126 -- ** Breaking strings
121127 , take
128+ , takeEnd
122129 , drop
130+ , dropEnd
123131 , takeWhile
132+ , takeWhileEnd
124133 , dropWhile
125134 , dropWhileEnd
126135 , dropAround
@@ -167,92 +176,110 @@ module Data.Text
167176 , partition
168177
169178 -- , findSubstring
170−
179+
171180 -- * Indexing
172181 -- $index
173182 , index
174183 , findIndex
175184 , count
176185
177− -- * Zipping and unzipping
186+ -- * Zipping
178187 , zip
179188 , zipWith
180189
181190 -- -* Ordered text
182191 -- , sort
192+
193+ -- * Low level operations
194+ , copy
195+ , unpackCString#
183196 ) where
184197
185198import Prelude (Char, Bool(..), Int, Maybe(..), String,
186199 Eq(..), Ord(..), Ordering(..), (++),
187− Read(..), Show(..),
188− (&&), (||), (+), (-), (.), ($), ($!), (>>), (*),
189− div, maxBound, not, return, otherwise)
200+ Read(..),
201+ (&&), (||), (+), (-), (.), ($), ($!), (>>),
202+ not, return, otherwise, quot)
190203#if defined(HAVE_DEEPSEQ)
191−import Control.DeepSeq (NFData)
204+import Control.DeepSeq (NFData(rnf))
192205#endif
193206#if defined(ASSERTS)
194207import Control.Exception (assert)
195208#endif
196209import Data.Char (isSpace)
197−import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf))
198−#if __GLASGOW_HASKELL__ >= 612
199−import Data.Data (mkNoRepType)
200−#else
201−import Data.Data (mkNorepType)
202−#endif
210+import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf), constrIndex,
211+ Constr, mkConstr, DataType, mkDataType, Fixity(Prefix))
203212import Control.Monad (foldM)
213+import Control.Monad.ST (ST)
204214import qualified Data.Text.Array as A
205215import qualified Data.List as L
216+import Data.Binary (Binary(get, put))
206217import Data.Monoid (Monoid(..))
218+#if MIN_VERSION_base(4,9,0)
219+import Data.Semigroup (Semigroup(..))
220+#endif
207221import Data.String (IsString(..))
208−import qualified Data.Text.Fusion as S
209−import qualified Data.Text.Fusion.Common as S
210−import Data.Text.Fusion (stream, reverseStream, unstream)
211−import Data.Text.Internal (Text(..), empty, firstf, safe, text, textP)
222+import qualified Data.Text.Internal.Fusion as S
223+import qualified Data.Text.Internal.Fusion.Common as S
224+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
225+import Data.Text.Internal.Fusion (stream, reverseStream, unstream)
226+import Data.Text.Internal.Private (span_)
227+import Data.Text.Internal (Text(..), empty, firstf, mul, safe, text)
228+import Data.Text.Show (singleton, unpack, unpackCString#)
212229import qualified Prelude as P
213230import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter,
214− unsafeHead, unsafeTail)
215−import Data.Text.UnsafeChar (unsafeChr)
216−import qualified Data.Text.Util as U
217−import qualified Data.Text.Encoding.Utf16 as U16
218−import Data.Text.Search (indices)
231+ reverseIter_, unsafeHead, unsafeTail)
232+import Data.Text.Internal.Unsafe.Char (unsafeChr)
233+import qualified Data.Text.Internal.Functions as F
234+import qualified Data.Text.Internal.Encoding.Utf16 as U16
235+import Data.Text.Internal.Search (indices)
219236#if defined(__HADDOCK__)
220237import Data.ByteString (ByteString)
221238import qualified Data.Text.Lazy as L
222239import Data.Int (Int64)
223240#endif
241+import GHC.Base (eqInt, neInt, gtInt, geInt, ltInt, leInt)
242+#if __GLASGOW_HASKELL__ >= 708
243+import qualified GHC.Exts as Exts
244+#endif
245+#if MIN_VERSION_base(4,7,0)
246+import Text.Printf (PrintfArg, formatArg, formatString)
247+#endif
224248
225249-- $strict
226250--
227251-- This package provides both strict and lazy 'Text' types. The
228−-- strict type is provided by the 'Data.Text' package, while the lazy
229−-- type is provided by the 'Data.Text.Lazy' package. Internally, the
252+-- strict type is provided by the "Data.Text" module, while the lazy
253+-- type is provided by the "Data.Text.Lazy" module. Internally, the
230254-- lazy @Text@ type consists of a list of strict chunks.
231255--
232256-- The strict 'Text' type requires that an entire string fit into
233−-- memory at once. The lazy @Text@ type is capable of streaming
234−-- strings that are larger than memory using a small memory footprint.
235−-- In many cases, the overhead of chunked streaming makes the lazy
236−-- @Text@ type slower than its strict counterpart, but this is not
237−-- always the case. Sometimes, the time complexity of a function in
238−-- one module may be different from the other, due to their differing
239−-- internal structures.
257+-- memory at once. The lazy 'Data.Text.Lazy.Text' type is capable of
258+-- streaming strings that are larger than memory using a small memory
259+-- footprint. In many cases, the overhead of chunked streaming makes
260+-- the lazy 'Data.Text.Lazy.Text' type slower than its strict
261+-- counterpart, but this is not always the case. Sometimes, the time
262+-- complexity of a function in one module may be different from the
263+-- other, due to their differing internal structures.
240264--
241265-- Each module provides an almost identical API, with the main
242266-- difference being that the strict module uses 'Int' values for
243−-- lengths and counts, while the lazy module uses 'Int64' lengths.
267+-- lengths and counts, while the lazy module uses 'Data.Int.Int64'
268+-- lengths.
244269
245270-- $replacement
246271--
247272-- A 'Text' value is a sequence of Unicode scalar values, as defined
248−-- in &#xa7;3.9, definition D76 of the Unicode 5.2 standard:
249−-- <http://www.unicode.org/versions/Unicode5.2.0/ch03.pdf#page=35>. As
250−-- such, a 'Text' cannot contain values in the range U+D800 to U+DFFF
251−-- inclusive. Haskell implementations admit all Unicode code points
252−-- (&#xa7;3.4, definition D10) as 'Char' values, including code points
253−-- from this invalid range. This means that there are some 'Char'
254−-- values that are not valid Unicode scalar values, and the functions
255−-- in this module must handle those cases.
273+-- in
274+-- <http://www.unicode.org/versions/Unicode5.2.0/ch03.pdf#page=35 §3.9, definition D76 of the Unicode 5.2 standard >.
275+-- As such, a 'Text' cannot contain values in the range U+D800 to
276+-- U+DFFF inclusive. Haskell implementations admit all Unicode code
277+-- points
278+-- (<http://www.unicode.org/versions/Unicode5.2.0/ch03.pdf#page=13 §3.4, definition D10 >)
279+-- as 'Char' values, including code points from this invalid range.
280+-- This means that there are some 'Char' values that are not valid
281+-- Unicode scalar values, and the functions in this module must handle
282+-- those cases.
256283--
257284-- Within this module, many functions construct a 'Text' from one or
258285-- more 'Char' values. Those functions will substitute 'Char' values
@@ -266,8 +293,8 @@ import Data.Int (Int64)
266293-- range U+D800 through U+DFFF are used by UTF-16 to denote surrogate
267294-- code points, and so cannot be represented. The functions replace
268295-- invalid scalar values, instead of dropping them, as a security
269−-- measure. For details, see Unicode Technical Report 36, &#xa7;3.5:
270−-- <http://unicode.org/reports/tr36/#Deletion_of_Noncharacters>)
296+-- measure. For details, see
297+-- <http://unicode.org/reports/tr36/#Deletion_of_Noncharacters Unicode Technical Report 36, §3.5 >.)
271298
272299-- $fusion
273300--
@@ -285,11 +312,11 @@ import Data.Int (Int64)
285312-- > countChars = T.length . T.toUpper . E.decodeUtf8
286313--
287314-- From the type signatures involved, this looks like it should
288−-- allocate one 'ByteString' value, and two 'Text' values. However,
289−-- when a module is compiled with optimisation enabled under GHC, the
290−-- two intermediate 'Text' values will be optimised away, and the
291−-- function will be compiled down to a single loop over the source
292−-- 'ByteString'.
315+-- allocate one 'Data.ByteString.ByteString' value, and two 'Text'
316+-- values. However, when a module is compiled with optimisation
317+-- enabled under GHC, the two intermediate 'Text' values will be
318+-- optimised away, and the function will be compiled down to a single
319+-- loop over the source 'Data.ByteString.ByteString'.
293320--
294321-- Functions that can be fused by the compiler are documented with the
295322-- phrase \"Subject to fusion\".
@@ -303,46 +330,83 @@ instance Eq Text where
303330instance Ord Text where
304331 compare = compareText
305332
306−instance Show Text where
307− showsPrec p ps r = showsPrec p (unpack ps) r
308−
309333instance Read Text where
310334 readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
311335
336+#if MIN_VERSION_base(4,9,0)
337+-- Semigroup orphan instances for older GHCs are provided by
338+-- 'semigroups` package
339+
340+instance Semigroup Text where
341+ (<>) = append
342+#endif
343+
312344instance Monoid Text where
313345 mempty = empty
346+#if MIN_VERSION_base(4,9,0)
347+ mappend = (<>) -- future-proof definition
348+#else
314349 mappend = append
350+#endif
315351 mconcat = concat
316352
317353instance IsString Text where
318354 fromString = pack
319355
356+#if __GLASGOW_HASKELL__ >= 708
357+instance Exts.IsList Text where
358+ type Item Text = Char
359+ fromList = pack
360+ toList = unpack
361+#endif
362+
320363#if defined(HAVE_DEEPSEQ)
321−instance NFData Text
364+instance NFData Text where rnf !_ = ()
322365#endif
323366
324−-- This instance preserves data abstraction at the cost of inefficiency.
367+instance Binary Text where
368+ put t = put (encodeUtf8 t)
369+ get = do
370+ bs <- get
371+ case decodeUtf8' bs of
372+ P.Left exn -> P.fail (P.show exn)
373+ P.Right a -> P.return a
374+
375+-- | This instance preserves data abstraction at the cost of inefficiency.
325376-- We omit reflection services for the sake of data abstraction.
326−--
327−-- This instance was created by copying the behavior of Data.Set and
328−-- Data.Map. If you feel a mistake has been made, please feel free to
329−-- submit improvements.
330377--
331−-- Original discussion is archived here:
332−
333−-- "could we get a Data instance for Data.Text.Text?"
334−-- http://groups.google.com/group/haskell-cafe/browse_thread/thread/b5bbb1b28a7e525d/0639d46852575b93
378+-- This instance was created by copying the updated behavior of
379+-- @"Data.Set".@'Data.Set.Set' and @"Data.Map".@'Data.Map.Map'. If you
380+-- feel a mistake has been made, please feel free to submit
381+-- improvements.
382+--
383+-- The original discussion is archived here:
384+-- <http://groups.google.com/group/haskell-cafe/browse_thread/thread/b5bbb1b28a7e525d/0639d46852575b93 could we get a Data instance for Data.Text.Text? >
385+--
386+-- The followup discussion that changed the behavior of 'Data.Set.Set'
387+-- and 'Data.Map.Map' is archived here:
388+-- <http://markmail.org/message/trovdc6zkphyi3cr#query:+page:1+mid:a46der3iacwjcf6n+state:results Proposal: Allow gunfold for Data.Map, ... >
335389
336390instance Data Text where
337391 gfoldl f z txt = z pack `f` (unpack txt)
338− toConstr _ = P.error "Data.Text.Text.toConstr"
339− gunfold _ _ = P.error "Data.Text.Text.gunfold"
340−#if __GLASGOW_HASKELL__ >= 612
341− dataTypeOf _ = mkNoRepType "Data.Text.Text"
342−#else
343− dataTypeOf _ = mkNorepType "Data.Text.Text"
392+ toConstr _ = packConstr
393+ gunfold k z c = case constrIndex c of
394+ 1 -> k (z pack)
395+ _ -> P.error "gunfold"
396+ dataTypeOf _ = textDataType
397+
398+#if MIN_VERSION_base(4,7,0)
399+-- | Only defined for @base-4.7.0.0@ and later
400+instance PrintfArg Text where
401+ formatArg txt = formatString $ unpack txt
344402#endif
345403
404+packConstr :: Constr
405+packConstr = mkConstr textDataType "pack" [] Prefix
406+
407+textDataType :: DataType
408+textDataType = mkDataType "Data.Text.Text" [packConstr]
409+
346410-- | /O(n)/ Compare two 'Text' values lexicographically.
347411compareText :: Text -> Text -> Ordering
348412compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
@@ -363,20 +427,9 @@ compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
363427-- | /O(n)/ Convert a 'String' into a 'Text'. Subject to
364428-- fusion. Performs replacement on invalid scalar values.
365429pack :: String -> Text
366−pack = unstream . S.streamList . L.map safe
430+pack = unstream . S.map safe . S.streamList
367431{-# INLINE [1] pack #-}
368432
369−-- | /O(n)/ Convert a Text into a String. Subject to fusion.
370−unpack :: Text -> String
371−unpack = S.unstreamList . stream
372−{-# INLINE [1] unpack #-}
373−
374−-- | /O(1)/ Convert a character into a Text. Subject to fusion.
375−-- Performs replacement on invalid scalar values.
376−singleton :: Char -> Text
377−singleton = unstream . S.singleton . safe
378−{-# INLINE [1] singleton #-}
379−
380433-- -----------------------------------------------------------------------------
381434-- * Basic functions
382435
@@ -407,12 +460,13 @@ append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2)
407460 | otherwise = overflowError "append"
408461 where
409462 len = len1+len2
463+ x :: ST s (A.MArray s)
410464 x = do
411465 arr <- A.new len
412466 A.copyI arr 0 arr1 off1 len1
413467 A.copyI arr len1 arr2 off2 len
414468 return arr
415−{-# INLINE append #-}
469+{-# NOINLINE append #-}
416470
417471{-# RULES
418472"TEXT append -> fused" [~1] forall t1 t2.
@@ -432,8 +486,8 @@ head t = S.head (stream t)
432486uncons :: Text -> Maybe (Char, Text)
433487uncons t@(Text arr off len)
434488 | len <= 0 = Nothing
435− | otherwise = Just (c, textP arr (off+d) (len-d))
436− where Iter c d = iter t 0
489+ | otherwise = Just $ let !(Iter c d) = iter t 0
490+ in (c, text arr (off+d) (len-d))
437491{-# INLINE [1] uncons #-}
438492
439493-- | Lifted from Control.Arrow and specialized.
@@ -463,7 +517,7 @@ last (Text arr off len)
463517tail :: Text -> Text
464518tail t@(Text arr off len)
465519 | len <= 0 = emptyError "tail"
466− | otherwise = textP arr (off+d) (len-d)
520+ | otherwise = text arr (off+d) (len-d)
467521 where d = iter_ t 0
468522{-# INLINE [1] tail #-}
469523
@@ -478,8 +532,8 @@ tail t@(Text arr off len)
478532-- be non-empty. Subject to fusion.
479533init :: Text -> Text
480534init (Text arr off len) | len <= 0 = emptyError "init"
481− | n >= 0xDC00 && n <= 0xDFFF = textP arr off (len-2)
482− | otherwise = textP arr off (len-1)
535+ | n >= 0xDC00 && n <= 0xDFFF = text arr off (len-2)
536+ | otherwise = text arr off (len-1)
483537 where
484538 n = A.unsafeIndex arr (off+len-1)
485539{-# INLINE [1] init #-}
@@ -518,7 +572,9 @@ isSingleton = S.isSingleton . stream
518572-- Subject to fusion.
519573length :: Text -> Int
520574length t = S.length (stream t)
521−{-# INLINE length #-}
575+{-# INLINE [0] length #-}
576+-- length needs to be phased after the compareN/length rules otherwise
577+-- it may inline before the rules have an opportunity to fire.
522578
523579-- | /O(n)/ Compare the count of characters in a 'Text' to a number.
524580-- Subject to fusion.
@@ -537,32 +593,32 @@ compareLength t n = S.compareLengthI (stream t) n
537593
538594{-# RULES
539595"TEXT ==N/length -> compareLength/==EQ" [~1] forall t n.
540− (==) (length t) n = compareLength t n == EQ
596+ eqInt (length t) n = compareLength t n == EQ
541597 #-}
542598
543599{-# RULES
544600"TEXT /=N/length -> compareLength//=EQ" [~1] forall t n.
545− (/=) (length t) n = compareLength t n /= EQ
601+ neInt (length t) n = compareLength t n /= EQ
546602 #-}
547603
548604{-# RULES
549605"TEXT <N/length -> compareLength/==LT" [~1] forall t n.
550− (<) (length t) n = compareLength t n == LT
606+ ltInt (length t) n = compareLength t n == LT
551607 #-}
552608
553609{-# RULES
554610"TEXT <=N/length -> compareLength//=GT" [~1] forall t n.
555− (<=) (length t) n = compareLength t n /= GT
611+ leInt (length t) n = compareLength t n /= GT
556612 #-}
557613
558614{-# RULES
559615"TEXT >N/length -> compareLength/==GT" [~1] forall t n.
560− (>) (length t) n = compareLength t n == GT
616+ gtInt (length t) n = compareLength t n == GT
561617 #-}
562618
563619{-# RULES
564620"TEXT >=N/length -> compareLength//=LT" [~1] forall t n.
565− (>=) (length t) n = compareLength t n /= LT
621+ geInt (length t) n = compareLength t n /= LT
566622 #-}
567623
568624-- -----------------------------------------------------------------------------
@@ -578,7 +634,7 @@ map f t = unstream (S.map (safe . f) (stream t))
578634-- 'Text's and concatenates the list after interspersing the first
579635-- argument between each element of the list.
580636intercalate :: Text -> [Text] -> Text
581−intercalate t = concat . (U.intersperse t)
637+intercalate t = concat . (F.intersperse t)
582638{-# INLINE intercalate #-}
583639
584640-- | /O(n)/ The 'intersperse' function takes a character and places it
@@ -593,16 +649,59 @@ reverse :: Text -> Text
593649reverse t = S.reverse (stream t)
594650{-# INLINE reverse #-}
595651
596−-- | /O(m+n)/ Replace every occurrence of one substring with another.
652+-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
653+-- @haystack@ with @replacement@.
654+--
655+-- This function behaves as though it was defined as follows:
656+--
657+-- @
658+-- replace needle replacement haystack =
659+-- 'intercalate' replacement ('splitOn' needle haystack)
660+-- @
661+--
662+-- As this suggests, each occurrence is replaced exactly once. So if
663+-- @needle@ occurs in @replacement@, that occurrence will /not/ itself
664+-- be replaced recursively:
665+--
666+-- > replace "oo" "foo" "oo" == "foo"
667+--
668+-- In cases where several instances of @needle@ overlap, only the
669+-- first one will be replaced:
670+--
671+-- > replace "ofo" "bar" "ofofo" == "barfo"
597672--
598673-- In (unlikely) bad cases, this function's time complexity degrades
599674-- towards /O(n*m)/.
600−replace :: Text -- ^ Text to search for
601− -> Text -- ^ Replacement text
602− -> Text -- ^ Input text
675+replace :: Text
676+ -- ^ @needle@ to search for. If this string is empty, an
677+ -- error will occur.
678+ -> Text
679+ -- ^ @replacement@ to replace @needle@ with.
680+ -> Text
681+ -- ^ @haystack@ in which to search.
603682 -> Text
604−replace s d = intercalate d . splitOn s
605−{-# INLINE replace #-}
683+replace needle@(Text _ _ neeLen)
684+ (Text repArr repOff repLen)
685+ haystack@(Text hayArr hayOff hayLen)
686+ | neeLen == 0 = emptyError "replace"
687+ | L.null ixs = haystack
688+ | len > 0 = Text (A.run x) 0 len
689+ | otherwise = empty
690+ where
691+ ixs = indices needle haystack
692+ len = hayLen - (neeLen - repLen) `mul` L.length ixs
693+ x :: ST s (A.MArray s)
694+ x = do
695+ marr <- A.new len
696+ let loop (i:is) o d = do
697+ let d0 = d + i - o
698+ d1 = d0 + repLen
699+ A.copyI marr d hayArr (hayOff+o) d0
700+ A.copyI marr d0 repArr repOff d1
701+ loop is (i + neeLen) d1
702+ loop [] o d = A.copyI marr d hayArr (hayOff+o) len
703+ loop ixs 0 0
704+ return marr
606705
607706-- ----------------------------------------------------------------------------
608707-- ** Case conversions (folds)
@@ -621,13 +720,13 @@ replace s d = intercalate d . splitOn s
621720-- /Note/: In some languages, case conversion is a locale- and
622721-- context-dependent operation. The case conversion functions in this
623722-- module are /not/ locale sensitive. Programs that require locale
624−-- sensitivity should use appropriate versions of the case mapping
625−-- functions from the @text-icu@ package:
626−-- <http://hackage.haskell.org/package/text-icu>
723+-- sensitivity should use appropriate versions of the
724+-- <http://hackage.haskell.org/package/text-icu-0.6.3.7/docs/Data-Text-ICU.html#g:4 case mapping functions from the text-icu package >.
627725
628−-- | /O(n)/ Convert a string to folded case. This function is mainly
629−-- useful for performing caseless (also known as case insensitive)
630−-- string comparisons.
726+-- | /O(n)/ Convert a string to folded case. Subject to fusion.
727+--
728+-- This function is mainly useful for performing caseless (also known
729+-- as case insensitive) string comparisons.
631730--
632731-- A string @x@ is a caseless match for a string @y@ if and only if:
633732--
@@ -642,25 +741,51 @@ replace s d = intercalate d . splitOn s
642741-- instead of itself.
643742toCaseFold :: Text -> Text
644743toCaseFold t = unstream (S.toCaseFold (stream t))
645−{-# INLINE [0] toCaseFold #-}
744+{-# INLINE toCaseFold #-}
646745
647746-- | /O(n)/ Convert a string to lower case, using simple case
648−-- conversion. The result string may be longer than the input string.
649−-- For instance, \"&#x130;\" (Latin capital letter I with dot above,
650−-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069) followed
651−-- by \" &#x307;\" (combining dot above, U+0307).
747+-- conversion. Subject to fusion.
748+--
749+-- The result string may be longer than the input string. For
750+-- instance, \"&#x130;\" (Latin capital letter I with dot above,
751+-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
752+-- followed by \" &#x307;\" (combining dot above, U+0307).
652753toLower :: Text -> Text
653754toLower t = unstream (S.toLower (stream t))
654755{-# INLINE toLower #-}
655756
656757-- | /O(n)/ Convert a string to upper case, using simple case
657−-- conversion. The result string may be longer than the input string.
658−-- For instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
758+-- conversion. Subject to fusion.
759+--
760+-- The result string may be longer than the input string. For
761+-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
659762-- two-letter sequence \"SS\".
660763toUpper :: Text -> Text
661764toUpper t = unstream (S.toUpper (stream t))
662765{-# INLINE toUpper #-}
663766
767+-- | /O(n)/ Convert a string to title case, using simple case
768+-- conversion. Subject to fusion.
769+--
770+-- The first letter of the input is converted to title case, as is
771+-- every subsequent letter that immediately follows a non-letter.
772+-- Every letter that immediately follows another letter is converted
773+-- to lower case.
774+--
775+-- The result string may be longer than the input string. For example,
776+-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
777+-- sequence Latin capital letter F (U+0046) followed by Latin small
778+-- letter l (U+006C).
779+--
780+-- /Note/: this function does not take language or culture specific
781+-- rules into account. For instance, in English, different style
782+-- guides disagree on whether the book name \"The Hill of the Red
783+-- Fox\" is correctly title cased&#x2014;but this function will
784+-- capitalize /every/ word.
785+toTitle :: Text -> Text
786+toTitle t = unstream (S.toTitle (stream t))
787+{-# INLINE toTitle #-}
788+
664789-- | /O(n)/ Left-justify a string to the given length, using the
665790-- specified fill character on the right. Subject to fusion.
666791-- Performs replacement on invalid scalar values.
@@ -711,7 +836,7 @@ center k c t
711836 | otherwise = replicateChar l c `append` t `append` replicateChar r c
712837 where len = length t
713838 d = k - len
714− r = d `div` 2
839+ r = d `quot` 2
715840 l = d - r
716841{-# INLINE center #-}
717842
@@ -758,7 +883,7 @@ foldr f z t = S.foldr f z (stream t)
758883{-# INLINE foldr #-}
759884
760885-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
761−-- and thust must be applied to a non-empty 'Text'. Subject to
886+-- and thus must be applied to a non-empty 'Text'. Subject to
762887-- fusion.
763888foldr1 :: (Char -> Char -> Char) -> Text -> Char
764889foldr1 f t = S.foldr1 f (stream t)
@@ -776,6 +901,7 @@ concat ts = case ts' of
776901 where
777902 ts' = L.filter (not . null) ts
778903 len = sumP "concat" $ L.map lengthWord16 ts'
904+ go :: ST s (A.MArray s)
779905 go = do
780906 arr <- A.new len
781907 let step i (Text a o l) =
@@ -789,13 +915,13 @@ concatMap f = concat . foldr ((:) . f) []
789915{-# INLINE concatMap #-}
790916
791917-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
792−-- 'Text' @t@ satisifes the predicate @p@. Subject to fusion.
918+-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
793919any :: (Char -> Bool) -> Text -> Bool
794920any p t = S.any p (stream t)
795921{-# INLINE any #-}
796922
797923-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
798−-- 'Text' @t@ satisify the predicate @p@. Subject to fusion.
924+-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
799925all :: (Char -> Bool) -> Text -> Bool
800926all p t = S.all p (stream t)
801927{-# INLINE all #-}
@@ -883,13 +1009,13 @@ mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
8831009-- @t@ repeated @n@ times.
8841010replicate :: Int -> Text -> Text
8851011replicate n t@(Text a o l)
886− | n <= 0 || l <= 0 = empty
887− | n == 1 = t
888− | isSingleton t = replicateChar n (unsafeHead t)
889− | n <= maxBound `div` l = Text (A.run x) 0 len
890− | otherwise = overflowError "replicate"
1012+ | n <= 0 || l <= 0 = empty
1013+ | n == 1 = t
1014+ | isSingleton t = replicateChar n (unsafeHead t)
1015+ | otherwise = Text (A.run x) 0 len
8911016 where
892− len = l * n
1017+ len = l `mul` n
1018+ x :: ST s (A.MArray s)
8931019 x = do
8941020 arr <- A.new len
8951021 let loop !d !i | i >= n = return arr
@@ -940,14 +1066,16 @@ take :: Int -> Text -> Text
9401066take n t@(Text arr off len)
9411067 | n <= 0 = empty
9421068 | n >= len = t
943− | otherwise = Text arr off (loop 0 0)
944− where
945− loop !i !cnt
946− | i >= len || cnt >= n = i
947− | otherwise = loop (i+d) (cnt+1)
948− where d = iter_ t i
1069+ | otherwise = text arr off (iterN n t)
9491070{-# INLINE [1] take #-}
9501071
1072+iterN :: Int -> Text -> Int
1073+iterN n t@(Text _arr _off len) = loop 0 0
1074+ where loop !i !cnt
1075+ | i >= len || cnt >= n = i
1076+ | otherwise = loop (i+d) (cnt+1)
1077+ where d = iter_ t i
1078+
9511079{-# RULES
9521080"TEXT take -> fused" [~1] forall n t.
9531081 take n t = unstream (S.take n (stream t))
@@ -955,6 +1083,27 @@ take n t@(Text arr off len)
9551083 unstream (S.take n (stream t)) = take n t
9561084 #-}
9571085
1086+-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
1087+-- taking @n@ characters from the end of @t@.
1088+--
1089+-- Examples:
1090+--
1091+-- > takeEnd 3 "foobar" == "bar"
1092+takeEnd :: Int -> Text -> Text
1093+takeEnd n t@(Text arr off len)
1094+ | n <= 0 = empty
1095+ | n >= len = t
1096+ | otherwise = text arr (off+i) (len-i)
1097+ where i = iterNEnd n t
1098+
1099+iterNEnd :: Int -> Text -> Int
1100+iterNEnd n t@(Text _arr _off len) = loop (len-1) n
1101+ where loop i !m
1102+ | i <= 0 = 0
1103+ | m <= 1 = i
1104+ | otherwise = loop (i+d) (m-1)
1105+ where d = reverseIter_ t i
1106+
9581107-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
9591108-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
9601109-- is greater than the length of the 'Text'. Subject to fusion.
@@ -962,11 +1111,8 @@ drop :: Int -> Text -> Text
9621111drop n t@(Text arr off len)
9631112 | n <= 0 = t
9641113 | n >= len = empty
965− | otherwise = loop 0 0
966− where loop !i !cnt
967− | i >= len || cnt >= n = Text arr (off+i) (len-i)
968− | otherwise = loop (i+d) (cnt+1)
969− where d = iter_ t i
1114+ | otherwise = text arr (off+i) (len-i)
1115+ where i = iterN n t
9701116{-# INLINE [1] drop #-}
9711117
9721118{-# RULES
@@ -976,6 +1122,18 @@ drop n t@(Text arr off len)
9761122 unstream (S.drop n (stream t)) = drop n t
9771123 #-}
9781124
1125+-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
1126+-- dropping @n@ characters from the end of @t@.
1127+--
1128+-- Examples:
1129+--
1130+-- > dropEnd 3 "foobar" == "foo"
1131+dropEnd :: Int -> Text -> Text
1132+dropEnd n t@(Text arr off len)
1133+ | n <= 0 = t
1134+ | n >= len = empty
1135+ | otherwise = text arr off (iterNEnd n t)
1136+
9791137-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
9801138-- returns the longest prefix (possibly empty) of elements that
9811139-- satisfy @p@. Subject to fusion.
@@ -983,7 +1141,7 @@ takeWhile :: (Char -> Bool) -> Text -> Text
9831141takeWhile p t@(Text arr off len) = loop 0
9841142 where loop !i | i >= len = t
9851143 | p c = loop (i+d)
986− | otherwise = textP arr off i
1144+ | otherwise = text arr off i
9871145 where Iter c d = iter t i
9881146{-# INLINE [1] takeWhile #-}
9891147
@@ -994,6 +1152,27 @@ takeWhile p t@(Text arr off len) = loop 0
9941152 unstream (S.takeWhile p (stream t)) = takeWhile p t
9951153 #-}
9961154
1155+-- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text',
1156+-- returns the longest suffix (possibly empty) of elements that
1157+-- satisfy @p@. Subject to fusion.
1158+-- Examples:
1159+--
1160+-- > takeWhileEnd (=='o') "foo" == "oo"
1161+takeWhileEnd :: (Char -> Bool) -> Text -> Text
1162+takeWhileEnd p t@(Text arr off len) = loop (len-1) len
1163+ where loop !i !l | l <= 0 = t
1164+ | p c = loop (i+d) (l+d)
1165+ | otherwise = text arr (off+l) (len-l)
1166+ where (c,d) = reverseIter t i
1167+{-# INLINE [1] takeWhileEnd #-}
1168+
1169+{-# RULES
1170+"TEXT takeWhileEnd -> fused" [~1] forall p t.
1171+ takeWhileEnd p t = S.reverse (S.takeWhile p (S.reverseStream t))
1172+"TEXT takeWhileEnd -> unfused" [1] forall p t.
1173+ S.reverse (S.takeWhile p (S.reverseStream t)) = takeWhileEnd p t
1174+ #-}
1175+
9971176-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
9981177-- 'takeWhile' @p@ @t@. Subject to fusion.
9991178dropWhile :: (Char -> Bool) -> Text -> Text
@@ -1012,8 +1191,9 @@ dropWhile p t@(Text arr off len) = loop 0 0
10121191 #-}
10131192
10141193-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
1015−-- dropping characters that fail the predicate @p@ from the end of
1194+-- dropping characters that satisfy the predicate @p@ from the end of
10161195-- @t@. Subject to fusion.
1196+--
10171197-- Examples:
10181198--
10191199-- > dropWhileEnd (=='.') "foo..." == "foo"
@@ -1033,7 +1213,7 @@ dropWhileEnd p t@(Text arr off len) = loop (len-1) len
10331213 #-}
10341214
10351215-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
1036−-- dropping characters that fail the predicate @p@ from both the
1216+-- dropping characters that satisfy the predicate @p@ from both the
10371217-- beginning and end of @t@. Subject to fusion.
10381218dropAround :: (Char -> Bool) -> Text -> Text
10391219dropAround p = dropWhile p . dropWhileEnd p
@@ -1068,24 +1248,16 @@ splitAt :: Int -> Text -> (Text, Text)
10681248splitAt n t@(Text arr off len)
10691249 | n <= 0 = (empty, t)
10701250 | n >= len = (t, empty)
1071− | otherwise = (Text arr off k, Text arr (off+k) (len-k))
1072− where k = loop 0 0
1073− loop !i !cnt
1074− | i >= len || cnt >= n = i
1075− | otherwise = loop (i+d) (cnt+1)
1076− where d = iter_ t i
1077−{-# INLINE splitAt #-}
1251+ | otherwise = let k = iterN n t
1252+ in (text arr off k, text arr (off+k) (len-k))
10781253
10791254-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
10801255-- a pair whose first element is the longest prefix (possibly empty)
10811256-- of @t@ of elements that satisfy @p@, and whose second is the
10821257-- remainder of the list.
10831258span :: (Char -> Bool) -> Text -> (Text, Text)
1084−span p t@(Text arr off len) = (textP arr off k, textP arr (off+k) (len-k))
1085− where k = loop 0
1086− loop !i | i >= len || not (p c) = i
1087− | otherwise = loop (i+d)
1088− where Iter c d = iter t i
1259+span p t = case span_ p t of
1260+ (# hd,tl #) -> (hd,tl)
10891261{-# INLINE span #-}
10901262
10911263-- | /O(n)/ 'break' is like 'span', but the prefix returned is
@@ -1112,7 +1284,7 @@ findAIndexOrEnd q t@(Text _arr _off len) = go 0
11121284 where go !i | i >= len || q c = i
11131285 | otherwise = go (i+d)
11141286 where Iter c d = iter t i
1115−
1287+
11161288-- | /O(n)/ Group characters in a string by equality.
11171289group :: Text -> [Text]
11181290group = groupBy (==)
@@ -1136,31 +1308,38 @@ tails t | null t = [empty]
11361308-- copies to create substrings; they just construct new 'Text's that
11371309-- are slices of the original.
11381310
1139−-- | /O(m+n)/ Break a 'Text' into pieces separated by the first
1140−-- 'Text' argument, consuming the delimiter. An empty delimiter is
1141−-- invalid, and will cause an error to be raised.
1311+-- | /O(m+n)/ Break a 'Text' into pieces separated by the first 'Text'
1312+-- argument (which cannot be empty), consuming the delimiter. An empty
1313+-- delimiter is invalid, and will cause an error to be raised.
11421314--
11431315-- Examples:
11441316--
11451317-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
11461318-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
11471319-- > splitOn "x" "x" == ["",""]
1148−--
1320+--
11491321-- and
11501322--
11511323-- > intercalate s . splitOn s == id
11521324-- > splitOn (singleton c) == split (==c)
11531325--
1326+-- (Note: the string @s@ to split on above cannot be empty.)
1327+--
11541328-- In (unlikely) bad cases, this function's time complexity degrades
11551329-- towards /O(n*m)/.
1156−splitOn :: Text -> Text -> [Text]
1330+splitOn :: Text
1331+ -- ^ String to split on. If this string is empty, an error
1332+ -- will occur.
1333+ -> Text
1334+ -- ^ Input text.
1335+ -> [Text]
11571336splitOn pat@(Text _ _ l) src@(Text arr off len)
11581337 | l <= 0 = emptyError "splitOn"
11591338 | isSingleton pat = split (== unsafeHead pat) src
11601339 | otherwise = go 0 (indices pat src)
11611340 where
1162− go !s (x:xs) = textP arr (s+off) (x-s) : go (x+l) xs
1163− go s _ = [textP arr (s+off) (len-s)]
1341+ go !s (x:xs) = text arr (s+off) (x-s) : go (x+l) xs
1342+ go s _ = [text arr (s+off) (len-s)]
11641343{-# INLINE [1] splitOn #-}
11651344
11661345{-# RULES
@@ -1180,7 +1359,7 @@ split _ t@(Text _off _arr 0) = [t]
11801359split p t = loop t
11811360 where loop s | null s' = [l]
11821361 | otherwise = l : loop (unsafeTail s')
1183− where (l, s') = break p s
1362+ where (# l, s' #) = span_ (not . p) s
11841363{-# INLINE split #-}
11851364
11861365-- | /O(n)/ Splits a 'Text' into components of length @k@. The last
@@ -1252,7 +1431,7 @@ breakOn pat src@(Text arr off len)
12521431 | null pat = emptyError "breakOn"
12531432 | otherwise = case indices pat src of
12541433 [] -> (src, empty)
1255− (x:_) -> (textP arr off x, textP arr (off+x) (len-x))
1434+ (x:_) -> (text arr off x, text arr (off+x) (len-x))
12561435{-# INLINE breakOn #-}
12571436
12581437-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
@@ -1277,9 +1456,9 @@ breakOnEnd pat src = (reverse b, reverse a)
12771456--
12781457-- Examples:
12791458--
1280−-- > find "::" ""
1459+-- > breakOnAll "::" ""
12811460-- > ==> []
1282−-- > find "/" "a/b/c/"
1461+-- > breakOnAll "/" "a/b/c/"
12831462-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
12841463--
12851464-- In (unlikely) bad cases, this function's time complexity degrades
@@ -1294,7 +1473,7 @@ breakOnAll pat src@(Text arr off slen)
12941473 | otherwise = L.map step (indices pat src)
12951474 where
12961475 step x = (chunk 0 x, chunk x (slen-x))
1297− chunk !n !l = textP arr (n+off) l
1476+ chunk !n !l = text arr (n+off) l
12981477{-# INLINE breakOnAll #-}
12991478
13001479-------------------------------------------------------------------------------
@@ -1314,7 +1493,7 @@ breakOnAll pat src@(Text arr off slen)
13141493-- For example, suppose you have a string that you want to split on
13151494-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of
13161495-- searching for the index of @\"::\"@ and taking the substrings
1317−-- before and after that index, you would instead use @find \"::\"@.
1496+-- before and after that index, you would instead use @breakOnAll \"::\"@.
13181497
13191498-- | /O(n)/ 'Text' index (subscript) operator, starting from 0.
13201499index :: Text -> Int -> Char
@@ -1361,7 +1540,7 @@ countChar c t = S.countChar c (stream t)
13611540-- equivalent to a pair of 'unpack' operations.
13621541zip :: Text -> Text -> [(Char,Char)]
13631542zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1364−{-# INLINE [0] zip #-}
1543+{-# INLINE zip #-}
13651544
13661545-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
13671546-- given as the first argument, instead of a tupling function.
@@ -1369,7 +1548,7 @@ zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
13691548zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
13701549zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
13711550 where g a b = safe (f a b)
1372−{-# INLINE [0] zipWith #-}
1551+{-# INLINE zipWith #-}
13731552
13741553-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's
13751554-- representing white space.
@@ -1395,7 +1574,7 @@ lines ps | null ps = []
13951574 | otherwise = h : if null t
13961575 then []
13971576 else lines (unsafeTail t)
1398− where (h,t) = span (/= '\n') ps
1577+ where (# h,t #) = span_ (/= '\n') ps
13991578{-# INLINE lines #-}
14001579
14011580{-
@@ -1441,8 +1620,6 @@ isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
14411620{-# RULES
14421621"TEXT isPrefixOf -> fused" [~1] forall s t.
14431622 isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1444−"TEXT isPrefixOf -> unfused" [1] forall s t.
1445− S.isPrefixOf (stream s) (stream t) = isPrefixOf s t
14461623 #-}
14471624
14481625-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns
@@ -1496,7 +1673,7 @@ isInfixOf needle haystack
14961673-- > fnordLength _ = -1
14971674stripPrefix :: Text -> Text -> Maybe Text
14981675stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1499− | p `isPrefixOf` t = Just $! textP arr (off+plen) (len-plen)
1676+ | p `isPrefixOf` t = Just $! text arr (off+plen) (len-plen)
15001677 | otherwise = Nothing
15011678
15021679-- | /O(n)/ Find the longest non-empty common prefix of two strings
@@ -1516,8 +1693,8 @@ commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
15161693 where
15171694 go !i !j | i < len0 && j < len1 && a == b = go (i+d0) (j+d1)
15181695 | i > 0 = Just (Text arr0 off0 i,
1519− textP arr0 (off0+i) (len0-i),
1520− textP arr1 (off1+j) (len1-j))
1696+ text arr0 (off0+i) (len0-i),
1697+ text arr1 (off1+j) (len1-j))
15211698 | otherwise = Nothing
15221699 where Iter a d0 = iter t0 i
15231700 Iter b d1 = iter t1 j
@@ -1542,7 +1719,7 @@ commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
15421719-- > quuxLength _ = -1
15431720stripSuffix :: Text -> Text -> Maybe Text
15441721stripSuffix p@(Text _arr _off plen) t@(Text arr off len)
1545− | p `isSuffixOf` t = Just $! textP arr off (len-plen)
1722+ | p `isSuffixOf` t = Just $! text arr off (len-plen)
15461723 | otherwise = Nothing
15471724
15481725-- | Add a list of non-negative numbers. Errors out on overflow.
@@ -1559,3 +1736,20 @@ emptyError fun = P.error $ "Data.Text." ++ fun ++ ": empty input"
15591736
15601737overflowError :: String -> a
15611738overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
1739+
1740+-- | /O(n)/ Make a distinct copy of the given string, sharing no
1741+-- storage with the original string.
1742+--
1743+-- As an example, suppose you read a large string, of which you need
1744+-- only a small portion. If you do not use 'copy', the entire original
1745+-- array will be kept alive in memory by the smaller string. Making a
1746+-- copy \"breaks the link\" to the original array, allowing it to be
1747+-- garbage collected if there are no other live references to it.
1748+copy :: Text -> Text
1749+copy (Text arr off len) = Text (A.run go) 0 len
1750+ where
1751+ go :: ST s (A.MArray s)
1752+ go = do
1753+ marr <- A.new len
1754+ A.copyI marr 0 arr off len
1755+ return marr
Data/Text/Array.hs+60−110
@@ -1,13 +1,12 @@
1−{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, RecordWildCards,
2− UnboxedTuples #-}
1+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, Rank2Types,
2+ RecordWildCards, UnboxedTuples, UnliftedFFITypes #-}
33{-# OPTIONS_GHC -fno-warn-unused-matches #-}
44-- |
55-- Module : Data.Text.Array
6−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
6+-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
77--
88-- License : BSD-style
9−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10−-- duncan@haskell.org
9+-- Maintainer : bos@serpentine.com
1110-- Stability : experimental
1211-- Portability : portable
1312--
@@ -21,13 +20,13 @@
2120-- > import qualified Data.Text.Array as A
2221--
2322-- The names in this module resemble those in the 'Data.Array' family
24−-- of modules, but are shorter due to the assumption of qualifid
23+-- of modules, but are shorter due to the assumption of qualified
2524-- naming.
2625module Data.Text.Array
2726 (
2827 -- * Types
29− Array(aBA)
30− , MArray(maBA)
28+ Array(Array, aBA)
29+ , MArray(MArray, maBA)
3130
3231 -- * Functions
3332 , copyM
@@ -60,14 +59,24 @@ if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.Text.Array." ++ (_func_) ++ "
6059#if defined(ASSERTS)
6160import Control.Exception (assert)
6261#endif
62+#if __GLASGOW_HASKELL__ >= 702
63+import Control.Monad.ST.Unsafe (unsafeIOToST)
64+#else
65+import Control.Monad.ST (unsafeIOToST)
66+#endif
6367import Data.Bits ((.&.), xor)
64−import Data.Text.UnsafeShift (shiftL, shiftR)
68+import Data.Text.Internal.Unsafe (inlinePerformIO)
69+import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
70+#if __GLASGOW_HASKELL__ >= 703
71+import Foreign.C.Types (CInt(CInt), CSize(CSize))
72+#else
73+import Foreign.C.Types (CInt, CSize)
74+#endif
6575import GHC.Base (ByteArray#, MutableByteArray#, Int(..),
66− indexWord16Array#, indexWordArray#, newByteArray#,
67− readWord16Array#, readWordArray#, unsafeCoerce#,
68− writeWord16Array#, writeWordArray#)
76+ indexWord16Array#, newByteArray#,
77+ unsafeFreezeByteArray#, writeWord16Array#)
6978import GHC.ST (ST(..), runST)
70−import GHC.Word (Word16(..), Word(..))
79+import GHC.Word (Word16(..))
7180import Prelude hiding (length, read)
7281
7382-- | Immutable array type.
@@ -104,7 +113,7 @@ instance IArray (MArray s) where
104113-- | Create an uninitialized mutable array.
105114new :: forall s. Int -> ST s (MArray s)
106115new n
107− | n < 0 || n .&. highBit /= 0 = error $ "Data.Text.Array.new: size overflow"
116+ | n < 0 || n .&. highBit /= 0 = array_size_error
108117 | otherwise = ST $ \s1# ->
109118 case newByteArray# len# s1# of
110119 (# s2#, marr# #) -> (# s2#, MArray marr#
@@ -116,10 +125,14 @@ new n
116125 highBit = maxBound `xor` (maxBound `shiftR` 1)
117126{-# INLINE new #-}
118127
128+array_size_error :: a
129+array_size_error = error "Data.Text.Array.new: size overflow"
130+
119131-- | Freeze a mutable array. Do not mutate the 'MArray' afterwards!
120132unsafeFreeze :: MArray s -> ST s Array
121−unsafeFreeze MArray{..} = ST $ \s# ->
122− (# s#, Array (unsafeCoerce# maBA)
133+unsafeFreeze MArray{..} = ST $ \s1# ->
134+ case unsafeFreezeByteArray# maBA s1# of
135+ (# s2#, ba# #) -> (# s2#, Array ba#
123136#if defined(ASSERTS)
124137 maLen
125138#endif
@@ -140,23 +153,6 @@ unsafeIndex Array{..} i@(I# i#) =
140153 case indexWord16Array# aBA i# of r# -> (W16# r#)
141154{-# INLINE unsafeIndex #-}
142155
143−-- | Unchecked read of an immutable array. May return garbage or
144−-- crash on an out-of-bounds access.
145−unsafeIndexWord :: Array -> Int -> Word
146−unsafeIndexWord Array{..} i@(I# i#) =
147− CHECK_BOUNDS("unsafeIndexWord",aLen`div`wordFactor,i)
148− case indexWordArray# aBA i# of r# -> (W# r#)
149−{-# INLINE unsafeIndexWord #-}
150−
151−-- | Unchecked read of a mutable array. May return garbage or
152−-- crash on an out-of-bounds access.
153−unsafeRead :: MArray s -> Int -> ST s Word16
154−unsafeRead MArray{..} i@(I# i#) = ST $ \s# ->
155− CHECK_BOUNDS("unsafeRead",maLen,i)
156− case readWord16Array# maBA i# s# of
157− (# s2#, r# #) -> (# s2#, W16# r# #)
158−{-# INLINE unsafeRead #-}
159−
160156-- | Unchecked write of a mutable array. May return garbage or crash
161157-- on an out-of-bounds access.
162158unsafeWrite :: MArray s -> Int -> Word16 -> ST s ()
@@ -166,24 +162,6 @@ unsafeWrite MArray{..} i@(I# i#) (W16# e#) = ST $ \s1# ->
166162 s2# -> (# s2#, () #)
167163{-# INLINE unsafeWrite #-}
168164
169−-- | Unchecked read of a mutable array. May return garbage or
170−-- crash on an out-of-bounds access.
171−unsafeReadWord :: MArray s -> Int -> ST s Word
172−unsafeReadWord MArray{..} i@(I# i#) = ST $ \s# ->
173− CHECK_BOUNDS("unsafeRead64",maLen`div`wordFactor,i)
174− case readWordArray# maBA i# s# of
175− (# s2#, r# #) -> (# s2#, W# r# #)
176−{-# INLINE unsafeReadWord #-}
177−
178−-- | Unchecked write of a mutable array. May return garbage or crash
179−-- on an out-of-bounds access.
180−unsafeWriteWord :: MArray s -> Int -> Word -> ST s ()
181−unsafeWriteWord MArray{..} i@(I# i#) (W# e#) = ST $ \s1# ->
182− CHECK_BOUNDS("unsafeWriteWord",maLen`div`wordFactor,i)
183− case writeWordArray# maBA i# e# s1# of
184− s2# -> (# s2#, () #)
185−{-# INLINE unsafeWriteWord #-}
186−
187165-- | Convert an immutable array to a list.
188166toList :: Array -> Int -> Int -> [Word16]
189167toList ary off len = loop 0
@@ -206,15 +184,7 @@ run2 k = runST (do
206184 (marr,b) <- k
207185 arr <- unsafeFreeze marr
208186 return (arr,b))
209−
210−-- | The amount to divide or multiply by to switch between units of
211−-- 'Word16' and units of 'Word'.
212−wordFactor :: Int
213−wordFactor = SIZEOF_HSWORD `shiftR` 1
214−
215−-- | Indicate whether an offset is word-aligned.
216−wordAligned :: Int -> Bool
217−wordAligned i = i .&. (wordFactor - 1) == 0
187+{-# INLINE run2 #-}
218188
219189-- | Copy some elements of a mutable array.
220190copyM :: MArray s -- ^ Destination
@@ -223,49 +193,33 @@ copyM :: MArray s -- ^ Destination
223193 -> Int -- ^ Source offset
224194 -> Int -- ^ Count
225195 -> ST s ()
226−copyM dest didx src sidx count =
196+copyM dest didx src sidx count
197+ | count <= 0 = return ()
198+ | otherwise =
227199#if defined(ASSERTS)
228200 assert (sidx + count <= length src) .
229− assert (didx + count <= length dest) $
201+ assert (didx + count <= length dest) .
230202#endif
231− if srem == 0 && drem == 0
232− then fast_loop 0
233− else slow_loop 0
234− where
235− (swidx,srem) = sidx `divMod` wordFactor
236− (dwidx,drem) = didx `divMod` wordFactor
237− nwds = count `div` wordFactor
238− fast_loop !i
239− | i >= nwds = slow_loop (i * wordFactor)
240− | otherwise = do w <- unsafeReadWord src (swidx+i)
241− unsafeWriteWord dest (dwidx+i) w
242− fast_loop (i+1)
243− slow_loop !i
244− | i >= count= return ()
245− | otherwise = do unsafeRead src (sidx+i) >>= unsafeWrite dest (didx+i)
246− slow_loop (i+1)
203+ unsafeIOToST $ memcpyM (maBA dest) (fromIntegral didx)
204+ (maBA src) (fromIntegral sidx)
205+ (fromIntegral count)
206+{-# INLINE copyM #-}
247207
248208-- | Copy some elements of an immutable array.
249209copyI :: MArray s -- ^ Destination
250210 -> Int -- ^ Destination offset
251211 -> Array -- ^ Source
252212 -> Int -- ^ Source offset
253− -> Int -- ^ First offset in source /not/ to
213+ -> Int -- ^ First offset in destination /not/ to
254214 -- copy (i.e. /not/ length)
255215 -> ST s ()
256216copyI dest i0 src j0 top
257− | wordAligned i0 && wordAligned j0 = fast (i0 `div` wordFactor) (j0 `div` wordFactor)
258− | otherwise = slow i0 j0
259− where
260− topwds = top `div` wordFactor
261− fast !i !j
262− | i >= topwds = slow (i * wordFactor) (j * wordFactor)
263− | otherwise = do unsafeWriteWord dest i (src `unsafeIndexWord` j)
264− fast (i+1) (j+1)
265− slow !i !j
266− | i >= top = return ()
267− | otherwise = do unsafeWrite dest i (src `unsafeIndex` j)
268− slow (i+1) (j+1)
217+ | i0 >= top = return ()
218+ | otherwise = unsafeIOToST $
219+ memcpyI (maBA dest) (fromIntegral i0)
220+ (aBA src) (fromIntegral j0)
221+ (fromIntegral (top-i0))
222+{-# INLINE copyI #-}
269223
270224-- | Compare portions of two arrays for equality. No bounds checking
271225-- is performed.
@@ -275,22 +229,18 @@ equal :: Array -- ^ First
275229 -> Int -- ^ Offset into second
276230 -> Int -- ^ Count
277231 -> Bool
278−equal arrA offA arrB offB count
279− | wordAligned offA && wordAligned offB = fast 0
280− | otherwise = slow 0
281− where
282− countWords = count `div` wordFactor
283− fast !i
284− | i >= countWords = slow (i * wordFactor)
285− | a /= b = False
286− | otherwise = fast (i+1)
287− where a = unsafeIndexWord arrA (offAW+i)
288− b = unsafeIndexWord arrB (offBW+i)
289− offAW = offA `div` wordFactor
290− offBW = offB `div` wordFactor
291− slow !i
292− | i >= count = True
293− | a /= b = False
294− | otherwise = slow (i+1)
295− where a = unsafeIndex arrA (offA+i)
296− b = unsafeIndex arrB (offB+i)
232+equal arrA offA arrB offB count = inlinePerformIO $ do
233+ i <- memcmp (aBA arrA) (fromIntegral offA)
234+ (aBA arrB) (fromIntegral offB) (fromIntegral count)
235+ return $! i == 0
236+{-# INLINE equal #-}
237+
238+foreign import ccall unsafe "_hs_text_memcpy" memcpyI
239+ :: MutableByteArray# s -> CSize -> ByteArray# -> CSize -> CSize -> IO ()
240+
241+foreign import ccall unsafe "_hs_text_memcmp" memcmp
242+ :: ByteArray# -> CSize -> ByteArray# -> CSize -> CSize -> IO CInt
243+
244+foreign import ccall unsafe "_hs_text_memcpy" memcpyM
245+ :: MutableByteArray# s -> CSize -> MutableByteArray# s -> CSize -> CSize
246+ -> IO ()
Data/Text/Encoding.hs+316−96
@@ -1,13 +1,16 @@
1−{-# LANGUAGE BangPatterns #-}
1+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving, MagicHash,
2+ UnliftedFFITypes #-}
3+#if __GLASGOW_HASKELL__ >= 702
4+{-# LANGUAGE Trustworthy #-}
5+#endif
26-- |
37-- Module : Data.Text.Encoding
4−-- Copyright : (c) 2008, 2009 Tom Harper,
5−-- (c) 2009, 2010 Bryan O'Sullivan,
6−-- (c) 2009 Duncan Coutts
8+-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,
9+-- (c) 2009 Duncan Coutts,
10+-- (c) 2008, 2009 Tom Harper
711--
812-- License : BSD-style
9−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10−-- duncan@haskell.org
13+-- Maintainer : bos@serpentine.com
1114-- Stability : experimental
1215-- Portability : portable
1316--
@@ -22,6 +25,7 @@ module Data.Text.Encoding
2225 -- * Decoding ByteStrings to Text
2326 -- $strict
2427 decodeASCII
28+ , decodeLatin1
2529 , decodeUtf8
2630 , decodeUtf16LE
2731 , decodeUtf16BE
@@ -38,33 +42,59 @@ module Data.Text.Encoding
3842 , decodeUtf32LEWith
3943 , decodeUtf32BEWith
4044
45+ -- ** Stream oriented decoding
46+ -- $stream
47+ , streamDecodeUtf8
48+ , streamDecodeUtf8With
49+ , Decoding(..)
50+
4151 -- * Encoding Text to ByteStrings
4252 , encodeUtf8
4353 , encodeUtf16LE
4454 , encodeUtf16BE
4555 , encodeUtf32LE
4656 , encodeUtf32BE
57+
58+ -- * Encoding Text using ByteString Builders
59+ , encodeUtf8Builder
60+ , encodeUtf8BuilderEscaped
4761 ) where
4862
63+#if __GLASGOW_HASKELL__ >= 702
64+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
65+#else
66+import Control.Monad.ST (unsafeIOToST, unsafeSTToIO)
67+#endif
68+
4969import Control.Exception (evaluate, try)
70+import Control.Monad.ST (runST)
5071import Data.Bits ((.&.))
5172import Data.ByteString as B
52−import Data.ByteString.Internal as B
53−import Data.ByteString.Unsafe as B
73+import Data.ByteString.Internal as B hiding (c2w)
5474import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
55−import Data.Text.Internal (Text(..), textP)
56−import Data.Text.UnsafeChar (ord, unsafeWrite)
57−import Data.Text.UnsafeShift (shiftL, shiftR)
58−import Data.Word (Word8)
75+import Data.Text.Internal (Text(..), safe, text)
76+import Data.Text.Internal.Private (runText)
77+import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
78+import Data.Text.Internal.Unsafe.Shift (shiftR)
79+import Data.Text.Show ()
80+import Data.Text.Unsafe (unsafeDupablePerformIO)
81+import Data.Word (Word8, Word32)
82+import Foreign.C.Types (CSize(..))
5983import Foreign.ForeignPtr (withForeignPtr)
60−import Foreign.Ptr (plusPtr)
61−import Foreign.Storable (poke)
62−import System.IO.Unsafe (unsafePerformIO)
84+import Foreign.Marshal.Utils (with)
85+import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
86+import Foreign.Storable (Storable, peek, poke)
87+import GHC.Base (ByteArray#, MutableByteArray#)
88+import qualified Data.ByteString.Builder as B
89+import qualified Data.ByteString.Builder.Internal as B hiding (empty, append)
90+import qualified Data.ByteString.Builder.Prim as BP
91+import qualified Data.ByteString.Builder.Prim.Internal as BP
6392import qualified Data.Text.Array as A
64−import qualified Data.Text.Encoding.Fusion as E
65−import qualified Data.Text.Encoding.Utf16 as U16
66−import qualified Data.Text.Encoding.Utf8 as U8
67−import qualified Data.Text.Fusion as F
93+import qualified Data.Text.Internal.Encoding.Fusion as E
94+import qualified Data.Text.Internal.Encoding.Utf16 as U16
95+import qualified Data.Text.Internal.Fusion as F
96+
97+#include "text_cbits.h"
6898
6999-- $strict
70100--
@@ -79,48 +109,185 @@ import qualified Data.Text.Fusion as F
79109-- 'decodeUtf8With' allows the programmer to determine what to do on a
80110-- decoding error.
81111
82−-- | Decode a 'ByteString' containing 7-bit ASCII encoded text.
112+-- | /Deprecated/. Decode a 'ByteString' containing 7-bit ASCII
113+-- encoded text.
83114decodeASCII :: ByteString -> Text
84−decodeASCII bs = F.unstream (E.streamASCII bs)
85−{-# INLINE decodeASCII #-}
115+decodeASCII = decodeUtf8
116+{-# DEPRECATED decodeASCII "Use decodeUtf8 instead" #-}
117+
118+-- | Decode a 'ByteString' containing Latin-1 (aka ISO-8859-1) encoded text.
119+--
120+-- 'decodeLatin1' is semantically equivalent to
121+-- @Data.Text.pack . Data.ByteString.Char8.unpack@
122+decodeLatin1 :: ByteString -> Text
123+decodeLatin1 (PS fp off len) = text a 0 len
124+ where
125+ a = A.run (A.new len >>= unsafeIOToST . go)
126+ go dest = withForeignPtr fp $ \ptr -> do
127+ c_decode_latin1 (A.maBA dest) (ptr `plusPtr` off) (ptr `plusPtr` (off+len))
128+ return dest
86129
87130-- | Decode a 'ByteString' containing UTF-8 encoded text.
88131decodeUtf8With :: OnDecodeError -> ByteString -> Text
89−decodeUtf8With onErr bs = textP (fst a) 0 (snd a)
132+decodeUtf8With onErr (PS fp off len) = runText $ \done -> do
133+ let go dest = withForeignPtr fp $ \ptr ->
134+ with (0::CSize) $ \destOffPtr -> do
135+ let end = ptr `plusPtr` (off + len)
136+ loop curPtr = do
137+ curPtr' <- c_decode_utf8 (A.maBA dest) destOffPtr curPtr end
138+ if curPtr' == end
139+ then do
140+ n <- peek destOffPtr
141+ unsafeSTToIO (done dest (fromIntegral n))
142+ else do
143+ x <- peek curPtr'
144+ case onErr desc (Just x) of
145+ Nothing -> loop $ curPtr' `plusPtr` 1
146+ Just c -> do
147+ destOff <- peek destOffPtr
148+ w <- unsafeSTToIO $
149+ unsafeWrite dest (fromIntegral destOff) (safe c)
150+ poke destOffPtr (destOff + fromIntegral w)
151+ loop $ curPtr' `plusPtr` 1
152+ loop (ptr `plusPtr` off)
153+ (unsafeIOToST . go) =<< A.new len
90154 where
91− a = A.run2 (A.new len >>= outer 0 0)
92− len = B.length bs
93− outer n0 m0 arr = go n0 m0
155+ desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
156+{- INLINE[0] decodeUtf8With #-}
157+
158+-- $stream
159+--
160+-- The 'streamDecodeUtf8' and 'streamDecodeUtf8With' functions accept
161+-- a 'ByteString' that represents a possibly incomplete input (e.g. a
162+-- packet from a network stream) that may not end on a UTF-8 boundary.
163+--
164+-- 1. The maximal prefix of 'Text' that could be decoded from the
165+-- given input.
166+--
167+-- 2. The suffix of the 'ByteString' that could not be decoded due to
168+-- insufficient input.
169+--
170+-- 3. A function that accepts another 'ByteString'. That string will
171+-- be assumed to directly follow the string that was passed as
172+-- input to the original function, and it will in turn be decoded.
173+--
174+-- To help understand the use of these functions, consider the Unicode
175+-- string @\"hi &#9731;\"@. If encoded as UTF-8, this becomes @\"hi
176+-- \\xe2\\x98\\x83\"@; the final @\'&#9731;\'@ is encoded as 3 bytes.
177+--
178+-- Now suppose that we receive this encoded string as 3 packets that
179+-- are split up on untidy boundaries: @[\"hi \\xe2\", \"\\x98\",
180+-- \"\\x83\"]@. We cannot decode the entire Unicode string until we
181+-- have received all three packets, but we would like to make progress
182+-- as we receive each one.
183+--
184+-- @
185+-- ghci> let s0\@('Some' _ _ f0) = 'streamDecodeUtf8' \"hi \\xe2\"
186+-- ghci> s0
187+-- 'Some' \"hi \" \"\\xe2\" _
188+-- @
189+--
190+-- We use the continuation @f0@ to decode our second packet.
191+--
192+-- @
193+-- ghci> let s1\@('Some' _ _ f1) = f0 \"\\x98\"
194+-- ghci> s1
195+-- 'Some' \"\" \"\\xe2\\x98\"
196+-- @
197+--
198+-- We could not give @f0@ enough input to decode anything, so it
199+-- returned an empty string. Once we feed our second continuation @f1@
200+-- the last byte of input, it will make progress.
201+--
202+-- @
203+-- ghci> let s2\@('Some' _ _ f2) = f1 \"\\x83\"
204+-- ghci> s2
205+-- 'Some' \"\\x2603\" \"\" _
206+-- @
207+--
208+-- If given invalid input, an exception will be thrown by the function
209+-- or continuation where it is encountered.
210+
211+-- | A stream oriented decoding result.
212+data Decoding = Some Text ByteString (ByteString -> Decoding)
213+
214+instance Show Decoding where
215+ showsPrec d (Some t bs _) = showParen (d > prec) $
216+ showString "Some " . showsPrec prec' t .
217+ showChar ' ' . showsPrec prec' bs .
218+ showString " _"
219+ where prec = 10; prec' = prec + 1
220+
221+newtype CodePoint = CodePoint Word32 deriving (Eq, Show, Num, Storable)
222+newtype DecoderState = DecoderState Word32 deriving (Eq, Show, Num, Storable)
223+
224+-- | Decode, in a stream oriented way, a 'ByteString' containing UTF-8
225+-- encoded text that is known to be valid.
226+--
227+-- If the input contains any invalid UTF-8 data, an exception will be
228+-- thrown (either by this function or a continuation) that cannot be
229+-- caught in pure code. For more control over the handling of invalid
230+-- data, use 'streamDecodeUtf8With'.
231+streamDecodeUtf8 :: ByteString -> Decoding
232+streamDecodeUtf8 = streamDecodeUtf8With strictDecode
233+
234+-- | Decode, in a stream oriented way, a 'ByteString' containing UTF-8
235+-- encoded text.
236+streamDecodeUtf8With :: OnDecodeError -> ByteString -> Decoding
237+streamDecodeUtf8With onErr = decodeChunk B.empty 0 0
238+ where
239+ -- We create a slightly larger than necessary buffer to accommodate a
240+ -- potential surrogate pair started in the last buffer
241+ decodeChunk :: ByteString -> CodePoint -> DecoderState -> ByteString
242+ -> Decoding
243+ decodeChunk undecoded0 codepoint0 state0 bs@(PS fp off len) =
244+ runST $ (unsafeIOToST . decodeChunkToBuffer) =<< A.new (len+1)
94245 where
95− go !n !m = do
96− let x1 = idx m
97− x2 = idx (m + 1)
98− x3 = idx (m + 2)
99− x4 = idx (m + 3)
100− idx = B.unsafeIndex bs
101− case undefined of
102− _| m >= len -> return (arr,n)
103− | U8.validate1 x1 -> do
104− A.unsafeWrite arr n (fromIntegral x1)
105− go (n+1) (m+1)
106− | m+1 < len && U8.validate2 x1 x2 -> do
107− w <- unsafeWrite arr n (U8.chr2 x1 x2)
108− go (n+w) (m+2)
109− | m+2 < len && U8.validate3 x1 x2 x3 -> do
110− w <- unsafeWrite arr n (U8.chr3 x1 x2 x3)
111− go (n+w) (m+3)
112− | m+3 < len && U8.validate4 x1 x2 x3 x4 -> do
113− w <- unsafeWrite arr n (U8.chr4 x1 x2 x3 x4)
114− go (n+w) (m+4)
115− | otherwise -> case onErr desc (Just x1) of
116− Nothing -> go n (m+1)
117− Just c -> do
118− w <- unsafeWrite arr n c
119− go (n+w) (m+1)
120− desc = "Data.Text.Encoding.decodeUtf8: Invalid UTF-8 stream"
121−{-# INLINE[0] decodeUtf8With #-}
122−
123−-- | Decode a 'ByteString' containing known-valid UTF-8 encoded text.
246+ decodeChunkToBuffer :: A.MArray s -> IO Decoding
247+ decodeChunkToBuffer dest = withForeignPtr fp $ \ptr ->
248+ with (0::CSize) $ \destOffPtr ->
249+ with codepoint0 $ \codepointPtr ->
250+ with state0 $ \statePtr ->
251+ with nullPtr $ \curPtrPtr ->
252+ let end = ptr `plusPtr` (off + len)
253+ loop curPtr = do
254+ poke curPtrPtr curPtr
255+ curPtr' <- c_decode_utf8_with_state (A.maBA dest) destOffPtr
256+ curPtrPtr end codepointPtr statePtr
257+ state <- peek statePtr
258+ case state of
259+ UTF8_REJECT -> do
260+ -- We encountered an encoding error
261+ x <- peek curPtr'
262+ poke statePtr 0
263+ case onErr desc (Just x) of
264+ Nothing -> loop $ curPtr' `plusPtr` 1
265+ Just c -> do
266+ destOff <- peek destOffPtr
267+ w <- unsafeSTToIO $
268+ unsafeWrite dest (fromIntegral destOff) (safe c)
269+ poke destOffPtr (destOff + fromIntegral w)
270+ loop $ curPtr' `plusPtr` 1
271+
272+ _ -> do
273+ -- We encountered the end of the buffer while decoding
274+ n <- peek destOffPtr
275+ codepoint <- peek codepointPtr
276+ chunkText <- unsafeSTToIO $ do
277+ arr <- A.unsafeFreeze dest
278+ return $! text arr 0 (fromIntegral n)
279+ lastPtr <- peek curPtrPtr
280+ let left = lastPtr `minusPtr` curPtr
281+ !undecoded = case state of
282+ UTF8_ACCEPT -> B.empty
283+ _ -> B.append undecoded0 (B.drop left bs)
284+ return $ Some chunkText undecoded
285+ (decodeChunk undecoded codepoint state)
286+ in loop (ptr `plusPtr` off)
287+ desc = "Data.Text.Internal.Encoding.streamDecodeUtf8With: Invalid UTF-8 stream"
288+
289+-- | Decode a 'ByteString' containing UTF-8 encoded text that is known
290+-- to be valid.
124291--
125292-- If the input contains any invalid UTF-8 data, an exception will be
126293-- thrown that cannot be caught in pure code. For more control over
@@ -132,55 +299,93 @@ decodeUtf8 = decodeUtf8With strictDecode
132299{-# RULES "STREAM stream/decodeUtf8 fusion" [1]
133300 forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-}
134301
135−-- | Decode a 'ByteString' containing UTF-8 encoded text..
302+-- | Decode a 'ByteString' containing UTF-8 encoded text.
136303--
137304-- If the input contains any invalid UTF-8 data, the relevant
138305-- exception will be returned, otherwise the decoded text.
139306decodeUtf8' :: ByteString -> Either UnicodeException Text
140−decodeUtf8' = unsafePerformIO . try . evaluate . decodeUtf8With strictDecode
307+decodeUtf8' = unsafeDupablePerformIO . try . evaluate . decodeUtf8With strictDecode
141308{-# INLINE decodeUtf8' #-}
142309
310+-- | Encode text to a ByteString 'B.Builder' using UTF-8 encoding.
311+encodeUtf8Builder :: Text -> B.Builder
312+encodeUtf8Builder = encodeUtf8BuilderEscaped (BP.liftFixedToBounded BP.word8)
313+
314+-- | Encode text using UTF-8 encoding and escape the ASCII characters using
315+-- a 'BP.BoundedPrim'.
316+--
317+-- Use this function is to implement efficient encoders for text-based formats
318+-- like JSON or HTML.
319+{-# INLINE encodeUtf8BuilderEscaped #-}
320+-- TODO: Extend documentation with references to source code in @blaze-html@
321+-- or @aeson@ that uses this function.
322+encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder
323+encodeUtf8BuilderEscaped be =
324+ -- manual eta-expansion to ensure inlining works as expected
325+ \txt -> B.builder (mkBuildstep txt)
326+ where
327+ bound = max 4 $ BP.sizeBound be
328+
329+ mkBuildstep (Text arr off len) !k =
330+ outerLoop off
331+ where
332+ iend = off + len
333+
334+ outerLoop !i0 !br@(B.BufferRange op0 ope)
335+ | i0 >= iend = k br
336+ | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)
337+ -- TODO: Use a loop with an integrated bound's check if outRemaining
338+ -- is smaller than 8, as this will save on divisions.
339+ | otherwise = return $ B.bufferFull bound op0 (outerLoop i0)
340+ where
341+ outRemaining = (ope `minusPtr` op0) `div` bound
342+ inpRemaining = iend - i0
343+
344+ goPartial !iendTmp = go i0 op0
345+ where
346+ go !i !op
347+ | i < iendTmp = case A.unsafeIndex arr i of
348+ w | w <= 0x7F -> do
349+ BP.runB be (fromIntegral w) op >>= go (i + 1)
350+ | w <= 0x7FF -> do
351+ poke8 0 $ (w `shiftR` 6) + 0xC0
352+ poke8 1 $ (w .&. 0x3f) + 0x80
353+ go (i + 1) (op `plusPtr` 2)
354+ | 0xD800 <= w && w <= 0xDBFF -> do
355+ let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))
356+ poke8 0 $ (c `shiftR` 18) + 0xF0
357+ poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80
358+ poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80
359+ poke8 3 $ (c .&. 0x3F) + 0x80
360+ go (i + 2) (op `plusPtr` 4)
361+ | otherwise -> do
362+ poke8 0 $ (w `shiftR` 12) + 0xE0
363+ poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80
364+ poke8 2 $ (w .&. 0x3F) + 0x80
365+ go (i + 1) (op `plusPtr` 3)
366+ | otherwise =
367+ outerLoop i (B.BufferRange op ope)
368+ where
369+ poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8)
370+
143371-- | Encode text using UTF-8 encoding.
144372encodeUtf8 :: Text -> ByteString
145−encodeUtf8 (Text arr off len) = unsafePerformIO $ do
146− let size0 = min len 4
147− mallocByteString size0 >>= start size0 off 0
148− where
149− start size n0 m0 fp = withForeignPtr fp $ loop n0 m0
150− where
151− loop n1 m1 ptr = go n1 m1
152− where
153− go !n !m
154− | n-off == len = return $! PS fp 0 m
155− | size-m < 4 = {-# SCC "encodeUtf8/resize" #-} do
156− let newSize = size `shiftL` 1
157− fp' <- mallocByteString newSize
158− withForeignPtr fp' $ \ptr' -> memcpy ptr' ptr (fromIntegral m)
159− start newSize n m fp'
160− | otherwise = do
161− let poke8 k v = poke (ptr `plusPtr` k) (fromIntegral v :: Word8)
162− w = A.unsafeIndex arr n
163− case undefined of
164− _| w <= 0x7F -> do
165− poke8 m w
166− go (n+1) (m+1)
167− | w <= 0x7FF -> do
168− poke8 m $ (w `shiftR` 6) + 0xC0
169− poke8 (m+1) $ (w .&. 0x3f) + 0x80
170− go (n+1) (m+2)
171− | 0xD800 <= w && w <= 0xDBFF -> do
172− let c = ord $ U16.chr2 w (A.unsafeIndex arr (n+1))
173− poke8 m $ (c `shiftR` 18) + 0xF0
174− poke8 (m+1) $ ((c `shiftR` 12) .&. 0x3F) + 0x80
175− poke8 (m+2) $ ((c `shiftR` 6) .&. 0x3F) + 0x80
176− poke8 (m+3) $ (c .&. 0x3F) + 0x80
177− go (n+2) (m+4)
178− | otherwise -> do
179− poke8 m $ (w `shiftR` 12) + 0xE0
180− poke8 (m+1) $ ((w `shiftR` 6) .&. 0x3F) + 0x80
181− poke8 (m+2) $ (w .&. 0x3F) + 0x80
182− go (n+1) (m+3)
183−{- INLINE encodeUtf8 #-}
373+encodeUtf8 (Text arr off len)
374+ | len == 0 = B.empty
375+ | otherwise = unsafeDupablePerformIO $ do
376+ fp <- mallocByteString (len*4)
377+ withForeignPtr fp $ \ptr ->
378+ with ptr $ \destPtr -> do
379+ c_encode_utf8 destPtr (A.aBA arr) (fromIntegral off) (fromIntegral len)
380+ newDest <- peek destPtr
381+ let utf8len = newDest `minusPtr` ptr
382+ if utf8len >= len `shiftR` 1
383+ then return (PS fp 0 utf8len)
384+ else do
385+ fp' <- mallocByteString utf8len
386+ withForeignPtr fp' $ \ptr' -> do
387+ memcpy ptr' ptr (fromIntegral utf8len)
388+ return (PS fp' 0 utf8len)
184389
185390-- | Decode text from little endian UTF-16 encoding.
186391decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
@@ -257,3 +462,18 @@ encodeUtf32LE txt = E.unstream (E.restreamUtf32LE (F.stream txt))
257462encodeUtf32BE :: Text -> ByteString
258463encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt))
259464{-# INLINE encodeUtf32BE #-}
465+
466+foreign import ccall unsafe "_hs_text_decode_utf8" c_decode_utf8
467+ :: MutableByteArray# s -> Ptr CSize
468+ -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)
469+
470+foreign import ccall unsafe "_hs_text_decode_utf8_state" c_decode_utf8_with_state
471+ :: MutableByteArray# s -> Ptr CSize
472+ -> Ptr (Ptr Word8) -> Ptr Word8
473+ -> Ptr CodePoint -> Ptr DecoderState -> IO (Ptr Word8)
474+
475+foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
476+ :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
477+
478+foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
479+ :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()
Data/Text/Encoding/Error.hs+16−7
@@ -1,11 +1,15 @@
11{-# LANGUAGE CPP, DeriveDataTypeable #-}
2+#if __GLASGOW_HASKELL__ >= 704
3+{-# LANGUAGE Safe #-}
4+#elif __GLASGOW_HASKELL__ >= 702
5+{-# LANGUAGE Trustworthy #-}
6+#endif
27-- |
38-- Module : Data.Text.Encoding.Error
49-- Copyright : (c) Bryan O'Sullivan 2009
510--
611-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8−-- duncan@haskell.org
12+-- Maintainer : bos@serpentine.com
913-- Stability : experimental
1014-- Portability : GHC
1115--
@@ -35,11 +39,8 @@ module Data.Text.Encoding.Error
3539 , replace
3640 ) where
3741
38−#if __GLASGOW_HASKELL__ >= 610
42+import Control.DeepSeq (NFData (..))
3943import Control.Exception (Exception, throw)
40−#else
41−import Control.Exception.Extensible (Exception, throw)
42−#endif
4344import Data.Typeable (Typeable)
4445import Data.Word (Word8)
4546import Numeric (showHex)
@@ -67,6 +68,7 @@ type OnError a b = String -> Maybe a -> Maybe b
6768type OnDecodeError = OnError Word8 Char
6869
6970-- | A handler for an encoding error.
71+{-# DEPRECATED OnEncodeError "This exception is never used in practice, and will be removed." #-}
7072type OnEncodeError = OnError Char Word8
7173
7274-- | An exception type for representing Unicode encoding errors.
@@ -79,6 +81,8 @@ data UnicodeException =
7981 -- under the given encoding, or ran out of input in mid-encode.
8082 deriving (Eq, Typeable)
8183
84+{-# DEPRECATED EncodeError "This constructor is never used, and will be removed." #-}
85+
8286showUnicodeException :: UnicodeException -> String
8387showUnicodeException (DecodeError desc (Just w))
8488 = "Cannot decode byte '\\x" ++ showHex w ("': " ++ desc)
@@ -88,12 +92,16 @@ showUnicodeException (EncodeError desc (Just c))
8892 = "Cannot encode character '\\x" ++ showHex (fromEnum c) ("': " ++ desc)
8993showUnicodeException (EncodeError desc Nothing)
9094 = "Cannot encode input: " ++ desc
91−
95+
9296instance Show UnicodeException where
9397 show = showUnicodeException
9498
9599instance Exception UnicodeException
96100
101+instance NFData UnicodeException where
102+ rnf (DecodeError desc w) = rnf desc `seq` rnf w `seq` ()
103+ rnf (EncodeError desc c) = rnf desc `seq` rnf c `seq` ()
104+
97105-- | Throw a 'UnicodeException' if decoding fails.
98106strictDecode :: OnDecodeError
99107strictDecode desc c = throw (DecodeError desc c)
@@ -104,6 +112,7 @@ lenientDecode :: OnDecodeError
104112lenientDecode _ _ = Just '\xfffd'
105113
106114-- | Throw a 'UnicodeException' if encoding fails.
115+{-# DEPRECATED strictEncode "This function always throws an exception, and will be removed." #-}
107116strictEncode :: OnEncodeError
108117strictEncode desc c = throw (EncodeError desc c)
109118
Data/Text/Encoding/Fusion/Common.hsdeleted−162
@@ -1,162 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−-- |
4−-- Module : Data.Text.Encoding.Fusion.Common
5−-- Copyright : (c) Tom Harper 2008-2009,
6−-- (c) Bryan O'Sullivan 2009,
7−-- (c) Duncan Coutts 2009
8−--
9−-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11−-- duncan@haskell.org
12−-- Stability : experimental
13−-- Portability : portable
14−--
15−-- Fusible 'Stream'-oriented functions for converting between 'Text'
16−-- and several common encodings.
17−
18−module Data.Text.Encoding.Fusion.Common
19− (
20− -- * Restreaming
21− -- Restreaming is the act of converting from one 'Stream'
22− -- representation to another.
23− restreamUtf8
24− , restreamUtf16LE
25− , restreamUtf16BE
26− , restreamUtf32LE
27− , restreamUtf32BE
28− ) where
29−
30−import Data.Bits ((.&.))
31−import Data.Text.Fusion (Step(..), Stream(..))
32−import Data.Text.Fusion.Internal (M(..), S(..))
33−import Data.Text.UnsafeChar (ord)
34−import Data.Text.UnsafeShift (shiftR)
35−import Data.Word (Word8)
36−import qualified Data.Text.Encoding.Utf8 as U8
37−
38−-- | /O(n)/ Convert a Stream Char into a UTF-8 encoded Stream Word8.
39−restreamUtf8 :: Stream Char -> Stream Word8
40−restreamUtf8 (Stream next0 s0 len) =
41− Stream next (S s0 N N N) (len*2)
42− where
43− {-# INLINE next #-}
44− next (S s N N N) = case next0 s of
45− Done -> Done
46− Skip s' -> Skip (S s' N N N)
47− Yield x xs
48− | n <= 0x7F -> Yield c (S xs N N N)
49− | n <= 0x07FF -> Yield a2 (S xs (J b2) N N)
50− | n <= 0xFFFF -> Yield a3 (S xs (J b3) (J c3) N)
51− | otherwise -> Yield a4 (S xs (J b4) (J c4) (J d4))
52− where
53− n = ord x
54− c = fromIntegral n
55− (a2,b2) = U8.ord2 x
56− (a3,b3,c3) = U8.ord3 x
57− (a4,b4,c4,d4) = U8.ord4 x
58− next (S s (J x2) N N) = Yield x2 (S s N N N)
59− next (S s (J x2) x3 N) = Yield x2 (S s x3 N N)
60− next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N)
61− next _ = internalError "restreamUtf8"
62−{-# INLINE restreamUtf8 #-}
63−
64−restreamUtf16BE :: Stream Char -> Stream Word8
65−restreamUtf16BE (Stream next0 s0 len) =
66− Stream next (S s0 N N N) (len*2)
67− where
68− {-# INLINE next #-}
69− next (S s N N N) = case next0 s of
70− Done -> Done
71− Skip s' -> Skip (S s' N N N)
72− Yield x xs
73− | n < 0x10000 -> Yield (fromIntegral $ n `shiftR` 8) $
74− S xs (J $ fromIntegral n) N N
75− | otherwise -> Yield c1 $
76− S xs (J c2) (J c3) (J c4)
77− where
78− n = ord x
79− n1 = n - 0x10000
80− c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
81− c2 = fromIntegral (n1 `shiftR` 10)
82− n2 = n1 .&. 0x3FF
83− c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
84− c4 = fromIntegral n2
85− next (S s (J x2) N N) = Yield x2 (S s N N N)
86− next (S s (J x2) x3 N) = Yield x2 (S s x3 N N)
87− next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N)
88− next _ = internalError "restreamUtf16BE"
89−{-# INLINE restreamUtf16BE #-}
90−
91−restreamUtf16LE :: Stream Char -> Stream Word8
92−restreamUtf16LE (Stream next0 s0 len) =
93− Stream next (S s0 N N N) (len*2)
94− where
95− {-# INLINE next #-}
96− next (S s N N N) = case next0 s of
97− Done -> Done
98− Skip s' -> Skip (S s' N N N)
99− Yield x xs
100− | n < 0x10000 -> Yield (fromIntegral n) $
101− S xs (J (fromIntegral $ shiftR n 8)) N N
102− | otherwise -> Yield c1 $
103− S xs (J c2) (J c3) (J c4)
104− where
105− n = ord x
106− n1 = n - 0x10000
107− c2 = fromIntegral (shiftR n1 18 + 0xD8)
108− c1 = fromIntegral (shiftR n1 10)
109− n2 = n1 .&. 0x3FF
110− c4 = fromIntegral (shiftR n2 8 + 0xDC)
111− c3 = fromIntegral n2
112− next (S s (J x2) N N) = Yield x2 (S s N N N)
113− next (S s (J x2) x3 N) = Yield x2 (S s x3 N N)
114− next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N)
115− next _ = internalError "restreamUtf16LE"
116−{-# INLINE restreamUtf16LE #-}
117−
118−restreamUtf32BE :: Stream Char -> Stream Word8
119−restreamUtf32BE (Stream next0 s0 len) =
120− Stream next (S s0 N N N) (len*2)
121− where
122− {-# INLINE next #-}
123− next (S s N N N) = case next0 s of
124− Done -> Done
125− Skip s' -> Skip (S s' N N N)
126− Yield x xs -> Yield c1 (S xs (J c2) (J c3) (J c4))
127− where
128− n = ord x
129− c1 = fromIntegral $ shiftR n 24
130− c2 = fromIntegral $ shiftR n 16
131− c3 = fromIntegral $ shiftR n 8
132− c4 = fromIntegral n
133− next (S s (J x2) N N) = Yield x2 (S s N N N)
134− next (S s (J x2) x3 N) = Yield x2 (S s x3 N N)
135− next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N)
136− next _ = internalError "restreamUtf32BE"
137−{-# INLINE restreamUtf32BE #-}
138−
139−restreamUtf32LE :: Stream Char -> Stream Word8
140−restreamUtf32LE (Stream next0 s0 len) =
141− Stream next (S s0 N N N) (len*2)
142− where
143− {-# INLINE next #-}
144− next (S s N N N) = case next0 s of
145− Done -> Done
146− Skip s' -> Skip (S s' N N N)
147− Yield x xs -> Yield c1 (S xs (J c2) (J c3) (J c4))
148− where
149− n = ord x
150− c4 = fromIntegral $ shiftR n 24
151− c3 = fromIntegral $ shiftR n 16
152− c2 = fromIntegral $ shiftR n 8
153− c1 = fromIntegral n
154− next (S s (J x2) N N) = Yield x2 (S s N N N)
155− next (S s (J x2) x3 N) = Yield x2 (S s x3 N N)
156− next (S s (J x2) x3 x4) = Yield x2 (S s x3 x4 N)
157− next _ = internalError "restreamUtf32LE"
158−{-# INLINE restreamUtf32LE #-}
159−
160−internalError :: String -> a
161−internalError func =
162− error $ "Data.Text.Encoding.Fusion.Common." ++ func ++ ": internal error"
Data/Text/Foreign.hs+31−4
@@ -4,8 +4,7 @@
44-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
55--
66-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8−-- duncan@haskell.org
7+-- Maintainer : bos@serpentine.com
98-- Stability : experimental
109-- Portability : GHC
1110--
@@ -21,6 +20,9 @@ module Data.Text.Foreign
2120 , fromPtr
2221 , useAsPtr
2322 , asForeignPtr
23+ -- ** Encoding as UTF-8
24+ , peekCStringLen
25+ , withCStringLen
2426 -- * Unsafe conversion code
2527 , lengthWord16
2628 , unsafeCopyToPtr
@@ -33,15 +35,22 @@ module Data.Text.Foreign
3335#if defined(ASSERTS)
3436import Control.Exception (assert)
3537#endif
38+#if __GLASGOW_HASKELL__ >= 702
39+import Control.Monad.ST.Unsafe (unsafeIOToST)
40+#else
3641import Control.Monad.ST (unsafeIOToST)
42+#endif
43+import Data.ByteString.Unsafe (unsafePackCStringLen, unsafeUseAsCStringLen)
44+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
3745import Data.Text.Internal (Text(..), empty)
3846import Data.Text.Unsafe (lengthWord16)
39−import qualified Data.Text.Array as A
4047import Data.Word (Word16)
48+import Foreign.C.String (CStringLen)
49+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray, withForeignPtr)
4150import Foreign.Marshal.Alloc (allocaBytes)
4251import Foreign.Ptr (Ptr, castPtr, plusPtr)
43−import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray, withForeignPtr)
4452import Foreign.Storable (peek, poke)
53+import qualified Data.Text.Array as A
4554
4655-- $interop
4756--
@@ -144,3 +153,21 @@ asForeignPtr t@(Text _arr _off len) = do
144153 fp <- mallocForeignPtrArray len
145154 withForeignPtr fp $ unsafeCopyToPtr t
146155 return (fp, I16 len)
156+
157+-- | /O(n)/ Decode a C string with explicit length, which is assumed
158+-- to have been encoded as UTF-8. If decoding fails, a
159+-- 'UnicodeException' is thrown.
160+peekCStringLen :: CStringLen -> IO Text
161+peekCStringLen cs = do
162+ bs <- unsafePackCStringLen cs
163+ return $! decodeUtf8 bs
164+
165+-- | Marshal a 'Text' into a C string encoded as UTF-8 in temporary
166+-- storage, with explicit length information. The encoded string may
167+-- contain NUL bytes, and is not followed by a trailing NUL byte.
168+--
169+-- The temporary storage is freed when the subcomputation terminates
170+-- (either normally or via an exception), so the pointer to the
171+-- temporary storage must /not/ be used after this function returns.
172+withCStringLen :: Text -> (CStringLen -> IO a) -> IO a
173+withCStringLen t act = unsafeUseAsCStringLen (encodeUtf8 t) act
Data/Text/Fusion/Size.hsdeleted−146
@@ -1,146 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# OPTIONS_GHC -fno-warn-missing-methods #-}
3−-- |
4−-- Module : Data.Text.Fusion.Internal
5−-- Copyright : (c) Roman Leshchinskiy 2008,
6−-- (c) Bryan O'Sullivan 2009
7−--
8−-- License : BSD-style
9−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10−-- duncan@haskell.org
11−-- Stability : experimental
12−-- Portability : portable
13−--
14−-- Size hints.
15−
16−module Data.Text.Fusion.Size
17− (
18− Size
19− , exactly
20− , exactSize
21− , maxSize
22− , unknownSize
23− , smaller
24− , larger
25− , upperBound
26− , isEmpty
27− ) where
28−
29−#if defined(ASSERTS)
30−import Control.Exception (assert)
31−#endif
32−
33−data Size = Exact {-# UNPACK #-} !Int -- ^ Exact size.
34− | Max {-# UNPACK #-} !Int -- ^ Upper bound on size.
35− | Unknown -- ^ Unknown size.
36− deriving (Eq, Show)
37−
38−exactly :: Size -> Maybe Int
39−exactly (Exact n) = Just n
40−exactly _ = Nothing
41−{-# INLINE exactly #-}
42−
43−exactSize :: Int -> Size
44−exactSize n =
45−#if defined(ASSERTS)
46− assert (n >= 0)
47−#endif
48− Exact n
49−{-# INLINE exactSize #-}
50−
51−maxSize :: Int -> Size
52−maxSize n =
53−#if defined(ASSERTS)
54− assert (n >= 0)
55−#endif
56− Max n
57−{-# INLINE maxSize #-}
58−
59−unknownSize :: Size
60−unknownSize = Unknown
61−{-# INLINE unknownSize #-}
62−
63−instance Num Size where
64− (+) = addSize
65− (-) = subtractSize
66− (*) = mulSize
67−
68− fromInteger = f where f = Exact . fromInteger
69− {-# INLINE f #-}
70−
71−add :: Int -> Int -> Int
72−add m n | mn > 0 = mn
73− | otherwise = overflowError
74− where mn = m + n
75−{-# INLINE add #-}
76−
77−addSize :: Size -> Size -> Size
78−addSize (Exact m) (Exact n) = Exact (add m n)
79−addSize (Exact m) (Max n) = Max (add m n)
80−addSize (Max m) (Exact n) = Max (add m n)
81−addSize (Max m) (Max n) = Max (add m n)
82−addSize _ _ = Unknown
83−{-# INLINE addSize #-}
84−
85−subtractSize :: Size -> Size -> Size
86−subtractSize (Exact m) (Exact n) = Exact (max (m-n) 0)
87−subtractSize (Exact m) (Max _) = Max m
88−subtractSize (Max m) (Exact n) = Max (max (m-n) 0)
89−subtractSize a@(Max _) (Max _) = a
90−subtractSize a@(Max _) Unknown = a
91−subtractSize _ _ = Unknown
92−{-# INLINE subtractSize #-}
93−
94−mul :: Int -> Int -> Int
95−mul m n
96− | m <= maxBound `div` n = m * n
97− | otherwise = overflowError
98−{-# INLINE mul #-}
99−
100−mulSize :: Size -> Size -> Size
101−mulSize (Exact m) (Exact n) = Exact (mul m n)
102−mulSize (Exact m) (Max n) = Max (mul m n)
103−mulSize (Max m) (Exact n) = Max (mul m n)
104−mulSize (Max m) (Max n) = Max (mul m n)
105−mulSize _ _ = Unknown
106−{-# INLINE mulSize #-}
107−
108−-- | Minimum of two size hints.
109−smaller :: Size -> Size -> Size
110−smaller (Exact m) (Exact n) = Exact (m `min` n)
111−smaller (Exact m) (Max n) = Max (m `min` n)
112−smaller (Exact m) Unknown = Max m
113−smaller (Max m) (Exact n) = Max (m `min` n)
114−smaller (Max m) (Max n) = Max (m `min` n)
115−smaller a@(Max _) Unknown = a
116−smaller Unknown (Exact n) = Max n
117−smaller Unknown (Max n) = Max n
118−smaller Unknown Unknown = Unknown
119−{-# INLINE smaller #-}
120−
121−-- | Maximum of two size hints.
122−larger :: Size -> Size -> Size
123−larger (Exact m) (Exact n) = Exact (m `max` n)
124−larger a@(Exact m) b@(Max n) | m >= n = a
125− | otherwise = b
126−larger a@(Max m) b@(Exact n) | n >= m = b
127− | otherwise = a
128−larger (Max m) (Max n) = Max (m `max` n)
129−larger _ _ = Unknown
130−{-# INLINE larger #-}
131−
132−-- | Compute the maximum size from a size hint, if possible.
133−upperBound :: Int -> Size -> Int
134−upperBound _ (Exact n) = n
135−upperBound _ (Max n) = n
136−upperBound k _ = k
137−{-# INLINE upperBound #-}
138−
139−isEmpty :: Size -> Bool
140−isEmpty (Exact n) = n <= 0
141−isEmpty (Max n) = n <= 0
142−isEmpty _ = False
143−{-# INLINE isEmpty #-}
144−
145−overflowError :: Int
146−overflowError = error "Data.Text.Fusion.Size: size overflow"
Data/Text/IO.hs+42−38
@@ -1,4 +1,7 @@
11{-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
25-- |
36-- Module : Data.Text.IO
47-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
@@ -16,7 +19,7 @@
1619module Data.Text.IO
1720 (
1821 -- * Performance
19− -- $performance
22+ -- $performance
2023
2124 -- * Locale support
2225 -- $locale
@@ -26,6 +29,7 @@ module Data.Text.IO
2629 , appendFile
2730 -- * Operations on handles
2831 , hGetContents
32+ , hGetChunk
2933 , hGetLine
3034 , hPutStr
3135 , hPutStrLn
@@ -38,21 +42,17 @@ module Data.Text.IO
3842 ) where
3943
4044import Data.Text (Text)
41−import Prelude hiding (appendFile, catch, getContents, getLine, interact,
45+import Prelude hiding (appendFile, getContents, getLine, interact,
4246 putStr, putStrLn, readFile, writeFile)
4347import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,
4448 withFile)
45−#if __GLASGOW_HASKELL__ <= 610
46−import qualified Data.ByteString.Char8 as B
47−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
48−#else
49−import Control.Exception (catch, throw)
49+import qualified Control.Exception as E
5050import Control.Monad (liftM2, when)
5151import Data.IORef (readIORef, writeIORef)
5252import qualified Data.Text as T
53−import Data.Text.Fusion (stream)
54−import Data.Text.Fusion.Internal (Step(..), Stream(..))
55−import Data.Text.IO.Internal (hGetLineWith, readChunk)
53+import Data.Text.Internal.Fusion (stream)
54+import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
55+import Data.Text.Internal.IO (hGetLineWith, readChunk)
5656import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,
5757 RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer,
5858 writeCharBuf)
@@ -64,7 +64,6 @@ import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),
6464 HandleType(..), Newline(..))
6565import System.IO (hGetBuffering, hFileSize, hSetBuffering, hTell)
6666import System.IO.Error (isEOFError)
67−#endif
6867
6968-- $performance
7069-- #performance#
@@ -97,6 +96,30 @@ writeFile p = withFile p WriteMode . flip hPutStr
9796appendFile :: FilePath -> Text -> IO ()
9897appendFile p = withFile p AppendMode . flip hPutStr
9998
99+catchError :: String -> Handle -> Handle__ -> IOError -> IO Text
100+catchError caller h Handle__{..} err
101+ | isEOFError err = do
102+ buf <- readIORef haCharBuffer
103+ return $ if isEmptyBuffer buf
104+ then T.empty
105+ else T.singleton '\r'
106+ | otherwise = E.throwIO (augmentIOError err caller h)
107+
108+-- | /Experimental./ Read a single chunk of strict text from a
109+-- 'Handle'. The size of the chunk depends on the amount of input
110+-- currently buffered.
111+--
112+-- This function blocks only if there is no data available, and EOF
113+-- has not yet been reached. Once EOF is reached, this function
114+-- returns an empty string instead of throwing an exception.
115+hGetChunk :: Handle -> IO Text
116+hGetChunk h = wantReadableHandle "hGetChunk" h readSingleChunk
117+ where
118+ readSingleChunk hh@Handle__{..} = do
119+ buf <- readIORef haCharBuffer
120+ t <- readChunk hh buf `E.catch` catchError "hGetChunk" h hh
121+ return (hh, t)
122+
100123-- | Read the remaining contents of a 'Handle' as a string. The
101124-- 'Handle' is closed once the contents have been read, or if an
102125-- exception is thrown.
@@ -109,31 +132,21 @@ appendFile p = withFile p AppendMode . flip hPutStr
109132-- result to construct its result. For files more than a half of
110133-- available RAM in size, this may result in memory exhaustion.
111134hGetContents :: Handle -> IO Text
112−#if __GLASGOW_HASKELL__ <= 610
113−hGetContents = fmap decodeUtf8 . B.hGetContents
114−#else
115135hGetContents h = do
116136 chooseGoodBuffering h
117137 wantReadableHandle "hGetContents" h readAll
118138 where
119139 readAll hh@Handle__{..} = do
120− let catchError e
121− | isEOFError e = do
122− buf <- readIORef haCharBuffer
123− return $ if isEmptyBuffer buf
124− then T.empty
125− else T.singleton '\r'
126− | otherwise = throw (augmentIOError e "hGetContents" h)
127− readChunks = do
140+ let readChunks = do
128141 buf <- readIORef haCharBuffer
129− t <- readChunk hh buf `catch` catchError
142+ t <- readChunk hh buf `E.catch` catchError "hGetContents" h hh
130143 if T.null t
131144 then return [t]
132145 else (t:) `fmap` readChunks
133146 ts <- readChunks
134147 (hh', _) <- hClose_help hh
135148 return (hh'{haType=ClosedHandle}, T.concat ts)
136−
149+
137150-- | Use a more efficient buffer size if we're reading in
138151-- block-buffered mode with the default buffer size. When we can
139152-- determine the size of the handle we're reading, set the buffer size
@@ -144,30 +157,22 @@ chooseGoodBuffering h = do
144157 bufMode <- hGetBuffering h
145158 case bufMode of
146159 BlockBuffering Nothing -> do
147− d <- catch (liftM2 (-) (hFileSize h) (hTell h)) $ \(e::IOException) ->
160+ d <- E.catch (liftM2 (-) (hFileSize h) (hTell h)) $ \(e::IOException) ->
148161 if ioe_type e == InappropriateType
149162 then return 16384 -- faster than the 2KB default
150− else throw e
163+ else E.throwIO e
151164 when (d > 0) . hSetBuffering h . BlockBuffering . Just . fromIntegral $ d
152165 _ -> return ()
153−#endif
154166
155167-- | Read a single line from a handle.
156168hGetLine :: Handle -> IO Text
157−#if __GLASGOW_HASKELL__ <= 610
158−hGetLine = fmap decodeUtf8 . B.hGetLine
159−#else
160169hGetLine = hGetLineWith T.concat
161−#endif
162170
163171-- | Write a string to a handle.
164172hPutStr :: Handle -> Text -> IO ()
165−#if __GLASGOW_HASKELL__ <= 610
166−hPutStr h = B.hPutStr h . encodeUtf8
167−#else
168173-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
169174hPutStr h t = do
170− (buffer_mode, nl) <-
175+ (buffer_mode, nl) <-
171176 wantWritableHandle "hPutStr" h $ \h_ -> do
172177 bmode <- getSpareBuffer h_
173178 return (bmode, haOutputNL h_)
@@ -249,7 +254,7 @@ writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
249254
250255-- This function is completely lifted from GHC.IO.Handle.Text.
251256getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
252−getSpareBuffer Handle__{haCharBuffer=ref,
257+getSpareBuffer Handle__{haCharBuffer=ref,
253258 haBuffers=spare_ref,
254259 haBufferMode=mode}
255260 = do
@@ -270,11 +275,10 @@ getSpareBuffer Handle__{haCharBuffer=ref,
270275-- This function is completely lifted from GHC.IO.Handle.Text.
271276commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
272277 -> IO CharBuffer
273−commitBuffer hdl !raw !sz !count flush release =
278+commitBuffer hdl !raw !sz !count flush release =
274279 wantWritableHandle "commitAndReleaseBuffer" hdl $
275280 commitBuffer' raw sz count flush release
276281{-# INLINE commitBuffer #-}
277−#endif
278282
279283-- | Write a string to a handle, followed by a newline.
280284hPutStrLn :: Handle -> Text -> IO ()
Data/Text/Internal.hs+102−17
@@ -1,4 +1,5 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}
2+{-# OPTIONS_HADDOCK not-home #-}
23
34-- |
45-- Module : Data.Text.Internal
@@ -7,8 +8,7 @@
78-- (c) 2009 Duncan Coutts
89--
910-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11−-- duncan@haskell.org
11+-- Maintainer : bos@serpentine.com
1212-- Stability : experimental
1313-- Portability : GHC
1414--
@@ -20,9 +20,14 @@
2020-- with the internals, as the functions here do just about nothing to
2121-- preserve data invariants. You have been warned!
2222
23+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
24+#include "MachDeps.h"
25+#endif
26+
2327module Data.Text.Internal
2428 (
2529 -- * Types
30+ -- $internals
2631 Text(..)
2732 -- * Construction
2833 , text
@@ -31,8 +36,13 @@ module Data.Text.Internal
3136 , safe
3237 -- * Code that must be here for accessibility
3338 , empty
39+ , empty_
3440 -- * Utilities
3541 , firstf
42+ -- * Checked multiplication
43+ , mul
44+ , mul32
45+ , mul64
3646 -- * Debugging
3747 , showText
3848 ) where
@@ -40,21 +50,22 @@ module Data.Text.Internal
4050#if defined(ASSERTS)
4151import Control.Exception (assert)
4252#endif
43−import Data.Bits ((.&.))
44−import qualified Data.Text.Array as A
45−import Data.Text.UnsafeChar (ord)
53+import Data.Bits
54+import Data.Int (Int32, Int64)
55+import Data.Text.Internal.Unsafe.Char (ord)
4656import Data.Typeable (Typeable)
57+import qualified Data.Text.Array as A
4758
4859-- | A space efficient, packed, unboxed Unicode text type.
4960data Text = Text
50− {-# UNPACK #-} !A.Array -- payload
51− {-# UNPACK #-} !Int -- offset
52− {-# UNPACK #-} !Int -- length
61+ {-# UNPACK #-} !A.Array -- payload (Word16 elements)
62+ {-# UNPACK #-} !Int -- offset (units of Word16, not Char)
63+ {-# UNPACK #-} !Int -- length (units of Word16, not Char)
5364 deriving (Typeable)
5465
5566-- | Smart constructor.
56−text :: A.Array -> Int -> Int -> Text
57−text arr off len =
67+text_ :: A.Array -> Int -> Int -> Text
68+text_ arr off len =
5869#if defined(ASSERTS)
5970 let c = A.unsafeIndex arr off
6071 alen = A.length arr
@@ -64,19 +75,28 @@ text arr off len =
6475 assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $
6576#endif
6677 Text arr off len
67−{-# INLINE text #-}
78+{-# INLINE text_ #-}
6879
6980-- | /O(1)/ The empty 'Text'.
7081empty :: Text
7182empty = Text A.empty 0 0
7283{-# INLINE [1] empty #-}
7384
85+-- | A non-inlined version of 'empty'.
86+empty_ :: Text
87+empty_ = Text A.empty 0 0
88+{-# NOINLINE empty_ #-}
89+
7490-- | Construct a 'Text' without invisibly pinning its byte array in
7591-- memory if its length has dwindled to zero.
92+text :: A.Array -> Int -> Int -> Text
93+text arr off len | len == 0 = empty
94+ | otherwise = text_ arr off len
95+{-# INLINE text #-}
96+
7697textP :: A.Array -> Int -> Int -> Text
77−textP arr off len | len == 0 = empty
78− | otherwise = text arr off len
79−{-# INLINE textP #-}
98+{-# DEPRECATED textP "Use text instead" #-}
99+textP = text
80100
81101-- | A useful 'show'-like function for debugging purposes.
82102showText :: Text -> String
@@ -90,14 +110,79 @@ showText (Text arr off len) =
90110-- scalar values, but are unfortunately admitted as valid 'Char'
91111-- values by Haskell. They cannot be represented in a 'Text'. This
92112-- function remaps those code points to the Unicode replacement
93−-- character \"&#xfffd;\", and leaves other code points unchanged.
113+-- character (U+FFFD, \'&#xfffd;\'), and leaves other code points
114+-- unchanged.
94115safe :: Char -> Char
95116safe c
96117 | ord c .&. 0x1ff800 /= 0xd800 = c
97118 | otherwise = '\xfffd'
98−{-# INLINE safe #-}
119+{-# INLINE [0] safe #-}
99120
100121-- | Apply a function to the first element of an optional pair.
101122firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
102123firstf f (Just (a, b)) = Just (f a, b)
103124firstf _ Nothing = Nothing
125+
126+-- | Checked multiplication. Calls 'error' if the result would
127+-- overflow.
128+mul :: Int -> Int -> Int
129+#if WORD_SIZE_IN_BITS == 64
130+mul a b = fromIntegral $ fromIntegral a `mul64` fromIntegral b
131+#else
132+mul a b = fromIntegral $ fromIntegral a `mul32` fromIntegral b
133+#endif
134+{-# INLINE mul #-}
135+infixl 7 `mul`
136+
137+-- | Checked multiplication. Calls 'error' if the result would
138+-- overflow.
139+mul64 :: Int64 -> Int64 -> Int64
140+mul64 a b
141+ | a >= 0 && b >= 0 = mul64_ a b
142+ | a >= 0 = -mul64_ a (-b)
143+ | b >= 0 = -mul64_ (-a) b
144+ | otherwise = mul64_ (-a) (-b)
145+{-# INLINE mul64 #-}
146+infixl 7 `mul64`
147+
148+mul64_ :: Int64 -> Int64 -> Int64
149+mul64_ a b
150+ | ahi > 0 && bhi > 0 = error "overflow"
151+ | top > 0x7fffffff = error "overflow"
152+ | total < 0 = error "overflow"
153+ | otherwise = total
154+ where (# ahi, alo #) = (# a `shiftR` 32, a .&. 0xffffffff #)
155+ (# bhi, blo #) = (# b `shiftR` 32, b .&. 0xffffffff #)
156+ top = ahi * blo + alo * bhi
157+ total = (top `shiftL` 32) + alo * blo
158+{-# INLINE mul64_ #-}
159+
160+-- | Checked multiplication. Calls 'error' if the result would
161+-- overflow.
162+mul32 :: Int32 -> Int32 -> Int32
163+mul32 a b = case fromIntegral a * fromIntegral b of
164+ ab | ab < min32 || ab > max32 -> error "overflow"
165+ | otherwise -> fromIntegral ab
166+ where min32 = -0x80000000 :: Int64
167+ max32 = 0x7fffffff
168+{-# INLINE mul32 #-}
169+infixl 7 `mul32`
170+
171+-- $internals
172+--
173+-- Internally, the 'Text' type is represented as an array of 'Word16'
174+-- UTF-16 code units. The offset and length fields in the constructor
175+-- are in these units, /not/ units of 'Char'.
176+--
177+-- Invariants that all functions must maintain:
178+--
179+-- * Since the 'Text' type uses UTF-16 internally, it cannot represent
180+-- characters in the reserved surrogate code point range U+D800 to
181+-- U+DFFF. To maintain this invariant, the 'safe' function maps
182+-- 'Char' values in this range to the replacement character (U+FFFD,
183+-- \'&#xfffd;\').
184+--
185+-- * A leading (or \"high\") surrogate code unit (0xD800–0xDBFF) must
186+-- always be followed by a trailing (or \"low\") surrogate code unit
187+-- (0xDC00-0xDFFF). A trailing surrogate code unit must always be
188+-- preceded by a leading surrogate code unit.
Data/Text/Internal/Builder.hsnew file+329
@@ -0,0 +1,329 @@
1+{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2+{-# OPTIONS_HADDOCK not-home #-}
3+
4+-----------------------------------------------------------------------------
5+-- |
6+-- Module : Data.Text.Internal.Builder
7+-- Copyright : (c) 2013 Bryan O'Sullivan
8+-- (c) 2010 Johan Tibell
9+-- License : BSD-style (see LICENSE)
10+--
11+-- Maintainer : Johan Tibell <johan.tibell@gmail.com>
12+-- Stability : experimental
13+-- Portability : portable to Hugs and GHC
14+--
15+-- /Warning/: this is an internal module, and does not have a stable
16+-- API or name. Functions in this module may not check or enforce
17+-- preconditions expected by public modules. Use at your own risk!
18+--
19+-- Efficient construction of lazy @Text@ values. The principal
20+-- operations on a @Builder@ are @singleton@, @fromText@, and
21+-- @fromLazyText@, which construct new builders, and 'mappend', which
22+-- concatenates two builders.
23+--
24+-- To get maximum performance when building lazy @Text@ values using a
25+-- builder, associate @mappend@ calls to the right. For example,
26+-- prefer
27+--
28+-- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c')
29+--
30+-- to
31+--
32+-- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c'
33+--
34+-- as the latter associates @mappend@ to the left.
35+--
36+-----------------------------------------------------------------------------
37+
38+module Data.Text.Internal.Builder
39+ ( -- * Public API
40+ -- ** The Builder type
41+ Builder
42+ , toLazyText
43+ , toLazyTextWith
44+
45+ -- ** Constructing Builders
46+ , singleton
47+ , fromText
48+ , fromLazyText
49+ , fromString
50+
51+ -- ** Flushing the buffer state
52+ , flush
53+
54+ -- * Internal functions
55+ , append'
56+ , ensureFree
57+ , writeN
58+ ) where
59+
60+import Control.Monad.ST (ST, runST)
61+import Data.Monoid (Monoid(..))
62+#if MIN_VERSION_base(4,9,0)
63+import Data.Semigroup (Semigroup(..))
64+#endif
65+import Data.Text.Internal (Text(..))
66+import Data.Text.Internal.Lazy (smallChunkSize)
67+import Data.Text.Unsafe (inlineInterleaveST)
68+import Data.Text.Internal.Unsafe.Char (unsafeWrite)
69+import Prelude hiding (map, putChar)
70+
71+import qualified Data.String as String
72+import qualified Data.Text as S
73+import qualified Data.Text.Array as A
74+import qualified Data.Text.Lazy as L
75+
76+------------------------------------------------------------------------
77+
78+-- | A @Builder@ is an efficient way to build lazy @Text@ values.
79+-- There are several functions for constructing builders, but only one
80+-- to inspect them: to extract any data, you have to turn them into
81+-- lazy @Text@ values using @toLazyText@.
82+--
83+-- Internally, a builder constructs a lazy @Text@ by filling arrays
84+-- piece by piece. As each buffer is filled, it is \'popped\' off, to
85+-- become a new chunk of the resulting lazy @Text@. All this is
86+-- hidden from the user of the @Builder@.
87+newtype Builder = Builder {
88+ -- Invariant (from Data.Text.Lazy):
89+ -- The lists include no null Texts.
90+ runBuilder :: forall s. (Buffer s -> ST s [S.Text])
91+ -> Buffer s
92+ -> ST s [S.Text]
93+ }
94+
95+#if MIN_VERSION_base(4,9,0)
96+instance Semigroup Builder where
97+ (<>) = append
98+ {-# INLINE (<>) #-}
99+#endif
100+
101+instance Monoid Builder where
102+ mempty = empty
103+ {-# INLINE mempty #-}
104+#if MIN_VERSION_base(4,9,0)
105+ mappend = (<>) -- future-proof definition
106+#else
107+ mappend = append
108+#endif
109+ {-# INLINE mappend #-}
110+ mconcat = foldr mappend Data.Monoid.mempty
111+ {-# INLINE mconcat #-}
112+
113+instance String.IsString Builder where
114+ fromString = fromString
115+ {-# INLINE fromString #-}
116+
117+instance Show Builder where
118+ show = show . toLazyText
119+
120+instance Eq Builder where
121+ a == b = toLazyText a == toLazyText b
122+
123+instance Ord Builder where
124+ a <= b = toLazyText a <= toLazyText b
125+
126+------------------------------------------------------------------------
127+
128+-- | /O(1)./ The empty @Builder@, satisfying
129+--
130+-- * @'toLazyText' 'empty' = 'L.empty'@
131+--
132+empty :: Builder
133+empty = Builder (\ k buf -> k buf)
134+{-# INLINE empty #-}
135+
136+-- | /O(1)./ A @Builder@ taking a single character, satisfying
137+--
138+-- * @'toLazyText' ('singleton' c) = 'L.singleton' c@
139+--
140+singleton :: Char -> Builder
141+singleton c = writeAtMost 2 $ \ marr o -> unsafeWrite marr o c
142+{-# INLINE singleton #-}
143+
144+------------------------------------------------------------------------
145+
146+-- | /O(1)./ The concatenation of two builders, an associative
147+-- operation with identity 'empty', satisfying
148+--
149+-- * @'toLazyText' ('append' x y) = 'L.append' ('toLazyText' x) ('toLazyText' y)@
150+--
151+append :: Builder -> Builder -> Builder
152+append (Builder f) (Builder g) = Builder (f . g)
153+{-# INLINE [0] append #-}
154+
155+-- TODO: Experiment to find the right threshold.
156+copyLimit :: Int
157+copyLimit = 128
158+
159+-- This function attempts to merge small @Text@ values instead of
160+-- treating each value as its own chunk. We may not always want this.
161+
162+-- | /O(1)./ A @Builder@ taking a 'S.Text', satisfying
163+--
164+-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
165+--
166+fromText :: S.Text -> Builder
167+fromText t@(Text arr off l)
168+ | S.null t = empty
169+ | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
170+ | otherwise = flush `append` mapBuilder (t :)
171+{-# INLINE [1] fromText #-}
172+
173+{-# RULES
174+"fromText/pack" forall s .
175+ fromText (S.pack s) = fromString s
176+ #-}
177+
178+-- | /O(1)./ A Builder taking a @String@, satisfying
179+--
180+-- * @'toLazyText' ('fromString' s) = 'L.fromChunks' [S.pack s]@
181+--
182+fromString :: String -> Builder
183+fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
184+ let loop !marr !o !u !l [] = k (Buffer marr o u l)
185+ loop marr o u l s@(c:cs)
186+ | l <= 1 = do
187+ arr <- A.unsafeFreeze marr
188+ let !t = Text arr o u
189+ marr' <- A.new chunkSize
190+ ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
191+ return $ t : ts
192+ | otherwise = do
193+ n <- unsafeWrite marr (o+u) c
194+ loop marr o (u+n) (l-n) cs
195+ in loop p0 o0 u0 l0 str
196+ where
197+ chunkSize = smallChunkSize
198+{-# INLINE fromString #-}
199+
200+-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
201+--
202+-- * @'toLazyText' ('fromLazyText' t) = t@
203+--
204+fromLazyText :: L.Text -> Builder
205+fromLazyText ts = flush `append` mapBuilder (L.toChunks ts ++)
206+{-# INLINE fromLazyText #-}
207+
208+------------------------------------------------------------------------
209+
210+-- Our internal buffer type
211+data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s)
212+ {-# UNPACK #-} !Int -- offset
213+ {-# UNPACK #-} !Int -- used units
214+ {-# UNPACK #-} !Int -- length left
215+
216+------------------------------------------------------------------------
217+
218+-- | /O(n)./ Extract a lazy @Text@ from a @Builder@ with a default
219+-- buffer size. The construction work takes place if and when the
220+-- relevant part of the lazy @Text@ is demanded.
221+toLazyText :: Builder -> L.Text
222+toLazyText = toLazyTextWith smallChunkSize
223+
224+-- | /O(n)./ Extract a lazy @Text@ from a @Builder@, using the given
225+-- size for the initial buffer. The construction work takes place if
226+-- and when the relevant part of the lazy @Text@ is demanded.
227+--
228+-- If the initial buffer is too small to hold all data, subsequent
229+-- buffers will be the default buffer size.
230+toLazyTextWith :: Int -> Builder -> L.Text
231+toLazyTextWith chunkSize m = L.fromChunks (runST $
232+ newBuffer chunkSize >>= runBuilder (m `append` flush) (const (return [])))
233+
234+-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
235+-- yielding a new chunk in the result lazy @Text@.
236+flush :: Builder
237+flush = Builder $ \ k buf@(Buffer p o u l) ->
238+ if u == 0
239+ then k buf
240+ else do arr <- A.unsafeFreeze p
241+ let !b = Buffer p (o+u) 0 l
242+ !t = Text arr o u
243+ ts <- inlineInterleaveST (k b)
244+ return $! t : ts
245+{-# INLINE [1] flush #-}
246+-- defer inlining so that flush/flush rule may fire.
247+
248+------------------------------------------------------------------------
249+
250+-- | Sequence an ST operation on the buffer
251+withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder
252+withBuffer f = Builder $ \k buf -> f buf >>= k
253+{-# INLINE withBuffer #-}
254+
255+-- | Get the size of the buffer
256+withSize :: (Int -> Builder) -> Builder
257+withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
258+ runBuilder (f l) k buf
259+{-# INLINE withSize #-}
260+
261+-- | Map the resulting list of texts.
262+mapBuilder :: ([S.Text] -> [S.Text]) -> Builder
263+mapBuilder f = Builder (fmap f .)
264+
265+------------------------------------------------------------------------
266+
267+-- | Ensure that there are at least @n@ many elements available.
268+ensureFree :: Int -> Builder
269+ensureFree !n = withSize $ \ l ->
270+ if n <= l
271+ then empty
272+ else flush `append'` withBuffer (const (newBuffer (max n smallChunkSize)))
273+{-# INLINE [0] ensureFree #-}
274+
275+writeAtMost :: Int -> (forall s. A.MArray s -> Int -> ST s Int) -> Builder
276+writeAtMost n f = ensureFree n `append'` withBuffer (writeBuffer f)
277+{-# INLINE [0] writeAtMost #-}
278+
279+-- | Ensure that @n@ many elements are available, and then use @f@ to
280+-- write some elements into the memory.
281+writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder
282+writeN n f = writeAtMost n (\ p o -> f p o >> return n)
283+{-# INLINE writeN #-}
284+
285+writeBuffer :: (A.MArray s -> Int -> ST s Int) -> Buffer s -> ST s (Buffer s)
286+writeBuffer f (Buffer p o u l) = do
287+ n <- f p (o+u)
288+ return $! Buffer p o (u+n) (l-n)
289+{-# INLINE writeBuffer #-}
290+
291+newBuffer :: Int -> ST s (Buffer s)
292+newBuffer size = do
293+ arr <- A.new size
294+ return $! Buffer arr 0 0 size
295+{-# INLINE newBuffer #-}
296+
297+------------------------------------------------------------------------
298+-- Some nice rules for Builder
299+
300+-- This function makes GHC understand that 'writeN' and 'ensureFree'
301+-- are *not* recursive in the precense of the rewrite rules below.
302+-- This is not needed with GHC 7+.
303+append' :: Builder -> Builder -> Builder
304+append' (Builder f) (Builder g) = Builder (f . g)
305+{-# INLINE append' #-}
306+
307+{-# RULES
308+
309+"append/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int)
310+ (g::forall s. A.MArray s -> Int -> ST s Int) ws.
311+ append (writeAtMost a f) (append (writeAtMost b g) ws) =
312+ append (writeAtMost (a+b) (\marr o -> f marr o >>= \ n ->
313+ g marr (o+n) >>= \ m ->
314+ let s = n+m in s `seq` return s)) ws
315+
316+"writeAtMost/writeAtMost" forall a b (f::forall s. A.MArray s -> Int -> ST s Int)
317+ (g::forall s. A.MArray s -> Int -> ST s Int).
318+ append (writeAtMost a f) (writeAtMost b g) =
319+ writeAtMost (a+b) (\marr o -> f marr o >>= \ n ->
320+ g marr (o+n) >>= \ m ->
321+ let s = n+m in s `seq` return s)
322+
323+"ensureFree/ensureFree" forall a b .
324+ append (ensureFree a) (ensureFree b) = ensureFree (max a b)
325+
326+"flush/flush"
327+ append flush flush = flush
328+
329+ #-}
Data/Text/Internal/Builder/Functions.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE MagicHash #-}
2+
3+-- |
4+-- Module : Data.Text.Internal.Builder.Functions
5+-- Copyright : (c) 2011 MailRank, Inc.
6+--
7+-- License : BSD-style
8+-- Maintainer : bos@serpentine.com
9+-- Stability : experimental
10+-- Portability : GHC
11+--
12+-- /Warning/: this is an internal module, and does not have a stable
13+-- API or name. Functions in this module may not check or enforce
14+-- preconditions expected by public modules. Use at your own risk!
15+--
16+-- Useful functions and combinators.
17+
18+module Data.Text.Internal.Builder.Functions
19+ (
20+ (<>)
21+ , i2d
22+ ) where
23+
24+import Data.Monoid (mappend)
25+import Data.Text.Lazy.Builder (Builder)
26+import GHC.Base (chr#,ord#,(+#),Int(I#),Char(C#))
27+import Prelude ()
28+
29+-- | Unsafe conversion for decimal digits.
30+{-# INLINE i2d #-}
31+i2d :: Int -> Char
32+i2d (I# i#) = C# (chr# (ord# '0'# +# i#))
33+
34+-- | The normal 'mappend' function with right associativity instead of
35+-- left.
36+(<>) :: Builder -> Builder -> Builder
37+(<>) = mappend
38+{-# INLINE (<>) #-}
39+
40+infixr 4 <>
Data/Text/Internal/Builder/Int/Digits.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- Module: Data.Text.Internal.Builder.Int.Digits
4+-- Copyright: (c) 2013 Bryan O'Sullivan
5+-- License: BSD-style
6+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
7+-- Stability: experimental
8+-- Portability: portable
9+--
10+-- /Warning/: this is an internal module, and does not have a stable
11+-- API or name. Functions in this module may not check or enforce
12+-- preconditions expected by public modules. Use at your own risk!
13+--
14+-- This module exists because the C preprocessor does things that we
15+-- shall not speak of when confronted with Haskell multiline strings.
16+
17+module Data.Text.Internal.Builder.Int.Digits (digits) where
18+
19+import Data.ByteString.Char8 (ByteString)
20+
21+digits :: ByteString
22+digits = "0001020304050607080910111213141516171819\
23+ \2021222324252627282930313233343536373839\
24+ \4041424344454647484950515253545556575859\
25+ \6061626364656667686970717273747576777879\
26+ \8081828384858687888990919293949596979899"
Data/Text/Internal/Builder/RealFloat/Functions.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# LANGUAGE CPP #-}
2+
3+-- |
4+-- Module: Data.Text.Internal.Builder.RealFloat.Functions
5+-- Copyright: (c) The University of Glasgow 1994-2002
6+-- License: see libraries/base/LICENSE
7+--
8+-- /Warning/: this is an internal module, and does not have a stable
9+-- API or name. Functions in this module may not check or enforce
10+-- preconditions expected by public modules. Use at your own risk!
11+
12+module Data.Text.Internal.Builder.RealFloat.Functions
13+ (
14+ roundTo
15+ ) where
16+
17+roundTo :: Int -> [Int] -> (Int,[Int])
18+
19+#if MIN_VERSION_base(4,6,0)
20+
21+roundTo d is =
22+ case f d True is of
23+ x@(0,_) -> x
24+ (1,xs) -> (1, 1:xs)
25+ _ -> error "roundTo: bad Value"
26+ where
27+ b2 = base `quot` 2
28+
29+ f n _ [] = (0, replicate n 0)
30+ f 0 e (x:xs) | x == b2 && e && all (== 0) xs = (0, []) -- Round to even when at exactly half the base
31+ | otherwise = (if x >= b2 then 1 else 0, [])
32+ f n _ (i:xs)
33+ | i' == base = (1,0:ds)
34+ | otherwise = (0,i':ds)
35+ where
36+ (c,ds) = f (n-1) (even i) xs
37+ i' = c + i
38+ base = 10
39+
40+#else
41+
42+roundTo d is =
43+ case f d is of
44+ x@(0,_) -> x
45+ (1,xs) -> (1, 1:xs)
46+ _ -> error "roundTo: bad Value"
47+ where
48+ f n [] = (0, replicate n 0)
49+ f 0 (x:_) = (if x >= 5 then 1 else 0, [])
50+ f n (i:xs)
51+ | i' == 10 = (1,0:ds)
52+ | otherwise = (0,i':ds)
53+ where
54+ (c,ds) = f (n-1) xs
55+ i' = c + i
56+
57+#endif
Data/Text/Encoding/Fusion.hs → Data/Text/Internal/Encoding/Fusion.hsrenamed+20−16
@@ -1,21 +1,24 @@
11{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
22
33-- |
4−-- Module : Data.Text.Encoding.Fusion
4+-- Module : Data.Text.Internal.Encoding.Fusion
55-- Copyright : (c) Tom Harper 2008-2009,
66-- (c) Bryan O'Sullivan 2009,
77-- (c) Duncan Coutts 2009
88--
99-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11−-- duncan@haskell.org
10+-- Maintainer : bos@serpentine.com
1211-- Stability : experimental
1312-- Portability : portable
1413--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
1518-- Fusible 'Stream'-oriented functions for converting between 'Text'
1619-- and several common encodings.
1720
18−module Data.Text.Encoding.Fusion
21+module Data.Text.Internal.Encoding.Fusion
1922 (
2023 -- * Streaming
2124 streamASCII
@@ -28,28 +31,28 @@ module Data.Text.Encoding.Fusion
2831 -- * Unstreaming
2932 , unstream
3033
31− , module Data.Text.Encoding.Fusion.Common
34+ , module Data.Text.Internal.Encoding.Fusion.Common
3235 ) where
3336
3437#if defined(ASSERTS)
3538import Control.Exception (assert)
3639#endif
3740import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy)
38−import Data.Text.Fusion (Step(..), Stream(..))
39−import Data.Text.Fusion.Size
41+import Data.Text.Internal.Fusion (Step(..), Stream(..))
42+import Data.Text.Internal.Fusion.Size
4043import Data.Text.Encoding.Error
41−import Data.Text.Encoding.Fusion.Common
42−import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32)
43−import Data.Text.UnsafeShift (shiftL, shiftR)
44+import Data.Text.Internal.Encoding.Fusion.Common
45+import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
46+import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
4447import Data.Word (Word8, Word16, Word32)
4548import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
4649import Foreign.Storable (pokeByteOff)
47−import System.IO.Unsafe (unsafePerformIO)
4850import qualified Data.ByteString as B
4951import qualified Data.ByteString.Unsafe as B
50−import qualified Data.Text.Encoding.Utf8 as U8
51−import qualified Data.Text.Encoding.Utf16 as U16
52−import qualified Data.Text.Encoding.Utf32 as U32
52+import qualified Data.Text.Internal.Encoding.Utf8 as U8
53+import qualified Data.Text.Internal.Encoding.Utf16 as U16
54+import qualified Data.Text.Internal.Encoding.Utf32 as U32
55+import Data.Text.Unsafe (unsafeDupablePerformIO)
5356
5457streamASCII :: ByteString -> Stream Char
5558streamASCII bs = Stream next 0 (maxSize l)
@@ -61,6 +64,7 @@ streamASCII bs = Stream next 0 (maxSize l)
6164 | otherwise = Yield (unsafeChr8 x1) (i+1)
6265 where
6366 x1 = B.unsafeIndex bs i
67+{-# DEPRECATED streamASCII "Do not use this function" #-}
6468{-# INLINE [0] streamASCII #-}
6569
6670-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8
@@ -162,7 +166,7 @@ streamUtf32LE onErr bs = Stream next 0 (maxSize (l `shiftR` 2))
162166
163167-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
164168unstream :: Stream Word8 -> ByteString
165−unstream (Stream next s0 len) = unsafePerformIO $ do
169+unstream (Stream next s0 len) = unsafeDupablePerformIO $ do
166170 let mlen = upperBound 4 len
167171 mallocByteString mlen >>= loop mlen 0 s0
168172 where
@@ -200,5 +204,5 @@ decodeError func kind onErr mb i =
200204 case onErr desc mb of
201205 Nothing -> Skip i
202206 Just c -> Yield c i
203− where desc = "Data.Text.Encoding.Fusion." ++ func ++ ": Invalid " ++
207+ where desc = "Data.Text.Internal.Encoding.Fusion." ++ func ++ ": Invalid " ++
204208 kind ++ " stream"
Data/Text/Internal/Encoding/Fusion/Common.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE BangPatterns #-}
2+
3+-- |
4+-- Module : Data.Text.Internal.Encoding.Fusion.Common
5+-- Copyright : (c) Tom Harper 2008-2009,
6+-- (c) Bryan O'Sullivan 2009,
7+-- (c) Duncan Coutts 2009,
8+-- (c) Jasper Van der Jeugt 2011
9+--
10+-- License : BSD-style
11+-- Maintainer : bos@serpentine.com
12+-- Stability : experimental
13+-- Portability : portable
14+--
15+-- /Warning/: this is an internal module, and does not have a stable
16+-- API or name. Use at your own risk!
17+--
18+-- Fusible 'Stream'-oriented functions for converting between 'Text'
19+-- and several common encodings.
20+
21+module Data.Text.Internal.Encoding.Fusion.Common
22+ (
23+ -- * Restreaming
24+ -- Restreaming is the act of converting from one 'Stream'
25+ -- representation to another.
26+ restreamUtf16LE
27+ , restreamUtf16BE
28+ , restreamUtf32LE
29+ , restreamUtf32BE
30+ ) where
31+
32+import Data.Bits ((.&.))
33+import Data.Text.Internal.Fusion (Step(..), Stream(..))
34+import Data.Text.Internal.Fusion.Types (RS(..))
35+import Data.Text.Internal.Unsafe.Char (ord)
36+import Data.Text.Internal.Unsafe.Shift (shiftR)
37+import Data.Word (Word8)
38+
39+restreamUtf16BE :: Stream Char -> Stream Word8
40+restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
41+ where
42+ next (RS0 s) = case next0 s of
43+ Done -> Done
44+ Skip s' -> Skip (RS0 s')
45+ Yield x s'
46+ | n < 0x10000 -> Yield (fromIntegral $ n `shiftR` 8) $
47+ RS1 s' (fromIntegral n)
48+ | otherwise -> Yield c1 $ RS3 s' c2 c3 c4
49+ where
50+ n = ord x
51+ n1 = n - 0x10000
52+ c1 = fromIntegral (n1 `shiftR` 18 + 0xD8)
53+ c2 = fromIntegral (n1 `shiftR` 10)
54+ n2 = n1 .&. 0x3FF
55+ c3 = fromIntegral (n2 `shiftR` 8 + 0xDC)
56+ c4 = fromIntegral n2
57+ next (RS1 s x2) = Yield x2 (RS0 s)
58+ next (RS2 s x2 x3) = Yield x2 (RS1 s x3)
59+ next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4)
60+ {-# INLINE next #-}
61+{-# INLINE restreamUtf16BE #-}
62+
63+restreamUtf16LE :: Stream Char -> Stream Word8
64+restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
65+ where
66+ next (RS0 s) = case next0 s of
67+ Done -> Done
68+ Skip s' -> Skip (RS0 s')
69+ Yield x s'
70+ | n < 0x10000 -> Yield (fromIntegral n) $
71+ RS1 s' (fromIntegral $ shiftR n 8)
72+ | otherwise -> Yield c1 $ RS3 s' c2 c3 c4
73+ where
74+ n = ord x
75+ n1 = n - 0x10000
76+ c2 = fromIntegral (shiftR n1 18 + 0xD8)
77+ c1 = fromIntegral (shiftR n1 10)
78+ n2 = n1 .&. 0x3FF
79+ c4 = fromIntegral (shiftR n2 8 + 0xDC)
80+ c3 = fromIntegral n2
81+ next (RS1 s x2) = Yield x2 (RS0 s)
82+ next (RS2 s x2 x3) = Yield x2 (RS1 s x3)
83+ next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4)
84+ {-# INLINE next #-}
85+{-# INLINE restreamUtf16LE #-}
86+
87+restreamUtf32BE :: Stream Char -> Stream Word8
88+restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
89+ where
90+ next (RS0 s) = case next0 s of
91+ Done -> Done
92+ Skip s' -> Skip (RS0 s')
93+ Yield x s' -> Yield c1 (RS3 s' c2 c3 c4)
94+ where
95+ n = ord x
96+ c1 = fromIntegral $ shiftR n 24
97+ c2 = fromIntegral $ shiftR n 16
98+ c3 = fromIntegral $ shiftR n 8
99+ c4 = fromIntegral n
100+ next (RS1 s x2) = Yield x2 (RS0 s)
101+ next (RS2 s x2 x3) = Yield x2 (RS1 s x3)
102+ next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4)
103+ {-# INLINE next #-}
104+{-# INLINE restreamUtf32BE #-}
105+
106+restreamUtf32LE :: Stream Char -> Stream Word8
107+restreamUtf32LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
108+ where
109+ next (RS0 s) = case next0 s of
110+ Done -> Done
111+ Skip s' -> Skip (RS0 s')
112+ Yield x s' -> Yield c1 (RS3 s' c2 c3 c4)
113+ where
114+ n = ord x
115+ c4 = fromIntegral $ shiftR n 24
116+ c3 = fromIntegral $ shiftR n 16
117+ c2 = fromIntegral $ shiftR n 8
118+ c1 = fromIntegral n
119+ next (RS1 s x2) = Yield x2 (RS0 s)
120+ next (RS2 s x2 x3) = Yield x2 (RS1 s x3)
121+ next (RS3 s x2 x3 x4) = Yield x2 (RS2 s x3 x4)
122+ {-# INLINE next #-}
123+{-# INLINE restreamUtf32LE #-}
Data/Text/Encoding/Utf16.hs → Data/Text/Internal/Encoding/Utf16.hsrenamed+8−5
@@ -1,19 +1,22 @@
1−{-# LANGUAGE MagicHash #-}
1+{-# LANGUAGE MagicHash, BangPatterns #-}
22
33-- |
4−-- Module : Data.Text.Encoding.Utf16
4+-- Module : Data.Text.Internal.Encoding.Utf16
55-- Copyright : (c) 2008, 2009 Tom Harper,
66-- (c) 2009 Bryan O'Sullivan,
77-- (c) 2009 Duncan Coutts
88--
99-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11−-- duncan@haskell.org
10+-- Maintainer : bos@serpentine.com
1211-- Stability : experimental
1312-- Portability : GHC
1413--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
1518-- Basic UTF-16 validation and character manipulation.
16−module Data.Text.Encoding.Utf16
19+module Data.Text.Internal.Encoding.Utf16
1720 (
1821 chr2
1922 , validate1
Data/Text/Encoding/Utf32.hs → Data/Text/Internal/Encoding/Utf32.hsrenamed+7−4
@@ -1,17 +1,20 @@
11-- |
2−-- Module : Data.Text.Encoding.Utf32
2+-- Module : Data.Text.Internal.Encoding.Utf32
33-- Copyright : (c) 2008, 2009 Tom Harper,
44-- (c) 2009, 2010 Bryan O'Sullivan,
55-- (c) 2009 Duncan Coutts
66--
77-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
8+-- Maintainer : bos@serpentine.com
109-- Stability : experimental
1110-- Portability : portable
1211--
12+-- /Warning/: this is an internal module, and does not have a stable
13+-- API or name. Functions in this module may not check or enforce
14+-- preconditions expected by public modules. Use at your own risk!
15+--
1316-- Basic UTF-32 validation.
14−module Data.Text.Encoding.Utf32
17+module Data.Text.Internal.Encoding.Utf32
1518 (
1619 validate
1720 ) where
Data/Text/Encoding/Utf8.hs → Data/Text/Internal/Encoding/Utf8.hsrenamed+15−8
@@ -1,19 +1,22 @@
1−{-# LANGUAGE CPP, MagicHash #-}
1+{-# LANGUAGE CPP, MagicHash, BangPatterns #-}
22
33-- |
4−-- Module : Data.Text.Encoding.Utf8
4+-- Module : Data.Text.Internal.Encoding.Utf8
55-- Copyright : (c) 2008, 2009 Tom Harper,
66-- (c) 2009, 2010 Bryan O'Sullivan,
77-- (c) 2009 Duncan Coutts
88--
99-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11−-- duncan@haskell.org
10+-- Maintainer : bos@serpentine.com
1211-- Stability : experimental
1312-- Portability : GHC
1413--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
1518-- Basic UTF-8 validation and character manipulation.
16−module Data.Text.Encoding.Utf8
19+module Data.Text.Internal.Encoding.Utf8
1720 (
1821 -- Decomposition
1922 ord2
@@ -30,12 +33,16 @@ module Data.Text.Encoding.Utf8
3033 , validate4
3134 ) where
3235
36+#if defined(TEST_SUITE)
37+# undef ASSERTS
38+#endif
39+
3340#if defined(ASSERTS)
3441import Control.Exception (assert)
3542#endif
3643import Data.Bits ((.&.))
37−import Data.Text.UnsafeChar (ord)
38−import Data.Text.UnsafeShift (shiftR)
44+import Data.Text.Internal.Unsafe.Char (ord)
45+import Data.Text.Internal.Unsafe.Shift (shiftR)
3946import GHC.Exts
4047import GHC.Word (Word8(..))
4148
@@ -146,7 +153,7 @@ validate3 x1 x2 x3 = validate3_1 || validate3_2 || validate3_3 || validate3_4
146153validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
147154{-# INLINE validate4 #-}
148155validate4 x1 x2 x3 x4 = validate4_1 || validate4_2 || validate4_3
149− where
156+ where
150157 validate4_1 = x1 == 0xF0 &&
151158 between x2 0x90 0xBF &&
152159 between x3 0x80 0xBF &&
Data/Text/Util.hs → Data/Text/Internal/Functions.hsrenamed+6−2
@@ -1,7 +1,7 @@
11{-# LANGUAGE CPP, DeriveDataTypeable #-}
22
33-- |
4−-- Module : Data.Text.Util
4+-- Module : Data.Text.Internal.Functions
55-- Copyright : 2010 Bryan O'Sullivan
66--
77-- License : BSD-style
@@ -9,9 +9,13 @@
99-- Stability : experimental
1010-- Portability : GHC
1111--
12+-- /Warning/: this is an internal module, and does not have a stable
13+-- API or name. Functions in this module may not check or enforce
14+-- preconditions expected by public modules. Use at your own risk!
15+--
1216-- Useful functions.
1317
14−module Data.Text.Util
18+module Data.Text.Internal.Functions
1519 (
1620 intersperse
1721 ) where
Data/Text/Fusion.hs → Data/Text/Internal/Fusion.hsrenamed+58−45
@@ -1,20 +1,23 @@
11{-# LANGUAGE BangPatterns, MagicHash #-}
22
33-- |
4−-- Module : Data.Text.Fusion
4+-- Module : Data.Text.Internal.Fusion
55-- Copyright : (c) Tom Harper 2008-2009,
66-- (c) Bryan O'Sullivan 2009-2010,
77-- (c) Duncan Coutts 2009
88--
99-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11−-- duncan@haskell.org
10+-- Maintainer : bos@serpentine.com
1211-- Stability : experimental
1312-- Portability : GHC
1413--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
1518-- Text manipulation functions represented as fusible operations over
1619-- streams.
17−module Data.Text.Fusion
20+module Data.Text.Internal.Fusion
1821 (
1922 -- * Types
2023 Stream(..)
@@ -51,21 +54,21 @@ import Prelude (Bool(..), Char, Maybe(..), Monad(..), Int,
5154 fromIntegral, otherwise)
5255import Data.Bits ((.&.))
5356import Data.Text.Internal (Text(..))
54−import Data.Text.UnsafeChar (ord, unsafeChr, unsafeWrite)
55−import Data.Text.UnsafeShift (shiftL, shiftR)
57+import Data.Text.Internal.Private (runText)
58+import Data.Text.Internal.Unsafe.Char (ord, unsafeChr, unsafeWrite)
59+import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
5660import qualified Data.Text.Array as A
57−import qualified Data.Text.Fusion.Common as S
58−import Data.Text.Fusion.Internal
59−import Data.Text.Fusion.Size
61+import qualified Data.Text.Internal.Fusion.Common as S
62+import Data.Text.Internal.Fusion.Types
63+import Data.Text.Internal.Fusion.Size
6064import qualified Data.Text.Internal as I
61−import qualified Data.Text.Encoding.Utf16 as U16
62−import qualified Prelude as P
65+import qualified Data.Text.Internal.Encoding.Utf16 as U16
6366
6467default(Int)
6568
6669-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
6770stream :: Text -> Stream Char
68−stream (Text arr off len) = Stream next off (maxSize len)
71+stream (Text arr off len) = Stream next off (betweenSize (len `shiftR` 1) len)
6972 where
7073 !end = off+len
7174 next !i
@@ -80,7 +83,7 @@ stream (Text arr off len) = Stream next off (maxSize len)
8083-- | /O(n)/ Convert a 'Text' into a 'Stream Char', but iterate
8184-- backwards.
8285reverseStream :: Text -> Stream Char
83−reverseStream (Text arr off len) = Stream next (off+len-1) (maxSize len)
86+reverseStream (Text arr off len) = Stream next (off+len-1) (betweenSize (len `shiftR` 1) len)
8487 where
8588 {-# INLINE next #-}
8689 next !i
@@ -94,26 +97,36 @@ reverseStream (Text arr off len) = Stream next (off+len-1) (maxSize len)
9497
9598-- | /O(n)/ Convert a 'Stream Char' into a 'Text'.
9699unstream :: Stream Char -> Text
97−unstream (Stream next0 s0 len) = I.textP (P.fst a) 0 (P.snd a)
98− where
99− a = A.run2 (A.new mlen >>= \arr -> outer arr mlen s0 0)
100− where mlen = upperBound 4 len
101− outer arr top = loop
102− where
103− loop !s !i =
104− case next0 s of
105− Done -> return (arr, i)
106− Skip s' -> loop s' i
107− Yield x s'
108− | j >= top -> {-# SCC "unstream/resize" #-} do
109− let top' = (top + 1) `shiftL` 1
110− arr' <- A.new top'
111− A.copyM arr' 0 arr 0 top
112− outer arr' top' s i
113− | otherwise -> do d <- unsafeWrite arr i x
114− loop s' (i+d)
115− where j | ord x < 0x10000 = i
116− | otherwise = i + 1
100+unstream (Stream next0 s0 len) = runText $ \done -> do
101+ -- Before encoding each char we perform a buffer realloc check assuming
102+ -- worst case encoding size of two 16-bit units for the char. Just add an
103+ -- extra space to the buffer so that we do not end up reallocating even when
104+ -- all the chars are encoded as single unit.
105+ let mlen = upperBound 4 len + 1
106+ arr0 <- A.new mlen
107+ let outer !arr !maxi = encode
108+ where
109+ -- keep the common case loop as small as possible
110+ encode !si !di =
111+ case next0 si of
112+ Done -> done arr di
113+ Skip si' -> encode si' di
114+ Yield c si'
115+ -- simply check for the worst case
116+ | maxi < di + 1 -> realloc si di
117+ | otherwise -> do
118+ n <- unsafeWrite arr di c
119+ encode si' (di + n)
120+
121+ -- keep uncommon case separate from the common case code
122+ {-# NOINLINE realloc #-}
123+ realloc !si !di = do
124+ let newlen = (maxi + 1) * 2
125+ arr' <- A.new newlen
126+ A.copyM arr' 0 arr 0 di
127+ outer arr' (newlen - 1) si di
128+
129+ outer arr0 (mlen - 1) s0 0
117130{-# INLINE [0] unstream #-}
118131{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
119132
@@ -129,7 +142,7 @@ length = S.lengthI
129142reverse :: Stream Char -> Text
130143reverse (Stream next s len0)
131144 | isEmpty len0 = I.empty
132− | otherwise = I.textP arr off' len'
145+ | otherwise = I.text arr off' len'
133146 where
134147 len0' = upperBound 4 (larger len0 4)
135148 (arr, (off', len')) = A.run2 (A.new len0' >>= loop s (len0'-1) len0')
@@ -163,15 +176,15 @@ reverse (Stream next s len0)
163176-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
164177-- the input and result reversed.
165178reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
166−reverseScanr f z0 (Stream next0 s0 len) = Stream next (S1 :*: z0 :*: s0) (len+1) -- HINT maybe too low
179+reverseScanr f z0 (Stream next0 s0 len) = Stream next (Scan1 z0 s0) (len+1) -- HINT maybe too low
167180 where
168181 {-# INLINE next #-}
169− next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s)
170− next (S2 :*: z :*: s) = case next0 s of
171− Yield x s' -> let !x' = f x z
172− in Yield x' (S2 :*: x' :*: s')
173− Skip s' -> Skip (S2 :*: z :*: s')
174− Done -> Done
182+ next (Scan1 z s) = Yield z (Scan2 z s)
183+ next (Scan2 z s) = case next0 s of
184+ Yield x s' -> let !x' = f x z
185+ in Yield x' (Scan2 x' s')
186+ Skip s' -> Skip (Scan2 z s')
187+ Done -> Done
175188{-# INLINE reverseScanr #-}
176189
177190-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
@@ -207,7 +220,7 @@ countChar = S.countCharI
207220-- function to each element of a 'Text', passing an accumulating
208221-- parameter from left to right, and returns a final 'Text'.
209222mapAccumL :: (a -> Char -> (a,Char)) -> a -> Stream Char -> (a, Text)
210−mapAccumL f z0 (Stream next0 s0 len) = (nz,I.textP na 0 nl)
223+mapAccumL f z0 (Stream next0 s0 len) = (nz, I.text na 0 nl)
211224 where
212225 (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0)
213226 where mlen = upperBound 4 len
@@ -223,9 +236,9 @@ mapAccumL f z0 (Stream next0 s0 len) = (nz,I.textP na 0 nl)
223236 arr' <- A.new top'
224237 A.copyM arr' 0 arr 0 top
225238 outer arr' top' z s i
226− | otherwise -> do let (z',c) = f z x
227− d <- unsafeWrite arr i c
239+ | otherwise -> do d <- unsafeWrite arr i c
228240 loop z' s' (i+d)
229− where j | ord x < 0x10000 = i
241+ where (z',c) = f z x
242+ j | ord c < 0x10000 = i
230243 | otherwise = i + 1
231244{-# INLINE [0] mapAccumL #-}
Data/Text/Fusion/CaseMapping.hs → Data/Text/Internal/Fusion/CaseMapping.hsrenamed+392−6
@@ -1,12 +1,17 @@
11{-# LANGUAGE Rank2Types #-}
22-- AUTOMATICALLY GENERATED - DO NOT EDIT
3−-- Generated by scripts/SpecialCasing.hs
4−module Data.Text.Fusion.CaseMapping where
3+-- Generated by scripts/CaseMapping.hs
4+-- CaseFolding-8.0.0.txt
5+-- Date: 2015-01-13, 18:16:36 GMT [MD]
6+-- SpecialCasing-8.0.0.txt
7+-- Date: 2014-12-16, 23:08:04 GMT [MD]
8+
9+module Data.Text.Internal.Fusion.CaseMapping where
510import Data.Char
6−import Data.Text.Fusion.Internal
11+import Data.Text.Internal.Fusion.Types
712
813upperMapping :: forall s. Char -> s -> Step (CC s) Char
9−{-# INLINE upperMapping #-}
14+{-# NOINLINE upperMapping #-}
1015-- LATIN SMALL LETTER SHARP S
1116upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')
1217-- LATIN SMALL LIGATURE FF
@@ -213,12 +218,111 @@ upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399')
213218upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')
214219upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')
215220lowerMapping :: forall s. Char -> s -> Step (CC s) Char
216−{-# INLINE lowerMapping #-}
221+{-# NOINLINE lowerMapping #-}
217222-- LATIN CAPITAL LETTER I WITH DOT ABOVE
218223lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
219224lowerMapping c s = Yield (toLower c) (CC s '\0' '\0')
225+titleMapping :: forall s. Char -> s -> Step (CC s) Char
226+{-# NOINLINE titleMapping #-}
227+-- LATIN SMALL LETTER SHARP S
228+titleMapping '\x00df' s = Yield '\x0053' (CC s '\x0073' '\x0000')
229+-- LATIN SMALL LIGATURE FF
230+titleMapping '\xfb00' s = Yield '\x0046' (CC s '\x0066' '\x0000')
231+-- LATIN SMALL LIGATURE FI
232+titleMapping '\xfb01' s = Yield '\x0046' (CC s '\x0069' '\x0000')
233+-- LATIN SMALL LIGATURE FL
234+titleMapping '\xfb02' s = Yield '\x0046' (CC s '\x006c' '\x0000')
235+-- LATIN SMALL LIGATURE FFI
236+titleMapping '\xfb03' s = Yield '\x0046' (CC s '\x0066' '\x0069')
237+-- LATIN SMALL LIGATURE FFL
238+titleMapping '\xfb04' s = Yield '\x0046' (CC s '\x0066' '\x006c')
239+-- LATIN SMALL LIGATURE LONG S T
240+titleMapping '\xfb05' s = Yield '\x0053' (CC s '\x0074' '\x0000')
241+-- LATIN SMALL LIGATURE ST
242+titleMapping '\xfb06' s = Yield '\x0053' (CC s '\x0074' '\x0000')
243+-- ARMENIAN SMALL LIGATURE ECH YIWN
244+titleMapping '\x0587' s = Yield '\x0535' (CC s '\x0582' '\x0000')
245+-- ARMENIAN SMALL LIGATURE MEN NOW
246+titleMapping '\xfb13' s = Yield '\x0544' (CC s '\x0576' '\x0000')
247+-- ARMENIAN SMALL LIGATURE MEN ECH
248+titleMapping '\xfb14' s = Yield '\x0544' (CC s '\x0565' '\x0000')
249+-- ARMENIAN SMALL LIGATURE MEN INI
250+titleMapping '\xfb15' s = Yield '\x0544' (CC s '\x056b' '\x0000')
251+-- ARMENIAN SMALL LIGATURE VEW NOW
252+titleMapping '\xfb16' s = Yield '\x054e' (CC s '\x0576' '\x0000')
253+-- ARMENIAN SMALL LIGATURE MEN XEH
254+titleMapping '\xfb17' s = Yield '\x0544' (CC s '\x056d' '\x0000')
255+-- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
256+titleMapping '\x0149' s = Yield '\x02bc' (CC s '\x004e' '\x0000')
257+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
258+titleMapping '\x0390' s = Yield '\x0399' (CC s '\x0308' '\x0301')
259+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
260+titleMapping '\x03b0' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
261+-- LATIN SMALL LETTER J WITH CARON
262+titleMapping '\x01f0' s = Yield '\x004a' (CC s '\x030c' '\x0000')
263+-- LATIN SMALL LETTER H WITH LINE BELOW
264+titleMapping '\x1e96' s = Yield '\x0048' (CC s '\x0331' '\x0000')
265+-- LATIN SMALL LETTER T WITH DIAERESIS
266+titleMapping '\x1e97' s = Yield '\x0054' (CC s '\x0308' '\x0000')
267+-- LATIN SMALL LETTER W WITH RING ABOVE
268+titleMapping '\x1e98' s = Yield '\x0057' (CC s '\x030a' '\x0000')
269+-- LATIN SMALL LETTER Y WITH RING ABOVE
270+titleMapping '\x1e99' s = Yield '\x0059' (CC s '\x030a' '\x0000')
271+-- LATIN SMALL LETTER A WITH RIGHT HALF RING
272+titleMapping '\x1e9a' s = Yield '\x0041' (CC s '\x02be' '\x0000')
273+-- GREEK SMALL LETTER UPSILON WITH PSILI
274+titleMapping '\x1f50' s = Yield '\x03a5' (CC s '\x0313' '\x0000')
275+-- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA
276+titleMapping '\x1f52' s = Yield '\x03a5' (CC s '\x0313' '\x0300')
277+-- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA
278+titleMapping '\x1f54' s = Yield '\x03a5' (CC s '\x0313' '\x0301')
279+-- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI
280+titleMapping '\x1f56' s = Yield '\x03a5' (CC s '\x0313' '\x0342')
281+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI
282+titleMapping '\x1fb6' s = Yield '\x0391' (CC s '\x0342' '\x0000')
283+-- GREEK SMALL LETTER ETA WITH PERISPOMENI
284+titleMapping '\x1fc6' s = Yield '\x0397' (CC s '\x0342' '\x0000')
285+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA
286+titleMapping '\x1fd2' s = Yield '\x0399' (CC s '\x0308' '\x0300')
287+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
288+titleMapping '\x1fd3' s = Yield '\x0399' (CC s '\x0308' '\x0301')
289+-- GREEK SMALL LETTER IOTA WITH PERISPOMENI
290+titleMapping '\x1fd6' s = Yield '\x0399' (CC s '\x0342' '\x0000')
291+-- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI
292+titleMapping '\x1fd7' s = Yield '\x0399' (CC s '\x0308' '\x0342')
293+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA
294+titleMapping '\x1fe2' s = Yield '\x03a5' (CC s '\x0308' '\x0300')
295+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA
296+titleMapping '\x1fe3' s = Yield '\x03a5' (CC s '\x0308' '\x0301')
297+-- GREEK SMALL LETTER RHO WITH PSILI
298+titleMapping '\x1fe4' s = Yield '\x03a1' (CC s '\x0313' '\x0000')
299+-- GREEK SMALL LETTER UPSILON WITH PERISPOMENI
300+titleMapping '\x1fe6' s = Yield '\x03a5' (CC s '\x0342' '\x0000')
301+-- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI
302+titleMapping '\x1fe7' s = Yield '\x03a5' (CC s '\x0308' '\x0342')
303+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI
304+titleMapping '\x1ff6' s = Yield '\x03a9' (CC s '\x0342' '\x0000')
305+-- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI
306+titleMapping '\x1fb2' s = Yield '\x1fba' (CC s '\x0345' '\x0000')
307+-- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
308+titleMapping '\x1fb4' s = Yield '\x0386' (CC s '\x0345' '\x0000')
309+-- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI
310+titleMapping '\x1fc2' s = Yield '\x1fca' (CC s '\x0345' '\x0000')
311+-- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
312+titleMapping '\x1fc4' s = Yield '\x0389' (CC s '\x0345' '\x0000')
313+-- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI
314+titleMapping '\x1ff2' s = Yield '\x1ffa' (CC s '\x0345' '\x0000')
315+-- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
316+titleMapping '\x1ff4' s = Yield '\x038f' (CC s '\x0345' '\x0000')
317+-- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI
318+titleMapping '\x1fb7' s = Yield '\x0391' (CC s '\x0342' '\x0345')
319+-- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI
320+titleMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0345')
321+-- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI
322+titleMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0345')
323+titleMapping c s = Yield (toTitle c) (CC s '\0' '\0')
220324foldMapping :: forall s. Char -> s -> Step (CC s) Char
221−{-# INLINE foldMapping #-}
325+{-# NOINLINE foldMapping #-}
222326-- MICRO SIGN
223327foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')
224328-- LATIN SMALL LETTER SHARP S
@@ -255,6 +359,18 @@ foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000')
255359foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')
256360-- ARMENIAN SMALL LIGATURE ECH YIWN
257361foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000')
362+-- CHEROKEE SMALL LETTER YE
363+foldMapping '\x13f8' s = Yield '\x13f0' (CC s '\x0000' '\x0000')
364+-- CHEROKEE SMALL LETTER YI
365+foldMapping '\x13f9' s = Yield '\x13f1' (CC s '\x0000' '\x0000')
366+-- CHEROKEE SMALL LETTER YO
367+foldMapping '\x13fa' s = Yield '\x13f2' (CC s '\x0000' '\x0000')
368+-- CHEROKEE SMALL LETTER YU
369+foldMapping '\x13fb' s = Yield '\x13f3' (CC s '\x0000' '\x0000')
370+-- CHEROKEE SMALL LETTER YV
371+foldMapping '\x13fc' s = Yield '\x13f4' (CC s '\x0000' '\x0000')
372+-- CHEROKEE SMALL LETTER MV
373+foldMapping '\x13fd' s = Yield '\x13f5' (CC s '\x0000' '\x0000')
258374-- LATIN SMALL LETTER H WITH LINE BELOW
259375foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')
260376-- LATIN SMALL LETTER T WITH DIAERESIS
@@ -429,6 +545,174 @@ foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000')
429545foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')
430546-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
431547foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
548+-- LATIN CAPITAL LETTER J WITH CROSSED-TAIL
549+foldMapping '\xa7b2' s = Yield '\x029d' (CC s '\x0000' '\x0000')
550+-- LATIN CAPITAL LETTER CHI
551+foldMapping '\xa7b3' s = Yield '\xab53' (CC s '\x0000' '\x0000')
552+-- LATIN CAPITAL LETTER BETA
553+foldMapping '\xa7b4' s = Yield '\xa7b5' (CC s '\x0000' '\x0000')
554+-- LATIN CAPITAL LETTER OMEGA
555+foldMapping '\xa7b6' s = Yield '\xa7b7' (CC s '\x0000' '\x0000')
556+-- CHEROKEE SMALL LETTER A
557+foldMapping '\xab70' s = Yield '\x13a0' (CC s '\x0000' '\x0000')
558+-- CHEROKEE SMALL LETTER E
559+foldMapping '\xab71' s = Yield '\x13a1' (CC s '\x0000' '\x0000')
560+-- CHEROKEE SMALL LETTER I
561+foldMapping '\xab72' s = Yield '\x13a2' (CC s '\x0000' '\x0000')
562+-- CHEROKEE SMALL LETTER O
563+foldMapping '\xab73' s = Yield '\x13a3' (CC s '\x0000' '\x0000')
564+-- CHEROKEE SMALL LETTER U
565+foldMapping '\xab74' s = Yield '\x13a4' (CC s '\x0000' '\x0000')
566+-- CHEROKEE SMALL LETTER V
567+foldMapping '\xab75' s = Yield '\x13a5' (CC s '\x0000' '\x0000')
568+-- CHEROKEE SMALL LETTER GA
569+foldMapping '\xab76' s = Yield '\x13a6' (CC s '\x0000' '\x0000')
570+-- CHEROKEE SMALL LETTER KA
571+foldMapping '\xab77' s = Yield '\x13a7' (CC s '\x0000' '\x0000')
572+-- CHEROKEE SMALL LETTER GE
573+foldMapping '\xab78' s = Yield '\x13a8' (CC s '\x0000' '\x0000')
574+-- CHEROKEE SMALL LETTER GI
575+foldMapping '\xab79' s = Yield '\x13a9' (CC s '\x0000' '\x0000')
576+-- CHEROKEE SMALL LETTER GO
577+foldMapping '\xab7a' s = Yield '\x13aa' (CC s '\x0000' '\x0000')
578+-- CHEROKEE SMALL LETTER GU
579+foldMapping '\xab7b' s = Yield '\x13ab' (CC s '\x0000' '\x0000')
580+-- CHEROKEE SMALL LETTER GV
581+foldMapping '\xab7c' s = Yield '\x13ac' (CC s '\x0000' '\x0000')
582+-- CHEROKEE SMALL LETTER HA
583+foldMapping '\xab7d' s = Yield '\x13ad' (CC s '\x0000' '\x0000')
584+-- CHEROKEE SMALL LETTER HE
585+foldMapping '\xab7e' s = Yield '\x13ae' (CC s '\x0000' '\x0000')
586+-- CHEROKEE SMALL LETTER HI
587+foldMapping '\xab7f' s = Yield '\x13af' (CC s '\x0000' '\x0000')
588+-- CHEROKEE SMALL LETTER HO
589+foldMapping '\xab80' s = Yield '\x13b0' (CC s '\x0000' '\x0000')
590+-- CHEROKEE SMALL LETTER HU
591+foldMapping '\xab81' s = Yield '\x13b1' (CC s '\x0000' '\x0000')
592+-- CHEROKEE SMALL LETTER HV
593+foldMapping '\xab82' s = Yield '\x13b2' (CC s '\x0000' '\x0000')
594+-- CHEROKEE SMALL LETTER LA
595+foldMapping '\xab83' s = Yield '\x13b3' (CC s '\x0000' '\x0000')
596+-- CHEROKEE SMALL LETTER LE
597+foldMapping '\xab84' s = Yield '\x13b4' (CC s '\x0000' '\x0000')
598+-- CHEROKEE SMALL LETTER LI
599+foldMapping '\xab85' s = Yield '\x13b5' (CC s '\x0000' '\x0000')
600+-- CHEROKEE SMALL LETTER LO
601+foldMapping '\xab86' s = Yield '\x13b6' (CC s '\x0000' '\x0000')
602+-- CHEROKEE SMALL LETTER LU
603+foldMapping '\xab87' s = Yield '\x13b7' (CC s '\x0000' '\x0000')
604+-- CHEROKEE SMALL LETTER LV
605+foldMapping '\xab88' s = Yield '\x13b8' (CC s '\x0000' '\x0000')
606+-- CHEROKEE SMALL LETTER MA
607+foldMapping '\xab89' s = Yield '\x13b9' (CC s '\x0000' '\x0000')
608+-- CHEROKEE SMALL LETTER ME
609+foldMapping '\xab8a' s = Yield '\x13ba' (CC s '\x0000' '\x0000')
610+-- CHEROKEE SMALL LETTER MI
611+foldMapping '\xab8b' s = Yield '\x13bb' (CC s '\x0000' '\x0000')
612+-- CHEROKEE SMALL LETTER MO
613+foldMapping '\xab8c' s = Yield '\x13bc' (CC s '\x0000' '\x0000')
614+-- CHEROKEE SMALL LETTER MU
615+foldMapping '\xab8d' s = Yield '\x13bd' (CC s '\x0000' '\x0000')
616+-- CHEROKEE SMALL LETTER NA
617+foldMapping '\xab8e' s = Yield '\x13be' (CC s '\x0000' '\x0000')
618+-- CHEROKEE SMALL LETTER HNA
619+foldMapping '\xab8f' s = Yield '\x13bf' (CC s '\x0000' '\x0000')
620+-- CHEROKEE SMALL LETTER NAH
621+foldMapping '\xab90' s = Yield '\x13c0' (CC s '\x0000' '\x0000')
622+-- CHEROKEE SMALL LETTER NE
623+foldMapping '\xab91' s = Yield '\x13c1' (CC s '\x0000' '\x0000')
624+-- CHEROKEE SMALL LETTER NI
625+foldMapping '\xab92' s = Yield '\x13c2' (CC s '\x0000' '\x0000')
626+-- CHEROKEE SMALL LETTER NO
627+foldMapping '\xab93' s = Yield '\x13c3' (CC s '\x0000' '\x0000')
628+-- CHEROKEE SMALL LETTER NU
629+foldMapping '\xab94' s = Yield '\x13c4' (CC s '\x0000' '\x0000')
630+-- CHEROKEE SMALL LETTER NV
631+foldMapping '\xab95' s = Yield '\x13c5' (CC s '\x0000' '\x0000')
632+-- CHEROKEE SMALL LETTER QUA
633+foldMapping '\xab96' s = Yield '\x13c6' (CC s '\x0000' '\x0000')
634+-- CHEROKEE SMALL LETTER QUE
635+foldMapping '\xab97' s = Yield '\x13c7' (CC s '\x0000' '\x0000')
636+-- CHEROKEE SMALL LETTER QUI
637+foldMapping '\xab98' s = Yield '\x13c8' (CC s '\x0000' '\x0000')
638+-- CHEROKEE SMALL LETTER QUO
639+foldMapping '\xab99' s = Yield '\x13c9' (CC s '\x0000' '\x0000')
640+-- CHEROKEE SMALL LETTER QUU
641+foldMapping '\xab9a' s = Yield '\x13ca' (CC s '\x0000' '\x0000')
642+-- CHEROKEE SMALL LETTER QUV
643+foldMapping '\xab9b' s = Yield '\x13cb' (CC s '\x0000' '\x0000')
644+-- CHEROKEE SMALL LETTER SA
645+foldMapping '\xab9c' s = Yield '\x13cc' (CC s '\x0000' '\x0000')
646+-- CHEROKEE SMALL LETTER S
647+foldMapping '\xab9d' s = Yield '\x13cd' (CC s '\x0000' '\x0000')
648+-- CHEROKEE SMALL LETTER SE
649+foldMapping '\xab9e' s = Yield '\x13ce' (CC s '\x0000' '\x0000')
650+-- CHEROKEE SMALL LETTER SI
651+foldMapping '\xab9f' s = Yield '\x13cf' (CC s '\x0000' '\x0000')
652+-- CHEROKEE SMALL LETTER SO
653+foldMapping '\xaba0' s = Yield '\x13d0' (CC s '\x0000' '\x0000')
654+-- CHEROKEE SMALL LETTER SU
655+foldMapping '\xaba1' s = Yield '\x13d1' (CC s '\x0000' '\x0000')
656+-- CHEROKEE SMALL LETTER SV
657+foldMapping '\xaba2' s = Yield '\x13d2' (CC s '\x0000' '\x0000')
658+-- CHEROKEE SMALL LETTER DA
659+foldMapping '\xaba3' s = Yield '\x13d3' (CC s '\x0000' '\x0000')
660+-- CHEROKEE SMALL LETTER TA
661+foldMapping '\xaba4' s = Yield '\x13d4' (CC s '\x0000' '\x0000')
662+-- CHEROKEE SMALL LETTER DE
663+foldMapping '\xaba5' s = Yield '\x13d5' (CC s '\x0000' '\x0000')
664+-- CHEROKEE SMALL LETTER TE
665+foldMapping '\xaba6' s = Yield '\x13d6' (CC s '\x0000' '\x0000')
666+-- CHEROKEE SMALL LETTER DI
667+foldMapping '\xaba7' s = Yield '\x13d7' (CC s '\x0000' '\x0000')
668+-- CHEROKEE SMALL LETTER TI
669+foldMapping '\xaba8' s = Yield '\x13d8' (CC s '\x0000' '\x0000')
670+-- CHEROKEE SMALL LETTER DO
671+foldMapping '\xaba9' s = Yield '\x13d9' (CC s '\x0000' '\x0000')
672+-- CHEROKEE SMALL LETTER DU
673+foldMapping '\xabaa' s = Yield '\x13da' (CC s '\x0000' '\x0000')
674+-- CHEROKEE SMALL LETTER DV
675+foldMapping '\xabab' s = Yield '\x13db' (CC s '\x0000' '\x0000')
676+-- CHEROKEE SMALL LETTER DLA
677+foldMapping '\xabac' s = Yield '\x13dc' (CC s '\x0000' '\x0000')
678+-- CHEROKEE SMALL LETTER TLA
679+foldMapping '\xabad' s = Yield '\x13dd' (CC s '\x0000' '\x0000')
680+-- CHEROKEE SMALL LETTER TLE
681+foldMapping '\xabae' s = Yield '\x13de' (CC s '\x0000' '\x0000')
682+-- CHEROKEE SMALL LETTER TLI
683+foldMapping '\xabaf' s = Yield '\x13df' (CC s '\x0000' '\x0000')
684+-- CHEROKEE SMALL LETTER TLO
685+foldMapping '\xabb0' s = Yield '\x13e0' (CC s '\x0000' '\x0000')
686+-- CHEROKEE SMALL LETTER TLU
687+foldMapping '\xabb1' s = Yield '\x13e1' (CC s '\x0000' '\x0000')
688+-- CHEROKEE SMALL LETTER TLV
689+foldMapping '\xabb2' s = Yield '\x13e2' (CC s '\x0000' '\x0000')
690+-- CHEROKEE SMALL LETTER TSA
691+foldMapping '\xabb3' s = Yield '\x13e3' (CC s '\x0000' '\x0000')
692+-- CHEROKEE SMALL LETTER TSE
693+foldMapping '\xabb4' s = Yield '\x13e4' (CC s '\x0000' '\x0000')
694+-- CHEROKEE SMALL LETTER TSI
695+foldMapping '\xabb5' s = Yield '\x13e5' (CC s '\x0000' '\x0000')
696+-- CHEROKEE SMALL LETTER TSO
697+foldMapping '\xabb6' s = Yield '\x13e6' (CC s '\x0000' '\x0000')
698+-- CHEROKEE SMALL LETTER TSU
699+foldMapping '\xabb7' s = Yield '\x13e7' (CC s '\x0000' '\x0000')
700+-- CHEROKEE SMALL LETTER TSV
701+foldMapping '\xabb8' s = Yield '\x13e8' (CC s '\x0000' '\x0000')
702+-- CHEROKEE SMALL LETTER WA
703+foldMapping '\xabb9' s = Yield '\x13e9' (CC s '\x0000' '\x0000')
704+-- CHEROKEE SMALL LETTER WE
705+foldMapping '\xabba' s = Yield '\x13ea' (CC s '\x0000' '\x0000')
706+-- CHEROKEE SMALL LETTER WI
707+foldMapping '\xabbb' s = Yield '\x13eb' (CC s '\x0000' '\x0000')
708+-- CHEROKEE SMALL LETTER WO
709+foldMapping '\xabbc' s = Yield '\x13ec' (CC s '\x0000' '\x0000')
710+-- CHEROKEE SMALL LETTER WU
711+foldMapping '\xabbd' s = Yield '\x13ed' (CC s '\x0000' '\x0000')
712+-- CHEROKEE SMALL LETTER WV
713+foldMapping '\xabbe' s = Yield '\x13ee' (CC s '\x0000' '\x0000')
714+-- CHEROKEE SMALL LETTER YA
715+foldMapping '\xabbf' s = Yield '\x13ef' (CC s '\x0000' '\x0000')
432716-- LATIN SMALL LIGATURE FF
433717foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')
434718-- LATIN SMALL LIGATURE FI
@@ -453,4 +737,106 @@ foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000')
453737foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')
454738-- ARMENIAN SMALL LIGATURE MEN XEH
455739foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')
740+-- OLD HUNGARIAN CAPITAL LETTER A
741+foldMapping '\x10c80' s = Yield '\x10cc0' (CC s '\x0000' '\x0000')
742+-- OLD HUNGARIAN CAPITAL LETTER AA
743+foldMapping '\x10c81' s = Yield '\x10cc1' (CC s '\x0000' '\x0000')
744+-- OLD HUNGARIAN CAPITAL LETTER EB
745+foldMapping '\x10c82' s = Yield '\x10cc2' (CC s '\x0000' '\x0000')
746+-- OLD HUNGARIAN CAPITAL LETTER AMB
747+foldMapping '\x10c83' s = Yield '\x10cc3' (CC s '\x0000' '\x0000')
748+-- OLD HUNGARIAN CAPITAL LETTER EC
749+foldMapping '\x10c84' s = Yield '\x10cc4' (CC s '\x0000' '\x0000')
750+-- OLD HUNGARIAN CAPITAL LETTER ENC
751+foldMapping '\x10c85' s = Yield '\x10cc5' (CC s '\x0000' '\x0000')
752+-- OLD HUNGARIAN CAPITAL LETTER ECS
753+foldMapping '\x10c86' s = Yield '\x10cc6' (CC s '\x0000' '\x0000')
754+-- OLD HUNGARIAN CAPITAL LETTER ED
755+foldMapping '\x10c87' s = Yield '\x10cc7' (CC s '\x0000' '\x0000')
756+-- OLD HUNGARIAN CAPITAL LETTER AND
757+foldMapping '\x10c88' s = Yield '\x10cc8' (CC s '\x0000' '\x0000')
758+-- OLD HUNGARIAN CAPITAL LETTER E
759+foldMapping '\x10c89' s = Yield '\x10cc9' (CC s '\x0000' '\x0000')
760+-- OLD HUNGARIAN CAPITAL LETTER CLOSE E
761+foldMapping '\x10c8a' s = Yield '\x10cca' (CC s '\x0000' '\x0000')
762+-- OLD HUNGARIAN CAPITAL LETTER EE
763+foldMapping '\x10c8b' s = Yield '\x10ccb' (CC s '\x0000' '\x0000')
764+-- OLD HUNGARIAN CAPITAL LETTER EF
765+foldMapping '\x10c8c' s = Yield '\x10ccc' (CC s '\x0000' '\x0000')
766+-- OLD HUNGARIAN CAPITAL LETTER EG
767+foldMapping '\x10c8d' s = Yield '\x10ccd' (CC s '\x0000' '\x0000')
768+-- OLD HUNGARIAN CAPITAL LETTER EGY
769+foldMapping '\x10c8e' s = Yield '\x10cce' (CC s '\x0000' '\x0000')
770+-- OLD HUNGARIAN CAPITAL LETTER EH
771+foldMapping '\x10c8f' s = Yield '\x10ccf' (CC s '\x0000' '\x0000')
772+-- OLD HUNGARIAN CAPITAL LETTER I
773+foldMapping '\x10c90' s = Yield '\x10cd0' (CC s '\x0000' '\x0000')
774+-- OLD HUNGARIAN CAPITAL LETTER II
775+foldMapping '\x10c91' s = Yield '\x10cd1' (CC s '\x0000' '\x0000')
776+-- OLD HUNGARIAN CAPITAL LETTER EJ
777+foldMapping '\x10c92' s = Yield '\x10cd2' (CC s '\x0000' '\x0000')
778+-- OLD HUNGARIAN CAPITAL LETTER EK
779+foldMapping '\x10c93' s = Yield '\x10cd3' (CC s '\x0000' '\x0000')
780+-- OLD HUNGARIAN CAPITAL LETTER AK
781+foldMapping '\x10c94' s = Yield '\x10cd4' (CC s '\x0000' '\x0000')
782+-- OLD HUNGARIAN CAPITAL LETTER UNK
783+foldMapping '\x10c95' s = Yield '\x10cd5' (CC s '\x0000' '\x0000')
784+-- OLD HUNGARIAN CAPITAL LETTER EL
785+foldMapping '\x10c96' s = Yield '\x10cd6' (CC s '\x0000' '\x0000')
786+-- OLD HUNGARIAN CAPITAL LETTER ELY
787+foldMapping '\x10c97' s = Yield '\x10cd7' (CC s '\x0000' '\x0000')
788+-- OLD HUNGARIAN CAPITAL LETTER EM
789+foldMapping '\x10c98' s = Yield '\x10cd8' (CC s '\x0000' '\x0000')
790+-- OLD HUNGARIAN CAPITAL LETTER EN
791+foldMapping '\x10c99' s = Yield '\x10cd9' (CC s '\x0000' '\x0000')
792+-- OLD HUNGARIAN CAPITAL LETTER ENY
793+foldMapping '\x10c9a' s = Yield '\x10cda' (CC s '\x0000' '\x0000')
794+-- OLD HUNGARIAN CAPITAL LETTER O
795+foldMapping '\x10c9b' s = Yield '\x10cdb' (CC s '\x0000' '\x0000')
796+-- OLD HUNGARIAN CAPITAL LETTER OO
797+foldMapping '\x10c9c' s = Yield '\x10cdc' (CC s '\x0000' '\x0000')
798+-- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG OE
799+foldMapping '\x10c9d' s = Yield '\x10cdd' (CC s '\x0000' '\x0000')
800+-- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA OE
801+foldMapping '\x10c9e' s = Yield '\x10cde' (CC s '\x0000' '\x0000')
802+-- OLD HUNGARIAN CAPITAL LETTER OEE
803+foldMapping '\x10c9f' s = Yield '\x10cdf' (CC s '\x0000' '\x0000')
804+-- OLD HUNGARIAN CAPITAL LETTER EP
805+foldMapping '\x10ca0' s = Yield '\x10ce0' (CC s '\x0000' '\x0000')
806+-- OLD HUNGARIAN CAPITAL LETTER EMP
807+foldMapping '\x10ca1' s = Yield '\x10ce1' (CC s '\x0000' '\x0000')
808+-- OLD HUNGARIAN CAPITAL LETTER ER
809+foldMapping '\x10ca2' s = Yield '\x10ce2' (CC s '\x0000' '\x0000')
810+-- OLD HUNGARIAN CAPITAL LETTER SHORT ER
811+foldMapping '\x10ca3' s = Yield '\x10ce3' (CC s '\x0000' '\x0000')
812+-- OLD HUNGARIAN CAPITAL LETTER ES
813+foldMapping '\x10ca4' s = Yield '\x10ce4' (CC s '\x0000' '\x0000')
814+-- OLD HUNGARIAN CAPITAL LETTER ESZ
815+foldMapping '\x10ca5' s = Yield '\x10ce5' (CC s '\x0000' '\x0000')
816+-- OLD HUNGARIAN CAPITAL LETTER ET
817+foldMapping '\x10ca6' s = Yield '\x10ce6' (CC s '\x0000' '\x0000')
818+-- OLD HUNGARIAN CAPITAL LETTER ENT
819+foldMapping '\x10ca7' s = Yield '\x10ce7' (CC s '\x0000' '\x0000')
820+-- OLD HUNGARIAN CAPITAL LETTER ETY
821+foldMapping '\x10ca8' s = Yield '\x10ce8' (CC s '\x0000' '\x0000')
822+-- OLD HUNGARIAN CAPITAL LETTER ECH
823+foldMapping '\x10ca9' s = Yield '\x10ce9' (CC s '\x0000' '\x0000')
824+-- OLD HUNGARIAN CAPITAL LETTER U
825+foldMapping '\x10caa' s = Yield '\x10cea' (CC s '\x0000' '\x0000')
826+-- OLD HUNGARIAN CAPITAL LETTER UU
827+foldMapping '\x10cab' s = Yield '\x10ceb' (CC s '\x0000' '\x0000')
828+-- OLD HUNGARIAN CAPITAL LETTER NIKOLSBURG UE
829+foldMapping '\x10cac' s = Yield '\x10cec' (CC s '\x0000' '\x0000')
830+-- OLD HUNGARIAN CAPITAL LETTER RUDIMENTA UE
831+foldMapping '\x10cad' s = Yield '\x10ced' (CC s '\x0000' '\x0000')
832+-- OLD HUNGARIAN CAPITAL LETTER EV
833+foldMapping '\x10cae' s = Yield '\x10cee' (CC s '\x0000' '\x0000')
834+-- OLD HUNGARIAN CAPITAL LETTER EZ
835+foldMapping '\x10caf' s = Yield '\x10cef' (CC s '\x0000' '\x0000')
836+-- OLD HUNGARIAN CAPITAL LETTER EZS
837+foldMapping '\x10cb0' s = Yield '\x10cf0' (CC s '\x0000' '\x0000')
838+-- OLD HUNGARIAN CAPITAL LETTER ENT-SHAPED SIGN
839+foldMapping '\x10cb1' s = Yield '\x10cf1' (CC s '\x0000' '\x0000')
840+-- OLD HUNGARIAN CAPITAL LETTER US
841+foldMapping '\x10cb2' s = Yield '\x10cf2' (CC s '\x0000' '\x0000')
456842foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
Data/Text/Fusion/Common.hs → Data/Text/Internal/Fusion/Common.hsrenamed+153−89
@@ -1,22 +1,26 @@
1−{-# LANGUAGE BangPatterns, Rank2Types #-}
1+{-# LANGUAGE BangPatterns, MagicHash, Rank2Types #-}
22-- |
3−-- Module : Data.Text.Fusion.Common
4−-- Copyright : (c) Bryan O'Sullivan 2009
3+-- Module : Data.Text.Internal.Fusion.Common
4+-- Copyright : (c) Bryan O'Sullivan 2009, 2012
55--
66-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8−-- duncan@haskell.org
7+-- Maintainer : bos@serpentine.com
98-- Stability : experimental
109-- Portability : GHC
1110--
11+-- /Warning/: this is an internal module, and does not have a stable
12+-- API or name. Functions in this module may not check or enforce
13+-- preconditions expected by public modules. Use at your own risk!
14+--
1215-- Common stream fusion functionality for text.
1316
14−module Data.Text.Fusion.Common
17+module Data.Text.Internal.Fusion.Common
1518 (
1619 -- * Creation and elimination
1720 singleton
1821 , streamList
1922 , unstreamList
23+ , streamCString#
2024
2125 -- * Basic interface
2226 , cons
@@ -41,6 +45,7 @@ module Data.Text.Fusion.Common
4145 -- $case
4246 , toCaseFold
4347 , toLower
48+ , toTitle
4449 , toUpper
4550
4651 -- ** Justification
@@ -66,9 +71,6 @@ module Data.Text.Fusion.Common
6671 -- ** Scans
6772 , scanl
6873
69− -- ** Accumulating maps
70− -- , mapAccumL
71−
7274 -- ** Generation and unfolding
7375 , replicateCharI
7476 , replicateI
@@ -104,16 +106,21 @@ import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),
104106 (&&), fromIntegral, otherwise)
105107import qualified Data.List as L
106108import qualified Prelude as P
109+import Data.Bits (shiftL)
110+import Data.Char (isLetter)
107111import Data.Int (Int64)
108−import Data.Text.Fusion.Internal
109−import Data.Text.Fusion.CaseMapping (foldMapping, lowerMapping, upperMapping)
110−import Data.Text.Fusion.Size
112+import Data.Text.Internal.Fusion.Types
113+import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping,
114+ upperMapping)
115+import Data.Text.Internal.Fusion.Size
116+import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)
117+import GHC.Types (Char(..), Int(..))
111118
112119singleton :: Char -> Stream Char
113120singleton c = Stream next False 1
114121 where next False = Yield c True
115122 next True = Done
116−{-# INLINE singleton #-}
123+{-# INLINE [0] singleton #-}
117124
118125streamList :: [a] -> Stream a
119126{-# INLINE [0] streamList #-}
@@ -131,6 +138,35 @@ unstreamList (Stream next s0 _len) = unfold s0
131138
132139{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}
133140
141+-- | Stream the UTF-8-like packed encoding used by GHC to represent
142+-- constant strings in generated code.
143+--
144+-- This encoding uses the byte sequence "\xc0\x80" to represent NUL,
145+-- and the string is NUL-terminated.
146+streamCString# :: Addr# -> Stream Char
147+streamCString# addr = Stream step 0 unknownSize
148+ where
149+ step !i
150+ | b == 0 = Done
151+ | b <= 0x7f = Yield (C# b#) (i+1)
152+ | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1
153+ in Yield c (i+2)
154+ | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) +
155+ (next 1 `shiftL` 6) +
156+ next 2
157+ in Yield c (i+3)
158+ | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) +
159+ (next 1 `shiftL` 12) +
160+ (next 2 `shiftL` 6) +
161+ next 3
162+ in Yield c (i+4)
163+ where b = I# (ord# b#)
164+ next n = I# (ord# (at# (i+n))) - 0x80
165+ !b# = at# i
166+ at# (I# i#) = indexCharOffAddr# addr i#
167+ chr (I# i#) = C# (chr# i#)
168+{-# INLINE [0] streamCString# #-}
169+
134170-- ----------------------------------------------------------------------------
135171-- * Basic stream functions
136172
@@ -139,7 +175,7 @@ data C s = C0 !s
139175
140176-- | /O(n)/ Adds a character to the front of a Stream Char.
141177cons :: Char -> Stream Char -> Stream Char
142−cons w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
178+cons !w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
143179 where
144180 next (C1 s) = Yield w (C0 s)
145181 next (C0 s) = case next0 s of
@@ -148,6 +184,9 @@ cons w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
148184 Yield x s' -> Yield x (C0 s')
149185{-# INLINE [0] cons #-}
150186
187+data Snoc a = N
188+ | J !a
189+
151190-- | /O(n)/ Adds a character to the end of a stream.
152191snoc :: Stream Char -> Char -> Stream Char
153192snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)
@@ -185,9 +224,13 @@ head (Stream next s0 _len) = loop_head s0
185224 loop_head !s = case next s of
186225 Yield x _ -> x
187226 Skip s' -> loop_head s'
188− Done -> streamError "head" "Empty stream"
227+ Done -> head_empty
189228{-# INLINE [0] head #-}
190229
230+head_empty :: a
231+head_empty = streamError "head" "Empty stream"
232+{-# NOINLINE head_empty #-}
233+
191234-- | /O(1)/ Returns the first character and remainder of a 'Stream
192235-- Char', or 'Nothing' if empty. Subject to array fusion.
193236uncons :: Stream Char -> Maybe (Char, Stream Char)
@@ -272,12 +315,13 @@ lengthI (Stream next s0 _len) = loop_length 0 s0
272315--
273316-- This function gives the same answer as comparing against the result
274317-- of 'lengthI', but can short circuit if the count of characters is
275−-- greater than the number, and hence be more efficient.
318+-- greater than the number or if the stream can't possibly be as long
319+-- as the number supplied, and hence be more efficient.
276320compareLengthI :: Integral a => Stream Char -> a -> Ordering
277−compareLengthI (Stream next s0 len) n =
278− case exactly len of
321+compareLengthI (Stream next s0 len) n =
322+ case compareSize len (fromIntegral n) of
323+ Just o -> o
279324 Nothing -> loop_cmp 0 s0
280− Just i -> compare (fromIntegral i) n
281325 where
282326 loop_cmp !z s = case next s of
283327 Done -> compare z n
@@ -395,17 +439,54 @@ toLower :: Stream Char -> Stream Char
395439toLower = caseConvert lowerMapping
396440{-# INLINE [0] toLower #-}
397441
442+-- | /O(n)/ Convert a string to title case, using simple case
443+-- conversion.
444+--
445+-- The first letter of the input is converted to title case, as is
446+-- every subsequent letter that immediately follows a non-letter.
447+-- Every letter that immediately follows another letter is converted
448+-- to lower case.
449+--
450+-- The result string may be longer than the input string. For example,
451+-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
452+-- sequence Latin capital letter F (U+0046) followed by Latin small
453+-- letter l (U+006C).
454+--
455+-- /Note/: this function does not take language or culture specific
456+-- rules into account. For instance, in English, different style
457+-- guides disagree on whether the book name \"The Hill of the Red
458+-- Fox\" is correctly title cased&#x2014;but this function will
459+-- capitalize /every/ word.
460+toTitle :: Stream Char -> Stream Char
461+toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') len
462+ where
463+ next (CC (letter :*: s) '\0' _) =
464+ case next0 s of
465+ Done -> Done
466+ Skip s' -> Skip (CC (letter :*: s') '\0' '\0')
467+ Yield c s'
468+ | letter' -> if letter
469+ then lowerMapping c (letter' :*: s')
470+ else titleMapping c (letter' :*: s')
471+ | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0')
472+ where letter' = isLetter c
473+ next (CC s a b) = Yield a (CC s b '\0')
474+{-# INLINE [0] toTitle #-}
475+
476+data Justify i s = Just1 !i !s
477+ | Just2 !i !s
478+
398479justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char
399480justifyLeftI k c (Stream next0 s0 len) =
400− Stream next (s0 :*: S1 :*: 0) (larger (fromIntegral k) len)
481+ Stream next (Just1 0 s0) (larger (fromIntegral k) len)
401482 where
402− next (s :*: S1 :*: n) =
483+ next (Just1 n s) =
403484 case next0 s of
404− Done -> next (s :*: S2 :*: n)
405− Skip s' -> Skip (s' :*: S1 :*: n)
406− Yield x s' -> Yield x (s' :*: S1 :*: n+1)
407− next (s :*: S2 :*: n)
408− | n < k = Yield c (s :*: S2 :*: n+1)
485+ Done -> next (Just2 n s)
486+ Skip s' -> Skip (Just1 n s')
487+ Yield x s' -> Yield x (Just1 (n+1) s')
488+ next (Just2 n s)
489+ | n < k = Yield c (Just2 (n+1) s)
409490 | otherwise = Done
410491 {-# INLINE next #-}
411492{-# INLINE [0] justifyLeftI #-}
@@ -512,7 +593,7 @@ concatMap f = foldr (append . f) empty
512593{-# INLINE [0] concatMap #-}
513594
514595-- | /O(n)/ any @p @xs determines if any character in the stream
515−-- @xs@ satisifes the predicate @p@.
596+-- @xs@ satisfies the predicate @p@.
516597any :: (Char -> Bool) -> Stream Char -> Bool
517598any p (Stream next0 s0 _len) = loop_any s0
518599 where
@@ -524,7 +605,7 @@ any p (Stream next0 s0 _len) = loop_any s0
524605{-# INLINE [0] any #-}
525606
526607-- | /O(n)/ all @p @xs determines if all characters in the 'Text'
527−-- @xs@ satisify the predicate @p@.
608+-- @xs@ satisfy the predicate @p@.
528609all :: (Char -> Bool) -> Stream Char -> Bool
529610all p (Stream next0 s0 _len) = loop_all s0
530611 where
@@ -573,50 +654,27 @@ minimum (Stream next0 s0 _len) = loop0_minimum s0
573654-- * Building streams
574655
575656scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
576−scanl f z0 (Stream next0 s0 len) = Stream next (S1 :*: z0 :*: s0) (len+1) -- HINT maybe too low
657+scanl f z0 (Stream next0 s0 len) = Stream next (Scan1 z0 s0) (len+1) -- HINT maybe too low
577658 where
578659 {-# INLINE next #-}
579− next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s)
580− next (S2 :*: z :*: s) = case next0 s of
581− Yield x s' -> let !x' = f z x
582− in Yield x' (S2 :*: x' :*: s')
583− Skip s' -> Skip (S2 :*: z :*: s')
584− Done -> Done
660+ next (Scan1 z s) = Yield z (Scan2 z s)
661+ next (Scan2 z s) = case next0 s of
662+ Yield x s' -> let !x' = f z x
663+ in Yield x' (Scan2 x' s')
664+ Skip s' -> Skip (Scan2 z s')
665+ Done -> Done
585666{-# INLINE [0] scanl #-}
586667
587−-- -----------------------------------------------------------------------------
588−-- ** Accumulating maps
589−
590−{-
591−-- | /O(n)/ Like a combination of 'map' and 'foldl'. Applies a
592−-- function to each element of a stream, passing an accumulating
593−-- parameter from left to right, and returns a final stream.
594−--
595−-- /Note/: Unlike the version over lists, this function does not
596−-- return a final value for the accumulator, because the nature of
597−-- streams precludes it.
598−mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b
599−mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :*: z0) len -- HINT depends on f
600− where
601− {-# INLINE next #-}
602− next (s :*: z) = case next0 s of
603− Yield x s' -> let (z',y) = f z x
604− in Yield y (s' :*: z')
605− Skip s' -> Skip (s' :*: z)
606− Done -> Done
607−{-# INLINE [0] mapAccumL #-}
608−-}
609−
610668-- -----------------------------------------------------------------------------
611669-- ** Generating and unfolding streams
612670
613671replicateCharI :: Integral a => a -> Char -> Stream Char
614−replicateCharI n c
672+replicateCharI !n !c
615673 | n < 0 = empty
616674 | otherwise = Stream next 0 (fromIntegral n) -- HINT maybe too low
617675 where
618− next i | i >= n = Done
619− | otherwise = Yield c (i + 1)
676+ next !i | i >= n = Done
677+ | otherwise = Yield c (i + 1)
620678{-# INLINE [0] replicateCharI #-}
621679
622680data RI s = RI !s {-# UNPACK #-} !Int64
@@ -681,24 +739,27 @@ take n0 (Stream next0 s0 len) =
681739 Yield x s' -> Yield x ((n-1) :*: s')
682740{-# INLINE [0] take #-}
683741
742+data Drop a s = NS !s
743+ | JS !a !s
744+
684745-- | /O(n)/ drop n, applied to a stream, returns the suffix of the
685746-- stream after the first @n@ characters, or the empty stream if @n@
686747-- is greater than the length of the stream.
687748drop :: Integral a => a -> Stream Char -> Stream Char
688749drop n0 (Stream next0 s0 len) =
689− Stream next (J n0 :*: s0) (len - fromIntegral (max 0 n0))
750+ Stream next (JS n0 s0) (len - fromIntegral (max 0 n0))
690751 where
691752 {-# INLINE next #-}
692− next (J n :*: s)
693− | n <= 0 = Skip (N :*: s)
753+ next (JS n s)
754+ | n <= 0 = Skip (NS s)
694755 | otherwise = case next0 s of
695756 Done -> Done
696− Skip s' -> Skip (J n :*: s')
697− Yield _ s' -> Skip (J (n-1) :*: s')
698− next (N :*: s) = case next0 s of
757+ Skip s' -> Skip (JS n s')
758+ Yield _ s' -> Skip (JS (n-1) s')
759+ next (NS s) = case next0 s of
699760 Done -> Done
700− Skip s' -> Skip (N :*: s')
701− Yield x s' -> Yield x (N :*: s')
761+ Skip s' -> Skip (NS s')
762+ Yield x s' -> Yield x (NS s')
702763{-# INLINE [0] drop #-}
703764
704765-- | takeWhile, applied to a predicate @p@ and a stream, returns the
@@ -716,18 +777,18 @@ takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
716777
717778-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
718779dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
719−dropWhile p (Stream next0 s0 len) = Stream next (S1 :*: s0) len -- HINT maybe too high
780+dropWhile p (Stream next0 s0 len) = Stream next (L s0) len -- HINT maybe too high
720781 where
721782 {-# INLINE next #-}
722− next (S1 :*: s) = case next0 s of
783+ next (L s) = case next0 s of
723784 Done -> Done
724− Skip s' -> Skip (S1 :*: s')
725− Yield x s' | p x -> Skip (S1 :*: s')
726− | otherwise -> Yield x (S2 :*: s')
727− next (S2 :*: s) = case next0 s of
785+ Skip s' -> Skip (L s')
786+ Yield x s' | p x -> Skip (L s')
787+ | otherwise -> Yield x (R s')
788+ next (R s) = case next0 s of
728789 Done -> Done
729− Skip s' -> Skip (S2 :*: s')
730− Yield x s' -> Yield x (S2 :*: s')
790+ Skip s' -> Skip (R s')
791+ Yield x s' -> Yield x (R s')
731792{-# INLINE [0] dropWhile #-}
732793
733794-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns
@@ -743,7 +804,6 @@ isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
743804 loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
744805 loop (next1 s1') (next2 s2')
745806{-# INLINE [0] isPrefixOf #-}
746−{-# SPECIALISE isPrefixOf :: Stream Char -> Stream Char -> Bool #-}
747807
748808-- ----------------------------------------------------------------------------
749809-- * Searching
@@ -835,21 +895,25 @@ findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0
835895-------------------------------------------------------------------------------
836896-- * Zipping
837897
898+-- | Strict triple.
899+data Zip a b m = Z1 !a !b
900+ | Z2 !a !b !m
901+
838902-- | zipWith generalises 'zip' by zipping with the function given as
839903-- the first argument, instead of a tupling function.
840904zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b
841905zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) =
842− Stream next (sa0 :*: sb0 :*: N) (smaller len1 len2)
906+ Stream next (Z1 sa0 sb0) (smaller len1 len2)
843907 where
844− next (sa :*: sb :*: N) = case next0 sa of
845− Done -> Done
846− Skip sa' -> Skip (sa' :*: sb :*: N)
847− Yield a sa' -> Skip (sa' :*: sb :*: J a)
848−
849− next (sa' :*: sb :*: J a) = case next1 sb of
850− Done -> Done
851− Skip sb' -> Skip (sa' :*: sb' :*: J a)
852− Yield b sb' -> Yield (f a b) (sa' :*: sb' :*: N)
908+ next (Z1 sa sb) = case next0 sa of
909+ Done -> Done
910+ Skip sa' -> Skip (Z1 sa' sb)
911+ Yield a sa' -> Skip (Z2 sa' sb a)
912+
913+ next (Z2 sa' sb a) = case next1 sb of
914+ Done -> Done
915+ Skip sb' -> Skip (Z2 sa' sb' a)
916+ Yield b sb' -> Yield (f a b) (Z1 sa' sb')
853917{-# INLINE [0] zipWith #-}
854918
855919-- | /O(n)/ The 'countCharI' function returns the number of times the
@@ -865,7 +929,7 @@ countCharI a (Stream next s0 _len) = loop 0 s0
865929{-# INLINE [0] countCharI #-}
866930
867931streamError :: String -> String -> a
868−streamError func msg = P.error $ "Data.Text.Fusion.Common." ++ func ++ ": " ++ msg
932+streamError func msg = P.error $ "Data.Text.Internal.Fusion.Common." ++ func ++ ": " ++ msg
869933
870934emptyError :: String -> a
871935emptyError func = internalError func "Empty input"
Data/Text/Internal/Fusion/Size.hsnew file+157
@@ -0,0 +1,157 @@
1+{-# LANGUAGE CPP #-}
2+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
3+-- |
4+-- Module : Data.Text.Internal.Fusion.Internal
5+-- Copyright : (c) Roman Leshchinskiy 2008,
6+-- (c) Bryan O'Sullivan 2009
7+--
8+-- License : BSD-style
9+-- Maintainer : bos@serpentine.com
10+-- Stability : experimental
11+-- Portability : portable
12+--
13+-- /Warning/: this is an internal module, and does not have a stable
14+-- API or name. Functions in this module may not check or enforce
15+-- preconditions expected by public modules. Use at your own risk!
16+--
17+-- Size hints.
18+
19+module Data.Text.Internal.Fusion.Size
20+ (
21+ Size
22+ , exactly
23+ , exactSize
24+ , maxSize
25+ , betweenSize
26+ , unknownSize
27+ , smaller
28+ , larger
29+ , upperBound
30+ , lowerBound
31+ , compareSize
32+ , isEmpty
33+ ) where
34+
35+import Data.Text.Internal (mul)
36+#if defined(ASSERTS)
37+import Control.Exception (assert)
38+#endif
39+
40+data Size = Between {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ Lower and upper bounds on size.
41+ | Unknown -- ^ Unknown size.
42+ deriving (Eq, Show)
43+
44+exactly :: Size -> Maybe Int
45+exactly (Between na nb) | na == nb = Just na
46+exactly _ = Nothing
47+{-# INLINE exactly #-}
48+
49+exactSize :: Int -> Size
50+exactSize n =
51+#if defined(ASSERTS)
52+ assert (n >= 0)
53+#endif
54+ Between n n
55+{-# INLINE exactSize #-}
56+
57+maxSize :: Int -> Size
58+maxSize n =
59+#if defined(ASSERTS)
60+ assert (n >= 0)
61+#endif
62+ Between 0 n
63+{-# INLINE maxSize #-}
64+
65+betweenSize :: Int -> Int -> Size
66+betweenSize m n =
67+#if defined(ASSERTS)
68+ assert (m >= 0)
69+ assert (n >= m)
70+#endif
71+ Between m n
72+{-# INLINE betweenSize #-}
73+
74+unknownSize :: Size
75+unknownSize = Unknown
76+{-# INLINE unknownSize #-}
77+
78+instance Num Size where
79+ (+) = addSize
80+ (-) = subtractSize
81+ (*) = mulSize
82+
83+ fromInteger = f where f = exactSize . fromInteger
84+ {-# INLINE f #-}
85+
86+add :: Int -> Int -> Int
87+add m n | mn >= 0 = mn
88+ | otherwise = overflowError
89+ where mn = m + n
90+{-# INLINE add #-}
91+
92+addSize :: Size -> Size -> Size
93+addSize (Between ma mb) (Between na nb) = Between (add ma na) (add mb nb)
94+addSize _ _ = Unknown
95+{-# INLINE addSize #-}
96+
97+subtractSize :: Size -> Size -> Size
98+subtractSize (Between ma mb) (Between na nb) = Between (max (ma-nb) 0) (max (mb-na) 0)
99+subtractSize a@(Between 0 _) Unknown = a
100+subtractSize (Between _ mb) Unknown = Between 0 mb
101+subtractSize _ _ = Unknown
102+{-# INLINE subtractSize #-}
103+
104+mulSize :: Size -> Size -> Size
105+mulSize (Between ma mb) (Between na nb) = Between (mul ma na) (mul mb nb)
106+mulSize _ _ = Unknown
107+{-# INLINE mulSize #-}
108+
109+-- | Minimum of two size hints.
110+smaller :: Size -> Size -> Size
111+smaller a@(Between ma mb) b@(Between na nb)
112+ | mb <= na = a
113+ | nb <= ma = b
114+ | otherwise = Between (ma `min` na) (mb `min` nb)
115+smaller a@(Between 0 _) Unknown = a
116+smaller (Between _ mb) Unknown = Between 0 mb
117+smaller Unknown b@(Between 0 _) = b
118+smaller Unknown (Between _ nb) = Between 0 nb
119+smaller Unknown Unknown = Unknown
120+{-# INLINE smaller #-}
121+
122+-- | Maximum of two size hints.
123+larger :: Size -> Size -> Size
124+larger a@(Between ma mb) b@(Between na nb)
125+ | ma >= nb = a
126+ | na >= mb = b
127+ | otherwise = Between (ma `max` na) (mb `max` nb)
128+larger _ _ = Unknown
129+{-# INLINE larger #-}
130+
131+-- | Compute the maximum size from a size hint, if possible.
132+upperBound :: Int -> Size -> Int
133+upperBound _ (Between _ n) = n
134+upperBound k _ = k
135+{-# INLINE upperBound #-}
136+
137+-- | Compute the maximum size from a size hint, if possible.
138+lowerBound :: Int -> Size -> Int
139+lowerBound _ (Between n _) = n
140+lowerBound k _ = k
141+{-# INLINE lowerBound #-}
142+
143+compareSize :: Size -> Int -> Maybe Ordering
144+compareSize (Between ma mb) n
145+ | mb < n = Just LT
146+ | ma > n = Just GT
147+ | ma == n && mb == n = Just EQ
148+compareSize _ _ = Nothing
149+
150+
151+isEmpty :: Size -> Bool
152+isEmpty (Between _ n) = n <= 0
153+isEmpty _ = False
154+{-# INLINE isEmpty #-}
155+
156+overflowError :: Int
157+overflowError = error "Data.Text.Internal.Fusion.Size: size overflow"
Data/Text/Fusion/Internal.hs → Data/Text/Internal/Fusion/Types.hsrenamed+24−23
@@ -1,53 +1,56 @@
11{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
22-- |
3−-- Module : Data.Text.Fusion.Internal
3+-- Module : Data.Text.Internal.Fusion.Types
44-- Copyright : (c) Tom Harper 2008-2009,
55-- (c) Bryan O'Sullivan 2009,
6−-- (c) Duncan Coutts 2009
6+-- (c) Duncan Coutts 2009,
7+-- (c) Jasper Van der Jeugt 2011
78--
89-- License : BSD-style
9−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10−-- duncan@haskell.org
10+-- Maintainer : bos@serpentine.com
1111-- Stability : experimental
1212-- Portability : GHC
1313--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
1418-- Core stream fusion functionality for text.
1519
16−module Data.Text.Fusion.Internal
20+module Data.Text.Internal.Fusion.Types
1721 (
1822 CC(..)
19− , M(..)
20− , M8
2123 , PairS(..)
22− , S(..)
24+ , Scan(..)
25+ , RS(..)
2326 , Step(..)
2427 , Stream(..)
25− , Switch(..)
2628 , empty
2729 ) where
2830
29−import Data.Text.Fusion.Size
31+import Data.Text.Internal.Fusion.Size
3032import Data.Word (Word8)
3133
3234-- | Specialised tuple for case conversion.
3335data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
3436
35−-- | Specialised, strict Maybe-like type.
36−data M a = N
37− | J !a
38−
39−type M8 = M Word8
40−
41−-- Restreaming state.
42−data S s = S !s !M8 !M8 !M8
37+-- | Restreaming state.
38+data RS s
39+ = RS0 !s
40+ | RS1 !s {-# UNPACK #-} !Word8
41+ | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
42+ | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
4343
44−infixl 2 :*:
44+-- | Strict pair.
4545data PairS a b = !a :*: !b
4646 -- deriving (Eq, Ord, Show)
47+infixl 2 :*:
4748
48−-- | Allow a function over a stream to switch between two states.
49−data Switch = S1 | S2
49+-- | An intermediate result in a scan.
50+data Scan s = Scan1 {-# UNPACK #-} !Char !s
51+ | Scan2 {-# UNPACK #-} !Char !s
5052
53+-- | Intermediate result in a processing pipeline.
5154data Step s a = Done
5255 | Skip !s
5356 | Yield !a !s
@@ -96,7 +99,6 @@ eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
9699 loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
97100 loop (next1 s1') (next2 s2')
98101{-# INLINE [0] eq #-}
99−{-# SPECIALISE eq :: Stream Char -> Stream Char -> Bool #-}
100102
101103cmp :: (Ord a) => Stream a -> Stream a -> Ordering
102104cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
@@ -112,7 +114,6 @@ cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
112114 EQ -> loop (next1 s1') (next2 s2')
113115 other -> other
114116{-# INLINE [0] cmp #-}
115−{-# SPECIALISE cmp :: Stream Char -> Stream Char -> Ordering #-}
116117
117118-- | The empty stream.
118119empty :: Stream a
Data/Text/IO/Internal.hs → Data/Text/Internal/IO.hsrenamed+13−12
@@ -1,6 +1,6 @@
11{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
22-- |
3−-- Module : Data.Text.IO.Internal
3+-- Module : Data.Text.Internal.IO
44-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
55-- (c) 2009 Simon Marlow
66-- License : BSD-style
@@ -8,22 +8,24 @@
88-- Stability : experimental
99-- Portability : GHC
1010--
11+-- /Warning/: this is an internal module, and does not have a stable
12+-- API or name. Functions in this module may not check or enforce
13+-- preconditions expected by public modules. Use at your own risk!
14+--
1115-- Low-level support for text I\/O.
1216
13−module Data.Text.IO.Internal
17+module Data.Text.Internal.IO
1418 (
15−#if __GLASGOW_HASKELL__ >= 612
1619 hGetLineWith
1720 , readChunk
18−#endif
1921 ) where
2022
21−#if __GLASGOW_HASKELL__ >= 612
23+import qualified Control.Exception as E
2224import Data.IORef (readIORef, writeIORef)
2325import Data.Text (Text)
24−import Data.Text.Fusion (unstream)
25−import Data.Text.Fusion.Internal (Step(..), Stream(..))
26−import Data.Text.Fusion.Size (exactSize, maxSize)
26+import Data.Text.Internal.Fusion (unstream)
27+import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
28+import Data.Text.Internal.Fusion.Size (exactSize, maxSize)
2729import Data.Text.Unsafe (inlinePerformIO)
2830import Foreign.Storable (peekElemOff)
2931import GHC.IO.Buffer (Buffer(..), CharBuffer, RawCharBuffer, bufferAdjustL,
@@ -82,9 +84,9 @@ hGetLineLoop hh@Handle__{..} = go where
8284-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
8385maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
8486maybeFillReadBuffer handle_ buf
85− = catch (Just `fmap` getSomeCharacters handle_ buf) $ \e ->
86− if isEOFError e
87− then return Nothing
87+ = E.catch (Just `fmap` getSomeCharacters handle_ buf) $ \e ->
88+ if isEOFError e
89+ then return Nothing
8890 else ioError e
8991
9092unpack :: RawCharBuffer -> Int -> Int -> IO Text
@@ -162,4 +164,3 @@ readChunk hh@Handle__{..} buf = do
162164
163165sizeError :: String -> a
164166sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size"
165−#endif
Data/Text/Internal/Lazy.hsnew file+119
@@ -0,0 +1,119 @@
1+{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
2+{-# OPTIONS_HADDOCK not-home #-}
3+
4+-- |
5+-- Module : Data.Text.Internal.Lazy
6+-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
7+--
8+-- License : BSD-style
9+-- Maintainer : bos@serpentine.com
10+-- Stability : experimental
11+-- Portability : GHC
12+--
13+-- /Warning/: this is an internal module, and does not have a stable
14+-- API or name. Functions in this module may not check or enforce
15+-- preconditions expected by public modules. Use at your own risk!
16+--
17+-- A module containing private 'Text' internals. This exposes the
18+-- 'Text' representation and low level construction functions.
19+-- Modules which extend the 'Text' system may need to use this module.
20+
21+module Data.Text.Internal.Lazy
22+ (
23+ Text(..)
24+ , chunk
25+ , empty
26+ , foldrChunks
27+ , foldlChunks
28+ -- * Data type invariant and abstraction functions
29+
30+ -- $invariant
31+ , strictInvariant
32+ , lazyInvariant
33+ , showStructure
34+
35+ -- * Chunk allocation sizes
36+ , defaultChunkSize
37+ , smallChunkSize
38+ , chunkOverhead
39+ ) where
40+
41+import Data.Text ()
42+import Data.Text.Internal.Unsafe.Shift (shiftL)
43+import Data.Typeable (Typeable)
44+import Foreign.Storable (sizeOf)
45+import qualified Data.Text.Internal as T
46+
47+data Text = Empty
48+ | Chunk {-# UNPACK #-} !T.Text Text
49+ deriving (Typeable)
50+
51+-- $invariant
52+--
53+-- The data type invariant for lazy 'Text': Every 'Text' is either 'Empty' or
54+-- consists of non-null 'T.Text's. All functions must preserve this,
55+-- and the QC properties must check this.
56+
57+-- | Check the invariant strictly.
58+strictInvariant :: Text -> Bool
59+strictInvariant Empty = True
60+strictInvariant x@(Chunk (T.Text _ _ len) cs)
61+ | len > 0 = strictInvariant cs
62+ | otherwise = error $ "Data.Text.Lazy: invariant violation: "
63+ ++ showStructure x
64+
65+-- | Check the invariant lazily.
66+lazyInvariant :: Text -> Text
67+lazyInvariant Empty = Empty
68+lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)
69+ | len > 0 = Chunk c (lazyInvariant cs)
70+ | otherwise = error $ "Data.Text.Lazy: invariant violation: "
71+ ++ showStructure x
72+
73+-- | Display the internal structure of a lazy 'Text'.
74+showStructure :: Text -> String
75+showStructure Empty = "Empty"
76+showStructure (Chunk t Empty) = "Chunk " ++ show t ++ " Empty"
77+showStructure (Chunk t ts) =
78+ "Chunk " ++ show t ++ " (" ++ showStructure ts ++ ")"
79+
80+-- | Smart constructor for 'Chunk'. Guarantees the data type invariant.
81+chunk :: T.Text -> Text -> Text
82+{-# INLINE chunk #-}
83+chunk t@(T.Text _ _ len) ts | len == 0 = ts
84+ | otherwise = Chunk t ts
85+
86+-- | Smart constructor for 'Empty'.
87+empty :: Text
88+{-# INLINE [0] empty #-}
89+empty = Empty
90+
91+-- | Consume the chunks of a lazy 'Text' with a natural right fold.
92+foldrChunks :: (T.Text -> a -> a) -> a -> Text -> a
93+foldrChunks f z = go
94+ where go Empty = z
95+ go (Chunk c cs) = f c (go cs)
96+{-# INLINE foldrChunks #-}
97+
98+-- | Consume the chunks of a lazy 'Text' with a strict, tail-recursive,
99+-- accumulating left fold.
100+foldlChunks :: (a -> T.Text -> a) -> a -> Text -> a
101+foldlChunks f z = go z
102+ where go !a Empty = a
103+ go !a (Chunk c cs) = go (f a c) cs
104+{-# INLINE foldlChunks #-}
105+
106+-- | Currently set to 16 KiB, less the memory management overhead.
107+defaultChunkSize :: Int
108+defaultChunkSize = 16384 - chunkOverhead
109+{-# INLINE defaultChunkSize #-}
110+
111+-- | Currently set to 128 bytes, less the memory management overhead.
112+smallChunkSize :: Int
113+smallChunkSize = 128 - chunkOverhead
114+{-# INLINE smallChunkSize #-}
115+
116+-- | The memory management overhead. Currently this is tuned for GHC only.
117+chunkOverhead :: Int
118+chunkOverhead = sizeOf (undefined :: Int) `shiftL` 1
119+{-# INLINE chunkOverhead #-}
Data/Text/Lazy/Encoding/Fusion.hs → Data/Text/Internal/Lazy/Encoding/Fusion.hsrenamed+17−14
@@ -5,15 +5,18 @@
55-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
66--
77-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
8+-- Maintainer : bos@serpentine.com
109-- Stability : experimental
1110-- Portability : portable
1211--
12+-- /Warning/: this is an internal module, and does not have a stable
13+-- API or name. Functions in this module may not check or enforce
14+-- preconditions expected by public modules. Use at your own risk!
15+--
1316-- Fusible 'Stream'-oriented functions for converting between lazy
1417-- 'Text' and several common encodings.
1518
16−module Data.Text.Lazy.Encoding.Fusion
19+module Data.Text.Internal.Lazy.Encoding.Fusion
1720 (
1821 -- * Streaming
1922 -- streamASCII
@@ -26,23 +29,23 @@ module Data.Text.Lazy.Encoding.Fusion
2629 -- * Unstreaming
2730 , unstream
2831
29− , module Data.Text.Encoding.Fusion.Common
32+ , module Data.Text.Internal.Encoding.Fusion.Common
3033 ) where
3134
3235import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize)
3336import qualified Data.ByteString as B
3437import qualified Data.ByteString.Unsafe as B
35−import Data.Text.Encoding.Fusion.Common
38+import Data.Text.Internal.Encoding.Fusion.Common
3639import Data.Text.Encoding.Error
37−import Data.Text.Fusion (Step(..), Stream(..))
38−import Data.Text.Fusion.Size
39−import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32)
40−import Data.Text.UnsafeShift (shiftL)
40+import Data.Text.Internal.Fusion (Step(..), Stream(..))
41+import Data.Text.Internal.Fusion.Size
42+import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
43+import Data.Text.Internal.Unsafe.Shift (shiftL)
4144import Data.Word (Word8, Word16, Word32)
42−import qualified Data.Text.Encoding.Utf8 as U8
43−import qualified Data.Text.Encoding.Utf16 as U16
44−import qualified Data.Text.Encoding.Utf32 as U32
45−import System.IO.Unsafe (unsafePerformIO)
45+import qualified Data.Text.Internal.Encoding.Utf8 as U8
46+import qualified Data.Text.Internal.Encoding.Utf16 as U16
47+import qualified Data.Text.Internal.Encoding.Utf32 as U32
48+import Data.Text.Unsafe (unsafeDupablePerformIO)
4649import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
4750import Foreign.Storable (pokeByteOff)
4851import Data.ByteString.Internal (mallocByteString, memcpy)
@@ -272,7 +275,7 @@ streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
272275-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.
273276unstreamChunks :: Int -> Stream Word8 -> ByteString
274277unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
275− where chunk s1 len1 = unsafePerformIO $ do
278+ where chunk s1 len1 = unsafeDupablePerformIO $ do
276279 let len = max 4 (min len1 chunkSize)
277280 mallocByteString len >>= loop len 0 s1
278281 where
Data/Text/Lazy/Fusion.hs → Data/Text/Internal/Lazy/Fusion.hsrenamed+38−31
@@ -4,14 +4,17 @@
44-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
55--
66-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8−-- duncan@haskell.org
7+-- Maintainer : bos@serpentine.com
98-- Stability : experimental
109-- Portability : GHC
1110--
11+-- /Warning/: this is an internal module, and does not have a stable
12+-- API or name. Functions in this module may not check or enforce
13+-- preconditions expected by public modules. Use at your own risk!
14+--
1215-- Core stream fusion functionality for text.
1316
14−module Data.Text.Lazy.Fusion
17+module Data.Text.Internal.Lazy.Fusion
1518 (
1619 stream
1720 , unstream
@@ -23,14 +26,15 @@ module Data.Text.Lazy.Fusion
2326 ) where
2427
2528import Prelude hiding (length)
26−import qualified Data.Text.Fusion.Common as S
27−import Data.Text.Fusion.Internal
28−import Data.Text.Fusion.Size (isEmpty, unknownSize)
29−import Data.Text.Lazy.Internal
29+import qualified Data.Text.Internal.Fusion.Common as S
30+import Control.Monad.ST (runST)
31+import Data.Text.Internal.Fusion.Types
32+import Data.Text.Internal.Fusion.Size (isEmpty, unknownSize)
33+import Data.Text.Internal.Lazy
3034import qualified Data.Text.Internal as I
3135import qualified Data.Text.Array as A
32−import Data.Text.UnsafeChar (unsafeWrite)
33−import Data.Text.UnsafeShift (shiftL)
36+import Data.Text.Internal.Unsafe.Char (unsafeWrite)
37+import Data.Text.Internal.Unsafe.Shift (shiftL)
3438import Data.Text.Unsafe (Iter(..), iter)
3539import Data.Int (Int64)
3640
@@ -50,33 +54,36 @@ stream text = Stream next (text :*: 0) unknownSize
5054-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given
5155-- chunk size.
5256unstreamChunks :: Int -> Stream Char -> Text
53−unstreamChunks chunkSize (Stream next s0 len0)
57+unstreamChunks !chunkSize (Stream next s0 len0)
5458 | isEmpty len0 = Empty
5559 | otherwise = outer s0
5660 where
57− outer s = {-# SCC "unstreamChunks/outer" #-}
58− case next s of
61+ outer so = {-# SCC "unstreamChunks/outer" #-}
62+ case next so of
5963 Done -> Empty
6064 Skip s' -> outer s'
61− Yield x s' -> I.Text arr 0 len `chunk` outer s''
62− where (arr,(s'',len)) = A.run2 fill
63− fill = do a <- A.new unknownLength
64− unsafeWrite a 0 x >>= inner a unknownLength s'
65− unknownLength = 4
66− inner marr len s !i
67− | i + 1 >= chunkSize = return (marr, (s,i))
68− | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
69− let newLen = min (len `shiftL` 1) chunkSize
70− marr' <- A.new newLen
71− A.copyM marr' 0 marr 0 len
72− inner marr' newLen s i
73− | otherwise =
74− {-# SCC "unstreamChunks/inner" #-}
75− case next s of
76− Done -> return (marr,(s,i))
77− Skip s' -> inner marr len s' i
78− Yield x s' -> do d <- unsafeWrite marr i x
79− inner marr len s' (i+d)
65+ Yield x s' -> runST $ do
66+ a <- A.new unknownLength
67+ unsafeWrite a 0 x >>= inner a unknownLength s'
68+ where unknownLength = 4
69+ where
70+ inner marr !len s !i
71+ | i + 1 >= chunkSize = finish marr i s
72+ | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
73+ let newLen = min (len `shiftL` 1) chunkSize
74+ marr' <- A.new newLen
75+ A.copyM marr' 0 marr 0 len
76+ inner marr' newLen s i
77+ | otherwise =
78+ {-# SCC "unstreamChunks/inner" #-}
79+ case next s of
80+ Done -> finish marr i s
81+ Skip s' -> inner marr len s' i
82+ Yield x s' -> do d <- unsafeWrite marr i x
83+ inner marr len s' (i+d)
84+ finish marr len s' = do
85+ arr <- A.unsafeFreeze marr
86+ return (I.Text arr 0 len `Chunk` outer s')
8087{-# INLINE [0] unstreamChunks #-}
8188
8289-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using
Data/Text/Lazy/Search.hs → Data/Text/Internal/Lazy/Search.hsrenamed+13−9
@@ -5,16 +5,19 @@
55-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
66--
77-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
8+-- Maintainer : bos@serpentine.com
109-- Stability : experimental
1110-- Portability : GHC
1211--
12+-- /Warning/: this is an internal module, and does not have a stable
13+-- API or name. Functions in this module may not check or enforce
14+-- preconditions expected by public modules. Use at your own risk!
15+--
1316-- Fast substring search for lazy 'Text', based on work by Boyer,
1417-- Moore, Horspool, Sunday, and Lundh. Adapted from the strict
1518-- implementation.
1619
17−module Data.Text.Lazy.Search
20+module Data.Text.Internal.Lazy.Search
1821 (
1922 indices
2023 ) where
@@ -23,10 +26,10 @@ import qualified Data.Text.Array as A
2326import Data.Int (Int64)
2427import Data.Word (Word16, Word64)
2528import qualified Data.Text.Internal as T
26−import Data.Text.Fusion.Internal (PairS(..))
27−import Data.Text.Lazy.Internal (Text(..), foldlChunks)
29+import Data.Text.Internal.Fusion.Types (PairS(..))
30+import Data.Text.Internal.Lazy (Text(..), foldlChunks)
2831import Data.Bits ((.|.), (.&.))
29−import Data.Text.UnsafeShift (shiftL)
32+import Data.Text.Internal.Unsafe.Shift (shiftL)
3033
3134-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
3235-- @needle@ within @haystack@.
@@ -77,10 +80,11 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
7780 go !(g::Int64) !i !msk !skp
7881 | i >= xlast = case xs of
7982 Empty -> (msk .|. swizzle z) :*: skp
80− Chunk y ys -> buildTable y ys g 0 msk skp
81− | otherwise = go (g+1) (i+1) (msk .|. swizzle c) skp'
83+ Chunk y ys -> buildTable y ys g 0 msk' skp'
84+ | otherwise = go (g+1) (i+1) msk' skp'
8285 where c = A.unsafeIndex xarr (xoff+i)
83− skp' | c == z = nlen - fromIntegral g - 2
86+ msk' = msk .|. swizzle c
87+ skp' | c == z = nlen - g - 2
8488 | otherwise = skp
8589 xlast = xlen - 1
8690 -- | Check whether an attempt to index into the haystack at the
Data/Text/Internal/Private.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
2+
3+-- |
4+-- Module : Data.Text.Internal.Private
5+-- Copyright : (c) 2011 Bryan O'Sullivan
6+--
7+-- License : BSD-style
8+-- Maintainer : bos@serpentine.com
9+-- Stability : experimental
10+-- Portability : GHC
11+
12+module Data.Text.Internal.Private
13+ (
14+ runText
15+ , span_
16+ ) where
17+
18+import Control.Monad.ST (ST, runST)
19+import Data.Text.Internal (Text(..), text)
20+import Data.Text.Unsafe (Iter(..), iter)
21+import qualified Data.Text.Array as A
22+
23+span_ :: (Char -> Bool) -> Text -> (# Text, Text #)
24+span_ p t@(Text arr off len) = (# hd,tl #)
25+ where hd = text arr off k
26+ tl = text arr (off+k) (len-k)
27+ !k = loop 0
28+ loop !i | i < len && p c = loop (i+d)
29+ | otherwise = i
30+ where Iter c d = iter t i
31+{-# INLINE span_ #-}
32+
33+runText :: (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text
34+runText act = runST (act $ \ !marr !len -> do
35+ arr <- A.unsafeFreeze marr
36+ return $! text arr 0 len)
37+{-# INLINE runText #-}
Data/Text/Internal/Read.hsnew file+62
@@ -0,0 +1,62 @@
1+-- |
2+-- Module : Data.Text.Internal.Read
3+-- Copyright : (c) 2014 Bryan O'Sullivan
4+--
5+-- License : BSD-style
6+-- Maintainer : bos@serpentine.com
7+-- Stability : experimental
8+-- Portability : GHC
9+--
10+-- Common internal functions for reading textual data.
11+module Data.Text.Internal.Read
12+ (
13+ IReader
14+ , IParser(..)
15+ , T(..)
16+ , digitToInt
17+ , hexDigitToInt
18+ , perhaps
19+ ) where
20+
21+import Control.Applicative as App (Applicative(..))
22+import Control.Arrow (first)
23+import Control.Monad (ap)
24+import Data.Char (ord)
25+
26+type IReader t a = t -> Either String (a,t)
27+
28+newtype IParser t a = P {
29+ runP :: IReader t a
30+ }
31+
32+instance Functor (IParser t) where
33+ fmap f m = P $ fmap (first f) . runP m
34+
35+instance Applicative (IParser t) where
36+ pure a = P $ \t -> Right (a,t)
37+ {-# INLINE pure #-}
38+ (<*>) = ap
39+
40+instance Monad (IParser t) where
41+ return = App.pure
42+ m >>= k = P $ \t -> case runP m t of
43+ Left err -> Left err
44+ Right (a,t') -> runP (k a) t'
45+ {-# INLINE (>>=) #-}
46+ fail msg = P $ \_ -> Left msg
47+
48+data T = T !Integer !Int
49+
50+perhaps :: a -> IParser t a -> IParser t a
51+perhaps def m = P $ \t -> case runP m t of
52+ Left _ -> Right (def,t)
53+ r@(Right _) -> r
54+
55+hexDigitToInt :: Char -> Int
56+hexDigitToInt c
57+ | c >= '0' && c <= '9' = ord c - ord '0'
58+ | c >= 'a' && c <= 'f' = ord c - (ord 'a' - 10)
59+ | otherwise = ord c - (ord 'A' - 10)
60+
61+digitToInt :: Char -> Int
62+digitToInt c = ord c - ord '0'
Data/Text/Search.hs → Data/Text/Internal/Search.hsrenamed+12−11
@@ -1,12 +1,11 @@
11{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
22
33-- |
4−-- Module : Data.Text.Search
4+-- Module : Data.Text.Internal.Search
55-- Copyright : (c) Bryan O'Sullivan 2009
66--
77-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
8+-- Maintainer : bos@serpentine.com
109-- Stability : experimental
1110-- Portability : GHC
1211--
@@ -14,7 +13,7 @@
1413-- Horspool, Sunday, and Lundh.
1514--
1615-- References:
17−--
16+--
1817-- * R. S. Boyer, J. S. Moore: A Fast String Searching Algorithm.
1918-- Communications of the ACM, 20, 10, 762-772 (1977)
2019--
@@ -27,7 +26,7 @@
2726-- * F. Lundh: The Fast Search Algorithm.
2827-- <http://effbot.org/zone/stringlib.htm> (2006)
2928
30−module Data.Text.Search
29+module Data.Text.Internal.Search
3130 (
3231 indices
3332 ) where
@@ -35,13 +34,15 @@ module Data.Text.Search
3534import qualified Data.Text.Array as A
3635import Data.Word (Word64)
3736import Data.Text.Internal (Text(..))
38−import Data.Text.Fusion.Internal (PairS(..))
3937import Data.Bits ((.|.), (.&.))
40−import Data.Text.UnsafeShift (shiftL)
38+import Data.Text.Internal.Unsafe.Shift (shiftL)
39+
40+data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
4141
4242-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
4343-- @needle@ within @haystack@. The offsets returned represent
44−-- locations in the low-level array.
44+-- uncorrected indices in the low-level \"needle\" array, to which its
45+-- offset must be added.
4546--
4647-- In (unlikely) bad cases, this algorithm's complexity degrades
4748-- towards /O(n*m)/.
@@ -60,9 +61,8 @@ indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
6061 hindex k = A.unsafeIndex harr (hoff+k)
6162 hindex' k | k == hlen = 0
6263 | otherwise = A.unsafeIndex harr (hoff+k)
63− (mask :: Word64) :*: skip = buildTable 0 0 (nlen-2)
6464 buildTable !i !msk !skp
65− | i >= nlast = (msk .|. swizzle z) :*: skp
65+ | i >= nlast = (msk .|. swizzle z) :* skp
6666 | otherwise = buildTable (i+1) (msk .|. swizzle c) skp'
6767 where c = nindex i
6868 skp' | c == z = nlen - i - 2
@@ -80,7 +80,8 @@ indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
8080 delta | nextInPattern = nlen + 1
8181 | c == z = skip + 1
8282 | otherwise = 1
83− nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0
83+ where nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0
84+ !(mask :* skip) = buildTable 0 0 (nlen-2)
8485 scanOne c = loop 0
8586 where loop !i | i >= hlen = []
8687 | hindex i == c = i : loop (i+1)
Data/Text/Internal/Unsafe.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
2+{-# OPTIONS_HADDOCK not-home #-}
3+
4+-- |
5+-- Module : Data.Text.Internal.Unsafe
6+-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
7+-- License : BSD-style
8+-- Maintainer : bos@serpentine.com
9+-- Stability : experimental
10+-- Portability : portable
11+--
12+-- /Warning/: this is an internal module, and does not have a stable
13+-- API or name. Functions in this module may not check or enforce
14+-- preconditions expected by public modules. Use at your own risk!
15+--
16+-- A module containing /unsafe/ operations, for /very very careful/ use
17+-- in /heavily tested/ code.
18+module Data.Text.Internal.Unsafe
19+ (
20+ inlineInterleaveST
21+ , inlinePerformIO
22+ ) where
23+
24+import GHC.ST (ST(..))
25+#if defined(__GLASGOW_HASKELL__)
26+import GHC.IO (IO(IO))
27+import GHC.Base (realWorld#)
28+#endif
29+
30+
31+-- | Just like unsafePerformIO, but we inline it. Big performance gains as
32+-- it exposes lots of things to further inlining. /Very unsafe/. In
33+-- particular, you should do no memory allocation inside an
34+-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.
35+--
36+{-# INLINE inlinePerformIO #-}
37+inlinePerformIO :: IO a -> a
38+#if defined(__GLASGOW_HASKELL__)
39+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
40+#else
41+inlinePerformIO = unsafePerformIO
42+#endif
43+
44+-- | Allow an 'ST' computation to be deferred lazily. When passed an
45+-- action of type 'ST' @s@ @a@, the action will only be performed when
46+-- the value of @a@ is demanded.
47+--
48+-- This function is identical to the normal unsafeInterleaveST, but is
49+-- inlined and hence faster.
50+--
51+-- /Note/: This operation is highly unsafe, as it can introduce
52+-- externally visible non-determinism into an 'ST' action.
53+inlineInterleaveST :: ST s a -> ST s a
54+inlineInterleaveST (ST m) = ST $ \ s ->
55+ let r = case m s of (# _, res #) -> res in (# s, r #)
56+{-# INLINE inlineInterleaveST #-}
Data/Text/UnsafeChar.hs → Data/Text/Internal/Unsafe/Char.hsrenamed+8−5
@@ -1,19 +1,22 @@
11{-# LANGUAGE CPP, MagicHash #-}
22
33-- |
4−-- Module : Data.Text.UnsafeChar
4+-- Module : Data.Text.Internal.Unsafe.Char
55-- Copyright : (c) 2008, 2009 Tom Harper,
66-- (c) 2009, 2010 Bryan O'Sullivan,
77-- (c) 2009 Duncan Coutts
88--
99-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11−-- duncan@haskell.org
10+-- Maintainer : bos@serpentine.com
1211-- Stability : experimental
1312-- Portability : GHC
1413--
14+-- /Warning/: this is an internal module, and does not have a stable
15+-- API or name. Functions in this module may not check or enforce
16+-- preconditions expected by public modules. Use at your own risk!
17+--
1518-- Fast character manipulation functions.
16−module Data.Text.UnsafeChar
19+module Data.Text.Internal.Unsafe.Char
1720 (
1821 ord
1922 , unsafeChr
@@ -28,7 +31,7 @@ import Control.Exception (assert)
2831#endif
2932import Control.Monad.ST (ST)
3033import Data.Bits ((.&.))
31−import Data.Text.UnsafeShift (shiftR)
34+import Data.Text.Internal.Unsafe.Shift (shiftR)
3235import GHC.Exts (Char(..), Int(..), chr#, ord#, word2Int#)
3336import GHC.Word (Word8(..), Word16(..), Word32(..))
3437import qualified Data.Text.Array as A
Data/Text/UnsafeShift.hs → Data/Text/Internal/Unsafe/Shift.hsrenamed+7−4
@@ -1,18 +1,21 @@
11{-# LANGUAGE MagicHash #-}
22
33-- |
4−-- Module : Data.Text.UnsafeShift
4+-- Module : Data.Text.Internal.Unsafe.Shift
55-- Copyright : (c) Bryan O'Sullivan 2009
66--
77-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
8+-- Maintainer : bos@serpentine.com
109-- Stability : experimental
1110-- Portability : GHC
1211--
12+-- /Warning/: this is an internal module, and does not have a stable
13+-- API or name. Functions in this module may not check or enforce
14+-- preconditions expected by public modules. Use at your own risk!
15+--
1316-- Fast, unchecked bit shifting functions.
1417
15−module Data.Text.UnsafeShift
18+module Data.Text.Internal.Unsafe.Shift
1619 (
1720 UnsafeShift(..)
1821 ) where
Data/Text/Lazy.hs+277−60
@@ -1,12 +1,18 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
2−{-# LANGUAGE BangPatterns, CPP #-}
2+{-# LANGUAGE BangPatterns, MagicHash, CPP #-}
3+#if __GLASGOW_HASKELL__ >= 702
4+{-# LANGUAGE Trustworthy #-}
5+#endif
6+#if __GLASGOW_HASKELL__ >= 708
7+{-# LANGUAGE TypeFamilies #-}
8+#endif
9+
310-- |
411-- Module : Data.Text.Lazy
5−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
12+-- Copyright : (c) 2009, 2010, 2012 Bryan O'Sullivan
613--
714-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
15+-- Maintainer : bos@serpentine.com
1016-- Stability : experimental
1117-- Portability : GHC
1218--
@@ -83,6 +89,7 @@ module Data.Text.Lazy
8389 , toCaseFold
8490 , toLower
8591 , toUpper
92+ , toTitle
8693
8794 -- ** Justification
8895 , justifyLeft
@@ -118,7 +125,10 @@ module Data.Text.Lazy
118125 , mapAccumR
119126
120127 -- ** Generation and unfolding
128+ , repeat
121129 , replicate
130+ , cycle
131+ , iterate
122132 , unfoldr
123133 , unfoldrN
124134
@@ -126,8 +136,11 @@ module Data.Text.Lazy
126136
127137 -- ** Breaking strings
128138 , take
139+ , takeEnd
129140 , drop
141+ , dropEnd
130142 , takeWhile
143+ , takeWhileEnd
131144 , dropWhile
132145 , dropWhileEnd
133146 , dropAround
@@ -174,7 +187,7 @@ module Data.Text.Lazy
174187 , partition
175188
176189 -- , findSubstring
177−
190+
178191 -- * Indexing
179192 , index
180193 , count
@@ -190,7 +203,7 @@ module Data.Text.Lazy
190203import Prelude (Char, Bool(..), Maybe(..), String,
191204 Eq(..), Ord(..), Ordering(..), Read(..), Show(..),
192205 (&&), (||), (+), (-), (.), ($), (++),
193− div, error, flip, fmap, fromIntegral, not, otherwise)
206+ error, flip, fmap, fromIntegral, not, otherwise, quot)
194207import qualified Prelude as P
195208#if defined(HAVE_DEEPSEQ)
196209import Control.DeepSeq (NFData(..))
@@ -198,25 +211,39 @@ import Control.DeepSeq (NFData(..))
198211import Data.Int (Int64)
199212import qualified Data.List as L
200213import Data.Char (isSpace)
201−import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf))
202−#if __GLASGOW_HASKELL__ >= 612
203−import Data.Data (mkNoRepType)
204−#else
205−import Data.Data (mkNorepType)
206−#endif
214+import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf), constrIndex,
215+ Constr, mkConstr, DataType, mkDataType, Fixity(Prefix))
216+import Data.Binary (Binary(get, put))
207217import Data.Monoid (Monoid(..))
218+#if MIN_VERSION_base(4,9,0)
219+import Data.Semigroup (Semigroup(..))
220+#endif
208221import Data.String (IsString(..))
209222import qualified Data.Text as T
210223import qualified Data.Text.Internal as T
211−import qualified Data.Text.Fusion.Common as S
224+import qualified Data.Text.Internal.Fusion.Common as S
212225import qualified Data.Text.Unsafe as T
213−import qualified Data.Text.Lazy.Fusion as S
214−import Data.Text.Fusion.Internal (PairS(..))
215−import Data.Text.Lazy.Fusion (stream, unstream)
216−import Data.Text.Lazy.Internal (Text(..), chunk, empty, foldlChunks, foldrChunks)
217−import Data.Text.Internal (firstf, safe, textP)
218−import qualified Data.Text.Util as U
219−import Data.Text.Lazy.Search (indices)
226+import qualified Data.Text.Internal.Lazy.Fusion as S
227+import Data.Text.Internal.Fusion.Types (PairS(..))
228+import Data.Text.Internal.Lazy.Fusion (stream, unstream)
229+import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldlChunks,
230+ foldrChunks, smallChunkSize)
231+import Data.Text.Internal (firstf, safe, text)
232+import Data.Text.Lazy.Encoding (decodeUtf8', encodeUtf8)
233+import qualified Data.Text.Internal.Functions as F
234+import Data.Text.Internal.Lazy.Search (indices)
235+#if __GLASGOW_HASKELL__ >= 702
236+import qualified GHC.CString as GHC
237+#else
238+import qualified GHC.Base as GHC
239+#endif
240+#if __GLASGOW_HASKELL__ >= 708
241+import qualified GHC.Exts as Exts
242+#endif
243+import GHC.Prim (Addr#)
244+#if MIN_VERSION_base(4,7,0)
245+import Text.Printf (PrintfArg, formatArg, formatString)
246+#endif
220247
221248-- $fusion
222249--
@@ -314,30 +341,72 @@ instance Show Text where
314341instance Read Text where
315342 readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
316343
344+#if MIN_VERSION_base(4,9,0)
345+-- Semigroup orphan instances for older GHCs are provided by
346+-- 'semigroups` package
347+
348+instance Semigroup Text where
349+ (<>) = append
350+#endif
351+
317352instance Monoid Text where
318353 mempty = empty
354+#if MIN_VERSION_base(4,9,0)
355+ mappend = (<>) -- future-proof definition
356+#else
319357 mappend = append
358+#endif
320359 mconcat = concat
321360
322361instance IsString Text where
323362 fromString = pack
324363
364+#if __GLASGOW_HASKELL__ >= 708
365+instance Exts.IsList Text where
366+ type Item Text = Char
367+ fromList = pack
368+ toList = unpack
369+#endif
370+
325371#if defined(HAVE_DEEPSEQ)
326372instance NFData Text where
327373 rnf Empty = ()
328374 rnf (Chunk _ ts) = rnf ts
329375#endif
330376
377+instance Binary Text where
378+ put t = put (encodeUtf8 t)
379+ get = do
380+ bs <- get
381+ case decodeUtf8' bs of
382+ P.Left exn -> P.fail (P.show exn)
383+ P.Right a -> P.return a
384+
385+-- | This instance preserves data abstraction at the cost of inefficiency.
386+-- We omit reflection services for the sake of data abstraction.
387+--
388+-- This instance was created by copying the updated behavior of
389+-- @"Data.Text".@'Data.Text.Text'
331390instance Data Text where
332391 gfoldl f z txt = z pack `f` (unpack txt)
333− toConstr _ = error "Data.Text.Lazy.Text.toConstr"
334− gunfold _ _ = error "Data.Text.Lazy.Text.gunfold"
335−#if __GLASGOW_HASKELL__ >= 612
336− dataTypeOf _ = mkNoRepType "Data.Text.Lazy.Text"
337−#else
338− dataTypeOf _ = mkNorepType "Data.Text.Lazy.Text"
392+ toConstr _ = packConstr
393+ gunfold k z c = case constrIndex c of
394+ 1 -> k (z pack)
395+ _ -> error "Data.Text.Lazy.Text.gunfold"
396+ dataTypeOf _ = textDataType
397+
398+#if MIN_VERSION_base(4,7,0)
399+-- | Only defined for @base-4.7.0.0@ and later
400+instance PrintfArg Text where
401+ formatArg txt = formatString $ unpack txt
339402#endif
340403
404+packConstr :: Constr
405+packConstr = mkConstr textDataType "pack" [] Prefix
406+
407+textDataType :: DataType
408+textDataType = mkDataType "Data.Text.Lazy.Text" [packConstr]
409+
341410-- | /O(n)/ Convert a 'String' into a 'Text'.
342411--
343412-- Subject to fusion. Performs replacement on invalid scalar values.
@@ -351,6 +420,27 @@ unpack :: Text -> String
351420unpack t = S.unstreamList (stream t)
352421{-# INLINE [1] unpack #-}
353422
423+-- | /O(n)/ Convert a literal string into a Text.
424+unpackCString# :: Addr# -> Text
425+unpackCString# addr# = unstream (S.streamCString# addr#)
426+{-# NOINLINE unpackCString# #-}
427+
428+{-# RULES "TEXT literal" forall a.
429+ unstream (S.streamList (L.map safe (GHC.unpackCString# a)))
430+ = unpackCString# a #-}
431+
432+{-# RULES "TEXT literal UTF8" forall a.
433+ unstream (S.streamList (L.map safe (GHC.unpackCStringUtf8# a)))
434+ = unpackCString# a #-}
435+
436+{-# RULES "LAZY TEXT empty literal"
437+ unstream (S.streamList (L.map safe []))
438+ = Empty #-}
439+
440+{-# RULES "LAZY TEXT empty literal" forall a.
441+ unstream (S.streamList (L.map safe [a]))
442+ = Chunk (T.singleton a) Empty #-}
443+
354444-- | /O(1)/ Convert a character into a Text. Subject to fusion.
355445-- Performs replacement on invalid scalar values.
356446singleton :: Char -> Text
@@ -455,7 +545,7 @@ tail Empty = emptyError "tail"
455545 unstream (S.tail (stream t)) = tail t
456546 #-}
457547
458−-- | /O(1)/ Returns all but the last character of a 'Text', which must
548+-- | /O(n\/c)/ Returns all but the last character of a 'Text', which must
459549-- be non-empty. Subject to fusion.
460550init :: Text -> Text
461551init (Chunk t0 ts0) = go t0 ts0
@@ -491,7 +581,7 @@ isSingleton :: Text -> Bool
491581isSingleton = S.isSingleton . stream
492582{-# INLINE isSingleton #-}
493583
494−-- | /O(1)/ Returns the last character of a 'Text', which must be
584+-- | /O(n\/c)/ Returns the last character of a 'Text', which must be
495585-- non-empty. Subject to fusion.
496586last :: Text -> Char
497587last Empty = emptyError "last"
@@ -546,7 +636,7 @@ map f t = unstream (S.map (safe . f) (stream t))
546636-- 'Text's and concatenates the list after interspersing the first
547637-- argument between each element of the list.
548638intercalate :: Text -> [Text] -> Text
549−intercalate t = concat . (U.intersperse t)
639+intercalate t = concat . (F.intersperse t)
550640{-# INLINE intercalate #-}
551641
552642-- | /O(n)/ The 'intersperse' function takes a character and places it
@@ -606,7 +696,7 @@ center k c t
606696 | otherwise = replicateChar l c `append` t `append` replicateChar r c
607697 where len = length t
608698 d = k - len
609− r = d `div` 2
699+ r = d `quot` 2
610700 l = d - r
611701{-# INLINE center #-}
612702
@@ -625,13 +715,36 @@ reverse = rev Empty
625715 where rev a Empty = a
626716 rev a (Chunk t ts) = rev (Chunk (T.reverse t) a) ts
627717
628−-- | /O(m+n)/ Replace every occurrence of one substring with another.
718+-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
719+-- @haystack@ with @replacement@.
720+--
721+-- This function behaves as though it was defined as follows:
722+--
723+-- @
724+-- replace needle replacement haystack =
725+-- 'intercalate' replacement ('splitOn' needle haystack)
726+-- @
727+--
728+-- As this suggests, each occurrence is replaced exactly once. So if
729+-- @needle@ occurs in @replacement@, that occurrence will /not/ itself
730+-- be replaced recursively:
731+--
732+-- > replace "oo" "foo" "oo" == "foo"
733+--
734+-- In cases where several instances of @needle@ overlap, only the
735+-- first one will be replaced:
736+--
737+-- > replace "ofo" "bar" "ofofo" == "barfo"
629738--
630739-- In (unlikely) bad cases, this function's time complexity degrades
631740-- towards /O(n*m)/.
632−replace :: Text -- ^ Text to search for
633− -> Text -- ^ Replacement text
634− -> Text -- ^ Input text
741+replace :: Text
742+ -- ^ @needle@ to search for. If this string is empty, an
743+ -- error will occur.
744+ -> Text
745+ -- ^ @replacement@ to replace @needle@ with.
746+ -> Text
747+ -- ^ @haystack@ in which to search.
635748 -> Text
636749replace s d = intercalate d . splitOn s
637750{-# INLINE replace #-}
@@ -648,9 +761,10 @@ replace s d = intercalate d . splitOn s
648761-- functions may map one input character to two or three output
649762-- characters.
650763
651−-- | /O(n)/ Convert a string to folded case. This function is mainly
652−-- useful for performing caseless (or case insensitive) string
653−-- comparisons.
764+-- | /O(n)/ Convert a string to folded case. Subject to fusion.
765+--
766+-- This function is mainly useful for performing caseless (or case
767+-- insensitive) string comparisons.
654768--
655769-- A string @x@ is a caseless match for a string @y@ if and only if:
656770--
@@ -667,22 +781,49 @@ toCaseFold t = unstream (S.toCaseFold (stream t))
667781{-# INLINE [0] toCaseFold #-}
668782
669783-- | /O(n)/ Convert a string to lower case, using simple case
670−-- conversion. The result string may be longer than the input string.
671−-- For instance, the Latin capital letter I with dot above (U+0130)
672−-- maps to the sequence Latin small letter i (U+0069) followed by
673−-- combining dot above (U+0307).
784+-- conversion. Subject to fusion.
785+--
786+-- The result string may be longer than the input string. For
787+-- instance, the Latin capital letter I with dot above (U+0130) maps
788+-- to the sequence Latin small letter i (U+0069) followed by combining
789+-- dot above (U+0307).
674790toLower :: Text -> Text
675791toLower t = unstream (S.toLower (stream t))
676792{-# INLINE toLower #-}
677793
678794-- | /O(n)/ Convert a string to upper case, using simple case
679−-- conversion. The result string may be longer than the input string.
680−-- For instance, the German eszett (U+00DF) maps to the two-letter
795+-- conversion. Subject to fusion.
796+--
797+-- The result string may be longer than the input string. For
798+-- instance, the German eszett (U+00DF) maps to the two-letter
681799-- sequence SS.
682800toUpper :: Text -> Text
683801toUpper t = unstream (S.toUpper (stream t))
684802{-# INLINE toUpper #-}
685803
804+
805+-- | /O(n)/ Convert a string to title case, using simple case
806+-- conversion. Subject to fusion.
807+--
808+-- The first letter of the input is converted to title case, as is
809+-- every subsequent letter that immediately follows a non-letter.
810+-- Every letter that immediately follows another letter is converted
811+-- to lower case.
812+--
813+-- The result string may be longer than the input string. For example,
814+-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
815+-- sequence Latin capital letter F (U+0046) followed by Latin small
816+-- letter l (U+006C).
817+--
818+-- /Note/: this function does not take language or culture specific
819+-- rules into account. For instance, in English, different style
820+-- guides disagree on whether the book name \"The Hill of the Red
821+-- Fox\" is correctly title cased&#x2014;but this function will
822+-- capitalize /every/ word.
823+toTitle :: Text -> Text
824+toTitle t = unstream (S.toTitle (stream t))
825+{-# INLINE toTitle #-}
826+
686827-- | /O(n)/ 'foldl', applied to a binary operator, a starting value
687828-- (typically the left-identity of the operator), and a 'Text',
688829-- reduces the 'Text' using the binary operator, from left to right.
@@ -717,7 +858,7 @@ foldr f z t = S.foldr f z (stream t)
717858{-# INLINE foldr #-}
718859
719860-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
720−-- and thust must be applied to a non-empty 'Text'. Subject to
861+-- and thus must be applied to a non-empty 'Text'. Subject to
721862-- fusion.
722863foldr1 :: (Char -> Char -> Char) -> Text -> Char
723864foldr1 f t = S.foldr1 f (stream t)
@@ -740,13 +881,13 @@ concatMap f = concat . foldr ((:) . f) []
740881{-# INLINE concatMap #-}
741882
742883-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
743−-- 'Text' @t@ satisifes the predicate @p@. Subject to fusion.
884+-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
744885any :: (Char -> Bool) -> Text -> Bool
745886any p t = S.any p (stream t)
746887{-# INLINE any #-}
747888
748889-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
749−-- 'Text' @t@ satisify the predicate @p@. Subject to fusion.
890+-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
750891all :: (Char -> Bool) -> Text -> Bool
751892all p t = S.all p (stream t)
752893{-# INLINE all #-}
@@ -829,6 +970,12 @@ mapAccumR f = go
829970 go z Empty = (z, Empty)
830971{-# INLINE mapAccumR #-}
831972
973+-- | @'repeat' x@ is an infinite 'Text', with @x@ the value of every
974+-- element.
975+repeat :: Char -> Text
976+repeat c = let t = Chunk (T.replicate smallChunkSize (T.singleton c)) t
977+ in t
978+
832979-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'Text' consisting of the input
833980-- @t@ repeated @n@ times.
834981replicate :: Int64 -> Text -> Text
@@ -838,7 +985,22 @@ replicate n t
838985 | otherwise = concat (rep 0)
839986 where rep !i | i >= n = []
840987 | otherwise = t : rep (i+1)
841−{-# INLINE replicate #-}
988+{-# INLINE [1] replicate #-}
989+
990+-- | 'cycle' ties a finite, non-empty 'Text' into a circular one, or
991+-- equivalently, the infinite repetition of the original 'Text'.
992+cycle :: Text -> Text
993+cycle Empty = emptyError "cycle"
994+cycle t = let t' = foldrChunks Chunk t' t
995+ in t'
996+
997+-- | @'iterate' f x@ returns an infinite 'Text' of repeated applications
998+-- of @f@ to @x@:
999+--
1000+-- > iterate f x == [x, f x, f (f x), ...]
1001+iterate :: (Char -> Char) -> Char -> Text
1002+iterate f c = let t c' = Chunk (T.singleton c') (t (f c'))
1003+ in t c
8421004
8431005-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the
8441006-- value of every element. Subject to fusion.
@@ -893,6 +1055,22 @@ take i t0 = take' i t0
8931055 unstream (S.take n (stream t)) = take n t
8941056 #-}
8951057
1058+-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
1059+-- taking @n@ characters from the end of @t@.
1060+--
1061+-- Examples:
1062+--
1063+-- > takeEnd 3 "foobar" == "bar"
1064+takeEnd :: Int64 -> Text -> Text
1065+takeEnd n t0
1066+ | n <= 0 = empty
1067+ | otherwise = takeChunk n empty . L.reverse . toChunks $ t0
1068+ where takeChunk _ acc [] = acc
1069+ takeChunk i acc (t:ts)
1070+ | i <= l = chunk (T.takeEnd (fromIntegral i) t) acc
1071+ | otherwise = takeChunk (i-l) (Chunk t acc) ts
1072+ where l = fromIntegral (T.length t)
1073+
8961074-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
8971075-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
8981076-- is greater than the length of the 'Text'. Subject to fusion.
@@ -902,7 +1080,7 @@ drop i t0
9021080 | otherwise = drop' i t0
9031081 where drop' 0 ts = ts
9041082 drop' _ Empty = Empty
905− drop' n (Chunk t ts)
1083+ drop' n (Chunk t ts)
9061084 | n < len = Chunk (T.drop (fromIntegral n) t) ts
9071085 | otherwise = drop' (n - len) ts
9081086 where len = fromIntegral (T.length t)
@@ -915,6 +1093,23 @@ drop i t0
9151093 unstream (S.drop n (stream t)) = drop n t
9161094 #-}
9171095
1096+-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
1097+-- dropping @n@ characters from the end of @t@.
1098+--
1099+-- Examples:
1100+--
1101+-- > dropEnd 3 "foobar" == "foo"
1102+dropEnd :: Int64 -> Text -> Text
1103+dropEnd n t0
1104+ | n <= 0 = t0
1105+ | otherwise = dropChunk n . L.reverse . toChunks $ t0
1106+ where dropChunk _ [] = empty
1107+ dropChunk m (t:ts)
1108+ | m >= l = dropChunk (m-l) ts
1109+ | otherwise = fromChunks . L.reverse $
1110+ T.dropEnd (fromIntegral m) t : ts
1111+ where l = fromIntegral (T.length t)
1112+
9181113-- | /O(n)/ 'dropWords' @n@ returns the suffix with @n@ 'Word16'
9191114-- values dropped, or the empty 'Text' if @n@ is greater than the
9201115-- number of 'Word16' values present.
@@ -925,7 +1120,7 @@ dropWords i t0
9251120 where drop' 0 ts = ts
9261121 drop' _ Empty = Empty
9271122 drop' n (Chunk (T.Text arr off len) ts)
928− | n < len' = chunk (textP arr (off+n') (len-n')) ts
1123+ | n < len' = chunk (text arr (off+n') (len-n')) ts
9291124 | otherwise = drop' (n - len') ts
9301125 where len' = fromIntegral len
9311126 n' = fromIntegral n
@@ -949,6 +1144,20 @@ takeWhile p t0 = takeWhile' t0
9491144"LAZY TEXT takeWhile -> unfused" [1] forall p t.
9501145 unstream (S.takeWhile p (stream t)) = takeWhile p t
9511146 #-}
1147+-- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text',
1148+-- returns the longest suffix (possibly empty) of elements that
1149+-- satisfy @p@.
1150+-- Examples:
1151+--
1152+-- > takeWhileEnd (=='o') "foo" == "oo"
1153+takeWhileEnd :: (Char -> Bool) -> Text -> Text
1154+takeWhileEnd p = takeChunk empty . L.reverse . toChunks
1155+ where takeChunk acc [] = acc
1156+ takeChunk acc (t:ts) = if T.length t' < T.length t
1157+ then (Chunk t' acc)
1158+ else takeChunk (Chunk t' acc) ts
1159+ where t' = T.takeWhileEnd p t
1160+{-# INLINE takeWhileEnd #-}
9521161
9531162-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
9541163-- 'takeWhile' @p@ @t@. Subject to fusion.
@@ -967,9 +1176,11 @@ dropWhile p t0 = dropWhile' t0
9671176"LAZY TEXT dropWhile -> unfused" [1] forall p t.
9681177 unstream (S.dropWhile p (stream t)) = dropWhile p t
9691178 #-}
1179+
9701180-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
971−-- dropping characters that fail the predicate @p@ from the end of
1181+-- dropping characters that satisfy the predicate @p@ from the end of
9721182-- @t@.
1183+--
9731184-- Examples:
9741185--
9751186-- > dropWhileEnd (=='.') "foo..." == "foo"
@@ -986,7 +1197,7 @@ dropWhileEnd p = go
9861197{-# INLINE dropWhileEnd #-}
9871198
9881199-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
989−-- dropping characters that fail the predicate @p@ from both the
1200+-- dropping characters that satisfy the predicate @p@ from both the
9901201-- beginning and end of @t@. Subject to fusion.
9911202dropAround :: (Char -> Bool) -> Text -> Text
9921203dropAround p = dropWhile p . dropWhileEnd p
@@ -1036,8 +1247,8 @@ splitAtWord _ Empty = empty :*: empty
10361247splitAtWord x (Chunk c@(T.Text arr off len) cs)
10371248 | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
10381249 in Chunk c h :*: t
1039− | otherwise = chunk (textP arr off y) empty :*:
1040− chunk (textP arr (off+y) (len-y)) cs
1250+ | otherwise = chunk (text arr off y) empty :*:
1251+ chunk (text arr (off+y) (len-y)) cs
10411252 where y = fromIntegral x
10421253
10431254-- | /O(n+m)/ Find the first instance of @needle@ (which must be
@@ -1056,7 +1267,7 @@ splitAtWord x (Chunk c@(T.Text arr off len) cs)
10561267-- > where (prefix, match) = breakOn needle haystack
10571268--
10581269-- If you need to break a string by a substring repeatedly (e.g. you
1059−-- want to break on every instance of a substring), use 'find'
1270+-- want to break on every instance of a substring), use 'breakOnAll'
10601271-- instead, as it has lower startup overhead.
10611272--
10621273-- This function is strict in its first argument, and lazy in its
@@ -1181,28 +1392,34 @@ tails ts@(Chunk t ts')
11811392-- copies to create substrings; they just construct new 'Text's that
11821393-- are slices of the original.
11831394
1184−-- | /O(m+n)/ Break a 'Text' into pieces separated by the first
1185−-- 'Text' argument, consuming the delimiter. An empty delimiter is
1186−-- invalid, and will cause an error to be raised.
1395+-- | /O(m+n)/ Break a 'Text' into pieces separated by the first 'Text'
1396+-- argument (which cannot be an empty string), consuming the
1397+-- delimiter. An empty delimiter is invalid, and will cause an error
1398+-- to be raised.
11871399--
11881400-- Examples:
11891401--
11901402-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
11911403-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
11921404-- > splitOn "x" "x" == ["",""]
1193−--
1405+--
11941406-- and
11951407--
11961408-- > intercalate s . splitOn s == id
11971409-- > splitOn (singleton c) == split (==c)
11981410--
1411+-- (Note: the string @s@ to split on above cannot be empty.)
1412+--
11991413-- This function is strict in its first argument, and lazy in its
12001414-- second.
12011415--
12021416-- In (unlikely) bad cases, this function's time complexity degrades
12031417-- towards /O(n*m)/.
1204−splitOn :: Text -- ^ Text to split on
1205− -> Text -- ^ Input text
1418+splitOn :: Text
1419+ -- ^ String to split on. If this string is empty, an error
1420+ -- will occur.
1421+ -> Text
1422+ -- ^ Input text.
12061423 -> [Text]
12071424splitOn pat src
12081425 | null pat = emptyError "splitOn"
Data/Text/Lazy/Builder.hs+19−261
@@ -1,11 +1,15 @@
11{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
25
36-----------------------------------------------------------------------------
47-- |
58-- Module : Data.Text.Lazy.Builder
6−-- Copyright : (c) 2010 Johan Tibell
7−-- License : BSD3-style (see LICENSE)
8−--
9+-- Copyright : (c) 2013 Bryan O'Sullivan
10+-- (c) 2010 Johan Tibell
11+-- License : BSD-style (see LICENSE)
12+--
913-- Maintainer : Johan Tibell <johan.tibell@gmail.com>
1014-- Stability : experimental
1115-- Portability : portable to Hugs and GHC
@@ -15,7 +19,9 @@
1519-- @fromLazyText@, which construct new builders, and 'mappend', which
1620-- concatenates two builders.
1721--
18−-- To get maximum performance when building lazy @Text@ values using a builder, associate @mappend@ calls to the right. For example, prefer
22+-- To get maximum performance when building lazy @Text@ values using a
23+-- builder, associate @mappend@ calls to the right. For example,
24+-- prefer
1925--
2026-- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c')
2127--
@@ -23,8 +29,14 @@
2329--
2430-- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c'
2531--
26−-- as the latter associates @mappend@ to the left.
32+-- as the latter associates @mappend@ to the left. Or, equivalently,
33+-- prefer
34+--
35+-- > singleton 'a' <> singleton 'b' <> singleton 'c'
2736--
37+-- since the '<>' from recent versions of 'Data.Monoid' associates
38+-- to the right.
39+
2840-----------------------------------------------------------------------------
2941
3042module Data.Text.Lazy.Builder
@@ -37,264 +49,10 @@ module Data.Text.Lazy.Builder
3749 , singleton
3850 , fromText
3951 , fromLazyText
52+ , fromString
4053
4154 -- * Flushing the buffer state
4255 , flush
4356 ) where
4457
45−import Control.Monad.ST (ST, runST)
46−import Data.Bits ((.&.))
47−import Data.Monoid (Monoid(..))
48−import Data.Text.Internal (Text(..))
49−import Data.Text.Lazy.Internal (smallChunkSize)
50−import Data.Text.Unsafe (inlineInterleaveST)
51−import Data.Text.UnsafeChar (ord, unsafeWrite)
52−import Data.Text.UnsafeShift (shiftR)
53−import Prelude hiding (map, putChar)
54−
55−import qualified Data.String as String
56−import qualified Data.Text as S
57−import qualified Data.Text.Array as A
58−import qualified Data.Text.Lazy as L
59−
60−------------------------------------------------------------------------
61−
62−-- | A @Builder@ is an efficient way to build lazy @Text@ values.
63−-- There are several functions for constructing builders, but only one
64−-- to inspect them: to extract any data, you have to turn them into
65−-- lazy @Text@ values using @toLazyText@.
66−--
67−-- Internally, a builder constructs a lazy @Text@ by filling arrays
68−-- piece by piece. As each buffer is filled, it is \'popped\' off, to
69−-- become a new chunk of the resulting lazy @Text@. All this is
70−-- hidden from the user of the @Builder@.
71−newtype Builder = Builder {
72− -- Invariant (from Data.Text.Lazy):
73− -- The lists include no null Texts.
74− runBuilder :: forall s. (Buffer s -> ST s [S.Text])
75− -> Buffer s
76− -> ST s [S.Text]
77− }
78−
79−instance Monoid Builder where
80− mempty = empty
81− {-# INLINE mempty #-}
82− mappend = append
83− {-# INLINE mappend #-}
84−
85−instance String.IsString Builder where
86− fromString = fromString
87− {-# INLINE fromString #-}
88−
89−instance Show Builder where
90− show = L.unpack . toLazyText
91−
92−------------------------------------------------------------------------
93−
94−-- | /O(1)./ The empty @Builder@, satisfying
95−--
96−-- * @'toLazyText' 'empty' = 'L.empty'@
97−--
98−empty :: Builder
99−empty = Builder id
100−{-# INLINE empty #-}
101−
102−-- | /O(1)./ A @Builder@ taking a single character, satisfying
103−--
104−-- * @'toLazyText' ('singleton' c) = 'L.singleton' c@
105−--
106−singleton :: Char -> Builder
107−singleton c = putChar c
108−{-# INLINE singleton #-}
109−
110−------------------------------------------------------------------------
111−
112−-- | /O(1)./ The concatenation of two builders, an associative
113−-- operation with identity 'empty', satisfying
114−--
115−-- * @'toLazyText' ('append' x y) = 'L.append' ('toLazyText' x) ('toLazyText' y)@
116−--
117−append :: Builder -> Builder -> Builder
118−append (Builder f) (Builder g) = Builder (f . g)
119−{-# INLINE [0] append #-}
120−
121−-- TODO: Experiment to find the right threshold.
122−copyLimit :: Int
123−copyLimit = 128
124−
125−-- This function attempts to merge small @Text@ values instead of
126−-- treating each value as its own chunk. We may not always want this.
127−
128−-- | /O(1)./ A @Builder@ taking a 'S.Text', satisfying
129−--
130−-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
131−--
132−fromText :: S.Text -> Builder
133−fromText t@(Text arr off l)
134− | S.null t = empty
135− | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
136− | otherwise = flush `append` mapBuilder (t :)
137−{-# INLINE [1] fromText #-}
138−
139−{-# RULES
140−"fromText/pack" forall s .
141− fromText (S.pack s) = fromString s
142− #-}
143−
144−-- | /O(1)./ A Builder taking a @String@, satisfying
145−--
146−-- * @'toLazyText' ('fromString' s) = 'L.fromChunks' [S.pack s]@
147−--
148−fromString :: String -> Builder
149−fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
150− let loop !marr !o !u !l [] = k (Buffer marr o u l)
151− loop marr o u l s@(c:cs)
152− | l <= 1 = do
153− arr <- A.unsafeFreeze marr
154− let !t = Text arr o u
155− marr' <- A.new chunkSize
156− ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
157− return $ t : ts
158− | otherwise = do
159− n <- unsafeWrite marr (o+u) c
160− loop marr o (u+n) (l-n) cs
161− in loop p0 o0 u0 l0 str
162− where
163− chunkSize = smallChunkSize
164−{-# INLINE fromString #-}
165−
166−-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
167−--
168−-- * @'toLazyText' ('fromLazyText' t) = t@
169−--
170−fromLazyText :: L.Text -> Builder
171−fromLazyText ts = flush `append` mapBuilder (L.toChunks ts ++)
172−{-# INLINE fromLazyText #-}
173−
174−------------------------------------------------------------------------
175−
176−-- Our internal buffer type
177−data Buffer s = Buffer {-# UNPACK #-} !(A.MArray s)
178− {-# UNPACK #-} !Int -- offset
179− {-# UNPACK #-} !Int -- used units
180− {-# UNPACK #-} !Int -- length left
181−
182−------------------------------------------------------------------------
183−
184−-- | /O(n)./ Extract a lazy @Text@ from a @Builder@ with a default
185−-- buffer size. The construction work takes place if and when the
186−-- relevant part of the lazy @Text@ is demanded.
187−toLazyText :: Builder -> L.Text
188−toLazyText = toLazyTextWith smallChunkSize
189−
190−-- | /O(n)./ Extract a lazy @Text@ from a @Builder@, using the given
191−-- size for the initial buffer. The construction work takes place if
192−-- and when the relevant part of the lazy @Text@ is demanded.
193−--
194−-- If the initial buffer is too small to hold all data, subsequent
195−-- buffers will be the default buffer size.
196−toLazyTextWith :: Int -> Builder -> L.Text
197−toLazyTextWith chunkSize m = L.fromChunks (runST $
198− newBuffer chunkSize >>= runBuilder (m `append` flush) (const (return [])))
199−
200−-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
201−-- yielding a new chunk in the result lazy @Text@.
202−flush :: Builder
203−flush = Builder $ \ k buf@(Buffer p o u l) ->
204− if u == 0
205− then k buf
206− else do arr <- A.unsafeFreeze p
207− let !b = Buffer p (o+u) 0 l
208− !t = Text arr o u
209− ts <- inlineInterleaveST (k b)
210− return $! t : ts
211−
212−------------------------------------------------------------------------
213−
214−-- | Sequence an ST operation on the buffer
215−withBuffer :: (forall s. Buffer s -> ST s (Buffer s)) -> Builder
216−withBuffer f = Builder $ \k buf -> f buf >>= k
217−{-# INLINE withBuffer #-}
218−
219−-- | Get the size of the buffer
220−withSize :: (Int -> Builder) -> Builder
221−withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
222− runBuilder (f l) k buf
223−{-# INLINE withSize #-}
224−
225−-- | Map the resulting list of texts.
226−mapBuilder :: ([S.Text] -> [S.Text]) -> Builder
227−mapBuilder f = Builder (fmap f .)
228−
229−------------------------------------------------------------------------
230−
231−putChar :: Char -> Builder
232−putChar c
233− | n < 0x10000 = writeN 1 $ \marr o -> A.unsafeWrite marr o (fromIntegral n)
234− | otherwise = writeN 2 $ \marr o -> do
235− A.unsafeWrite marr o lo
236− A.unsafeWrite marr (o+1) hi
237− where n = ord c
238− m = n - 0x10000
239− lo = fromIntegral $ (m `shiftR` 10) + 0xD800
240− hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00
241−{-# INLINE putChar #-}
242−
243−------------------------------------------------------------------------
244−
245−-- | Ensure that there are at least @n@ many elements available.
246−ensureFree :: Int -> Builder
247−ensureFree !n = withSize $ \ l ->
248− if n <= l
249− then empty
250− else flush `append'` withBuffer (const (newBuffer (max n smallChunkSize)))
251−{-# INLINE [0] ensureFree #-}
252−
253−-- | Ensure that @n@ many elements are available, and then use @f@ to
254−-- write some elements into the memory.
255−writeN :: Int -> (forall s. A.MArray s -> Int -> ST s ()) -> Builder
256−writeN n f = ensureFree n `append'` withBuffer (writeNBuffer n f)
257−{-# INLINE [0] writeN #-}
258−
259−writeNBuffer :: Int -> (A.MArray s -> Int -> ST s ()) -> (Buffer s)
260− -> ST s (Buffer s)
261−writeNBuffer n f (Buffer p o u l) = do
262− f p (o+u)
263− return $! Buffer p o (u+n) (l-n)
264−{-# INLINE writeNBuffer #-}
265−
266−newBuffer :: Int -> ST s (Buffer s)
267−newBuffer size = do
268− arr <- A.new size
269− return $! Buffer arr 0 0 size
270−{-# INLINE newBuffer #-}
271−
272−------------------------------------------------------------------------
273−-- Some nice rules for Builder
274−
275−-- This function makes GHC understand that 'writeN' and 'ensureFree'
276−-- are *not* recursive in the precense of the rewrite rules below.
277−-- This is not needed with GHC 6.14+.
278−append' :: Builder -> Builder -> Builder
279−append' (Builder f) (Builder g) = Builder (f . g)
280−{-# INLINE append' #-}
281−
282−{-# RULES
283−
284−"append/writeN" forall a b (f::forall s. A.MArray s -> Int -> ST s ())
285− (g::forall s. A.MArray s -> Int -> ST s ()) ws.
286− append (writeN a f) (append (writeN b g) ws) =
287− append (writeN (a+b) (\marr o -> f marr o >> g marr (o+a))) ws
288−
289−"writeN/writeN" forall a b (f::forall s. A.MArray s -> Int -> ST s ())
290− (g::forall s. A.MArray s -> Int -> ST s ()).
291− append (writeN a f) (writeN b g) =
292− writeN (a+b) (\marr o -> f marr o >> g marr (o+a))
293−
294−"ensureFree/ensureFree" forall a b .
295− append (ensureFree a) (ensureFree b) = ensureFree (max a b)
296−
297−"flush/flush"
298− append flush flush = flush
299−
300− #-}
58+import Data.Text.Internal.Builder
Data/Text/Lazy/Builder/Int.hsnew file+262
@@ -0,0 +1,262 @@
1+{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, ScopedTypeVariables,
2+ UnboxedTuples #-}
3+#if __GLASGOW_HASKELL__ >= 702
4+{-# LANGUAGE Trustworthy #-}
5+#endif
6+
7+-- Module: Data.Text.Lazy.Builder.Int
8+-- Copyright: (c) 2013 Bryan O'Sullivan
9+-- (c) 2011 MailRank, Inc.
10+-- License: BSD-style
11+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
12+-- Stability: experimental
13+-- Portability: portable
14+--
15+-- Efficiently write an integral value to a 'Builder'.
16+
17+module Data.Text.Lazy.Builder.Int
18+ (
19+ decimal
20+ , hexadecimal
21+ ) where
22+
23+import Data.Int (Int8, Int16, Int32, Int64)
24+import Data.Monoid (mempty)
25+import qualified Data.ByteString.Unsafe as B
26+import Data.Text.Internal.Builder.Functions ((<>), i2d)
27+import Data.Text.Internal.Builder
28+import Data.Text.Internal.Builder.Int.Digits (digits)
29+import Data.Text.Array
30+import Data.Word (Word, Word8, Word16, Word32, Word64)
31+import GHC.Base (quotInt, remInt)
32+import GHC.Num (quotRemInteger)
33+import GHC.Types (Int(..))
34+import Control.Monad.ST
35+
36+#ifdef __GLASGOW_HASKELL__
37+# if defined(INTEGER_GMP)
38+import GHC.Integer.GMP.Internals (Integer(S#))
39+# elif defined(INTEGER_SIMPLE)
40+import GHC.Integer
41+# else
42+# error "You need to use either GMP or integer-simple."
43+# endif
44+#endif
45+
46+#if defined(INTEGER_GMP) || defined(INTEGER_SIMPLE)
47+# define PAIR(a,b) (# a,b #)
48+#else
49+# define PAIR(a,b) (a,b)
50+#endif
51+
52+decimal :: Integral a => a -> Builder
53+{-# RULES "decimal/Int8" decimal = boundedDecimal :: Int8 -> Builder #-}
54+{-# RULES "decimal/Int" decimal = boundedDecimal :: Int -> Builder #-}
55+{-# RULES "decimal/Int16" decimal = boundedDecimal :: Int16 -> Builder #-}
56+{-# RULES "decimal/Int32" decimal = boundedDecimal :: Int32 -> Builder #-}
57+{-# RULES "decimal/Int64" decimal = boundedDecimal :: Int64 -> Builder #-}
58+{-# RULES "decimal/Word" decimal = positive :: Data.Word.Word -> Builder #-}
59+{-# RULES "decimal/Word8" decimal = positive :: Word8 -> Builder #-}
60+{-# RULES "decimal/Word16" decimal = positive :: Word16 -> Builder #-}
61+{-# RULES "decimal/Word32" decimal = positive :: Word32 -> Builder #-}
62+{-# RULES "decimal/Word64" decimal = positive :: Word64 -> Builder #-}
63+{-# RULES "decimal/Integer" decimal = integer 10 :: Integer -> Builder #-}
64+decimal i = decimal' (<= -128) i
65+{-# NOINLINE decimal #-}
66+
67+boundedDecimal :: (Integral a, Bounded a) => a -> Builder
68+{-# SPECIALIZE boundedDecimal :: Int -> Builder #-}
69+{-# SPECIALIZE boundedDecimal :: Int8 -> Builder #-}
70+{-# SPECIALIZE boundedDecimal :: Int16 -> Builder #-}
71+{-# SPECIALIZE boundedDecimal :: Int32 -> Builder #-}
72+{-# SPECIALIZE boundedDecimal :: Int64 -> Builder #-}
73+boundedDecimal i = decimal' (== minBound) i
74+
75+decimal' :: (Integral a) => (a -> Bool) -> a -> Builder
76+{-# INLINE decimal' #-}
77+decimal' p i
78+ | i < 0 = if p i
79+ then let (q, r) = i `quotRem` 10
80+ qq = -q
81+ !n = countDigits qq
82+ in writeN (n + 2) $ \marr off -> do
83+ unsafeWrite marr off minus
84+ posDecimal marr (off+1) n qq
85+ unsafeWrite marr (off+n+1) (i2w (-r))
86+ else let j = -i
87+ !n = countDigits j
88+ in writeN (n + 1) $ \marr off ->
89+ unsafeWrite marr off minus >> posDecimal marr (off+1) n j
90+ | otherwise = positive i
91+
92+positive :: (Integral a) => a -> Builder
93+{-# SPECIALIZE positive :: Int -> Builder #-}
94+{-# SPECIALIZE positive :: Int8 -> Builder #-}
95+{-# SPECIALIZE positive :: Int16 -> Builder #-}
96+{-# SPECIALIZE positive :: Int32 -> Builder #-}
97+{-# SPECIALIZE positive :: Int64 -> Builder #-}
98+{-# SPECIALIZE positive :: Word -> Builder #-}
99+{-# SPECIALIZE positive :: Word8 -> Builder #-}
100+{-# SPECIALIZE positive :: Word16 -> Builder #-}
101+{-# SPECIALIZE positive :: Word32 -> Builder #-}
102+{-# SPECIALIZE positive :: Word64 -> Builder #-}
103+positive i
104+ | i < 10 = writeN 1 $ \marr off -> unsafeWrite marr off (i2w i)
105+ | otherwise = let !n = countDigits i
106+ in writeN n $ \marr off -> posDecimal marr off n i
107+
108+posDecimal :: (Integral a) =>
109+ forall s. MArray s -> Int -> Int -> a -> ST s ()
110+{-# INLINE posDecimal #-}
111+posDecimal marr off0 ds v0 = go (off0 + ds - 1) v0
112+ where go off v
113+ | v >= 100 = do
114+ let (q, r) = v `quotRem` 100
115+ write2 off r
116+ go (off - 2) q
117+ | v < 10 = unsafeWrite marr off (i2w v)
118+ | otherwise = write2 off v
119+ write2 off i0 = do
120+ let i = fromIntegral i0; j = i + i
121+ unsafeWrite marr off $ get (j + 1)
122+ unsafeWrite marr (off - 1) $ get j
123+ get = fromIntegral . B.unsafeIndex digits
124+
125+minus, zero :: Word16
126+{-# INLINE minus #-}
127+{-# INLINE zero #-}
128+minus = 45
129+zero = 48
130+
131+i2w :: (Integral a) => a -> Word16
132+{-# INLINE i2w #-}
133+i2w v = zero + fromIntegral v
134+
135+countDigits :: (Integral a) => a -> Int
136+{-# INLINE countDigits #-}
137+countDigits v0
138+ | fromIntegral v64 == v0 = go 1 v64
139+ | otherwise = goBig 1 (fromIntegral v0)
140+ where v64 = fromIntegral v0
141+ goBig !k (v :: Integer)
142+ | v > big = goBig (k + 19) (v `quot` big)
143+ | otherwise = go k (fromIntegral v)
144+ big = 10000000000000000000
145+ go !k (v :: Word64)
146+ | v < 10 = k
147+ | v < 100 = k + 1
148+ | v < 1000 = k + 2
149+ | v < 1000000000000 =
150+ k + if v < 100000000
151+ then if v < 1000000
152+ then if v < 10000
153+ then 3
154+ else 4 + fin v 100000
155+ else 6 + fin v 10000000
156+ else if v < 10000000000
157+ then 8 + fin v 1000000000
158+ else 10 + fin v 100000000000
159+ | otherwise = go (k + 12) (v `quot` 1000000000000)
160+ fin v n = if v >= n then 1 else 0
161+
162+hexadecimal :: Integral a => a -> Builder
163+{-# SPECIALIZE hexadecimal :: Int -> Builder #-}
164+{-# SPECIALIZE hexadecimal :: Int8 -> Builder #-}
165+{-# SPECIALIZE hexadecimal :: Int16 -> Builder #-}
166+{-# SPECIALIZE hexadecimal :: Int32 -> Builder #-}
167+{-# SPECIALIZE hexadecimal :: Int64 -> Builder #-}
168+{-# SPECIALIZE hexadecimal :: Word -> Builder #-}
169+{-# SPECIALIZE hexadecimal :: Word8 -> Builder #-}
170+{-# SPECIALIZE hexadecimal :: Word16 -> Builder #-}
171+{-# SPECIALIZE hexadecimal :: Word32 -> Builder #-}
172+{-# SPECIALIZE hexadecimal :: Word64 -> Builder #-}
173+{-# RULES "hexadecimal/Integer"
174+ hexadecimal = hexInteger :: Integer -> Builder #-}
175+hexadecimal i
176+ | i < 0 = error hexErrMsg
177+ | otherwise = go i
178+ where
179+ go n | n < 16 = hexDigit n
180+ | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16)
181+{-# NOINLINE[0] hexadecimal #-}
182+
183+hexInteger :: Integer -> Builder
184+hexInteger i
185+ | i < 0 = error hexErrMsg
186+ | otherwise = integer 16 i
187+
188+hexErrMsg :: String
189+hexErrMsg = "Data.Text.Lazy.Builder.Int.hexadecimal: applied to negative number"
190+
191+hexDigit :: Integral a => a -> Builder
192+hexDigit n
193+ | n <= 9 = singleton $! i2d (fromIntegral n)
194+ | otherwise = singleton $! toEnum (fromIntegral n + 87)
195+{-# INLINE hexDigit #-}
196+
197+data T = T !Integer !Int
198+
199+integer :: Int -> Integer -> Builder
200+#ifdef INTEGER_GMP
201+integer 10 (S# i#) = decimal (I# i#)
202+integer 16 (S# i#) = hexadecimal (I# i#)
203+#endif
204+integer base i
205+ | i < 0 = singleton '-' <> go (-i)
206+ | otherwise = go i
207+ where
208+ go n | n < maxInt = int (fromInteger n)
209+ | otherwise = putH (splitf (maxInt * maxInt) n)
210+
211+ splitf p n
212+ | p > n = [n]
213+ | otherwise = splith p (splitf (p*p) n)
214+
215+ splith p (n:ns) = case n `quotRemInteger` p of
216+ PAIR(q,r) | q > 0 -> q : r : splitb p ns
217+ | otherwise -> r : splitb p ns
218+ splith _ _ = error "splith: the impossible happened."
219+
220+ splitb p (n:ns) = case n `quotRemInteger` p of
221+ PAIR(q,r) -> q : r : splitb p ns
222+ splitb _ _ = []
223+
224+ T maxInt10 maxDigits10 =
225+ until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)
226+ where mi = fromIntegral (maxBound :: Int)
227+ T maxInt16 maxDigits16 =
228+ until ((>mi) . (*16) . fstT) (\(T n d) -> T (n*16) (d+1)) (T 16 1)
229+ where mi = fromIntegral (maxBound :: Int)
230+
231+ fstT (T a _) = a
232+
233+ maxInt | base == 10 = maxInt10
234+ | otherwise = maxInt16
235+ maxDigits | base == 10 = maxDigits10
236+ | otherwise = maxDigits16
237+
238+ putH (n:ns) = case n `quotRemInteger` maxInt of
239+ PAIR(x,y)
240+ | q > 0 -> int q <> pblock r <> putB ns
241+ | otherwise -> int r <> putB ns
242+ where q = fromInteger x
243+ r = fromInteger y
244+ putH _ = error "putH: the impossible happened"
245+
246+ putB (n:ns) = case n `quotRemInteger` maxInt of
247+ PAIR(x,y) -> pblock q <> pblock r <> putB ns
248+ where q = fromInteger x
249+ r = fromInteger y
250+ putB _ = Data.Monoid.mempty
251+
252+ int :: Int -> Builder
253+ int x | base == 10 = decimal x
254+ | otherwise = hexadecimal x
255+
256+ pblock = loop maxDigits
257+ where
258+ loop !d !n
259+ | d == 1 = hexDigit n
260+ | otherwise = loop (d-1) q <> hexDigit r
261+ where q = n `quotInt` base
262+ r = n `remInt` base
Data/Text/Lazy/Builder/RealFloat.hsnew file+242
@@ -0,0 +1,242 @@
1+{-# LANGUAGE CPP, OverloadedStrings #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
5+
6+-- |
7+-- Module: Data.Text.Lazy.Builder.RealFloat
8+-- Copyright: (c) The University of Glasgow 1994-2002
9+-- License: see libraries/base/LICENSE
10+--
11+-- Write a floating point value to a 'Builder'.
12+
13+module Data.Text.Lazy.Builder.RealFloat
14+ (
15+ FPFormat(..)
16+ , realFloat
17+ , formatRealFloat
18+ ) where
19+
20+import Data.Array.Base (unsafeAt)
21+import Data.Array.IArray
22+import Data.Text.Internal.Builder.Functions ((<>), i2d)
23+import Data.Text.Lazy.Builder.Int (decimal)
24+import Data.Text.Internal.Builder.RealFloat.Functions (roundTo)
25+import Data.Text.Lazy.Builder
26+import qualified Data.Text as T
27+
28+-- | Control the rendering of floating point numbers.
29+data FPFormat = Exponent
30+ -- ^ Scientific notation (e.g. @2.3e123@).
31+ | Fixed
32+ -- ^ Standard decimal notation.
33+ | Generic
34+ -- ^ Use decimal notation for values between @0.1@ and
35+ -- @9,999,999@, and scientific notation otherwise.
36+ deriving (Enum, Read, Show)
37+
38+-- | Show a signed 'RealFloat' value to full precision,
39+-- using standard decimal notation for arguments whose absolute value lies
40+-- between @0.1@ and @9,999,999@, and scientific notation otherwise.
41+realFloat :: (RealFloat a) => a -> Builder
42+{-# SPECIALIZE realFloat :: Float -> Builder #-}
43+{-# SPECIALIZE realFloat :: Double -> Builder #-}
44+realFloat x = formatRealFloat Generic Nothing x
45+
46+formatRealFloat :: (RealFloat a) =>
47+ FPFormat
48+ -> Maybe Int -- ^ Number of decimal places to render.
49+ -> a
50+ -> Builder
51+{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Float -> Builder #-}
52+{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Double -> Builder #-}
53+formatRealFloat fmt decs x
54+ | isNaN x = "NaN"
55+ | isInfinite x = if x < 0 then "-Infinity" else "Infinity"
56+ | x < 0 || isNegativeZero x = singleton '-' <> doFmt fmt (floatToDigits (-x))
57+ | otherwise = doFmt fmt (floatToDigits x)
58+ where
59+ doFmt format (is, e) =
60+ let ds = map i2d is in
61+ case format of
62+ Generic ->
63+ doFmt (if e < 0 || e > 7 then Exponent else Fixed)
64+ (is,e)
65+ Exponent ->
66+ case decs of
67+ Nothing ->
68+ let show_e' = decimal (e-1) in
69+ case ds of
70+ "0" -> "0.0e0"
71+ [d] -> singleton d <> ".0e" <> show_e'
72+ (d:ds') -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> show_e'
73+ [] -> error "formatRealFloat/doFmt/Exponent: []"
74+ Just dec ->
75+ let dec' = max dec 1 in
76+ case is of
77+ [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0"
78+ _ ->
79+ let
80+ (ei,is') = roundTo (dec'+1) is
81+ (d:ds') = map i2d (if ei > 0 then init is' else is')
82+ in
83+ singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei)
84+ Fixed ->
85+ let
86+ mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls}
87+ in
88+ case decs of
89+ Nothing
90+ | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds
91+ | otherwise ->
92+ let
93+ f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs
94+ f n s "" = f (n-1) ('0':s) ""
95+ f n s (r:rs) = f (n-1) (r:s) rs
96+ in
97+ f e "" ds
98+ Just dec ->
99+ let dec' = max dec 0 in
100+ if e >= 0 then
101+ let
102+ (ei,is') = roundTo (dec' + e) is
103+ (ls,rs) = splitAt (e+ei) (map i2d is')
104+ in
105+ mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs)
106+ else
107+ let
108+ (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)
109+ d:ds' = map i2d (if ei > 0 then is' else 0:is')
110+ in
111+ singleton d <> (if null ds' then "" else singleton '.' <> fromString ds')
112+
113+
114+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
115+-- by R.G. Burger and R.K. Dybvig in PLDI 96.
116+-- This version uses a much slower logarithm estimator. It should be improved.
117+
118+-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,
119+-- and returns a list of digits and an exponent.
120+-- In particular, if @x>=0@, and
121+--
122+-- > floatToDigits base x = ([d1,d2,...,dn], e)
123+--
124+-- then
125+--
126+-- (1) @n >= 1@
127+--
128+-- (2) @x = 0.d1d2...dn * (base**e)@
129+--
130+-- (3) @0 <= di <= base-1@
131+
132+floatToDigits :: (RealFloat a) => a -> ([Int], Int)
133+{-# SPECIALIZE floatToDigits :: Float -> ([Int], Int) #-}
134+{-# SPECIALIZE floatToDigits :: Double -> ([Int], Int) #-}
135+floatToDigits 0 = ([0], 0)
136+floatToDigits x =
137+ let
138+ (f0, e0) = decodeFloat x
139+ (minExp0, _) = floatRange x
140+ p = floatDigits x
141+ b = floatRadix x
142+ minExp = minExp0 - p -- the real minimum exponent
143+ -- Haskell requires that f be adjusted so denormalized numbers
144+ -- will have an impossibly low exponent. Adjust for this.
145+ (f, e) =
146+ let n = minExp - e0 in
147+ if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0)
148+ (r, s, mUp, mDn) =
149+ if e >= 0 then
150+ let be = expt b e in
151+ if f == expt b (p-1) then
152+ (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig
153+ else
154+ (f*be*2, 2, be, be)
155+ else
156+ if e > minExp && f == expt b (p-1) then
157+ (f*b*2, expt b (-e+1)*2, b, 1)
158+ else
159+ (f*2, expt b (-e)*2, 1, 1)
160+ k :: Int
161+ k =
162+ let
163+ k0 :: Int
164+ k0 =
165+ if b == 2 then
166+ -- logBase 10 2 is very slightly larger than 8651/28738
167+ -- (about 5.3558e-10), so if log x >= 0, the approximation
168+ -- k1 is too small, hence we add one and need one fixup step less.
169+ -- If log x < 0, the approximation errs rather on the high side.
170+ -- That is usually more than compensated for by ignoring the
171+ -- fractional part of logBase 2 x, but when x is a power of 1/2
172+ -- or slightly larger and the exponent is a multiple of the
173+ -- denominator of the rational approximation to logBase 10 2,
174+ -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x,
175+ -- we get a leading zero-digit we don't want.
176+ -- With the approximation 3/10, this happened for
177+ -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above.
178+ -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x
179+ -- for IEEE-ish floating point types with exponent fields
180+ -- <= 17 bits and mantissae of several thousand bits, earlier
181+ -- convergents to logBase 10 2 would fail for long double.
182+ -- Using quot instead of div is a little faster and requires
183+ -- fewer fixup steps for negative lx.
184+ let lx = p - 1 + e0
185+ k1 = (lx * 8651) `quot` 28738
186+ in if lx >= 0 then k1 + 1 else k1
187+ else
188+ -- f :: Integer, log :: Float -> Float,
189+ -- ceiling :: Float -> Int
190+ ceiling ((log (fromInteger (f+1) :: Float) +
191+ fromIntegral e * log (fromInteger b)) /
192+ log 10)
193+--WAS: fromInt e * log (fromInteger b))
194+
195+ fixup n =
196+ if n >= 0 then
197+ if r + mUp <= expt 10 n * s then n else fixup (n+1)
198+ else
199+ if expt 10 (-n) * (r + mUp) <= s then n else fixup (n+1)
200+ in
201+ fixup k0
202+
203+ gen ds rn sN mUpN mDnN =
204+ let
205+ (dn, rn') = (rn * 10) `quotRem` sN
206+ mUpN' = mUpN * 10
207+ mDnN' = mDnN * 10
208+ in
209+ case (rn' < mDnN', rn' + mUpN' > sN) of
210+ (True, False) -> dn : ds
211+ (False, True) -> dn+1 : ds
212+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
213+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
214+
215+ rds =
216+ if k >= 0 then
217+ gen [] r (s * expt 10 k) mUp mDn
218+ else
219+ let bk = expt 10 (-k) in
220+ gen [] (r * bk) s (mUp * bk) (mDn * bk)
221+ in
222+ (map fromIntegral (reverse rds), k)
223+
224+-- Exponentiation with a cache for the most common numbers.
225+minExpt, maxExpt :: Int
226+minExpt = 0
227+maxExpt = 1100
228+
229+expt :: Integer -> Int -> Integer
230+expt base n
231+ | base == 2 && n >= minExpt && n <= maxExpt = expts `unsafeAt` n
232+ | base == 10 && n <= maxExpt10 = expts10 `unsafeAt` n
233+ | otherwise = base^n
234+
235+expts :: Array Int Integer
236+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
237+
238+maxExpt10 :: Int
239+maxExpt10 = 324
240+
241+expts10 :: Array Int Integer
242+expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]]
Data/Text/Lazy/Encoding.hs+87−49
@@ -1,11 +1,13 @@
1−{-# LANGUAGE BangPatterns #-}
1+{-# LANGUAGE BangPatterns,CPP #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
25-- |
36-- Module : Data.Text.Lazy.Encoding
47-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
58--
69-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8−-- duncan@haskell.org
10+-- Maintainer : bos@serpentine.com
911-- Stability : experimental
1012-- Portability : portable
1113--
@@ -20,11 +22,16 @@ module Data.Text.Lazy.Encoding
2022 -- * Decoding ByteStrings to Text
2123 -- $strict
2224 decodeASCII
25+ , decodeLatin1
2326 , decodeUtf8
2427 , decodeUtf16LE
2528 , decodeUtf16BE
2629 , decodeUtf32LE
2730 , decodeUtf32BE
31+
32+ -- ** Catchable failure
33+ , decodeUtf8'
34+
2835 -- ** Controllable error handling
2936 , decodeUtf8With
3037 , decodeUtf16LEWith
@@ -38,19 +45,29 @@ module Data.Text.Lazy.Encoding
3845 , encodeUtf16BE
3946 , encodeUtf32LE
4047 , encodeUtf32BE
48+
49+ -- * Encoding Text using ByteString Builders
50+ , encodeUtf8Builder
51+ , encodeUtf8BuilderEscaped
4152 ) where
4253
43−import Data.Bits ((.&.))
44−import Data.Text.Encoding.Error (OnDecodeError, strictDecode)
45−import Data.Text.Lazy.Internal (Text(..), chunk, empty, foldrChunks)
54+import Control.Exception (evaluate, try)
55+import Data.Monoid (Monoid(..))
56+import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
57+import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldrChunks)
58+import Data.Word (Word8)
4659import qualified Data.ByteString as S
60+import qualified Data.ByteString.Builder as B
61+import qualified Data.ByteString.Builder.Extra as B (safeStrategy, toLazyByteStringWith)
62+import qualified Data.ByteString.Builder.Prim as BP
4763import qualified Data.ByteString.Lazy as B
4864import qualified Data.ByteString.Lazy.Internal as B
49−import qualified Data.ByteString.Unsafe as S
65+import qualified Data.ByteString.Unsafe as B
5066import qualified Data.Text as T
5167import qualified Data.Text.Encoding as TE
52−import qualified Data.Text.Lazy.Encoding.Fusion as E
53−import qualified Data.Text.Lazy.Fusion as F
68+import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E
69+import qualified Data.Text.Internal.Lazy.Fusion as F
70+import Data.Text.Unsafe (unsafeDupablePerformIO)
5471
5572-- $strict
5673--
@@ -65,53 +82,39 @@ import qualified Data.Text.Lazy.Fusion as F
6582-- 'decodeUtf8With' allows the programmer to determine what to do on a
6683-- decoding error.
6784
68−-- | Decode a 'ByteString' containing 7-bit ASCII encoded text.
85+-- | /Deprecated/. Decode a 'ByteString' containing 7-bit ASCII
86+-- encoded text.
6987decodeASCII :: B.ByteString -> Text
70−decodeASCII bs = foldr (chunk . TE.decodeASCII) empty (B.toChunks bs)
71−{-# INLINE decodeASCII #-}
88+decodeASCII = decodeUtf8
89+{-# DEPRECATED decodeASCII "Use decodeUtf8 instead" #-}
90+
91+-- | Decode a 'ByteString' containing Latin-1 (aka ISO-8859-1) encoded text.
92+decodeLatin1 :: B.ByteString -> Text
93+decodeLatin1 = foldr (chunk . TE.decodeLatin1) empty . B.toChunks
7294
7395-- | Decode a 'ByteString' containing UTF-8 encoded text.
7496decodeUtf8With :: OnDecodeError -> B.ByteString -> Text
75−decodeUtf8With onErr bs0 = fast bs0
97+decodeUtf8With onErr (B.Chunk b0 bs0) =
98+ case TE.streamDecodeUtf8With onErr b0 of
99+ TE.Some t l f -> chunk t (go f l bs0)
76100 where
77− decode = TE.decodeUtf8With onErr
78− fast (B.Chunk p ps) | isComplete p = chunk (decode p) (fast ps)
79− | otherwise = chunk (decode h) (slow t ps)
80− where (h,t) = S.splitAt pivot p
81− pivot | at 1 = len-1
82− | at 2 = len-2
83− | otherwise = len-3
84− len = S.length p
85− at n = len >= n && S.unsafeIndex p (len-n) .&. 0xc0 == 0xc0
86− fast B.Empty = empty
87− slow i bs = {-# SCC "decodeUtf8With'/slow" #-}
88− case B.uncons bs of
89− Just (w,bs') | isComplete i' -> chunk (decode i') (fast bs')
90− | otherwise -> slow i' bs'
91− where i' = S.snoc i w
92− Nothing -> case S.uncons i of
93− Just (j,i') ->
94− case onErr desc (Just j) of
95− Nothing -> slow i' bs
96− Just c -> Chunk (T.singleton c) (slow i' bs)
97− Nothing ->
98− case onErr desc Nothing of
99− Nothing -> empty
100− Just c -> Chunk (T.singleton c) empty
101− isComplete bs = {-# SCC "decodeUtf8With'/isComplete" #-}
102− ix 1 .&. 0x80 == 0 ||
103− (len >= 2 && ix 2 .&. 0xe0 == 0xc0) ||
104− (len >= 3 && ix 3 .&. 0xf0 == 0xe0) ||
105− (len >= 4 && ix 4 .&. 0xf8 == 0xf0)
106− where len = S.length bs
107− ix n = S.unsafeIndex bs (len-n)
101+ go f0 _ (B.Chunk b bs) =
102+ case f0 b of
103+ TE.Some t l f -> chunk t (go f l bs)
104+ go _ l _
105+ | S.null l = empty
106+ | otherwise = case onErr desc (Just (B.unsafeHead l)) of
107+ Nothing -> empty
108+ Just c -> Chunk (T.singleton c) Empty
108109 desc = "Data.Text.Lazy.Encoding.decodeUtf8With: Invalid UTF-8 stream"
109−{-# INLINE[0] decodeUtf8With #-}
110+decodeUtf8With _ _ = empty
110111
111−-- | Decode a 'ByteString' containing UTF-8 encoded text.
112+-- | Decode a 'ByteString' containing UTF-8 encoded text that is known
113+-- to be valid.
112114--
113115-- If the input contains any invalid UTF-8 data, an exception will be
114−-- thrown. For more control over the handling of invalid data, use
116+-- thrown that cannot be caught in pure code. For more control over
117+-- the handling of invalid data, use 'decodeUtf8'' or
115118-- 'decodeUtf8With'.
116119decodeUtf8 :: B.ByteString -> Text
117120decodeUtf8 = decodeUtf8With strictDecode
@@ -121,9 +124,44 @@ decodeUtf8 = decodeUtf8With strictDecode
121124{- RULES "LAZY STREAM stream/decodeUtf8' fusion" [1]
122125 forall bs. F.stream (decodeUtf8' bs) = E.streamUtf8 strictDecode bs #-}
123126
127+-- | Decode a 'ByteString' containing UTF-8 encoded text..
128+--
129+-- If the input contains any invalid UTF-8 data, the relevant
130+-- exception will be returned, otherwise the decoded text.
131+--
132+-- /Note/: this function is /not/ lazy, as it must decode its entire
133+-- input before it can return a result. If you need lazy (streaming)
134+-- decoding, use 'decodeUtf8With' in lenient mode.
135+decodeUtf8' :: B.ByteString -> Either UnicodeException Text
136+decodeUtf8' bs = unsafeDupablePerformIO $ do
137+ let t = decodeUtf8 bs
138+ try (evaluate (rnf t `seq` t))
139+ where
140+ rnf Empty = ()
141+ rnf (Chunk _ ts) = rnf ts
142+{-# INLINE decodeUtf8' #-}
143+
124144encodeUtf8 :: Text -> B.ByteString
125−encodeUtf8 (Chunk c cs) = B.Chunk (TE.encodeUtf8 c) (encodeUtf8 cs)
126−encodeUtf8 Empty = B.Empty
145+encodeUtf8 Empty = B.empty
146+encodeUtf8 lt@(Chunk t _) =
147+ B.toLazyByteStringWith strategy B.empty $ encodeUtf8Builder lt
148+ where
149+ -- To improve our small string performance, we use a strategy that
150+ -- allocates a buffer that is guaranteed to be large enough for the
151+ -- encoding of the first chunk, but not larger than the default
152+ -- B.smallChunkSize. We clamp the firstChunkSize to ensure that we don't
153+ -- generate too large buffers which hamper streaming.
154+ firstChunkSize = min B.smallChunkSize (4 * (T.length t + 1))
155+ strategy = B.safeStrategy firstChunkSize B.defaultChunkSize
156+
157+encodeUtf8Builder :: Text -> B.Builder
158+encodeUtf8Builder =
159+ foldrChunks (\c b -> TE.encodeUtf8Builder c `mappend` b) Data.Monoid.mempty
160+
161+{-# INLINE encodeUtf8BuilderEscaped #-}
162+encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder
163+encodeUtf8BuilderEscaped prim =
164+ foldrChunks (\c b -> TE.encodeUtf8BuilderEscaped prim c `mappend` b) mempty
127165
128166-- | Decode text from little endian UTF-16 encoding.
129167decodeUtf16LEWith :: OnDecodeError -> B.ByteString -> Text
Data/Text/Lazy/IO.hs+12−23
@@ -1,4 +1,7 @@
11{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
25-- |
36-- Module : Data.Text.Lazy.IO
47-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
@@ -16,7 +19,7 @@
1619module Data.Text.Lazy.IO
1720 (
1821 -- * Performance
19− -- $performance
22+ -- $performance
2023
2124 -- * Locale support
2225 -- $locale
@@ -38,22 +41,17 @@ module Data.Text.Lazy.IO
3841 ) where
3942
4043import Data.Text.Lazy (Text)
41−import Prelude hiding (appendFile, getContents, getLine, interact, putStr,
42− putStrLn, readFile, writeFile)
44+import Prelude hiding (appendFile, getContents, getLine, interact,
45+ putStr, putStrLn, readFile, writeFile)
4346import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,
4447 withFile)
4548import qualified Data.Text.IO as T
4649import qualified Data.Text.Lazy as L
47−#if __GLASGOW_HASKELL__ <= 610
48−import Data.Text.Lazy.Encoding (decodeUtf8)
49−import qualified Data.ByteString.Char8 as S8
50−import qualified Data.ByteString.Lazy.Char8 as L8
51−#else
52−import Control.Exception (throw)
50+import qualified Control.Exception as E
5351import Control.Monad (when)
5452import Data.IORef (readIORef)
55−import Data.Text.IO.Internal (hGetLineWith, readChunk)
56−import Data.Text.Lazy.Internal (chunk, empty)
53+import Data.Text.Internal.IO (hGetLineWith, readChunk)
54+import Data.Text.Internal.Lazy (chunk, empty)
5755import GHC.IO.Buffer (isEmptyBuffer)
5856import GHC.IO.Exception (IOException(..), IOErrorType(..), ioException)
5957import GHC.IO.Handle.Internals (augmentIOError, hClose_help,
@@ -62,7 +60,6 @@ import GHC.IO.Handle.Types (Handle__(..), HandleType(..))
6260import System.IO (BufferMode(..), hGetBuffering, hSetBuffering)
6361import System.IO.Error (isEOFError)
6462import System.IO.Unsafe (unsafeInterleaveIO)
65−#endif
6663
6764-- $performance
6865--
@@ -96,9 +93,6 @@ appendFile p = withFile p AppendMode . flip hPutStr
9693-- | Lazily read the remaining contents of a 'Handle'. The 'Handle'
9794-- will be closed after the read completes, or on error.
9895hGetContents :: Handle -> IO Text
99−#if __GLASGOW_HASKELL__ <= 610
100−hGetContents = fmap decodeUtf8 . L8.hGetContents
101−#else
10296hGetContents h = do
10397 chooseGoodBuffering h
10498 wantReadableHandle "hGetContents" h $ \hh -> do
@@ -119,7 +113,7 @@ lazyRead h = unsafeInterleaveIO $
119113 case haType hh of
120114 ClosedHandle -> return (hh, L.empty)
121115 SemiClosedHandle -> lazyReadBuffered h hh
122− _ -> ioException
116+ _ -> ioException
123117 (IOError (Just h) IllegalOperation "hGetContents"
124118 "illegal handle type" Nothing Nothing)
125119
@@ -128,22 +122,17 @@ lazyReadBuffered h hh@Handle__{..} = do
128122 buf <- readIORef haCharBuffer
129123 (do t <- readChunk hh buf
130124 ts <- lazyRead h
131− return (hh, chunk t ts)) `catch` \e -> do
125+ return (hh, chunk t ts)) `E.catch` \e -> do
132126 (hh', _) <- hClose_help hh
133127 if isEOFError e
134128 then return $ if isEmptyBuffer buf
135129 then (hh', empty)
136130 else (hh', L.singleton '\r')
137− else throw (augmentIOError e "hGetContents" h)
138−#endif
131+ else E.throwIO (augmentIOError e "hGetContents" h)
139132
140133-- | Read a single line from a handle.
141134hGetLine :: Handle -> IO Text
142−#if __GLASGOW_HASKELL__ <= 610
143−hGetLine = fmap (decodeUtf8 . L8.fromChunks . (:[])) . S8.hGetLine
144−#else
145135hGetLine = hGetLineWith L.fromChunks
146−#endif
147136
148137-- | Write a string to a handle.
149138hPutStr :: Handle -> Text -> IO ()
Data/Text/Lazy/Internal.hs+7−105
@@ -1,118 +1,20 @@
11{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
22-- |
33-- Module : Data.Text.Lazy.Internal
4−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
4+-- Copyright : (c) 2013 Bryan O'Sullivan
55--
66-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8−-- duncan@haskell.org
7+-- Maintainer : bos@serpentine.com
98-- Stability : experimental
109-- Portability : GHC
11−--
12−-- A module containing private 'Text' internals. This exposes the
13−-- 'Text' representation and low level construction functions.
14−-- Modules which extend the 'Text' system may need to use this module.
1510--
16−-- You should not use this module unless you are determined to monkey
17−-- with the internals, as the functions here do just about nothing to
18−-- preserve data invariants. You have been warned!
11+-- This module has been renamed to 'Data.Text.Internal.Lazy'. This
12+-- name for the module will be removed in the next major release.
1913
2014module Data.Text.Lazy.Internal
15+ {-# DEPRECATED "Use Data.Text.Internal.Lazy instead" #-}
2116 (
22− Text(..)
23− , chunk
24− , empty
25− , foldrChunks
26− , foldlChunks
27− -- * Data type invariant and abstraction functions
28−
29− -- $invariant
30− , strictInvariant
31− , lazyInvariant
32− , showStructure
33−
34− -- * Chunk allocation sizes
35− , defaultChunkSize
36− , smallChunkSize
37− , chunkOverhead
17+ module Data.Text.Internal.Lazy
3818 ) where
3919
40−import Data.Text ()
41−import Data.Text.UnsafeShift (shiftL)
42−import Data.Typeable (Typeable)
43−import Foreign.Storable (sizeOf)
44−import qualified Data.Text.Internal as T
45−
46−data Text = Empty
47− | Chunk {-# UNPACK #-} !T.Text Text
48− deriving (Typeable)
49−
50−-- $invariant
51−--
52−-- The data type invariant for lazy 'Text': Every 'Text' is either 'Empty' or
53−-- consists of non-null 'T.Text's. All functions must preserve this,
54−-- and the QC properties must check this.
55−
56−-- | Check the invariant strictly.
57−strictInvariant :: Text -> Bool
58−strictInvariant Empty = True
59−strictInvariant x@(Chunk (T.Text _ _ len) cs)
60− | len > 0 = strictInvariant cs
61− | otherwise = error $ "Data.Text.Lazy: invariant violation: "
62− ++ showStructure x
63−
64−-- | Check the invariant lazily.
65−lazyInvariant :: Text -> Text
66−lazyInvariant Empty = Empty
67−lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)
68− | len > 0 = Chunk c (lazyInvariant cs)
69− | otherwise = error $ "Data.Text.Lazy: invariant violation: "
70− ++ showStructure x
71−
72−-- | Display the internal structure of a lazy 'Text'.
73−showStructure :: Text -> String
74−showStructure Empty = "Empty"
75−showStructure (Chunk t Empty) = "Chunk " ++ show t ++ " Empty"
76−showStructure (Chunk t ts) =
77− "Chunk " ++ show t ++ " (" ++ showStructure ts ++ ")"
78−
79−-- | Smart constructor for 'Chunk'. Guarantees the data type invariant.
80−chunk :: T.Text -> Text -> Text
81−{-# INLINE chunk #-}
82−chunk t@(T.Text _ _ len) ts | len == 0 = ts
83− | otherwise = Chunk t ts
84−
85−-- | Smart constructor for 'Empty'.
86−empty :: Text
87−{-# INLINE [0] empty #-}
88−empty = Empty
89−
90−-- | Consume the chunks of a lazy 'Text' with a natural right fold.
91−foldrChunks :: (T.Text -> a -> a) -> a -> Text -> a
92−foldrChunks f z = go
93− where go Empty = z
94− go (Chunk c cs) = f c (go cs)
95−{-# INLINE foldrChunks #-}
96−
97−-- | Consume the chunks of a lazy 'Text' with a strict, tail-recursive,
98−-- accumulating left fold.
99−foldlChunks :: (a -> T.Text -> a) -> a -> Text -> a
100−foldlChunks f z = go z
101− where go !a Empty = a
102− go !a (Chunk c cs) = go (f a c) cs
103−{-# INLINE foldlChunks #-}
104−
105−-- | Currently set to 16 KiB, less the memory management overhead.
106−defaultChunkSize :: Int
107−defaultChunkSize = 16384 - chunkOverhead
108−{-# INLINE defaultChunkSize #-}
109−
110−-- | Currently set to 128 bytes, less the memory management overhead.
111−smallChunkSize :: Int
112−smallChunkSize = 128 - chunkOverhead
113−{-# INLINE smallChunkSize #-}
114−
115−-- | The memory management overhead. Currently this is tuned for GHC only.
116−chunkOverhead :: Int
117−chunkOverhead = sizeOf (undefined :: Int) `shiftL` 1
118−{-# INLINE chunkOverhead #-}
20+import Data.Text.Internal.Lazy
Data/Text/Lazy/Read.hs+40−39
@@ -1,12 +1,16 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, CPP #-}
2+#if __GLASGOW_HASKELL__ >= 704
3+{-# LANGUAGE Safe #-}
4+#elif __GLASGOW_HASKELL__ >= 702
5+{-# LANGUAGE Trustworthy #-}
6+#endif
27
38-- |
49-- Module : Data.Text.Lazy.Read
5−-- Copyright : (c) 2010 Bryan O'Sullivan
10+-- Copyright : (c) 2010, 2011 Bryan O'Sullivan
611--
712-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
13+-- Maintainer : bos@serpentine.com
1014-- Stability : experimental
1115-- Portability : GHC
1216--
@@ -22,13 +26,17 @@ module Data.Text.Lazy.Read
2226 ) where
2327
2428import Control.Monad (liftM)
25−import Data.Char (isDigit, isHexDigit, ord)
29+import Data.Char (isDigit, isHexDigit)
30+import Data.Int (Int8, Int16, Int32, Int64)
2631import Data.Ratio ((%))
32+import Data.Text.Internal.Read
2733import Data.Text.Lazy as T
34+import Data.Word (Word, Word8, Word16, Word32, Word64)
2835
2936-- | Read some text. If the read succeeds, return its value and the
3037-- remaining text, otherwise an error message.
31−type Reader a = Text -> Either String (a,Text)
38+type Reader a = IReader Text a
39+type Parser = IParser Text
3240
3341-- | Read a decimal integer. The input must begin with at least one
3442-- decimal digit, and is consumed until a non-digit or end of string
@@ -43,7 +51,16 @@ type Reader a = Text -> Either String (a,Text)
4351-- 'Integer' for your result type.
4452decimal :: Integral a => Reader a
4553{-# SPECIALIZE decimal :: Reader Int #-}
54+{-# SPECIALIZE decimal :: Reader Int8 #-}
55+{-# SPECIALIZE decimal :: Reader Int16 #-}
56+{-# SPECIALIZE decimal :: Reader Int32 #-}
57+{-# SPECIALIZE decimal :: Reader Int64 #-}
4658{-# SPECIALIZE decimal :: Reader Integer #-}
59+{-# SPECIALIZE decimal :: Reader Data.Word.Word #-}
60+{-# SPECIALIZE decimal :: Reader Word8 #-}
61+{-# SPECIALIZE decimal :: Reader Word16 #-}
62+{-# SPECIALIZE decimal :: Reader Word32 #-}
63+{-# SPECIALIZE decimal :: Reader Word64 #-}
4764decimal txt
4865 | T.null h = Left "input does not start with a digit"
4966 | otherwise = Right (T.foldl' go 0 h, t)
@@ -71,23 +88,23 @@ hexadecimal txt
7188 where (h,t) = T.splitAt 2 txt
7289
7390hex :: Integral a => Reader a
74−{-# SPECIALIZE hex :: Reader Int #-}
75−{-# SPECIALIZE hex :: Reader Integer #-}
91+{-# SPECIALIZE hexadecimal :: Reader Int #-}
92+{-# SPECIALIZE hexadecimal :: Reader Int8 #-}
93+{-# SPECIALIZE hexadecimal :: Reader Int16 #-}
94+{-# SPECIALIZE hexadecimal :: Reader Int32 #-}
95+{-# SPECIALIZE hexadecimal :: Reader Int64 #-}
96+{-# SPECIALIZE hexadecimal :: Reader Integer #-}
97+{-# SPECIALIZE hexadecimal :: Reader Word #-}
98+{-# SPECIALIZE hexadecimal :: Reader Word8 #-}
99+{-# SPECIALIZE hexadecimal :: Reader Word16 #-}
100+{-# SPECIALIZE hexadecimal :: Reader Word32 #-}
101+{-# SPECIALIZE hexadecimal :: Reader Word64 #-}
76102hex txt
77103 | T.null h = Left "input does not start with a hexadecimal digit"
78104 | otherwise = Right (T.foldl' go 0 h, t)
79105 where (h,t) = T.span isHexDigit txt
80106 go n d = (n * 16 + fromIntegral (hexDigitToInt d))
81107
82−hexDigitToInt :: Char -> Int
83−hexDigitToInt c
84− | c >= '0' && c <= '9' = ord c - ord '0'
85− | c >= 'a' && c <= 'f' = ord c - (ord 'a' - 10)
86− | otherwise = ord c - (ord 'A' - 10)
87−
88−digitToInt :: Char -> Int
89−digitToInt c = ord c - ord '0'
90−
91108-- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
92109-- apply it to the result of applying the given reader.
93110signed :: Num a => Reader a -> Reader a
@@ -114,7 +131,7 @@ signed f = runP (signa (P f))
114131--
115132-- >rational "3.foo" == Right (3.0, ".foo")
116133-- >rational "3e" == Right (3.0, "e")
117−rational :: RealFloat a => Reader a
134+rational :: Fractional a => Reader a
118135{-# SPECIALIZE rational :: Reader Double #-}
119136rational = floaty $ \real frac fracDenom -> fromRational $
120137 real % 1 + frac % fracDenom
@@ -138,37 +155,21 @@ double = floaty $ \real frac fracDenom ->
138155
139156signa :: Num a => Parser a -> Parser a
140157{-# SPECIALIZE signa :: Parser Int -> Parser Int #-}
158+{-# SPECIALIZE signa :: Parser Int8 -> Parser Int8 #-}
159+{-# SPECIALIZE signa :: Parser Int16 -> Parser Int16 #-}
160+{-# SPECIALIZE signa :: Parser Int32 -> Parser Int32 #-}
161+{-# SPECIALIZE signa :: Parser Int64 -> Parser Int64 #-}
141162{-# SPECIALIZE signa :: Parser Integer -> Parser Integer #-}
142163signa p = do
143164 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
144165 if sign == '+' then p else negate `liftM` p
145166
146−newtype Parser a = P {
147− runP :: Reader a
148− }
149−
150−instance Monad Parser where
151− return a = P $ \t -> Right (a,t)
152− {-# INLINE return #-}
153− m >>= k = P $ \t -> case runP m t of
154− Left err -> Left err
155− Right (a,t') -> runP (k a) t'
156− {-# INLINE (>>=) #-}
157− fail msg = P $ \_ -> Left msg
158−
159−perhaps :: a -> Parser a -> Parser a
160−perhaps def m = P $ \t -> case runP m t of
161− Left _ -> Right (def,t)
162− r@(Right _) -> r
163−
164167char :: (Char -> Bool) -> Parser Char
165168char p = P $ \t -> case T.uncons t of
166169 Just (c,t') | p c -> Right (c,t')
167170 _ -> Left "character does not match"
168171
169−data T = T !Integer !Int
170−
171−floaty :: RealFloat a => (Integer -> Integer -> Integer -> a) -> Reader a
172+floaty :: Fractional a => (Integer -> Integer -> Integer -> a) -> Reader a
172173{-# INLINE floaty #-}
173174floaty f = runP $ do
174175 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
Data/Text/Read.hs+48−39
@@ -1,12 +1,14 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, UnboxedTuples, CPP #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
25
36-- |
47-- Module : Data.Text.Read
5−-- Copyright : (c) 2010 Bryan O'Sullivan
8+-- Copyright : (c) 2010, 2011 Bryan O'Sullivan
69--
710-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9−-- duncan@haskell.org
11+-- Maintainer : bos@serpentine.com
1012-- Stability : experimental
1113-- Portability : GHC
1214--
@@ -22,13 +24,18 @@ module Data.Text.Read
2224 ) where
2325
2426import Control.Monad (liftM)
25−import Data.Char (isDigit, isHexDigit, ord)
27+import Data.Char (isDigit, isHexDigit)
28+import Data.Int (Int8, Int16, Int32, Int64)
2629import Data.Ratio ((%))
2730import Data.Text as T
31+import Data.Text.Internal.Private (span_)
32+import Data.Text.Internal.Read
33+import Data.Word (Word, Word8, Word16, Word32, Word64)
2834
2935-- | Read some text. If the read succeeds, return its value and the
3036-- remaining text, otherwise an error message.
31−type Reader a = Text -> Either String (a,Text)
37+type Reader a = IReader Text a
38+type Parser a = IParser Text a
3239
3340-- | Read a decimal integer. The input must begin with at least one
3441-- decimal digit, and is consumed until a non-digit or end of string
@@ -43,11 +50,20 @@ type Reader a = Text -> Either String (a,Text)
4350-- 'Integer' for your result type.
4451decimal :: Integral a => Reader a
4552{-# SPECIALIZE decimal :: Reader Int #-}
53+{-# SPECIALIZE decimal :: Reader Int8 #-}
54+{-# SPECIALIZE decimal :: Reader Int16 #-}
55+{-# SPECIALIZE decimal :: Reader Int32 #-}
56+{-# SPECIALIZE decimal :: Reader Int64 #-}
4657{-# SPECIALIZE decimal :: Reader Integer #-}
58+{-# SPECIALIZE decimal :: Reader Data.Word.Word #-}
59+{-# SPECIALIZE decimal :: Reader Word8 #-}
60+{-# SPECIALIZE decimal :: Reader Word16 #-}
61+{-# SPECIALIZE decimal :: Reader Word32 #-}
62+{-# SPECIALIZE decimal :: Reader Word64 #-}
4763decimal txt
4864 | T.null h = Left "input does not start with a digit"
4965 | otherwise = Right (T.foldl' go 0 h, t)
50− where (h,t) = T.span isDigit txt
66+ where (# h,t #) = span_ isDigit txt
5167 go n d = (n * 10 + fromIntegral (digitToInt d))
5268
5369-- | Read a hexadecimal integer, consisting of an optional leading
@@ -64,7 +80,16 @@ decimal txt
6480-- 'Integer' for your result type.
6581hexadecimal :: Integral a => Reader a
6682{-# SPECIALIZE hexadecimal :: Reader Int #-}
83+{-# SPECIALIZE hexadecimal :: Reader Int8 #-}
84+{-# SPECIALIZE hexadecimal :: Reader Int16 #-}
85+{-# SPECIALIZE hexadecimal :: Reader Int32 #-}
86+{-# SPECIALIZE hexadecimal :: Reader Int64 #-}
6787{-# SPECIALIZE hexadecimal :: Reader Integer #-}
88+{-# SPECIALIZE hexadecimal :: Reader Word #-}
89+{-# SPECIALIZE hexadecimal :: Reader Word8 #-}
90+{-# SPECIALIZE hexadecimal :: Reader Word16 #-}
91+{-# SPECIALIZE hexadecimal :: Reader Word32 #-}
92+{-# SPECIALIZE hexadecimal :: Reader Word64 #-}
6893hexadecimal txt
6994 | h == "0x" || h == "0X" = hex t
7095 | otherwise = hex txt
@@ -72,22 +97,22 @@ hexadecimal txt
7297
7398hex :: Integral a => Reader a
7499{-# SPECIALIZE hex :: Reader Int #-}
100+{-# SPECIALIZE hex :: Reader Int8 #-}
101+{-# SPECIALIZE hex :: Reader Int16 #-}
102+{-# SPECIALIZE hex :: Reader Int32 #-}
103+{-# SPECIALIZE hex :: Reader Int64 #-}
75104{-# SPECIALIZE hex :: Reader Integer #-}
105+{-# SPECIALIZE hex :: Reader Word #-}
106+{-# SPECIALIZE hex :: Reader Word8 #-}
107+{-# SPECIALIZE hex :: Reader Word16 #-}
108+{-# SPECIALIZE hex :: Reader Word32 #-}
109+{-# SPECIALIZE hex :: Reader Word64 #-}
76110hex txt
77111 | T.null h = Left "input does not start with a hexadecimal digit"
78112 | otherwise = Right (T.foldl' go 0 h, t)
79− where (h,t) = T.span isHexDigit txt
113+ where (# h,t #) = span_ isHexDigit txt
80114 go n d = (n * 16 + fromIntegral (hexDigitToInt d))
81115
82−hexDigitToInt :: Char -> Int
83−hexDigitToInt c
84− | c >= '0' && c <= '9' = ord c - ord '0'
85− | c >= 'a' && c <= 'f' = ord c - (ord 'a' - 10)
86− | otherwise = ord c - (ord 'A' - 10)
87−
88−digitToInt :: Char -> Int
89−digitToInt c = ord c - ord '0'
90−
91116-- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
92117-- apply it to the result of applying the given reader.
93118signed :: Num a => Reader a -> Reader a
@@ -114,7 +139,7 @@ signed f = runP (signa (P f))
114139--
115140-- >rational "3.foo" == Right (3.0, ".foo")
116141-- >rational "3e" == Right (3.0, "e")
117−rational :: RealFloat a => Reader a
142+rational :: Fractional a => Reader a
118143{-# SPECIALIZE rational :: Reader Double #-}
119144rational = floaty $ \real frac fracDenom -> fromRational $
120145 real % 1 + frac % fracDenom
@@ -138,37 +163,21 @@ double = floaty $ \real frac fracDenom ->
138163
139164signa :: Num a => Parser a -> Parser a
140165{-# SPECIALIZE signa :: Parser Int -> Parser Int #-}
166+{-# SPECIALIZE signa :: Parser Int8 -> Parser Int8 #-}
167+{-# SPECIALIZE signa :: Parser Int16 -> Parser Int16 #-}
168+{-# SPECIALIZE signa :: Parser Int32 -> Parser Int32 #-}
169+{-# SPECIALIZE signa :: Parser Int64 -> Parser Int64 #-}
141170{-# SPECIALIZE signa :: Parser Integer -> Parser Integer #-}
142171signa p = do
143172 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
144173 if sign == '+' then p else negate `liftM` p
145174
146−newtype Parser a = P {
147− runP :: Reader a
148− }
149−
150−instance Monad Parser where
151− return a = P $ \t -> Right (a,t)
152− {-# INLINE return #-}
153− m >>= k = P $ \t -> case runP m t of
154− Left err -> Left err
155− Right (a,t') -> runP (k a) t'
156− {-# INLINE (>>=) #-}
157− fail msg = P $ \_ -> Left msg
158−
159−perhaps :: a -> Parser a -> Parser a
160−perhaps def m = P $ \t -> case runP m t of
161− Left _ -> Right (def,t)
162− r@(Right _) -> r
163−
164175char :: (Char -> Bool) -> Parser Char
165176char p = P $ \t -> case T.uncons t of
166177 Just (c,t') | p c -> Right (c,t')
167178 _ -> Left "character does not match"
168179
169−data T = T !Integer !Int
170−
171−floaty :: RealFloat a => (Integer -> Integer -> Integer -> a) -> Reader a
180+floaty :: Fractional a => (Integer -> Integer -> Integer -> a) -> Reader a
172181{-# INLINE floaty #-}
173182floaty f = runP $ do
174183 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
Data/Text/Show.hsnew file+89
@@ -0,0 +1,89 @@
1+{-# LANGUAGE CPP, MagicHash #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+#if __GLASGOW_HASKELL__ >= 702
4+{-# LANGUAGE Trustworthy #-}
5+#endif
6+
7+-- |
8+-- Module : Data.Text.Show
9+-- Copyright : (c) 2009-2015 Bryan O'Sullivan
10+--
11+-- License : BSD-style
12+-- Maintainer : bos@serpentine.com
13+-- Stability : experimental
14+-- Portability : GHC
15+
16+module Data.Text.Show
17+ (
18+ singleton
19+ , unpack
20+ , unpackCString#
21+ ) where
22+
23+import Control.Monad.ST (ST)
24+import Data.Text.Internal (Text(..), empty_, safe)
25+import Data.Text.Internal.Fusion (stream, unstream)
26+import Data.Text.Internal.Unsafe.Char (unsafeWrite)
27+import GHC.Prim (Addr#)
28+import qualified Data.Text.Array as A
29+import qualified Data.Text.Internal.Fusion.Common as S
30+
31+#if __GLASGOW_HASKELL__ >= 702
32+import qualified GHC.CString as GHC
33+#else
34+import qualified GHC.Base as GHC
35+#endif
36+
37+instance Show Text where
38+ showsPrec p ps r = showsPrec p (unpack ps) r
39+
40+-- | /O(n)/ Convert a 'Text' into a 'String'. Subject to fusion.
41+unpack :: Text -> String
42+unpack = S.unstreamList . stream
43+{-# INLINE [1] unpack #-}
44+
45+-- | /O(n)/ Convert a literal string into a 'Text'. Subject to
46+-- fusion.
47+--
48+-- This is exposed solely for people writing GHC rewrite rules.
49+unpackCString# :: Addr# -> Text
50+unpackCString# addr# = unstream (S.streamCString# addr#)
51+{-# NOINLINE unpackCString# #-}
52+
53+{-# RULES "TEXT literal" [1] forall a.
54+ unstream (S.map safe (S.streamList (GHC.unpackCString# a)))
55+ = unpackCString# a #-}
56+
57+{-# RULES "TEXT literal UTF8" [1] forall a.
58+ unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))
59+ = unpackCString# a #-}
60+
61+{-# RULES "TEXT empty literal" [1]
62+ unstream (S.map safe (S.streamList []))
63+ = empty_ #-}
64+
65+{-# RULES "TEXT singleton literal" [1] forall a.
66+ unstream (S.map safe (S.streamList [a]))
67+ = singleton_ a #-}
68+
69+-- | /O(1)/ Convert a character into a Text. Subject to fusion.
70+-- Performs replacement on invalid scalar values.
71+singleton :: Char -> Text
72+singleton = unstream . S.singleton . safe
73+{-# INLINE [1] singleton #-}
74+
75+{-# RULES "TEXT singleton" forall a.
76+ unstream (S.singleton (safe a))
77+ = singleton_ a #-}
78+
79+-- This is intended to reduce inlining bloat.
80+singleton_ :: Char -> Text
81+singleton_ c = Text (A.run x) 0 len
82+ where x :: ST s (A.MArray s)
83+ x = do arr <- A.new len
84+ _ <- unsafeWrite arr 0 d
85+ return arr
86+ len | d < '\x10000' = 1
87+ | otherwise = 2
88+ d = safe c
89+{-# NOINLINE singleton_ #-}
Data/Text/Unsafe.hs+19−42
@@ -1,10 +1,9 @@
11{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
22-- |
33-- Module : Data.Text.Unsafe
4−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
4+-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
55-- License : BSD-style
6−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
7−-- duncan@haskell.org
6+-- Maintainer : bos@serpentine.com
87-- Stability : experimental
98-- Portability : portable
109--
@@ -14,33 +13,28 @@ module Data.Text.Unsafe
1413 (
1514 inlineInterleaveST
1615 , inlinePerformIO
16+ , unsafeDupablePerformIO
1717 , Iter(..)
1818 , iter
1919 , iter_
2020 , reverseIter
21+ , reverseIter_
2122 , unsafeHead
2223 , unsafeTail
2324 , lengthWord16
2425 , takeWord16
2526 , dropWord16
2627 ) where
27−
28+
2829#if defined(ASSERTS)
2930import Control.Exception (assert)
3031#endif
31−import Data.Text.Encoding.Utf16 (chr2)
32+import Data.Text.Internal.Encoding.Utf16 (chr2)
3233import Data.Text.Internal (Text(..))
33−import Data.Text.UnsafeChar (unsafeChr)
34−import GHC.ST (ST(..))
34+import Data.Text.Internal.Unsafe (inlineInterleaveST, inlinePerformIO)
35+import Data.Text.Internal.Unsafe.Char (unsafeChr)
3536import qualified Data.Text.Array as A
36−#if defined(__GLASGOW_HASKELL__)
37−# if __GLASGOW_HASKELL__ >= 611
38−import GHC.IO (IO(IO))
39−# else
40−import GHC.IOBase (IO(IO))
41−# endif
42−import GHC.Base (realWorld#)
43−#endif
37+import GHC.IO (unsafeDupablePerformIO)
4438
4539-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
4640-- omits the check for the empty case, so there is an obligation on
@@ -53,7 +47,7 @@ unsafeHead (Text arr off _len)
5347 n = A.unsafeIndex arr (off+1)
5448{-# INLINE unsafeHead #-}
5549
56−-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeHead'
50+-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeTail'
5751-- omits the check for the empty case, so there is an obligation on
5852-- the programmer to provide a proof that the 'Text' is non-empty.
5953unsafeTail :: Text -> Text
@@ -101,32 +95,15 @@ reverseIter (Text arr off _len) i
10195 k = j - 1
10296{-# INLINE reverseIter #-}
10397
104−-- | Just like unsafePerformIO, but we inline it. Big performance gains as
105−-- it exposes lots of things to further inlining. /Very unsafe/. In
106−-- particular, you should do no memory allocation inside an
107−-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.
108−--
109−{-# INLINE inlinePerformIO #-}
110−inlinePerformIO :: IO a -> a
111−#if defined(__GLASGOW_HASKELL__)
112−inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
113−#else
114−inlinePerformIO = unsafePerformIO
115−#endif
116−
117−-- | Allow an 'ST' computation to be deferred lazily. When passed an
118−-- action of type 'ST' @s@ @a@, the action will only be performed when
119−-- the value of @a@ is demanded.
120−--
121−-- This function is identical to the normal unsafeInterleaveST, but is
122−-- inlined and hence faster.
123−--
124−-- /Note/: This operation is highly unsafe, as it can introduce
125−-- externally visible non-determinism into an 'ST' action.
126−inlineInterleaveST :: ST s a -> ST s a
127−inlineInterleaveST (ST m) = ST $ \ s ->
128− let r = case m s of (# _, res #) -> res in (# s, r #)
129−{-# INLINE inlineInterleaveST #-}
98+-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
99+-- returning the delta to add (i.e. a negative number) to give the
100+-- next offset to iterate at.
101+reverseIter_ :: Text -> Int -> Int
102+reverseIter_ (Text arr off _len) i
103+ | m < 0xDC00 || m > 0xDFFF = -1
104+ | otherwise = -2
105+ where m = A.unsafeIndex arr (off+i)
106+{-# INLINE reverseIter_ #-}
130107
131108-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This
132109-- is useful for sizing a target array appropriately before using
README.markdown+5−5
@@ -19,15 +19,15 @@ library to provide these facilities.
1919# Get involved!
2020
2121Please report bugs via the
22−[bitbucket issue tracker](http://bitbucket.org/bos/text/issues).
22+[github issue tracker](https://github.com/bos/text/issues).
2323
24−Master [Mercurial repository](http://bitbucket.org/bos/text):
24+Master [git repository](https://github.com/bos/text):
2525
26−* `hg clone http://bitbucket.org/bos/text`
26+* `git clone git://github.com/bos/text.git`
2727
28−There's also a [git mirror](http://github.com/bos/text):
28+There's also a [Mercurial mirror](https://bitbucket.org/bos/text):
2929
30−* `git clone git://github.com/bos/text.git`
30+* `hg clone https://bitbucket.org/bos/text`
3131
3232(You can create and contribute changes using either Mercurial or git.)
3333
benchmarks/.gitignorenew file+1
@@ -0,0 +1 @@
1+dist
benchmarks/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
benchmarks/cbits/time_iconv.cnew file+35
@@ -0,0 +1,35 @@
1+#include <iconv.h>
2+#include <stdlib.h>
3+#include <stdio.h>
4+#include <stdint.h>
5+
6+int time_iconv(char *srcbuf, size_t srcbufsize)
7+{
8+ uint16_t *destbuf = NULL;
9+ size_t destbufsize;
10+ static uint16_t *origdestbuf;
11+ static size_t origdestbufsize;
12+ iconv_t ic = (iconv_t) -1;
13+ int ret = 0;
14+
15+ if (ic == (iconv_t) -1) {
16+ ic = iconv_open("UTF-16LE", "UTF-8");
17+ if (ic == (iconv_t) -1) {
18+ ret = -1;
19+ goto done;
20+ }
21+ }
22+
23+ destbufsize = srcbufsize * sizeof(uint16_t);
24+ if (destbufsize > origdestbufsize) {
25+ free(origdestbuf);
26+ origdestbuf = destbuf = malloc(origdestbufsize = destbufsize);
27+ } else {
28+ destbuf = origdestbuf;
29+ }
30+
31+ iconv(ic, &srcbuf, &srcbufsize, (char**) &destbuf, &destbufsize);
32+
33+ done:
34+ return ret;
35+}
benchmarks/haskell/Benchmarks.hsnew file+79
@@ -0,0 +1,79 @@
1+-- | Main module to run the micro benchmarks
2+--
3+{-# LANGUAGE OverloadedStrings #-}
4+module Main
5+ ( main
6+ ) where
7+
8+import Criterion.Main (Benchmark, defaultMain, bgroup)
9+import System.FilePath ((</>))
10+import System.IO (IOMode (WriteMode), openFile, hSetEncoding, utf8)
11+
12+import qualified Benchmarks.Builder as Builder
13+import qualified Benchmarks.DecodeUtf8 as DecodeUtf8
14+import qualified Benchmarks.EncodeUtf8 as EncodeUtf8
15+import qualified Benchmarks.Equality as Equality
16+import qualified Benchmarks.FileRead as FileRead
17+import qualified Benchmarks.FoldLines as FoldLines
18+import qualified Benchmarks.Mul as Mul
19+import qualified Benchmarks.Pure as Pure
20+import qualified Benchmarks.ReadNumbers as ReadNumbers
21+import qualified Benchmarks.Replace as Replace
22+import qualified Benchmarks.Search as Search
23+import qualified Benchmarks.Stream as Stream
24+import qualified Benchmarks.WordFrequencies as WordFrequencies
25+
26+import qualified Benchmarks.Programs.BigTable as Programs.BigTable
27+import qualified Benchmarks.Programs.Cut as Programs.Cut
28+import qualified Benchmarks.Programs.Fold as Programs.Fold
29+import qualified Benchmarks.Programs.Sort as Programs.Sort
30+import qualified Benchmarks.Programs.StripTags as Programs.StripTags
31+import qualified Benchmarks.Programs.Throughput as Programs.Throughput
32+
33+main :: IO ()
34+main = benchmarks >>= defaultMain
35+
36+benchmarks :: IO [Benchmark]
37+benchmarks = do
38+ sink <- openFile "/dev/null" WriteMode
39+ hSetEncoding sink utf8
40+
41+ -- Traditional benchmarks
42+ bs <- sequence
43+ [ Builder.benchmark
44+ , DecodeUtf8.benchmark "html" (tf "libya-chinese.html")
45+ , DecodeUtf8.benchmark "xml" (tf "yiwiki.xml")
46+ , DecodeUtf8.benchmark "ascii" (tf "ascii.txt")
47+ , DecodeUtf8.benchmark "russian" (tf "russian.txt")
48+ , DecodeUtf8.benchmark "japanese" (tf "japanese.txt")
49+ , EncodeUtf8.benchmark "επανάληψη 竺法蘭共譯"
50+ , Equality.benchmark (tf "japanese.txt")
51+ , FileRead.benchmark (tf "russian.txt")
52+ , FoldLines.benchmark (tf "russian.txt")
53+ , Mul.benchmark
54+ , Pure.benchmark "tiny" (tf "tiny.txt")
55+ , Pure.benchmark "ascii" (tf "ascii-small.txt")
56+ -- , Pure.benchmark "france" (tf "france.html")
57+ , Pure.benchmark "russian" (tf "russian-small.txt")
58+ , Pure.benchmark "japanese" (tf "japanese.txt")
59+ , ReadNumbers.benchmark (tf "numbers.txt")
60+ , Replace.benchmark (tf "russian.txt") "принимая" "своем"
61+ , Search.benchmark (tf "russian.txt") "принимая"
62+ , Stream.benchmark (tf "russian.txt")
63+ , WordFrequencies.benchmark (tf "russian.txt")
64+ ]
65+
66+ -- Program-like benchmarks
67+ ps <- bgroup "Programs" `fmap` sequence
68+ [ Programs.BigTable.benchmark sink
69+ , Programs.Cut.benchmark (tf "russian.txt") sink 20 40
70+ , Programs.Fold.benchmark (tf "russian.txt") sink
71+ , Programs.Sort.benchmark (tf "russian.txt") sink
72+ , Programs.StripTags.benchmark (tf "yiwiki.xml") sink
73+ , Programs.Throughput.benchmark (tf "russian.txt") sink
74+ ]
75+
76+ return $ bs ++ [ps]
77+ where
78+ -- Location of a test file
79+ tf = ("../tests/text-test-data" </>)
benchmarks/haskell/Benchmarks/Builder.hsnew file+75
@@ -0,0 +1,75 @@
1+-- | Testing the internal builder monoid
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Concatenating many small strings using a builder
6+--
7+{-# LANGUAGE OverloadedStrings #-}
8+module Benchmarks.Builder
9+ ( benchmark
10+ ) where
11+
12+import Criterion (Benchmark, bgroup, bench, nf)
13+import Data.Binary.Builder as B
14+import Data.ByteString.Char8 ()
15+import Data.Monoid (mconcat, mempty)
16+import qualified Blaze.ByteString.Builder as Blaze
17+import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
18+import qualified Data.ByteString as SB
19+import qualified Data.ByteString.Lazy as LB
20+import qualified Data.Text as T
21+import qualified Data.Text.Lazy as LT
22+import qualified Data.Text.Lazy.Builder as LTB
23+import qualified Data.Text.Lazy.Builder.Int as Int
24+import Data.Int (Int64)
25+
26+benchmark :: IO Benchmark
27+benchmark = return $ bgroup "Builder"
28+ [ bgroup "Comparison"
29+ [ bench "LazyText" $ nf
30+ (LT.length . LTB.toLazyText . mconcat . map LTB.fromText) texts
31+ , bench "Binary" $ nf
32+ (LB.length . B.toLazyByteString . mconcat . map B.fromByteString)
33+ byteStrings
34+ , bench "Blaze" $ nf
35+ (LB.length . Blaze.toLazyByteString . mconcat . map Blaze.fromString)
36+ strings
37+ ]
38+ , bgroup "Int"
39+ [ bgroup "Decimal"
40+ [ bgroup "Positive" .
41+ flip map numbers $ \n ->
42+ (bench (show (length (show n))) $ nf (LTB.toLazyText . Int.decimal) n)
43+ , bgroup "Negative" .
44+ flip map numbers $ \m ->
45+ let n = negate m in
46+ (bench (show (length (show n))) $ nf (LTB.toLazyText . Int.decimal) n)
47+ , bench "Empty" $ nf LTB.toLazyText mempty
48+ , bgroup "Show" .
49+ flip map numbers $ \n ->
50+ (bench (show (length (show n))) $ nf show n)
51+ ]
52+ ]
53+ ]
54+ where
55+ numbers :: [Int64]
56+ numbers = [
57+ 6, 14, 500, 9688, 10654, 620735, 5608880, 37010612,
58+ 731223504, 5061580596, 24596952933, 711732309084, 2845910093839,
59+ 54601756118340, 735159434806159, 3619097625502435, 95777227510267124,
60+ 414944309510675693, 8986407456998704019
61+ ]
62+
63+texts :: [T.Text]
64+texts = take 200000 $ cycle ["foo", "λx", "由の"]
65+{-# NOINLINE texts #-}
66+
67+-- Note that the non-ascii characters will be chopped
68+byteStrings :: [SB.ByteString]
69+byteStrings = take 200000 $ cycle ["foo", "λx", "由の"]
70+{-# NOINLINE byteStrings #-}
71+
72+-- Note that the non-ascii characters will be chopped
73+strings :: [String]
74+strings = take 200000 $ cycle ["foo", "λx", "由の"]
75+{-# NOINLINE strings #-}
benchmarks/haskell/Benchmarks/DecodeUtf8.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+
3+-- | Test decoding of UTF-8
4+--
5+-- Tested in this benchmark:
6+--
7+-- * Decoding bytes using UTF-8
8+--
9+-- In some tests:
10+--
11+-- * Taking the length of the result
12+--
13+-- * Taking the init of the result
14+--
15+-- The latter are used for testing stream fusion.
16+--
17+module Benchmarks.DecodeUtf8
18+ ( benchmark
19+ ) where
20+
21+import Foreign.C.Types
22+import Data.ByteString.Internal (ByteString(..))
23+import Data.ByteString.Lazy.Internal (ByteString(..))
24+import Foreign.Ptr (Ptr, plusPtr)
25+import Foreign.ForeignPtr (withForeignPtr)
26+import Data.Word (Word8)
27+import qualified Criterion as C
28+import Criterion (Benchmark, bgroup, nf, whnfIO)
29+import qualified Codec.Binary.UTF8.Generic as U8
30+import qualified Data.ByteString as B
31+import qualified Data.ByteString.Lazy as BL
32+import qualified Data.Text as T
33+import qualified Data.Text.Encoding as T
34+import qualified Data.Text.Lazy as TL
35+import qualified Data.Text.Lazy.Encoding as TL
36+
37+benchmark :: String -> FilePath -> IO Benchmark
38+benchmark kind fp = do
39+ bs <- B.readFile fp
40+ lbs <- BL.readFile fp
41+ let bench name = C.bench (name ++ "+" ++ kind)
42+ decodeStream (Chunk b0 bs0) = case T.streamDecodeUtf8 b0 of
43+ T.Some t0 _ f0 -> t0 : go f0 bs0
44+ where go f (Chunk b bs1) = case f b of
45+ T.Some t1 _ f1 -> t1 : go f1 bs1
46+ go _ _ = []
47+ decodeStream _ = []
48+ return $ bgroup "DecodeUtf8"
49+ [ bench "Strict" $ nf T.decodeUtf8 bs
50+ , bench "Stream" $ nf decodeStream lbs
51+ , bench "IConv" $ whnfIO $ iconv bs
52+ , bench "StrictLength" $ nf (T.length . T.decodeUtf8) bs
53+ , bench "StrictInitLength" $ nf (T.length . T.init . T.decodeUtf8) bs
54+ , bench "Lazy" $ nf TL.decodeUtf8 lbs
55+ , bench "LazyLength" $ nf (TL.length . TL.decodeUtf8) lbs
56+ , bench "LazyInitLength" $ nf (TL.length . TL.init . TL.decodeUtf8) lbs
57+ , bench "StrictStringUtf8" $ nf U8.toString bs
58+ , bench "StrictStringUtf8Length" $ nf (length . U8.toString) bs
59+ , bench "LazyStringUtf8" $ nf U8.toString lbs
60+ , bench "LazyStringUtf8Length" $ nf (length . U8.toString) lbs
61+ ]
62+
63+iconv :: B.ByteString -> IO CInt
64+iconv (PS fp off len) = withForeignPtr fp $ \ptr ->
65+ time_iconv (ptr `plusPtr` off) (fromIntegral len)
66+
67+foreign import ccall unsafe time_iconv :: Ptr Word8 -> CSize -> IO CInt
benchmarks/haskell/Benchmarks/EncodeUtf8.hsnew file+33
@@ -0,0 +1,33 @@
1+-- | UTF-8 encode a text
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Replicating a string a number of times
6+--
7+-- * UTF-8 encoding it
8+--
9+module Benchmarks.EncodeUtf8
10+ ( benchmark
11+ ) where
12+
13+import Criterion (Benchmark, bgroup, bench, whnf)
14+import qualified Data.ByteString as B
15+import qualified Data.ByteString.Lazy as BL
16+import qualified Data.Text as T
17+import qualified Data.Text.Encoding as T
18+import qualified Data.Text.Lazy as TL
19+import qualified Data.Text.Lazy.Encoding as TL
20+
21+benchmark :: String -> IO Benchmark
22+benchmark string = do
23+ return $ bgroup "EncodeUtf8"
24+ [ bench "Text" $ whnf (B.length . T.encodeUtf8) text
25+ , bench "LazyText" $ whnf (BL.length . TL.encodeUtf8) lazyText
26+ ]
27+ where
28+ -- The string in different formats
29+ text = T.replicate k $ T.pack string
30+ lazyText = TL.replicate (fromIntegral k) $ TL.pack string
31+
32+ -- Amount
33+ k = 100000
benchmarks/haskell/Benchmarks/Equality.hsnew file+38
@@ -0,0 +1,38 @@
1+-- | Compare a string with a copy of itself that is identical except
2+-- for the last character.
3+--
4+-- Tested in this benchmark:
5+--
6+-- * Comparison of strings (Eq instance)
7+--
8+module Benchmarks.Equality
9+ ( benchmark
10+ ) where
11+
12+import Criterion (Benchmark, bgroup, bench, whnf)
13+import qualified Data.ByteString.Char8 as B
14+import qualified Data.ByteString.Lazy.Char8 as BL
15+import qualified Data.Text as T
16+import qualified Data.Text.Encoding as T
17+import qualified Data.Text.Lazy as TL
18+import qualified Data.Text.Lazy.Encoding as TL
19+
20+benchmark :: FilePath -> IO Benchmark
21+benchmark fp = do
22+ b <- B.readFile fp
23+ bl1 <- BL.readFile fp
24+ -- A lazy bytestring is a list of chunks. When we do not explicitly create two
25+ -- different lazy bytestrings at a different address, the bytestring library
26+ -- will compare the chunk addresses instead of the chunk contents. This is why
27+ -- we read the lazy bytestring twice here.
28+ bl2 <- BL.readFile fp
29+ l <- readFile fp
30+ let t = T.decodeUtf8 b
31+ tl = TL.decodeUtf8 bl1
32+ return $ bgroup "Equality"
33+ [ bench "Text" $ whnf (== T.init t `T.snoc` '\xfffd') t
34+ , bench "LazyText" $ whnf (== TL.init tl `TL.snoc` '\xfffd') tl
35+ , bench "ByteString" $ whnf (== B.init b `B.snoc` '\xfffd') b
36+ , bench "LazyByteString" $ whnf (== BL.init bl2 `BL.snoc` '\xfffd') bl1
37+ , bench "String" $ whnf (== init l ++ "\xfffd") l
38+ ]
benchmarks/haskell/Benchmarks/FileRead.hsnew file+33
@@ -0,0 +1,33 @@
1+-- | Benchmarks simple file reading
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Reading a file from the disk
6+--
7+module Benchmarks.FileRead
8+ ( benchmark
9+ ) where
10+
11+import Control.Applicative ((<$>))
12+import Criterion (Benchmark, bgroup, bench, whnfIO)
13+import qualified Data.ByteString as SB
14+import qualified Data.ByteString.Lazy as LB
15+import qualified Data.Text as T
16+import qualified Data.Text.Encoding as T
17+import qualified Data.Text.IO as T
18+import qualified Data.Text.Lazy as LT
19+import qualified Data.Text.Lazy.Encoding as LT
20+import qualified Data.Text.Lazy.IO as LT
21+
22+benchmark :: FilePath -> IO Benchmark
23+benchmark p = return $ bgroup "FileRead"
24+ [ bench "String" $ whnfIO $ length <$> readFile p
25+ , bench "ByteString" $ whnfIO $ SB.length <$> SB.readFile p
26+ , bench "LazyByteString" $ whnfIO $ LB.length <$> LB.readFile p
27+ , bench "Text" $ whnfIO $ T.length <$> T.readFile p
28+ , bench "LazyText" $ whnfIO $ LT.length <$> LT.readFile p
29+ , bench "TextByteString" $ whnfIO $
30+ (T.length . T.decodeUtf8) <$> SB.readFile p
31+ , bench "LazyTextByteString" $ whnfIO $
32+ (LT.length . LT.decodeUtf8) <$> LB.readFile p
33+ ]
benchmarks/haskell/Benchmarks/FoldLines.hsnew file+58
@@ -0,0 +1,58 @@
1+-- | Read a file line-by-line using handles, and perform a fold over the lines.
2+-- The fold is used here to calculate the number of lines in the file.
3+--
4+-- Tested in this benchmark:
5+--
6+-- * Buffered, line-based IO
7+--
8+{-# LANGUAGE BangPatterns #-}
9+module Benchmarks.FoldLines
10+ ( benchmark
11+ ) where
12+
13+import Criterion (Benchmark, bgroup, bench, whnfIO)
14+import System.IO
15+import qualified Data.ByteString as B
16+import qualified Data.Text as T
17+import qualified Data.Text.IO as T
18+
19+benchmark :: FilePath -> IO Benchmark
20+benchmark fp = return $ bgroup "ReadLines"
21+ [ bench "Text" $ withHandle $ foldLinesT (\n _ -> n + 1) (0 :: Int)
22+ , bench "ByteString" $ withHandle $ foldLinesB (\n _ -> n + 1) (0 :: Int)
23+ ]
24+ where
25+ withHandle f = whnfIO $ do
26+ h <- openFile fp ReadMode
27+ hSetBuffering h (BlockBuffering (Just 16384))
28+ x <- f h
29+ hClose h
30+ return x
31+
32+-- | Text line fold
33+--
34+foldLinesT :: (a -> T.Text -> a) -> a -> Handle -> IO a
35+foldLinesT f z0 h = go z0
36+ where
37+ go !z = do
38+ eof <- hIsEOF h
39+ if eof
40+ then return z
41+ else do
42+ l <- T.hGetLine h
43+ let z' = f z l in go z'
44+{-# INLINE foldLinesT #-}
45+
46+-- | ByteString line fold
47+--
48+foldLinesB :: (a -> B.ByteString -> a) -> a -> Handle -> IO a
49+foldLinesB f z0 h = go z0
50+ where
51+ go !z = do
52+ eof <- hIsEOF h
53+ if eof
54+ then return z
55+ else do
56+ l <- B.hGetLine h
57+ let z' = f z l in go z'
58+{-# INLINE foldLinesB #-}
benchmarks/haskell/Benchmarks/Mul.hsnew file+138
@@ -0,0 +1,138 @@
1+module Benchmarks.Mul (benchmark) where
2+
3+import Control.Exception (evaluate)
4+import Criterion.Main
5+import Data.Int (Int32, Int64)
6+import Data.Text.Internal (mul32, mul64)
7+import qualified Data.Vector.Unboxed as U
8+
9+oldMul :: Int64 -> Int64 -> Int64
10+oldMul m n
11+ | n == 0 = 0
12+ | m <= maxBound `quot` n = m * n
13+ | otherwise = error "overflow"
14+
15+benchmark :: IO Benchmark
16+benchmark = do
17+ _ <- evaluate testVector32
18+ _ <- evaluate testVector64
19+ return $ bgroup "Mul" [
20+ bench "oldMul" $ whnf (U.map (uncurry oldMul)) testVector64
21+ , bench "mul64" $ whnf (U.map (uncurry mul64)) testVector64
22+ , bench "*64" $ whnf (U.map (uncurry (*))) testVector64
23+ , bench "mul32" $ whnf (U.map (uncurry mul32)) testVector32
24+ , bench "*32" $ whnf (U.map (uncurry (*))) testVector32
25+ ]
26+
27+testVector64 :: U.Vector (Int64,Int64)
28+testVector64 = U.fromList [
29+ (0,1248868987182846646),(169004623633872,24458),(482549039517835,7614),
30+ (372,8157063115504364),(27,107095594861148252),(3,63249878517962420),
31+ (4363,255694473572912),(86678474,1732634806),(1572453024,1800489338),
32+ (9384523143,77053781),(49024709555,75095046),(7,43457620410239131),
33+ (8,8201563008844571),(387719037,1520696708),(189869238220197,1423),
34+ (46788016849611,23063),(503077742109974359,0),(104,1502010908706487),
35+ (30478140346,207525518),(80961140129236192,14),(4283,368012829143675),
36+ (1028719181728108146,6),(318904,5874863049591),(56724427166898,110794),
37+ (234539368,31369110449),(2,251729663598178612),(103291548194451219,5),
38+ (76013,5345328755566),(1769631,2980846129318),(40898,60598477385754),
39+ (0,98931348893227155),(573555872156917492,3),(318821187115,4476566),
40+ (11152874213584,243582),(40274276,16636653248),(127,4249988676030597),
41+ (103543712111871836,5),(71,16954462148248238),(3963027173504,216570),
42+ (13000,503523808916753),(17038308,20018685905),(0,510350226577891549),
43+ (175898,3875698895405),(425299191292676,5651),(17223451323664536,50),
44+ (61755131,14247665326),(0,1018195131697569303),(36433751497238985,20),
45+ (3473607861601050,1837),(1392342328,1733971838),(225770297367,3249655),
46+ (14,127545244155254102),(1751488975299136,2634),(3949208,504190668767),
47+ (153329,831454434345),(1066212122928663658,2),(351224,2663633539556),
48+ (344565,53388869217),(35825609350446863,54),(276011553660081475,10),
49+ (1969754174790470349,3),(35,68088438338633),(506710,3247689556438),
50+ (11099382291,327739909),(105787303549,32824363),(210366111,14759049409),
51+ (688893241579,3102676),(8490,70047474429581),(152085,29923000251880),
52+ (5046974599257095,400),(4183167795,263434071),(10089728,502781960687),
53+ (44831977765,4725378),(91,8978094664238578),(30990165721,44053350),
54+ (1772377,149651820860),(243420621763408572,4),(32,5790357453815138),
55+ (27980806337993771,5),(47696295759774,20848),(1745874142313778,1098),
56+ (46869334770121,1203),(886995283,1564424789),(40679396544,76002479),
57+ (1,672849481568486995),(337656187205,3157069),(816980552858963,6003),
58+ (2271434085804831543,1),(0,1934521023868747186),(6266220038281,15825),
59+ (4160,107115946987394),(524,246808621791561),(0,1952519482439636339),
60+ (128,2865935904539691),(1044,3211982069426297),(16000511542473,88922),
61+ (1253596745404082,2226),(27041,56836278958002),(23201,49247489754471),
62+ (175906590497,21252392),(185163584757182295,24),(34742225226802197,150),
63+ (2363228,250824838408),(216327527109550,45),(24,81574076994520675),
64+ (28559899906542,15356),(10890139774837133,511),(2293,707179303654492),
65+ (2749366833,40703233),(0,4498229704622845986),(439,4962056468281937),
66+ (662,1453820621089921),(16336770612459631,220),(24282989393,74239137),
67+ (2724564648490195,3),(743672760,124992589),(4528103,704330948891),
68+ (6050483122491561,250),(13322953,13594265152),(181794,22268101450214),
69+ (25957941712,75384092),(43352,7322262295009),(32838,52609059549923),
70+ (33003585202001564,2),(103019,68430142267402),(129918230800,8742978),
71+ (0,2114347379589080688),(2548,905723041545274),(222745067962838382,0),
72+ (1671683850790425181,1),(455,4836932776795684),(794227702827214,6620),
73+ (212534135175874,1365),(96432431858,29784975),(466626763743380,3484),
74+ (29793949,53041519613),(8359,309952753409844),(3908960585331901,26),
75+ (45185288970365760,114),(10131829775,68110174),(58039242399640479,83),
76+ (628092278238719399,6),(1,196469106875361889),(302336625,16347502444),
77+ (148,3748088684181047),(1,1649096568849015456),(1019866864,2349753026),
78+ (8211344830,569363306),(65647579546873,34753),(2340190,1692053129069),
79+ (64263301,30758930355),(48681618072372209,110),(7074794736,47640197),
80+ (249634721521,7991792),(1162917363807215,232),(7446433349,420634045),
81+ (63398619383,60709817),(51359004508011,14200),(131788797028647,7072),
82+ (52079887791430043,7),(7,136277667582599838),(28582879735696,50327),
83+ (1404582800566278,833),(469164435,15017166943),(99567079957578263,49),
84+ (1015285971,3625801566),(321504843,4104079293),(5196954,464515406632),
85+ (114246832260876,7468),(8149664437,487119673),(12265299,378168974869),
86+ (37711995764,30766513),(3971137243,710996152),(483120070302,603162),
87+ (103009942,61645547145),(8476344625340,6987),(547948761229739,1446),
88+ (42234,18624767306301),(13486714173011,58948),(4,198309153268019840),
89+ (9913176974,325539248),(28246225540203,116822),(2882463945582154,18),
90+ (959,25504987505398),(3,1504372236378217710),(13505229956793,374987),
91+ (751661959,457611342),(27375926,36219151769),(482168869,5301952074),
92+ (1,1577425863241520640),(714116235611821,1164),(904492524250310488,0),
93+ (5983514941763398,68),(10759472423,23540686),(72539568471529,34919),
94+ (4,176090672310337473),(938702842110356453,1),(673652445,3335287382),
95+ (3111998893666122,917),(1568013,3168419765469)]
96+
97+testVector32 :: U.Vector (Int32,Int32)
98+testVector32 = U.fromList [
99+ (39242,410),(0,100077553),(2206,9538),(509400240,1),(38048,6368),
100+ (1789,651480),(2399,157032),(701,170017),(5241456,14),(11212,70449),
101+ (1,227804876),(749687254,1),(74559,2954),(1158,147957),(410604456,1),
102+ (170851,1561),(92643422,1),(6192,180509),(7,24202210),(3440,241481),
103+ (5753677,5),(294327,1622),(252,4454673),(127684121,11),(28315800,30),
104+ (340370905,0),(1,667887987),(592782090,1),(49023,27641),(750,290387),
105+ (72886,3847),(0,301047933),(3050276,473),(1,788366142),(59457,15813),
106+ (637726933,1),(1135,344317),(853616,264),(696816,493),(7038,12046),
107+ (125219574,4),(803694088,1),(107081726,1),(39294,21699),(16361,38191),
108+ (132561123,12),(1760,23499),(847543,484),(175687349,1),(2963,252678),
109+ (6248,224553),(27596,4606),(5422922,121),(1542,485890),(131,583035),
110+ (59096,4925),(3637115,132),(0,947225435),(86854,6794),(2984745,339),
111+ (760129569,1),(1,68260595),(380835652,2),(430575,2579),(54514,7211),
112+ (15550606,3),(9,27367402),(3007053,207),(7060988,60),(28560,27130),
113+ (1355,21087),(10880,53059),(14563646,4),(461886361,1),(2,169260724),
114+ (241454126,2),(406797,1),(61631630,16),(44473,5943),(63869104,12),
115+ (950300,1528),(2113,62333),(120817,9358),(100261456,1),(426764723,1),
116+ (119,12723684),(3,53358711),(4448071,18),(1,230278091),(238,232102),
117+ (8,57316440),(42437979,10),(6769,19555),(48590,22006),(11500585,79),
118+ (2808,97638),(42,26952545),(11,32104194),(23954638,1),(785427272,0),
119+ (513,81379),(31333960,37),(897772,1009),(4,25679692),(103027993,12),
120+ (104972702,11),(546,443401),(7,65137092),(88574269,3),(872139069,0),
121+ (2,97417121),(378802603,0),(141071401,4),(22613,10575),(2191743,118),
122+ (470,116119),(7062,38166),(231056,1847),(43901963,9),(2400,70640),
123+ (63553,1555),(34,11249573),(815174,1820),(997894011,0),(98881794,2),
124+ (5448,43132),(27956,9),(904926,1357),(112608626,3),(124,613021),
125+ (282086,1966),(99,10656881),(113799,1501),(433318,2085),(442,948171),
126+ (165380,1043),(28,14372905),(14880,50462),(2386,219918),(229,1797565),
127+ (1174961,298),(3925,41833),(3903515,299),(15690452,111),(360860521,3),
128+ (7440846,81),(2541026,507),(0,492448477),(6869,82469),(245,8322939),
129+ (3503496,253),(123495298,0),(150963,2299),(33,4408482),(1,200911107),
130+ (305,252121),(13,123369189),(215846,8181),(2440,65387),(776764401,1),
131+ (1241172,434),(8,15493155),(81953961,6),(17884993,5),(26,6893822),
132+ (0,502035190),(1,582451018),(2,514870139),(227,3625619),(49,12720258),
133+ (1456769,207),(94797661,10),(234407,893),(26843,5783),(15688,24547),
134+ (4091,86268),(4339448,151),(21360,6294),(397046497,2),(1227,205936),
135+ (9966,21959),(160046791,1),(0,159992224),(27,24974797),(19177,29334),
136+ (4136148,42),(21179785,53),(61256583,31),(385,344176),(7,11934915),
137+ (1,18992566),(3488065,5),(768021,224),(36288474,7),(8624,117561),
138+ (8,20341439),(5903,261475),(561,1007618),(1738,392327),(633049,1708)]
benchmarks/haskell/Benchmarks/Programs/BigTable.hsnew file+42
@@ -0,0 +1,42 @@
1+-- | Create a large HTML table and dump it to a handle
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Creating a large HTML document using a builder
6+--
7+-- * Writing to a handle
8+--
9+{-# LANGUAGE OverloadedStrings #-}
10+module Benchmarks.Programs.BigTable
11+ ( benchmark
12+ ) where
13+
14+import Criterion (Benchmark, bench, whnfIO)
15+import Data.Monoid (mappend, mconcat)
16+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)
17+import Data.Text.Lazy.IO (hPutStr)
18+import System.IO (Handle)
19+import qualified Data.Text as T
20+
21+benchmark :: Handle -> IO Benchmark
22+benchmark sink = return $ bench "BigTable" $ whnfIO $ do
23+ hPutStr sink "Content-Type: text/html\n\n<table>"
24+ hPutStr sink . toLazyText . makeTable =<< rows
25+ hPutStr sink "</table>"
26+ where
27+ -- We provide the number of rows in IO so the builder value isn't shared
28+ -- between the benchmark samples.
29+ rows :: IO Int
30+ rows = return 20000
31+ {-# NOINLINE rows #-}
32+
33+makeTable :: Int -> Builder
34+makeTable n = mconcat $ replicate n $ mconcat $ map makeCol [1 .. 50]
35+
36+makeCol :: Int -> Builder
37+makeCol 1 = fromText "<tr><td>1</td>"
38+makeCol 50 = fromText "<td>50</td></tr>"
39+makeCol i = fromText "<td>" `mappend` (fromInt i `mappend` fromText "</td>")
40+
41+fromInt :: Int -> Builder
42+fromInt = fromText . T.pack . show
benchmarks/haskell/Benchmarks/Programs/Cut.hsnew file+98
@@ -0,0 +1,98 @@
1+-- | Cut into a file, selecting certain columns (e.g. columns 10 to 40)
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Reading the file
6+--
7+-- * Splitting into lines
8+--
9+-- * Taking a number of characters from the lines
10+--
11+-- * Joining the lines
12+--
13+-- * Writing back to a handle
14+--
15+module Benchmarks.Programs.Cut
16+ ( benchmark
17+ ) where
18+
19+import Criterion (Benchmark, bgroup, bench, whnfIO)
20+import System.IO (Handle, hPutStr)
21+import qualified Data.ByteString as B
22+import qualified Data.ByteString.Char8 as BC
23+import qualified Data.ByteString.Lazy as BL
24+import qualified Data.ByteString.Lazy.Char8 as BLC
25+import qualified Data.Text as T
26+import qualified Data.Text.Encoding as T
27+import qualified Data.Text.IO as T
28+import qualified Data.Text.Lazy as TL
29+import qualified Data.Text.Lazy.Encoding as TL
30+import qualified Data.Text.Lazy.IO as TL
31+
32+benchmark :: FilePath -> Handle -> Int -> Int -> IO Benchmark
33+benchmark p sink from to = return $ bgroup "Cut"
34+ [ bench' "String" string
35+ , bench' "ByteString" byteString
36+ , bench' "LazyByteString" lazyByteString
37+ , bench' "Text" text
38+ , bench' "LazyText" lazyText
39+ , bench' "TextByteString" textByteString
40+ , bench' "LazyTextByteString" lazyTextByteString
41+ ]
42+ where
43+ bench' n s = bench n $ whnfIO (s p sink from to)
44+
45+string :: FilePath -> Handle -> Int -> Int -> IO ()
46+string fp sink from to = do
47+ s <- readFile fp
48+ hPutStr sink $ cut s
49+ where
50+ cut = unlines . map (take (to - from) . drop from) . lines
51+
52+byteString :: FilePath -> Handle -> Int -> Int -> IO ()
53+byteString fp sink from to = do
54+ bs <- B.readFile fp
55+ B.hPutStr sink $ cut bs
56+ where
57+ cut = BC.unlines . map (B.take (to - from) . B.drop from) . BC.lines
58+
59+lazyByteString :: FilePath -> Handle -> Int -> Int -> IO ()
60+lazyByteString fp sink from to = do
61+ bs <- BL.readFile fp
62+ BL.hPutStr sink $ cut bs
63+ where
64+ cut = BLC.unlines . map (BL.take (to' - from') . BL.drop from') . BLC.lines
65+ from' = fromIntegral from
66+ to' = fromIntegral to
67+
68+text :: FilePath -> Handle -> Int -> Int -> IO ()
69+text fp sink from to = do
70+ t <- T.readFile fp
71+ T.hPutStr sink $ cut t
72+ where
73+ cut = T.unlines . map (T.take (to - from) . T.drop from) . T.lines
74+
75+lazyText :: FilePath -> Handle -> Int -> Int -> IO ()
76+lazyText fp sink from to = do
77+ t <- TL.readFile fp
78+ TL.hPutStr sink $ cut t
79+ where
80+ cut = TL.unlines . map (TL.take (to' - from') . TL.drop from') . TL.lines
81+ from' = fromIntegral from
82+ to' = fromIntegral to
83+
84+textByteString :: FilePath -> Handle -> Int -> Int -> IO ()
85+textByteString fp sink from to = do
86+ t <- T.decodeUtf8 `fmap` B.readFile fp
87+ B.hPutStr sink $ T.encodeUtf8 $ cut t
88+ where
89+ cut = T.unlines . map (T.take (to - from) . T.drop from) . T.lines
90+
91+lazyTextByteString :: FilePath -> Handle -> Int -> Int -> IO ()
92+lazyTextByteString fp sink from to = do
93+ t <- TL.decodeUtf8 `fmap` BL.readFile fp
94+ BL.hPutStr sink $ TL.encodeUtf8 $ cut t
95+ where
96+ cut = TL.unlines . map (TL.take (to' - from') . TL.drop from') . TL.lines
97+ from' = fromIntegral from
98+ to' = fromIntegral to
benchmarks/haskell/Benchmarks/Programs/Fold.hsnew file+68
@@ -0,0 +1,68 @@
1+-- | Benchmark which formats paragraph, like the @sort@ unix utility.
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Reading the file
6+--
7+-- * Splitting into paragraphs
8+--
9+-- * Reformatting the paragraphs to a certain line width
10+--
11+-- * Concatenating the results using the text builder
12+--
13+-- * Writing back to a handle
14+--
15+{-# LANGUAGE OverloadedStrings #-}
16+module Benchmarks.Programs.Fold
17+ ( benchmark
18+ ) where
19+
20+import Data.List (foldl')
21+import Data.List (intersperse)
22+import Data.Monoid (mempty, mappend, mconcat)
23+import System.IO (Handle)
24+import Criterion (Benchmark, bench, whnfIO)
25+import qualified Data.Text as T
26+import qualified Data.Text.IO as T
27+import qualified Data.Text.Lazy.Builder as TLB
28+import qualified Data.Text.Lazy as TL
29+import qualified Data.Text.Lazy.IO as TL
30+
31+benchmark :: FilePath -> Handle -> IO Benchmark
32+benchmark i o = return $
33+ bench "Fold" $ whnfIO $ T.readFile i >>= TL.hPutStr o . fold 80
34+
35+-- | We represent a paragraph by a word list
36+--
37+type Paragraph = [T.Text]
38+
39+-- | Fold a text
40+--
41+fold :: Int -> T.Text -> TL.Text
42+fold maxWidth = TLB.toLazyText . mconcat .
43+ intersperse "\n\n" . map (foldParagraph maxWidth) . paragraphs
44+
45+-- | Fold a paragraph
46+--
47+foldParagraph :: Int -> Paragraph -> TLB.Builder
48+foldParagraph _ [] = mempty
49+foldParagraph max' (w : ws) = fst $ foldl' go (TLB.fromText w, T.length w) ws
50+ where
51+ go (builder, width) word
52+ | width + len + 1 <= max' =
53+ (builder `mappend` " " `mappend` word', width + len + 1)
54+ | otherwise =
55+ (builder `mappend` "\n" `mappend` word', len)
56+ where
57+ word' = TLB.fromText word
58+ len = T.length word
59+
60+-- | Divide a text into paragraphs
61+--
62+paragraphs :: T.Text -> [Paragraph]
63+paragraphs = splitParagraphs . map T.words . T.lines
64+ where
65+ splitParagraphs ls = case break null ls of
66+ ([], []) -> []
67+ (p, []) -> [concat p]
68+ (p, lr) -> concat p : splitParagraphs (dropWhile null lr)
benchmarks/haskell/Benchmarks/Programs/Sort.hsnew file+71
@@ -0,0 +1,71 @@
1+-- | This benchmark sorts the lines of a file, like the @sort@ unix utility.
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Reading the file
6+--
7+-- * Splitting into lines
8+--
9+-- * Sorting the lines
10+--
11+-- * Joining the lines
12+--
13+-- * Writing back to a handle
14+--
15+{-# LANGUAGE OverloadedStrings #-}
16+module Benchmarks.Programs.Sort
17+ ( benchmark
18+ ) where
19+
20+import Criterion (Benchmark, bgroup, bench, whnfIO)
21+import Data.Monoid (mconcat)
22+import System.IO (Handle, hPutStr)
23+import qualified Data.ByteString as B
24+import qualified Data.ByteString.Char8 as BC
25+import qualified Data.ByteString.Lazy as BL
26+import qualified Data.ByteString.Lazy.Char8 as BLC
27+import qualified Data.List as L
28+import qualified Data.Text as T
29+import qualified Data.Text.Encoding as T
30+import qualified Data.Text.IO as T
31+import qualified Data.Text.Lazy as TL
32+import qualified Data.Text.Lazy.Builder as TLB
33+import qualified Data.Text.Lazy.Encoding as TL
34+import qualified Data.Text.Lazy.IO as TL
35+
36+benchmark :: FilePath -> Handle -> IO Benchmark
37+benchmark i o = return $ bgroup "Sort"
38+ [ bench "String" $ whnfIO $ readFile i >>= hPutStr o . string
39+ , bench "ByteString" $ whnfIO $ B.readFile i >>= B.hPutStr o . byteString
40+ , bench "LazyByteString" $ whnfIO $
41+ BL.readFile i >>= BL.hPutStr o . lazyByteString
42+ , bench "Text" $ whnfIO $ T.readFile i >>= T.hPutStr o . text
43+ , bench "LazyText" $ whnfIO $ TL.readFile i >>= TL.hPutStr o . lazyText
44+ , bench "TextByteString" $ whnfIO $ B.readFile i >>=
45+ B.hPutStr o . T.encodeUtf8 . text . T.decodeUtf8
46+ , bench "LazyTextByteString" $ whnfIO $ BL.readFile i >>=
47+ BL.hPutStr o . TL.encodeUtf8 . lazyText . TL.decodeUtf8
48+ , bench "TextBuilder" $ whnfIO $ B.readFile i >>=
49+ BL.hPutStr o . TL.encodeUtf8 . textBuilder . T.decodeUtf8
50+ ]
51+
52+string :: String -> String
53+string = unlines . L.sort . lines
54+
55+byteString :: B.ByteString -> B.ByteString
56+byteString = BC.unlines . L.sort . BC.lines
57+
58+lazyByteString :: BL.ByteString -> BL.ByteString
59+lazyByteString = BLC.unlines . L.sort . BLC.lines
60+
61+text :: T.Text -> T.Text
62+text = T.unlines . L.sort . T.lines
63+
64+lazyText :: TL.Text -> TL.Text
65+lazyText = TL.unlines . L.sort . TL.lines
66+
67+-- | Text variant using a builder monoid for the final concatenation
68+--
69+textBuilder :: T.Text -> TL.Text
70+textBuilder = TLB.toLazyText . mconcat . L.intersperse (TLB.singleton '\n') .
71+ map TLB.fromText . L.sort . T.lines
benchmarks/haskell/Benchmarks/Programs/StripTags.hsnew file+53
@@ -0,0 +1,53 @@
1+-- | Program to replace HTML tags by whitespace
2+--
3+-- This program was originally contributed by Petr Prokhorenkov.
4+--
5+-- Tested in this benchmark:
6+--
7+-- * Reading the file
8+--
9+-- * Replacing text between HTML tags (<>) with whitespace
10+--
11+-- * Writing back to a handle
12+--
13+{-# OPTIONS_GHC -fspec-constr-count=5 #-}
14+module Benchmarks.Programs.StripTags
15+ ( benchmark
16+ ) where
17+
18+import Criterion (Benchmark, bgroup, bench, whnfIO)
19+import Data.List (mapAccumL)
20+import System.IO (Handle, hPutStr)
21+import qualified Data.ByteString as B
22+import qualified Data.ByteString.Char8 as BC
23+import qualified Data.Text as T
24+import qualified Data.Text.Encoding as T
25+import qualified Data.Text.IO as T
26+
27+benchmark :: FilePath -> Handle -> IO Benchmark
28+benchmark i o = return $ bgroup "StripTags"
29+ [ bench "String" $ whnfIO $ readFile i >>= hPutStr o . string
30+ , bench "ByteString" $ whnfIO $ B.readFile i >>= B.hPutStr o . byteString
31+ , bench "Text" $ whnfIO $ T.readFile i >>= T.hPutStr o . text
32+ , bench "TextByteString" $ whnfIO $
33+ B.readFile i >>= B.hPutStr o . T.encodeUtf8 . text . T.decodeUtf8
34+ ]
35+
36+string :: String -> String
37+string = snd . mapAccumL step 0
38+
39+text :: T.Text -> T.Text
40+text = snd . T.mapAccumL step 0
41+
42+byteString :: B.ByteString -> B.ByteString
43+byteString = snd . BC.mapAccumL step 0
44+
45+step :: Int -> Char -> (Int, Char)
46+step d c
47+ | d > 0 || d' > 0 = (d', ' ')
48+ | otherwise = (d', c)
49+ where
50+ d' = d + depth c
51+ depth '>' = 1
52+ depth '<' = -1
53+ depth _ = 0
benchmarks/haskell/Benchmarks/Programs/Throughput.hsnew file+41
@@ -0,0 +1,41 @@
1+-- | This benchmark simply reads and writes a file using the various string
2+-- libraries. The point of it is that we can make better estimations on how
3+-- much time the other benchmarks spend doing IO.
4+--
5+-- Note that we expect ByteStrings to be a whole lot faster, since they do not
6+-- do any actual encoding/decoding here, while String and Text do have UTF-8
7+-- encoding/decoding.
8+--
9+-- Tested in this benchmark:
10+--
11+-- * Reading the file
12+--
13+-- * Replacing text between HTML tags (<>) with whitespace
14+--
15+-- * Writing back to a handle
16+--
17+module Benchmarks.Programs.Throughput
18+ ( benchmark
19+ ) where
20+
21+import Criterion (Benchmark, bgroup, bench, whnfIO)
22+import System.IO (Handle, hPutStr)
23+import qualified Data.ByteString as B
24+import qualified Data.ByteString.Lazy as BL
25+import qualified Data.Text.Encoding as T
26+import qualified Data.Text.IO as T
27+import qualified Data.Text.Lazy.Encoding as TL
28+import qualified Data.Text.Lazy.IO as TL
29+
30+benchmark :: FilePath -> Handle -> IO Benchmark
31+benchmark fp sink = return $ bgroup "Throughput"
32+ [ bench "String" $ whnfIO $ readFile fp >>= hPutStr sink
33+ , bench "ByteString" $ whnfIO $ B.readFile fp >>= B.hPutStr sink
34+ , bench "LazyByteString" $ whnfIO $ BL.readFile fp >>= BL.hPutStr sink
35+ , bench "Text" $ whnfIO $ T.readFile fp >>= T.hPutStr sink
36+ , bench "LazyText" $ whnfIO $ TL.readFile fp >>= TL.hPutStr sink
37+ , bench "TextByteString" $ whnfIO $
38+ B.readFile fp >>= B.hPutStr sink . T.encodeUtf8 . T.decodeUtf8
39+ , bench "LazyTextByteString" $ whnfIO $
40+ BL.readFile fp >>= BL.hPutStr sink . TL.encodeUtf8 . TL.decodeUtf8
41+ ]
benchmarks/haskell/Benchmarks/Pure.hsnew file+486
@@ -0,0 +1,486 @@
1+-- | Benchmarks various pure functions from the Text library
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Most pure functions defined the string types
6+--
7+{-# LANGUAGE BangPatterns, CPP, GADTs, MagicHash #-}
8+{-# OPTIONS_GHC -fno-warn-orphans #-}
9+module Benchmarks.Pure
10+ ( benchmark
11+ ) where
12+
13+import Control.DeepSeq (NFData (..))
14+import Control.Exception (evaluate)
15+import Criterion (Benchmark, bgroup, bench, nf)
16+import Data.Char (toLower, toUpper)
17+import Data.Monoid (mappend, mempty)
18+import GHC.Base (Char (..), Int (..), chr#, ord#, (+#))
19+import qualified Data.ByteString.Char8 as BS
20+import qualified Data.ByteString.Lazy.Char8 as BL
21+import qualified Data.ByteString.UTF8 as UTF8
22+import qualified Data.List as L
23+import qualified Data.Text as T
24+import qualified Data.Text.Encoding as T
25+import qualified Data.Text.Lazy as TL
26+import qualified Data.Text.Lazy.Builder as TB
27+import qualified Data.Text.Lazy.Encoding as TL
28+
29+benchmark :: String -> FilePath -> IO Benchmark
30+benchmark kind fp = do
31+ -- Evaluate stuff before actually running the benchmark, we don't want to
32+ -- count it here.
33+
34+ -- ByteString A
35+ bsa <- BS.readFile fp
36+
37+ -- Text A/B, LazyText A/B
38+ ta <- evaluate $ T.decodeUtf8 bsa
39+ tb <- evaluate $ T.toUpper ta
40+ tla <- evaluate $ TL.fromChunks (T.chunksOf 16376 ta)
41+ tlb <- evaluate $ TL.fromChunks (T.chunksOf 16376 tb)
42+
43+ -- ByteString B, LazyByteString A/B
44+ bsb <- evaluate $ T.encodeUtf8 tb
45+ bla <- evaluate $ BL.fromChunks (chunksOf 16376 bsa)
46+ blb <- evaluate $ BL.fromChunks (chunksOf 16376 bsb)
47+
48+ -- String A/B
49+ sa <- evaluate $ UTF8.toString bsa
50+ sb <- evaluate $ T.unpack tb
51+
52+ -- Lengths
53+ bsa_len <- evaluate $ BS.length bsa
54+ ta_len <- evaluate $ T.length ta
55+ bla_len <- evaluate $ BL.length bla
56+ tla_len <- evaluate $ TL.length tla
57+ sa_len <- evaluate $ L.length sa
58+
59+ -- Lines
60+ bsl <- evaluate $ BS.lines bsa
61+ bll <- evaluate $ BL.lines bla
62+ tl <- evaluate $ T.lines ta
63+ tll <- evaluate $ TL.lines tla
64+ sl <- evaluate $ L.lines sa
65+
66+ return $ bgroup "Pure"
67+ [ bgroup "append"
68+ [ benchT $ nf (T.append tb) ta
69+ , benchTL $ nf (TL.append tlb) tla
70+ , benchBS $ nf (BS.append bsb) bsa
71+ , benchBSL $ nf (BL.append blb) bla
72+ , benchS $ nf ((++) sb) sa
73+ ]
74+ , bgroup "concat"
75+ [ benchT $ nf T.concat tl
76+ , benchTL $ nf TL.concat tll
77+ , benchBS $ nf BS.concat bsl
78+ , benchBSL $ nf BL.concat bll
79+ , benchS $ nf L.concat sl
80+ ]
81+ , bgroup "cons"
82+ [ benchT $ nf (T.cons c) ta
83+ , benchTL $ nf (TL.cons c) tla
84+ , benchBS $ nf (BS.cons c) bsa
85+ , benchBSL $ nf (BL.cons c) bla
86+ , benchS $ nf (c:) sa
87+ ]
88+ , bgroup "concatMap"
89+ [ benchT $ nf (T.concatMap (T.replicate 3 . T.singleton)) ta
90+ , benchTL $ nf (TL.concatMap (TL.replicate 3 . TL.singleton)) tla
91+ , benchBS $ nf (BS.concatMap (BS.replicate 3)) bsa
92+ , benchBSL $ nf (BL.concatMap (BL.replicate 3)) bla
93+ , benchS $ nf (L.concatMap (L.replicate 3 . (:[]))) sa
94+ ]
95+ , bgroup "decode"
96+ [ benchT $ nf T.decodeUtf8 bsa
97+ , benchTL $ nf TL.decodeUtf8 bla
98+ , benchBS $ nf BS.unpack bsa
99+ , benchBSL $ nf BL.unpack bla
100+ , benchS $ nf UTF8.toString bsa
101+ ]
102+ , bgroup "decode'"
103+ [ benchT $ nf T.decodeUtf8' bsa
104+ , benchTL $ nf TL.decodeUtf8' bla
105+ ]
106+ , bgroup "drop"
107+ [ benchT $ nf (T.drop (ta_len `div` 3)) ta
108+ , benchTL $ nf (TL.drop (tla_len `div` 3)) tla
109+ , benchBS $ nf (BS.drop (bsa_len `div` 3)) bsa
110+ , benchBSL $ nf (BL.drop (bla_len `div` 3)) bla
111+ , benchS $ nf (L.drop (sa_len `div` 3)) sa
112+ ]
113+ , bgroup "encode"
114+ [ benchT $ nf T.encodeUtf8 ta
115+ , benchTL $ nf TL.encodeUtf8 tla
116+ , benchBS $ nf BS.pack sa
117+ , benchBSL $ nf BL.pack sa
118+ , benchS $ nf UTF8.fromString sa
119+ ]
120+ , bgroup "filter"
121+ [ benchT $ nf (T.filter p0) ta
122+ , benchTL $ nf (TL.filter p0) tla
123+ , benchBS $ nf (BS.filter p0) bsa
124+ , benchBSL $ nf (BL.filter p0) bla
125+ , benchS $ nf (L.filter p0) sa
126+ ]
127+ , bgroup "filter.filter"
128+ [ benchT $ nf (T.filter p1 . T.filter p0) ta
129+ , benchTL $ nf (TL.filter p1 . TL.filter p0) tla
130+ , benchBS $ nf (BS.filter p1 . BS.filter p0) bsa
131+ , benchBSL $ nf (BL.filter p1 . BL.filter p0) bla
132+ , benchS $ nf (L.filter p1 . L.filter p0) sa
133+ ]
134+ , bgroup "foldl'"
135+ [ benchT $ nf (T.foldl' len 0) ta
136+ , benchTL $ nf (TL.foldl' len 0) tla
137+ , benchBS $ nf (BS.foldl' len 0) bsa
138+ , benchBSL $ nf (BL.foldl' len 0) bla
139+ , benchS $ nf (L.foldl' len 0) sa
140+ ]
141+ , bgroup "foldr"
142+ [ benchT $ nf (L.length . T.foldr (:) []) ta
143+ , benchTL $ nf (L.length . TL.foldr (:) []) tla
144+ , benchBS $ nf (L.length . BS.foldr (:) []) bsa
145+ , benchBSL $ nf (L.length . BL.foldr (:) []) bla
146+ , benchS $ nf (L.length . L.foldr (:) []) sa
147+ ]
148+ , bgroup "head"
149+ [ benchT $ nf T.head ta
150+ , benchTL $ nf TL.head tla
151+ , benchBS $ nf BS.head bsa
152+ , benchBSL $ nf BL.head bla
153+ , benchS $ nf L.head sa
154+ ]
155+ , bgroup "init"
156+ [ benchT $ nf T.init ta
157+ , benchTL $ nf TL.init tla
158+ , benchBS $ nf BS.init bsa
159+ , benchBSL $ nf BL.init bla
160+ , benchS $ nf L.init sa
161+ ]
162+ , bgroup "intercalate"
163+ [ benchT $ nf (T.intercalate tsw) tl
164+ , benchTL $ nf (TL.intercalate tlw) tll
165+ , benchBS $ nf (BS.intercalate bsw) bsl
166+ , benchBSL $ nf (BL.intercalate blw) bll
167+ , benchS $ nf (L.intercalate lw) sl
168+ ]
169+ , bgroup "intersperse"
170+ [ benchT $ nf (T.intersperse c) ta
171+ , benchTL $ nf (TL.intersperse c) tla
172+ , benchBS $ nf (BS.intersperse c) bsa
173+ , benchBSL $ nf (BL.intersperse c) bla
174+ , benchS $ nf (L.intersperse c) sa
175+ ]
176+ , bgroup "isInfixOf"
177+ [ benchT $ nf (T.isInfixOf tsw) ta
178+ , benchTL $ nf (TL.isInfixOf tlw) tla
179+ , benchBS $ nf (BS.isInfixOf bsw) bsa
180+ -- no isInfixOf for lazy bytestrings
181+ , benchS $ nf (L.isInfixOf lw) sa
182+ ]
183+ , bgroup "last"
184+ [ benchT $ nf T.last ta
185+ , benchTL $ nf TL.last tla
186+ , benchBS $ nf BS.last bsa
187+ , benchBSL $ nf BL.last bla
188+ , benchS $ nf L.last sa
189+ ]
190+ , bgroup "map"
191+ [ benchT $ nf (T.map f) ta
192+ , benchTL $ nf (TL.map f) tla
193+ , benchBS $ nf (BS.map f) bsa
194+ , benchBSL $ nf (BL.map f) bla
195+ , benchS $ nf (L.map f) sa
196+ ]
197+ , bgroup "mapAccumL"
198+ [ benchT $ nf (T.mapAccumL g 0) ta
199+ , benchTL $ nf (TL.mapAccumL g 0) tla
200+ , benchBS $ nf (BS.mapAccumL g 0) bsa
201+ , benchBSL $ nf (BL.mapAccumL g 0) bla
202+ , benchS $ nf (L.mapAccumL g 0) sa
203+ ]
204+ , bgroup "mapAccumR"
205+ [ benchT $ nf (T.mapAccumR g 0) ta
206+ , benchTL $ nf (TL.mapAccumR g 0) tla
207+ , benchBS $ nf (BS.mapAccumR g 0) bsa
208+ , benchBSL $ nf (BL.mapAccumR g 0) bla
209+ , benchS $ nf (L.mapAccumR g 0) sa
210+ ]
211+ , bgroup "map.map"
212+ [ benchT $ nf (T.map f . T.map f) ta
213+ , benchTL $ nf (TL.map f . TL.map f) tla
214+ , benchBS $ nf (BS.map f . BS.map f) bsa
215+ , benchBSL $ nf (BL.map f . BL.map f) bla
216+ , benchS $ nf (L.map f . L.map f) sa
217+ ]
218+ , bgroup "replicate char"
219+ [ benchT $ nf (T.replicate bsa_len) (T.singleton c)
220+ , benchTL $ nf (TL.replicate (fromIntegral bsa_len)) (TL.singleton c)
221+ , benchBS $ nf (BS.replicate bsa_len) c
222+ , benchBSL $ nf (BL.replicate (fromIntegral bsa_len)) c
223+ , benchS $ nf (L.replicate bsa_len) c
224+ ]
225+ , bgroup "replicate string"
226+ [ benchT $ nf (T.replicate (bsa_len `div` T.length tsw)) tsw
227+ , benchTL $ nf (TL.replicate (fromIntegral bsa_len `div` TL.length tlw)) tlw
228+ , benchS $ nf (replicat (bsa_len `div` T.length tsw)) lw
229+ ]
230+ , bgroup "reverse"
231+ [ benchT $ nf T.reverse ta
232+ , benchTL $ nf TL.reverse tla
233+ , benchBS $ nf BS.reverse bsa
234+ , benchBSL $ nf BL.reverse bla
235+ , benchS $ nf L.reverse sa
236+ ]
237+ , bgroup "take"
238+ [ benchT $ nf (T.take (ta_len `div` 3)) ta
239+ , benchTL $ nf (TL.take (tla_len `div` 3)) tla
240+ , benchBS $ nf (BS.take (bsa_len `div` 3)) bsa
241+ , benchBSL $ nf (BL.take (bla_len `div` 3)) bla
242+ , benchS $ nf (L.take (sa_len `div` 3)) sa
243+ ]
244+ , bgroup "tail"
245+ [ benchT $ nf T.tail ta
246+ , benchTL $ nf TL.tail tla
247+ , benchBS $ nf BS.tail bsa
248+ , benchBSL $ nf BL.tail bla
249+ , benchS $ nf L.tail sa
250+ ]
251+ , bgroup "toLower"
252+ [ benchT $ nf T.toLower ta
253+ , benchTL $ nf TL.toLower tla
254+ , benchBS $ nf (BS.map toLower) bsa
255+ , benchBSL $ nf (BL.map toLower) bla
256+ , benchS $ nf (L.map toLower) sa
257+ ]
258+ , bgroup "toUpper"
259+ [ benchT $ nf T.toUpper ta
260+ , benchTL $ nf TL.toUpper tla
261+ , benchBS $ nf (BS.map toUpper) bsa
262+ , benchBSL $ nf (BL.map toUpper) bla
263+ , benchS $ nf (L.map toUpper) sa
264+ ]
265+ , bgroup "uncons"
266+ [ benchT $ nf T.uncons ta
267+ , benchTL $ nf TL.uncons tla
268+ , benchBS $ nf BS.uncons bsa
269+ , benchBSL $ nf BL.uncons bla
270+ , benchS $ nf L.uncons sa
271+ ]
272+ , bgroup "words"
273+ [ benchT $ nf T.words ta
274+ , benchTL $ nf TL.words tla
275+ , benchBS $ nf BS.words bsa
276+ , benchBSL $ nf BL.words bla
277+ , benchS $ nf L.words sa
278+ ]
279+ , bgroup "zipWith"
280+ [ benchT $ nf (T.zipWith min tb) ta
281+ , benchTL $ nf (TL.zipWith min tlb) tla
282+ , benchBS $ nf (BS.zipWith min bsb) bsa
283+ , benchBSL $ nf (BL.zipWith min blb) bla
284+ , benchS $ nf (L.zipWith min sb) sa
285+ ]
286+ , bgroup "length"
287+ [ bgroup "cons"
288+ [ benchT $ nf (T.length . T.cons c) ta
289+ , benchTL $ nf (TL.length . TL.cons c) tla
290+ , benchBS $ nf (BS.length . BS.cons c) bsa
291+ , benchBSL $ nf (BL.length . BL.cons c) bla
292+ , benchS $ nf (L.length . (:) c) sa
293+ ]
294+ , bgroup "decode"
295+ [ benchT $ nf (T.length . T.decodeUtf8) bsa
296+ , benchTL $ nf (TL.length . TL.decodeUtf8) bla
297+ , benchBS $ nf (L.length . BS.unpack) bsa
298+ , benchBSL $ nf (L.length . BL.unpack) bla
299+ , bench "StringUTF8" $ nf (L.length . UTF8.toString) bsa
300+ ]
301+ , bgroup "drop"
302+ [ benchT $ nf (T.length . T.drop (ta_len `div` 3)) ta
303+ , benchTL $ nf (TL.length . TL.drop (tla_len `div` 3)) tla
304+ , benchBS $ nf (BS.length . BS.drop (bsa_len `div` 3)) bsa
305+ , benchBSL $ nf (BL.length . BL.drop (bla_len `div` 3)) bla
306+ , benchS $ nf (L.length . L.drop (sa_len `div` 3)) sa
307+ ]
308+ , bgroup "filter"
309+ [ benchT $ nf (T.length . T.filter p0) ta
310+ , benchTL $ nf (TL.length . TL.filter p0) tla
311+ , benchBS $ nf (BS.length . BS.filter p0) bsa
312+ , benchBSL $ nf (BL.length . BL.filter p0) bla
313+ , benchS $ nf (L.length . L.filter p0) sa
314+ ]
315+ , bgroup "filter.filter"
316+ [ benchT $ nf (T.length . T.filter p1 . T.filter p0) ta
317+ , benchTL $ nf (TL.length . TL.filter p1 . TL.filter p0) tla
318+ , benchBS $ nf (BS.length . BS.filter p1 . BS.filter p0) bsa
319+ , benchBSL $ nf (BL.length . BL.filter p1 . BL.filter p0) bla
320+ , benchS $ nf (L.length . L.filter p1 . L.filter p0) sa
321+ ]
322+ , bgroup "init"
323+ [ benchT $ nf (T.length . T.init) ta
324+ , benchTL $ nf (TL.length . TL.init) tla
325+ , benchBS $ nf (BS.length . BS.init) bsa
326+ , benchBSL $ nf (BL.length . BL.init) bla
327+ , benchS $ nf (L.length . L.init) sa
328+ ]
329+ , bgroup "intercalate"
330+ [ benchT $ nf (T.length . T.intercalate tsw) tl
331+ , benchTL $ nf (TL.length . TL.intercalate tlw) tll
332+ , benchBS $ nf (BS.length . BS.intercalate bsw) bsl
333+ , benchBSL $ nf (BL.length . BL.intercalate blw) bll
334+ , benchS $ nf (L.length . L.intercalate lw) sl
335+ ]
336+ , bgroup "intersperse"
337+ [ benchT $ nf (T.length . T.intersperse c) ta
338+ , benchTL $ nf (TL.length . TL.intersperse c) tla
339+ , benchBS $ nf (BS.length . BS.intersperse c) bsa
340+ , benchBSL $ nf (BL.length . BL.intersperse c) bla
341+ , benchS $ nf (L.length . L.intersperse c) sa
342+ ]
343+ , bgroup "map"
344+ [ benchT $ nf (T.length . T.map f) ta
345+ , benchTL $ nf (TL.length . TL.map f) tla
346+ , benchBS $ nf (BS.length . BS.map f) bsa
347+ , benchBSL $ nf (BL.length . BL.map f) bla
348+ , benchS $ nf (L.length . L.map f) sa
349+ ]
350+ , bgroup "map.map"
351+ [ benchT $ nf (T.length . T.map f . T.map f) ta
352+ , benchTL $ nf (TL.length . TL.map f . TL.map f) tla
353+ , benchBS $ nf (BS.length . BS.map f . BS.map f) bsa
354+ , benchS $ nf (L.length . L.map f . L.map f) sa
355+ ]
356+ , bgroup "replicate char"
357+ [ benchT $ nf (T.length . T.replicate bsa_len) (T.singleton c)
358+ , benchTL $ nf (TL.length . TL.replicate (fromIntegral bsa_len)) (TL.singleton c)
359+ , benchBS $ nf (BS.length . BS.replicate bsa_len) c
360+ , benchBSL $ nf (BL.length . BL.replicate (fromIntegral bsa_len)) c
361+ , benchS $ nf (L.length . L.replicate bsa_len) c
362+ ]
363+ , bgroup "replicate string"
364+ [ benchT $ nf (T.length . T.replicate (bsa_len `div` T.length tsw)) tsw
365+ , benchTL $ nf (TL.length . TL.replicate (fromIntegral bsa_len `div` TL.length tlw)) tlw
366+ , benchS $ nf (L.length . replicat (bsa_len `div` T.length tsw)) lw
367+ ]
368+ , bgroup "take"
369+ [ benchT $ nf (T.length . T.take (ta_len `div` 3)) ta
370+ , benchTL $ nf (TL.length . TL.take (tla_len `div` 3)) tla
371+ , benchBS $ nf (BS.length . BS.take (bsa_len `div` 3)) bsa
372+ , benchBSL $ nf (BL.length . BL.take (bla_len `div` 3)) bla
373+ , benchS $ nf (L.length . L.take (sa_len `div` 3)) sa
374+ ]
375+ , bgroup "tail"
376+ [ benchT $ nf (T.length . T.tail) ta
377+ , benchTL $ nf (TL.length . TL.tail) tla
378+ , benchBS $ nf (BS.length . BS.tail) bsa
379+ , benchBSL $ nf (BL.length . BL.tail) bla
380+ , benchS $ nf (L.length . L.tail) sa
381+ ]
382+ , bgroup "toLower"
383+ [ benchT $ nf (T.length . T.toLower) ta
384+ , benchTL $ nf (TL.length . TL.toLower) tla
385+ , benchBS $ nf (BS.length . BS.map toLower) bsa
386+ , benchBSL $ nf (BL.length . BL.map toLower) bla
387+ , benchS $ nf (L.length . L.map toLower) sa
388+ ]
389+ , bgroup "toUpper"
390+ [ benchT $ nf (T.length . T.toUpper) ta
391+ , benchTL $ nf (TL.length . TL.toUpper) tla
392+ , benchBS $ nf (BS.length . BS.map toUpper) bsa
393+ , benchBSL $ nf (BL.length . BL.map toUpper) bla
394+ , benchS $ nf (L.length . L.map toUpper) sa
395+ ]
396+ , bgroup "words"
397+ [ benchT $ nf (L.length . T.words) ta
398+ , benchTL $ nf (L.length . TL.words) tla
399+ , benchBS $ nf (L.length . BS.words) bsa
400+ , benchBSL $ nf (L.length . BL.words) bla
401+ , benchS $ nf (L.length . L.words) sa
402+ ]
403+ , bgroup "zipWith"
404+ [ benchT $ nf (T.length . T.zipWith min tb) ta
405+ , benchTL $ nf (TL.length . TL.zipWith min tlb) tla
406+ , benchBS $ nf (L.length . BS.zipWith min bsb) bsa
407+ , benchBSL $ nf (L.length . BL.zipWith min blb) bla
408+ , benchS $ nf (L.length . L.zipWith min sb) sa
409+ ]
410+ ]
411+ , bgroup "Builder"
412+ [ bench "mappend char" $ nf (TL.length . TB.toLazyText . mappendNChar 'a') 10000
413+ , bench "mappend 8 char" $ nf (TL.length . TB.toLazyText . mappend8Char) 'a'
414+ , bench "mappend text" $ nf (TL.length . TB.toLazyText . mappendNText short) 10000
415+ ]
416+ ]
417+ where
418+ benchS = bench ("String+" ++ kind)
419+ benchT = bench ("Text+" ++ kind)
420+ benchTL = bench ("LazyText+" ++ kind)
421+ benchBS = bench ("ByteString+" ++ kind)
422+ benchBSL = bench ("LazyByteString+" ++ kind)
423+
424+ c = 'й'
425+ p0 = (== c)
426+ p1 = (/= 'д')
427+ lw = "право"
428+ bsw = UTF8.fromString lw
429+ blw = BL.fromChunks [bsw]
430+ tsw = T.pack lw
431+ tlw = TL.fromChunks [tsw]
432+ f (C# c#) = C# (chr# (ord# c# +# 1#))
433+ g (I# i#) (C# c#) = (I# (i# +# 1#), C# (chr# (ord# c# +# i#)))
434+ len l _ = l + (1::Int)
435+ replicat n = concat . L.replicate n
436+ short = T.pack "short"
437+
438+#if !MIN_VERSION_bytestring(0,10,0)
439+instance NFData BS.ByteString
440+
441+instance NFData BL.ByteString where
442+ rnf BL.Empty = ()
443+ rnf (BL.Chunk _ ts) = rnf ts
444+#endif
445+
446+data B where
447+ B :: NFData a => a -> B
448+
449+instance NFData B where
450+ rnf (B b) = rnf b
451+
452+-- | Split a bytestring in chunks
453+--
454+chunksOf :: Int -> BS.ByteString -> [BS.ByteString]
455+chunksOf k = go
456+ where
457+ go t = case BS.splitAt k t of
458+ (a,b) | BS.null a -> []
459+ | otherwise -> a : go b
460+
461+-- | Append a character n times
462+--
463+mappendNChar :: Char -> Int -> TB.Builder
464+mappendNChar c n = go 0
465+ where
466+ go i
467+ | i < n = TB.singleton c `mappend` go (i+1)
468+ | otherwise = mempty
469+
470+-- | Gives more opportunity for inlining and elimination of unnecesary
471+-- bounds checks.
472+--
473+mappend8Char :: Char -> TB.Builder
474+mappend8Char c = TB.singleton c `mappend` TB.singleton c `mappend`
475+ TB.singleton c `mappend` TB.singleton c `mappend`
476+ TB.singleton c `mappend` TB.singleton c `mappend`
477+ TB.singleton c `mappend` TB.singleton c
478+
479+-- | Append a text N times
480+--
481+mappendNText :: T.Text -> Int -> TB.Builder
482+mappendNText t n = go 0
483+ where
484+ go i
485+ | i < n = TB.fromText t `mappend` go (i+1)
486+ | otherwise = mempty
benchmarks/haskell/Benchmarks/ReadNumbers.hsnew file+93
@@ -0,0 +1,93 @@
1+-- | Read numbers from a file with a just a number on each line, find the
2+-- minimum of those numbers. The file contains different kinds of numbers:
3+--
4+-- * Decimals
5+--
6+-- * Hexadecimals
7+--
8+-- * Floating point numbers
9+--
10+-- * Floating point numbers in scientific notation
11+--
12+-- The different benchmarks will only take into account the values they can
13+-- parse.
14+--
15+-- Tested in this benchmark:
16+--
17+-- * Lexing/parsing of different numerical types
18+--
19+module Benchmarks.ReadNumbers
20+ ( benchmark
21+ ) where
22+
23+import Criterion (Benchmark, bgroup, bench, whnf)
24+import Data.List (foldl')
25+import Numeric (readDec, readFloat, readHex)
26+import qualified Data.ByteString.Char8 as B
27+import qualified Data.ByteString.Lazy.Char8 as BL
28+import qualified Data.ByteString.Lex.Fractional as B
29+import qualified Data.Text as T
30+import qualified Data.Text.IO as T
31+import qualified Data.Text.Lazy as TL
32+import qualified Data.Text.Lazy.IO as TL
33+import qualified Data.Text.Lazy.Read as TL
34+import qualified Data.Text.Read as T
35+
36+benchmark :: FilePath -> IO Benchmark
37+benchmark fp = do
38+ -- Read all files into lines: string, text, lazy text, bytestring, lazy
39+ -- bytestring
40+ s <- lines `fmap` readFile fp
41+ t <- T.lines `fmap` T.readFile fp
42+ tl <- TL.lines `fmap` TL.readFile fp
43+ b <- B.lines `fmap` B.readFile fp
44+ bl <- BL.lines `fmap` BL.readFile fp
45+ return $ bgroup "ReadNumbers"
46+ [ bench "DecimalString" $ whnf (int . string readDec) s
47+ , bench "HexadecimalString" $ whnf (int . string readHex) s
48+ , bench "DoubleString" $ whnf (double . string readFloat) s
49+
50+ , bench "DecimalText" $ whnf (int . text (T.signed T.decimal)) t
51+ , bench "HexadecimalText" $ whnf (int . text (T.signed T.hexadecimal)) t
52+ , bench "DoubleText" $ whnf (double . text T.double) t
53+ , bench "RationalText" $ whnf (double . text T.rational) t
54+
55+ , bench "DecimalLazyText" $
56+ whnf (int . text (TL.signed TL.decimal)) tl
57+ , bench "HexadecimalLazyText" $
58+ whnf (int . text (TL.signed TL.hexadecimal)) tl
59+ , bench "DoubleLazyText" $
60+ whnf (double . text TL.double) tl
61+ , bench "RationalLazyText" $
62+ whnf (double . text TL.rational) tl
63+
64+ , bench "DecimalByteString" $ whnf (int . byteString B.readInt) b
65+ , bench "DoubleByteString" $ whnf (double . byteString B.readDecimal) b
66+
67+ , bench "DecimalLazyByteString" $
68+ whnf (int . byteString BL.readInt) bl
69+ ]
70+ where
71+ -- Used for fixing types
72+ int :: Int -> Int
73+ int = id
74+ double :: Double -> Double
75+ double = id
76+
77+string :: (Ord a, Num a) => (t -> [(a, t)]) -> [t] -> a
78+string reader = foldl' go 1000000
79+ where
80+ go z t = case reader t of [(n, _)] -> min n z
81+ _ -> z
82+
83+text :: (Ord a, Num a) => (t -> Either String (a,t)) -> [t] -> a
84+text reader = foldl' go 1000000
85+ where
86+ go z t = case reader t of Left _ -> z
87+ Right (n, _) -> min n z
88+
89+byteString :: (Ord a, Num a) => (t -> Maybe (a,t)) -> [t] -> a
90+byteString reader = foldl' go 1000000
91+ where
92+ go z t = case reader t of Nothing -> z
93+ Just (n, _) -> min n z
benchmarks/haskell/Benchmarks/Replace.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# LANGUAGE BangPatterns #-}
2+-- | Replace a string by another string
3+--
4+-- Tested in this benchmark:
5+--
6+-- * Search and replace of a pattern in a text
7+--
8+module Benchmarks.Replace
9+ ( benchmark
10+ ) where
11+
12+import Criterion (Benchmark, bgroup, bench, nf)
13+import qualified Data.ByteString.Char8 as B
14+import qualified Data.ByteString.Lazy as BL
15+import qualified Data.ByteString.Lazy.Search as BL
16+import qualified Data.ByteString.Search as B
17+import qualified Data.Text as T
18+import qualified Data.Text.Encoding as T
19+import qualified Data.Text.Lazy as TL
20+import qualified Data.Text.Lazy.Encoding as TL
21+import qualified Data.Text.Lazy.IO as TL
22+
23+benchmark :: FilePath -> String -> String -> IO Benchmark
24+benchmark fp pat sub = do
25+ tl <- TL.readFile fp
26+ bl <- BL.readFile fp
27+ let !t = TL.toStrict tl
28+ !b = T.encodeUtf8 t
29+ return $ bgroup "Replace" [
30+ bench "Text" $ nf (T.length . T.replace tpat tsub) t
31+ , bench "ByteString" $ nf (BL.length . B.replace bpat bsub) b
32+ , bench "LazyText" $ nf (TL.length . TL.replace tlpat tlsub) tl
33+ , bench "LazyByteString" $ nf (BL.length . BL.replace blpat blsub) bl
34+ ]
35+ where
36+ tpat = T.pack pat
37+ tsub = T.pack sub
38+ tlpat = TL.pack pat
39+ tlsub = TL.pack sub
40+ bpat = T.encodeUtf8 tpat
41+ bsub = T.encodeUtf8 tsub
42+ blpat = B.concat $ BL.toChunks $ TL.encodeUtf8 tlpat
43+ blsub = B.concat $ BL.toChunks $ TL.encodeUtf8 tlsub
benchmarks/haskell/Benchmarks/Search.hsnew file+48
@@ -0,0 +1,48 @@
1+-- | Search for a pattern in a file, find the number of occurences
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Searching all occurences of a pattern using library routines
6+--
7+module Benchmarks.Search
8+ ( benchmark
9+ ) where
10+
11+import Criterion (Benchmark, bench, bgroup, whnf)
12+import qualified Data.ByteString as B
13+import qualified Data.ByteString.Lazy as BL
14+import qualified Data.ByteString.Lazy.Search as BL
15+import qualified Data.ByteString.Search as B
16+import qualified Data.Text as T
17+import qualified Data.Text.Encoding as T
18+import qualified Data.Text.IO as T
19+import qualified Data.Text.Lazy as TL
20+import qualified Data.Text.Lazy.IO as TL
21+
22+benchmark :: FilePath -> T.Text -> IO Benchmark
23+benchmark fp needleT = do
24+ b <- B.readFile fp
25+ bl <- BL.readFile fp
26+ t <- T.readFile fp
27+ tl <- TL.readFile fp
28+ return $ bgroup "FileIndices"
29+ [ bench "ByteString" $ whnf (byteString needleB) b
30+ , bench "LazyByteString" $ whnf (lazyByteString needleB) bl
31+ , bench "Text" $ whnf (text needleT) t
32+ , bench "LazyText" $ whnf (lazyText needleTL) tl
33+ ]
34+ where
35+ needleB = T.encodeUtf8 needleT
36+ needleTL = TL.fromChunks [needleT]
37+
38+byteString :: B.ByteString -> B.ByteString -> Int
39+byteString needle = length . B.indices needle
40+
41+lazyByteString :: B.ByteString -> BL.ByteString -> Int
42+lazyByteString needle = length . BL.indices needle
43+
44+text :: T.Text -> T.Text -> Int
45+text = T.count
46+
47+lazyText :: TL.Text -> TL.Text -> Int
48+lazyText needle = fromIntegral . TL.count needle
benchmarks/haskell/Benchmarks/Stream.hsnew file+104
@@ -0,0 +1,104 @@
1+-- | This module contains a number of benchmarks for the different streaming
2+-- functions
3+--
4+-- Tested in this benchmark:
5+--
6+-- * Most streaming functions
7+--
8+{-# LANGUAGE BangPatterns #-}
9+{-# OPTIONS_GHC -fno-warn-orphans #-}
10+module Benchmarks.Stream
11+ ( benchmark
12+ ) where
13+
14+import Control.DeepSeq (NFData (..))
15+import Criterion (Benchmark, bgroup, bench, nf)
16+import Data.Text.Internal.Fusion.Types (Step (..), Stream (..))
17+import qualified Data.Text.Encoding as T
18+import qualified Data.Text.Encoding.Error as E
19+import qualified Data.Text.Internal.Encoding.Fusion as T
20+import qualified Data.Text.Internal.Encoding.Fusion.Common as F
21+import qualified Data.Text.Internal.Fusion as F
22+import qualified Data.Text.IO as T
23+import qualified Data.Text.Lazy.Encoding as TL
24+import qualified Data.Text.Internal.Lazy.Encoding.Fusion as TL
25+import qualified Data.Text.Internal.Lazy.Fusion as FL
26+import qualified Data.Text.Lazy.IO as TL
27+
28+instance NFData a => NFData (Stream a) where
29+ -- Currently, this implementation does not force evaluation of the size hint
30+ rnf (Stream next s0 _) = go s0
31+ where
32+ go !s = case next s of
33+ Done -> ()
34+ Skip s' -> go s'
35+ Yield x s' -> rnf x `seq` go s'
36+
37+benchmark :: FilePath -> IO Benchmark
38+benchmark fp = do
39+ -- Different formats
40+ t <- T.readFile fp
41+ let !utf8 = T.encodeUtf8 t
42+ !utf16le = T.encodeUtf16LE t
43+ !utf16be = T.encodeUtf16BE t
44+ !utf32le = T.encodeUtf32LE t
45+ !utf32be = T.encodeUtf32BE t
46+
47+ -- Once again for the lazy variants
48+ tl <- TL.readFile fp
49+ let !utf8L = TL.encodeUtf8 tl
50+ !utf16leL = TL.encodeUtf16LE tl
51+ !utf16beL = TL.encodeUtf16BE tl
52+ !utf32leL = TL.encodeUtf32LE tl
53+ !utf32beL = TL.encodeUtf32BE tl
54+
55+ -- For the functions which operate on streams
56+ let !s = F.stream t
57+
58+ return $ bgroup "Stream"
59+
60+ -- Fusion
61+ [ bgroup "stream" $
62+ [ bench "Text" $ nf F.stream t
63+ , bench "LazyText" $ nf FL.stream tl
64+ ]
65+ -- must perform exactly the same as stream above due to
66+ -- stream/unstream (i.e. stream after unstream) fusion
67+ , bgroup "stream-fusion" $
68+ [ bench "Text" $ nf (F.stream . F.unstream . F.stream) t
69+ , bench "LazyText" $ nf (FL.stream . FL.unstream . FL.stream) tl
70+ ]
71+ -- measure the overhead of unstream after stream
72+ , bgroup "stream-unstream" $
73+ [ bench "Text" $ nf (F.unstream . F.stream) t
74+ , bench "LazyText" $ nf (FL.unstream . FL.stream) tl
75+ ]
76+
77+ -- Encoding.Fusion
78+ , bgroup "streamUtf8"
79+ [ bench "Text" $ nf (T.streamUtf8 E.lenientDecode) utf8
80+ , bench "LazyText" $ nf (TL.streamUtf8 E.lenientDecode) utf8L
81+ ]
82+ , bgroup "streamUtf16LE"
83+ [ bench "Text" $ nf (T.streamUtf16LE E.lenientDecode) utf16le
84+ , bench "LazyText" $ nf (TL.streamUtf16LE E.lenientDecode) utf16leL
85+ ]
86+ , bgroup "streamUtf16BE"
87+ [ bench "Text" $ nf (T.streamUtf16BE E.lenientDecode) utf16be
88+ , bench "LazyText" $ nf (TL.streamUtf16BE E.lenientDecode) utf16beL
89+ ]
90+ , bgroup "streamUtf32LE"
91+ [ bench "Text" $ nf (T.streamUtf32LE E.lenientDecode) utf32le
92+ , bench "LazyText" $ nf (TL.streamUtf32LE E.lenientDecode) utf32leL
93+ ]
94+ , bgroup "streamUtf32BE"
95+ [ bench "Text" $ nf (T.streamUtf32BE E.lenientDecode) utf32be
96+ , bench "LazyText" $ nf (TL.streamUtf32BE E.lenientDecode) utf32beL
97+ ]
98+
99+ -- Encoding.Fusion.Common
100+ , bench "restreamUtf16LE" $ nf F.restreamUtf16LE s
101+ , bench "restreamUtf16BE" $ nf F.restreamUtf16BE s
102+ , bench "restreamUtf32LE" $ nf F.restreamUtf32LE s
103+ , bench "restreamUtf32BE" $ nf F.restreamUtf32BE s
104+ ]
benchmarks/haskell/Benchmarks/WordFrequencies.hsnew file+36
@@ -0,0 +1,36 @@
1+-- | A word frequency count using the different string types
2+--
3+-- Tested in this benchmark:
4+--
5+-- * Splitting into words
6+--
7+-- * Converting to lowercase
8+--
9+-- * Comparing: Eq/Ord instances
10+--
11+module Benchmarks.WordFrequencies
12+ ( benchmark
13+ ) where
14+
15+import Criterion (Benchmark, bench, bgroup, whnf)
16+import Data.Char (toLower)
17+import Data.List (foldl')
18+import Data.Map (Map)
19+import qualified Data.ByteString.Char8 as B
20+import qualified Data.Map as M
21+import qualified Data.Text as T
22+import qualified Data.Text.IO as T
23+
24+benchmark :: FilePath -> IO Benchmark
25+benchmark fp = do
26+ s <- readFile fp
27+ b <- B.readFile fp
28+ t <- T.readFile fp
29+ return $ bgroup "WordFrequencies"
30+ [ bench "String" $ whnf (frequencies . words . map toLower) s
31+ , bench "ByteString" $ whnf (frequencies . B.words . B.map toLower) b
32+ , bench "Text" $ whnf (frequencies . T.words . T.toLower) t
33+ ]
34+
35+frequencies :: Ord a => [a] -> Map a Int
36+frequencies = foldl' (\m k -> M.insertWith (+) k 1 m) M.empty
benchmarks/haskell/Multilang.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# LANGUAGE BangPatterns, OverloadedStrings, RankNTypes #-}
2+
3+module Main (
4+ main
5+ ) where
6+
7+import Control.Monad (forM_)
8+import qualified Data.ByteString as B
9+import qualified Data.Text as Text
10+import Data.Text.Encoding (decodeUtf8)
11+import Data.Text (Text)
12+import System.IO (hFlush, stdout)
13+import Timer (timer)
14+
15+type BM = Text -> ()
16+
17+bm :: forall a. (Text -> a) -> BM
18+bm f t = f t `seq` ()
19+
20+benchmarks :: [(String, Text.Text -> ())]
21+benchmarks = [
22+ ("find_first", bm $ Text.isInfixOf "en:Benin")
23+ , ("find_index", bm $ Text.findIndex (=='c'))
24+ ]
25+
26+main :: IO ()
27+main = do
28+ !contents <- decodeUtf8 `fmap` B.readFile "../tests/text-test-data/yiwiki.xml"
29+ forM_ benchmarks $ \(name, bmark) -> do
30+ putStr $ name ++ " "
31+ hFlush stdout
32+ putStrLn =<< (timer 100 contents bmark)
benchmarks/haskell/Timer.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# LANGUAGE BangPatterns #-}
2+
3+module Timer (timer) where
4+
5+import Control.Exception (evaluate)
6+import Data.Time.Clock.POSIX (getPOSIXTime)
7+import GHC.Float (FFFormat(..), formatRealFloat)
8+
9+ickyRound :: Int -> Double -> String
10+ickyRound k = formatRealFloat FFFixed (Just k)
11+
12+timer :: Int -> a -> (a -> b) -> IO String
13+timer count a0 f = do
14+ let loop !k !fastest
15+ | k <= 0 = return fastest
16+ | otherwise = do
17+ start <- getPOSIXTime
18+ let inner a i
19+ | i <= 0 = return ()
20+ | otherwise = evaluate (f a) >> inner a (i-1)
21+ inner a0 count
22+ end <- getPOSIXTime
23+ let elapsed = end - start
24+ loop (k-1) (min fastest (elapsed / fromIntegral count))
25+ t <- loop (3::Int) 1e300
26+ let log10 x = log x / log 10
27+ ft = realToFrac t
28+ prec = round (log10 (fromIntegral count) - log10 ft)
29+ return $! ickyRound prec ft
30+{-# NOINLINE timer #-}
benchmarks/python/.gitignorenew file+2
@@ -0,0 +1,2 @@
1+__pycache__
2+*.pyc
benchmarks/python/cut.pynew file+12
@@ -0,0 +1,12 @@
1+#!/usr/bin/env python
2+
3+import utils, sys, codecs
4+
5+def cut(filename, l, r):
6+ content = open(filename, encoding='utf-8')
7+ for line in content:
8+ print(line[l:r])
9+
10+for f in sys.argv[1:]:
11+ t = utils.benchmark(lambda: cut(f, 20, 40))
12+ sys.stderr.write('{0}: {1}\n'.format(f, t))
benchmarks/python/multilang.pynew file+50
@@ -0,0 +1,50 @@
1+#!/usr/bin/env python
2+
3+import math
4+import sys
5+import time
6+
7+def find_first():
8+ cf = contents.find
9+ return timer(lambda: cf("en:Benin"))
10+
11+def timer(f, count=100):
12+ a = 1e300
13+ def g():
14+ return
15+ for i in xrange(3):
16+ start = time.time()
17+ for j in xrange(count):
18+ g()
19+ a = min(a, (time.time() - start) / count)
20+
21+ b = 1e300
22+ for i in xrange(3):
23+ start = time.time()
24+ for j in xrange(count):
25+ f()
26+ b = min(b, (time.time() - start) / count)
27+
28+ return round(b - a, int(round(math.log(count, 10) - math.log(b - a, 10))))
29+
30+contents = open('../../tests/text-test-data/yiwiki.xml', 'r').read()
31+contents = contents.decode('utf-8')
32+
33+benchmarks = (
34+ find_first,
35+ )
36+
37+to_run = sys.argv[1:]
38+bms = []
39+if to_run:
40+ for r in to_run:
41+ for b in benchmarks:
42+ if b.__name__.startswith(r):
43+ bms.append(b)
44+else:
45+ bms = benchmarks
46+
47+for b in bms:
48+ sys.stdout.write(b.__name__ + ' ')
49+ sys.stdout.flush()
50+ print b()
benchmarks/python/sort.pynew file+13
@@ -0,0 +1,13 @@
1+#!/usr/bin/env python
2+
3+import utils, sys, codecs
4+
5+def sort(filename):
6+ content = open(filename, encoding='utf-8').read()
7+ lines = content.splitlines()
8+ lines.sort()
9+ print('\n'.join(lines))
10+
11+for f in sys.argv[1:]:
12+ t = utils.benchmark(lambda: sort(f))
13+ sys.stderr.write('{0}: {1}\n'.format(f, t))
benchmarks/python/strip_tags.pynew file+25
@@ -0,0 +1,25 @@
1+#!/usr/bin/env python
2+
3+import utils, sys
4+
5+def strip_tags(filename):
6+ string = open(filename, encoding='utf-8').read()
7+
8+ d = 0
9+ out = []
10+
11+ for c in string:
12+ if c == '<': d += 1
13+
14+ if d > 0:
15+ out += ' '
16+ else:
17+ out += c
18+
19+ if c == '>': d -= 1
20+
21+ print(''.join(out))
22+
23+for f in sys.argv[1:]:
24+ t = utils.benchmark(lambda: strip_tags(f))
25+ sys.stderr.write('{0}: {1}\n'.format(f, t))
benchmarks/python/utils.pynew file+18
@@ -0,0 +1,18 @@
1+#!/usr/bin/env python
2+
3+import sys, time
4+
5+def benchmark_once(f):
6+ start = time.time()
7+ f()
8+ end = time.time()
9+ return end - start
10+
11+def benchmark(f):
12+ runs = 100
13+ total = 0.0
14+ for i in range(runs):
15+ result = benchmark_once(f)
16+ sys.stderr.write('Run {0}: {1}\n'.format(i, result))
17+ total += result
18+ return total / runs
benchmarks/ruby/cut.rbnew file+16
@@ -0,0 +1,16 @@
1+#!/usr/bin/env ruby
2+
3+require './utils.rb'
4+
5+def cut(filename, l, r)
6+ File.open(filename, 'r:utf-8') do |file|
7+ file.each_line do |line|
8+ puts line[l, r - l]
9+ end
10+ end
11+end
12+
13+ARGV.each do |f|
14+ t = benchmark { cut(f, 20, 40) }
15+ STDERR.puts "#{f}: #{t}"
16+end
benchmarks/ruby/fold.rbnew file+50
@@ -0,0 +1,50 @@
1+#!/usr/bin/env ruby
2+
3+require './utils.rb'
4+
5+def fold(filename, max_width)
6+ File.open(filename, 'r:utf-8') do |file|
7+ # Words in this paragraph
8+ paragraph = []
9+
10+ file.each_line do |line|
11+ # If we encounter an empty line, we reformat and dump the current
12+ # paragraph
13+ if line.strip.empty?
14+ puts fold_paragraph(paragraph, max_width)
15+ puts
16+ paragraph = []
17+ # Otherwise, we append the words found in the line to the paragraph
18+ else
19+ paragraph.concat line.split
20+ end
21+ end
22+
23+ # Last paragraph
24+ puts fold_paragraph(paragraph, max_width) unless paragraph.empty?
25+ end
26+end
27+
28+# Fold a single paragraph to the desired width
29+def fold_paragraph(paragraph, max_width)
30+ # Gradually build our output
31+ str, *rest = paragraph
32+ width = str.length
33+
34+ rest.each do |word|
35+ if width + word.length + 1 <= max_width
36+ str << ' ' << word
37+ width += word.length + 1
38+ else
39+ str << "\n" << word
40+ width = word.length
41+ end
42+ end
43+
44+ str
45+end
46+
47+ARGV.each do |f|
48+ t = benchmark { fold(f, 80) }
49+ STDERR.puts "#{f}: #{t}"
50+end
benchmarks/ruby/sort.rbnew file+15
@@ -0,0 +1,15 @@
1+#!/usr/bin/env ruby
2+
3+require './utils.rb'
4+
5+def sort(filename)
6+ File.open(filename, 'r:utf-8') do |file|
7+ content = file.read
8+ puts content.lines.sort.join
9+ end
10+end
11+
12+ARGV.each do |f|
13+ t = benchmark { sort(f) }
14+ STDERR.puts "#{f}: #{t}"
15+end
benchmarks/ruby/strip_tags.rbnew file+22
@@ -0,0 +1,22 @@
1+#!/usr/bin/env ruby
2+
3+require './utils.rb'
4+
5+def strip_tags(filename)
6+ File.open(filename, 'r:utf-8') do |file|
7+ str = file.read
8+
9+ d = 0
10+
11+ str.each_char do |c|
12+ d += 1 if c == '<'
13+ putc(if d > 0 then ' ' else c end)
14+ d -= 1 if c == '>'
15+ end
16+ end
17+end
18+
19+ARGV.each do |f|
20+ t = benchmark { strip_tags(f) }
21+ STDERR.puts "#{f}: #{t}"
22+end
benchmarks/ruby/utils.rbnew file+14
@@ -0,0 +1,14 @@
1+require 'benchmark'
2+
3+def benchmark(&block)
4+ runs = 100
5+ total = 0
6+
7+ runs.times do |i|
8+ result = Benchmark.measure(&block).total
9+ $stderr.puts "Run #{i}: #{result}"
10+ total += result
11+ end
12+
13+ total / runs
14+end
benchmarks/text-benchmarks.cabalnew file+66
@@ -0,0 +1,66 @@
1+name: text-benchmarks
2+version: 0.0.0.0
3+synopsis: Benchmarks for the text package
4+description: Benchmarks for the text package
5+homepage: https://bitbucket.org/bos/text
6+license: BSD2
7+license-file: ../LICENSE
8+author: Jasper Van der Jeugt <jaspervdj@gmail.com>,
9+ Bryan O'Sullivan <bos@serpentine.com>,
10+ Tom Harper <rtomharper@googlemail.com>,
11+ Duncan Coutts <duncan@haskell.org>
12+maintainer: jaspervdj@gmail.com
13+category: Text
14+build-type: Simple
15+
16+cabal-version: >=1.2
17+
18+flag bytestring-builder
19+ description: Depend on the bytestring-builder package for backwards compatibility.
20+ default: False
21+ manual: False
22+
23+flag llvm
24+ description: use LLVM
25+ default: False
26+ manual: True
27+
28+executable text-benchmarks
29+ hs-source-dirs: haskell ..
30+ c-sources: ../cbits/cbits.c
31+ cbits/time_iconv.c
32+ include-dirs: ../include
33+ main-is: Benchmarks.hs
34+ ghc-options: -Wall -O2 -rtsopts
35+ if flag(llvm)
36+ ghc-options: -fllvm
37+ cpp-options: -DHAVE_DEEPSEQ -DINTEGER_GMP
38+ build-depends: base == 4.*,
39+ binary,
40+ blaze-builder,
41+ bytestring-lexing >= 0.5.0,
42+ containers,
43+ criterion >= 0.10.0.0,
44+ deepseq,
45+ directory,
46+ filepath,
47+ ghc-prim,
48+ integer-gmp,
49+ stringsearch,
50+ utf8-string,
51+ vector
52+
53+ if flag(bytestring-builder)
54+ build-depends: bytestring >= 0.9 && < 0.10.4,
55+ bytestring-builder >= 0.10.4
56+ else
57+ build-depends: bytestring >= 0.10.4
58+
59+executable text-multilang
60+ hs-source-dirs: haskell
61+ main-is: Multilang.hs
62+ ghc-options: -Wall -O2
63+ build-depends: base == 4.*,
64+ bytestring,
65+ text,
66+ time
cbits/cbits.cnew file+311
@@ -0,0 +1,311 @@
1+/*
2+ * Copyright (c) 2011 Bryan O'Sullivan <bos@serpentine.com>.
3+ *
4+ * Portions copyright (c) 2008-2010 Björn Höhrmann <bjoern@hoehrmann.de>.
5+ *
6+ * See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
7+ */
8+
9+#include <string.h>
10+#include <stdint.h>
11+#include <stdio.h>
12+#include "text_cbits.h"
13+
14+void _hs_text_memcpy(void *dest, size_t doff, const void *src, size_t soff,
15+ size_t n)
16+{
17+ memcpy(dest + (doff<<1), src + (soff<<1), n<<1);
18+}
19+
20+int _hs_text_memcmp(const void *a, size_t aoff, const void *b, size_t boff,
21+ size_t n)
22+{
23+ return memcmp(a + (aoff<<1), b + (boff<<1), n<<1);
24+}
25+
26+#define UTF8_ACCEPT 0
27+#define UTF8_REJECT 12
28+
29+static const uint8_t utf8d[] = {
30+ /*
31+ * The first part of the table maps bytes to character classes that
32+ * to reduce the size of the transition table and create bitmasks.
33+ */
34+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
35+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
36+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
37+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
38+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,
39+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
40+ 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
41+ 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,
42+
43+ /*
44+ * The second part is a transition table that maps a combination of
45+ * a state of the automaton and a character class to a state.
46+ */
47+ 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
48+ 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
49+ 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
50+ 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
51+ 12,36,12,12,12,12,12,12,12,12,12,12,
52+};
53+
54+static inline uint32_t
55+decode(uint32_t *state, uint32_t* codep, uint32_t byte) {
56+ uint32_t type = utf8d[byte];
57+
58+ *codep = (*state != UTF8_ACCEPT) ?
59+ (byte & 0x3fu) | (*codep << 6) :
60+ (0xff >> type) & (byte);
61+
62+ return *state = utf8d[256 + *state + type];
63+}
64+
65+/*
66+ * The ISO 8859-1 (aka latin-1) code points correspond exactly to the first 256 unicode
67+ * code-points, therefore we can trivially convert from a latin-1 encoded bytestring to
68+ * an UTF16 array
69+ */
70+void
71+_hs_text_decode_latin1(uint16_t *dest, const uint8_t *src,
72+ const uint8_t *srcend)
73+{
74+ const uint8_t *p = src;
75+
76+#if defined(__i386__) || defined(__x86_64__)
77+ /* This optimization works on a little-endian systems by using
78+ (aligned) 32-bit loads instead of 8-bit loads
79+ */
80+
81+ /* consume unaligned prefix */
82+ while (p != srcend && (uintptr_t)p & 0x3)
83+ *dest++ = *p++;
84+
85+ /* iterate over 32-bit aligned loads */
86+ while (p < srcend - 3) {
87+ const uint32_t w = *((const uint32_t *)p);
88+
89+ *dest++ = w & 0xff;
90+ *dest++ = (w >> 8) & 0xff;
91+ *dest++ = (w >> 16) & 0xff;
92+ *dest++ = (w >> 24) & 0xff;
93+
94+ p += 4;
95+ }
96+#endif
97+
98+ /* handle unaligned suffix */
99+ while (p != srcend)
100+ *dest++ = *p++;
101+}
102+
103+/*
104+ * A best-effort decoder. Runs until it hits either end of input or
105+ * the start of an invalid byte sequence.
106+ *
107+ * At exit, we update *destoff with the next offset to write to, *src
108+ * with the next source location past the last one successfully
109+ * decoded, and return the next source location to read from.
110+ *
111+ * Moreover, we expose the internal decoder state (state0 and
112+ * codepoint0), allowing one to restart the decoder after it
113+ * terminates (say, due to a partial codepoint).
114+ *
115+ * In particular, there are a few possible outcomes,
116+ *
117+ * 1) We decoded the buffer entirely:
118+ * In this case we return srcend
119+ * state0 == UTF8_ACCEPT
120+ *
121+ * 2) We met an invalid encoding
122+ * In this case we return the address of the first invalid byte
123+ * state0 == UTF8_REJECT
124+ *
125+ * 3) We reached the end of the buffer while decoding a codepoint
126+ * In this case we return a pointer to the first byte of the partial codepoint
127+ * state0 != UTF8_ACCEPT, UTF8_REJECT
128+ *
129+ */
130+#if defined(__GNUC__) || defined(__clang__)
131+static inline uint8_t const *
132+_hs_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,
133+ const uint8_t **src, const uint8_t *srcend,
134+ uint32_t *codepoint0, uint32_t *state0)
135+ __attribute((always_inline));
136+#endif
137+
138+static inline uint8_t const *
139+_hs_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,
140+ const uint8_t **src, const uint8_t *srcend,
141+ uint32_t *codepoint0, uint32_t *state0)
142+{
143+ uint16_t *d = dest + *destoff;
144+ const uint8_t *s = *src, *last = *src;
145+ uint32_t state = *state0;
146+ uint32_t codepoint = *codepoint0;
147+
148+ while (s < srcend) {
149+#if defined(__i386__) || defined(__x86_64__)
150+ /*
151+ * This code will only work on a little-endian system that
152+ * supports unaligned loads.
153+ *
154+ * It gives a substantial speed win on data that is purely or
155+ * partly ASCII (e.g. HTML), at only a slight cost on purely
156+ * non-ASCII text.
157+ */
158+
159+ if (state == UTF8_ACCEPT) {
160+ while (s < srcend - 4) {
161+ codepoint = *((uint32_t *) s);
162+ if ((codepoint & 0x80808080) != 0)
163+ break;
164+ s += 4;
165+
166+ /*
167+ * Tried 32-bit stores here, but the extra bit-twiddling
168+ * slowed the code down.
169+ */
170+
171+ *d++ = (uint16_t) (codepoint & 0xff);
172+ *d++ = (uint16_t) ((codepoint >> 8) & 0xff);
173+ *d++ = (uint16_t) ((codepoint >> 16) & 0xff);
174+ *d++ = (uint16_t) ((codepoint >> 24) & 0xff);
175+ }
176+ last = s;
177+ }
178+#endif
179+
180+ if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {
181+ if (state != UTF8_REJECT)
182+ continue;
183+ break;
184+ }
185+
186+ if (codepoint <= 0xffff)
187+ *d++ = (uint16_t) codepoint;
188+ else {
189+ *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));
190+ *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));
191+ }
192+ last = s;
193+ }
194+
195+ *destoff = d - dest;
196+ *codepoint0 = codepoint;
197+ *state0 = state;
198+ *src = last;
199+
200+ return s;
201+}
202+
203+uint8_t const *
204+_hs_text_decode_utf8_state(uint16_t *const dest, size_t *destoff,
205+ const uint8_t **src,
206+ const uint8_t *srcend,
207+ uint32_t *codepoint0, uint32_t *state0)
208+{
209+ uint8_t const *ret = _hs_text_decode_utf8_int(dest, destoff, src, srcend,
210+ codepoint0, state0);
211+ if (*state0 == UTF8_REJECT)
212+ ret -=1;
213+ return ret;
214+}
215+
216+/*
217+ * Helper to decode buffer and discard final decoder state
218+ */
219+const uint8_t *
220+_hs_text_decode_utf8(uint16_t *const dest, size_t *destoff,
221+ const uint8_t *src, const uint8_t *const srcend)
222+{
223+ uint32_t codepoint;
224+ uint32_t state = UTF8_ACCEPT;
225+ uint8_t const *ret = _hs_text_decode_utf8_int(dest, destoff, &src, srcend,
226+ &codepoint, &state);
227+ /* Back up if we have an incomplete or invalid encoding */
228+ if (state != UTF8_ACCEPT)
229+ ret -= 1;
230+ return ret;
231+}
232+
233+void
234+_hs_text_encode_utf8(uint8_t **destp, const uint16_t *src, size_t srcoff,
235+ size_t srclen)
236+{
237+ const uint16_t *srcend;
238+ uint8_t *dest = *destp;
239+
240+ src += srcoff;
241+ srcend = src + srclen;
242+
243+ ascii:
244+#if defined(__x86_64__)
245+ while (srcend - src >= 4) {
246+ uint64_t w = *((uint64_t *) src);
247+
248+ if (w & 0xFF80FF80FF80FF80ULL) {
249+ if (!(w & 0x000000000000FF80ULL)) {
250+ *dest++ = w & 0xFFFF;
251+ src++;
252+ if (!(w & 0x00000000FF800000ULL)) {
253+ *dest++ = (w >> 16) & 0xFFFF;
254+ src++;
255+ if (!(w & 0x0000FF8000000000ULL)) {
256+ *dest++ = (w >> 32) & 0xFFFF;
257+ src++;
258+ }
259+ }
260+ }
261+ break;
262+ }
263+ *dest++ = w & 0xFFFF;
264+ *dest++ = (w >> 16) & 0xFFFF;
265+ *dest++ = (w >> 32) & 0xFFFF;
266+ *dest++ = w >> 48;
267+ src += 4;
268+ }
269+#endif
270+
271+#if defined(__i386__)
272+ while (srcend - src >= 2) {
273+ uint32_t w = *((uint32_t *) src);
274+
275+ if (w & 0xFF80FF80)
276+ break;
277+ *dest++ = w & 0xFFFF;
278+ *dest++ = w >> 16;
279+ src += 2;
280+ }
281+#endif
282+
283+ while (src < srcend) {
284+ uint16_t w = *src++;
285+
286+ if (w <= 0x7F) {
287+ *dest++ = w;
288+ /* An ASCII byte is likely to begin a run of ASCII bytes.
289+ Falling back into the fast path really helps performance. */
290+ goto ascii;
291+ }
292+ else if (w <= 0x7FF) {
293+ *dest++ = (w >> 6) | 0xC0;
294+ *dest++ = (w & 0x3f) | 0x80;
295+ }
296+ else if (w < 0xD800 || w > 0xDBFF) {
297+ *dest++ = (w >> 12) | 0xE0;
298+ *dest++ = ((w >> 6) & 0x3F) | 0x80;
299+ *dest++ = (w & 0x3F) | 0x80;
300+ } else {
301+ uint32_t c = ((((uint32_t) w) - 0xD800) << 10) +
302+ (((uint32_t) *src++) - 0xDC00) + 0x10000;
303+ *dest++ = (c >> 18) | 0xF0;
304+ *dest++ = ((c >> 12) & 0x3F) | 0x80;
305+ *dest++ = ((c >> 6) & 0x3F) | 0x80;
306+ *dest++ = (c & 0x3F) | 0x80;
307+ }
308+ }
309+
310+ *destp = dest;
311+}
changelog.mdnew file+164
@@ -0,0 +1,164 @@
1+1.2.2.1
2+
3+* The switch to `integer-pure` in 1.2.2.0 was apparently mistaken.
4+ The build flag has been renamed accordingly. Your army of diligent
5+ maintainers apologizes for the churn.
6+
7+* Spec compliance: toCaseFold now follows the Unicode 8.0 spec
8+ (updated from 7.0)
9+
10+* An STG lint error has been fixed
11+
12+1.2.2.0
13+
14+* The `integer-simple` package, upon which this package optionally
15+ depended, has been replaced with `integer-pure`. The build flag has
16+ been renamed accordingly.
17+
18+* Bug fix: For the `Binary` instance, If UTF-8 decoding fails during a
19+ `get`, the error is propagated via `fail` instead of an uncatchable
20+ crash.
21+
22+* New function: `takeWhileEnd`
23+
24+* New instances for the `Text` types:
25+ * if `base` >= 4.7: `PrintfArg`
26+ * if `base` >= 4.9: `Semigroup`
27+
28+1.2.1.3
29+
30+* Bug fix: As it turns out, moving the literal rewrite rules to simplifier
31+ phase 2 does not prevent competition with the `unpack` rule, which is
32+ also active in this phase. Unfortunately this was hidden due to a silly
33+ test environment mistake. Moving literal rules back to phase 1 finally
34+ fixes GHC Trac #10528 correctly.
35+
36+1.2.1.2
37+
38+* Bug fix: Run literal rewrite rules in simplifier phase 2.
39+ The behavior of the simplifier changed in GHC 7.10.2,
40+ causing these rules to fail to fire, leading to poor code generation
41+ and long compilation times. See
42+ [GHC Trac #10528](https://ghc.haskell.org/trac/ghc/ticket/10528).
43+
44+1.2.1.1
45+
46+* Expose unpackCString#, which you should never use.
47+
48+1.2.1.0
49+
50+* Added Binary instances for both Text types. (If you have previously
51+ been using the text-binary package to get a Binary instance, it is
52+ now obsolete.)
53+
54+1.2.0.6
55+
56+* Fixed a space leak in UTF-8 decoding
57+
58+1.2.0.5
59+
60+* Feature parity: repeat, cycle, iterate are now implemented for lazy
61+ Text, and the Data instance is more complete
62+
63+* Build speed: an inliner space explosion has been fixed with toCaseFold
64+
65+* Bug fix: encoding Int to a Builder would infinite-loop if the
66+ integer-simple package was used
67+
68+* Deprecation: OnEncodeError and EncodeError are deprecated, as they
69+ are never used
70+
71+* Internals: some types that are used internally in fusion-related
72+ functions have moved around, been renamed, or been deleted (we don't
73+ bump the major version if .Internal modules change)
74+
75+* Spec compliance: toCaseFold now follows the Unicode 7.0 spec
76+ (updated from 6.3)
77+
78+1.2.0.4
79+
80+* Fixed an incompatibility with base < 4.5
81+
82+1.2.0.3
83+
84+* Update formatRealFloat to correspond to the definition in versions
85+ of base newer than 4.5 (https://github.com/bos/text/issues/105)
86+
87+1.2.0.2
88+
89+* Bumped lower bound on deepseq to 1.4 for compatibility with the
90+ upcoming GHC 7.10
91+
92+1.2.0.1
93+
94+* Fixed a buffer overflow in rendering of large Integers
95+ (https://github.com/bos/text/issues/99)
96+
97+1.2.0.0
98+
99+* Fixed an integer overflow in the replace function
100+ (https://github.com/bos/text/issues/81)
101+
102+* Fixed a hang in lazy decodeUtf8With
103+ (https://github.com/bos/text/issues/87)
104+
105+* Reduced codegen bloat caused by use of empty and single-character
106+ literals
107+
108+* Added an instance of IsList for GHC 7.8 and above
109+
110+1.1.1.0
111+
112+* The Data.Data instance now allows gunfold to work, via a virtual
113+ pack constructor
114+
115+* dropEnd, takeEnd: new functions
116+
117+* Comparing the length of a Text against a number can now
118+ short-circuit in more cases
119+
120+1.1.0.1
121+
122+* streamDecodeUtf8: fixed gh-70, did not return all unconsumed bytes
123+ in single-byte chunks
124+
125+1.1.0.0
126+
127+* encodeUtf8: Performance is improved by up to 4x.
128+
129+* encodeUtf8Builder, encodeUtf8BuilderEscaped: new functions,
130+ available only if bytestring >= 0.10.4.0 is installed, that allow
131+ very fast and flexible encoding of a Text value to a bytestring
132+ Builder.
133+
134+ As an example of the performance gain to be had, the
135+ encodeUtf8BuilderEscaped function helps to double the speed of JSON
136+ encoding in the latest version of aeson! (Note: if all you need is a
137+ plain ByteString, encodeUtf8 is still the faster way to go.)
138+
139+* All of the internal module hierarchy is now publicly exposed. If a
140+ module is in the .Internal hierarchy, or is documented as internal,
141+ use at your own risk - there are no API stability guarantees for
142+ internal modules!
143+
144+1.0.0.1
145+
146+* decodeUtf8: Fixed a regression that caused us to incorrectly
147+ identify truncated UTF-8 as valid (gh-61)
148+
149+1.0.0.0
150+
151+* Added support for Unicode 6.3.0 to case conversion functions
152+
153+* New function toTitle converts words in a string to title case
154+
155+* New functions peekCStringLen and withCStringLen simplify
156+ interoperability with C functionns
157+
158+* Added support for decoding UTF-8 in stream-friendly fashion
159+
160+* Fixed a bug in mapAccumL
161+
162+* Added trusted Haskell support
163+
164+* Removed support for GHC 6.10 (released in 2008) and older
include/text_cbits.hnew file+11
@@ -0,0 +1,11 @@
1+/*
2+ * Copyright (c) 2013 Bryan O'Sullivan <bos@serpentine.com>.
3+ */
4+
5+#ifndef _text_cbits_h
6+#define _text_cbits_h
7+
8+#define UTF8_ACCEPT 0
9+#define UTF8_REJECT 12
10+
11+#endif
scripts/Arsec.hs+4−9
@@ -1,6 +1,7 @@
11module Arsec
22 (
3− comment
3+ Comment
4+ , comment
45 , semi
56 , showC
67 , unichar
@@ -23,13 +24,7 @@ import Text.ParserCombinators.Parsec.Combinator hiding (optional)
2324import Text.ParserCombinators.Parsec.Error
2425import Text.ParserCombinators.Parsec.Prim hiding ((<|>), many)
2526
26−instance Applicative (GenParser s a) where
27− pure = return
28− (<*>) = ap
29−
30−instance Alternative (GenParser s a) where
31− empty = mzero
32− (<|>) = mplus
27+type Comment = String
3328
3429unichar :: Parser Char
3530unichar = chr . fst . head . readHex <$> many1 hexDigit
@@ -40,7 +35,7 @@ unichars = manyTill (unichar <* spaces) semi
4035semi :: Parser ()
4136semi = char ';' *> spaces *> pure ()
4237
43−comment :: Parser String
38+comment :: Parser Comment
4439comment = (char '#' *> manyTill anyToken (char '\n')) <|> string "\n"
4540
4641showC :: Char -> String
scripts/CaseFolding.hs+11−7
@@ -4,7 +4,8 @@
44
55module CaseFolding
66 (
7− Fold(..)
7+ CaseFolding(..)
8+ , Fold(..)
89 , parseCF
910 , mapCF
1011 ) where
@@ -18,22 +19,25 @@ data Fold = Fold {
1819 , name :: String
1920 } deriving (Eq, Ord, Show)
2021
21−entries :: Parser [Fold]
22−entries = many comment *> many (entry <* many comment)
22+data CaseFolding = CF { cfComments :: [Comment], cfFolding :: [Fold] }
23+ deriving (Show)
24+
25+entries :: Parser CaseFolding
26+entries = CF <$> many comment <*> many (entry <* many comment)
2327 where
2428 entry = Fold <$> unichar <* semi
2529 <*> oneOf "CFST" <* semi
2630 <*> unichars
2731 <*> (string "# " *> manyTill anyToken (char '\n'))
2832
29−parseCF :: FilePath -> IO (Either ParseError [Fold])
33+parseCF :: FilePath -> IO (Either ParseError CaseFolding)
3034parseCF name = parse entries name <$> readFile name
3135
32−mapCF :: [Fold] -> [String]
33−mapCF ms = typ ++ (map nice . filter p $ ms) ++ [last]
36+mapCF :: CaseFolding -> [String]
37+mapCF (CF _ ms) = typ ++ (map nice . filter p $ ms) ++ [last]
3438 where
3539 typ = ["foldMapping :: forall s. Char -> s -> Step (CC s) Char"
36− ,"{-# INLINE foldMapping #-}"]
40+ ,"{-# NOINLINE foldMapping #-}"]
3741 last = "foldMapping c s = Yield (toLower c) (CC s '\\0' '\\0')"
3842 nice c = "-- " ++ name c ++ "\n" ++
3943 "foldMapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
scripts/CaseMapping.hs+11−5
@@ -8,7 +8,7 @@ import SpecialCasing
88main = do
99 args <- getArgs
1010 let oname = case args of
11− [] -> "../Data/Text/Fusion/CaseMapping.hs"
11+ [] -> "../Data/Text/Internal/Fusion/CaseMapping.hs"
1212 [o] -> o
1313 psc <- parseSC "SpecialCasing.txt"
1414 pcf <- parseCF "CaseFolding.txt"
@@ -19,14 +19,20 @@ main = do
1919 Left err -> print err >> return undefined
2020 Right ms -> return ms
2121 h <- openFile oname WriteMode
22− mapM_ (hPutStrLn h) ["{-# LANGUAGE Rank2Types #-}"
22+ let comments = map ("--" ++) $
23+ take 2 (cfComments cfs) ++ take 2 (scComments scs)
24+ mapM_ (hPutStrLn h) $
25+ ["{-# LANGUAGE Rank2Types #-}"
2326 ,"-- AUTOMATICALLY GENERATED - DO NOT EDIT"
24− ,"-- Generated by scripts/SpecialCasing.hs"
25− ,"module Data.Text.Fusion.CaseMapping where"
27+ ,"-- Generated by scripts/CaseMapping.hs"] ++
28+ comments ++
29+ [""
30+ ,"module Data.Text.Internal.Fusion.CaseMapping where"
2631 ,"import Data.Char"
27− ,"import Data.Text.Fusion.Internal"
32+ ,"import Data.Text.Internal.Fusion.Types"
2833 ,""]
2934 mapM_ (hPutStrLn h) (mapSC "upper" upper toUpper scs)
3035 mapM_ (hPutStrLn h) (mapSC "lower" lower toLower scs)
36+ mapM_ (hPutStrLn h) (mapSC "title" title toTitle scs)
3137 mapM_ (hPutStrLn h) (mapCF cfs)
3238 hClose h
scripts/SpecialCasing.hs+13−7
@@ -4,13 +4,17 @@
44
55module SpecialCasing
66 (
7− Case(..)
7+ SpecialCasing(..)
8+ , Case(..)
89 , parseSC
910 , mapSC
1011 ) where
1112
1213import Arsec
1314
15+data SpecialCasing = SC { scComments :: [Comment], scCasing :: [Case] }
16+ deriving (Show)
17+
1418data Case = Case {
1519 code :: Char
1620 , lower :: [Char]
@@ -20,8 +24,8 @@ data Case = Case {
2024 , name :: String
2125 } deriving (Eq, Ord, Show)
2226
23−entries :: Parser [Case]
24−entries = many comment *> many (entry <* many comment)
27+entries :: Parser SpecialCasing
28+entries = SC <$> many comment <*> many (entry <* many comment)
2529 where
2630 entry = Case <$> unichar <* semi
2731 <*> unichars
@@ -30,14 +34,16 @@ entries = many comment *> many (entry <* many comment)
3034 <*> manyTill anyToken (string "# ")
3135 <*> manyTill anyToken (char '\n')
3236
33−parseSC :: FilePath -> IO (Either ParseError [Case])
37+parseSC :: FilePath -> IO (Either ParseError SpecialCasing)
3438parseSC name = parse entries name <$> readFile name
3539
36−mapSC :: String -> (Case -> String) -> (Char -> Char) -> [Case] -> [String]
37−mapSC which access twiddle ms = typ ++ (map nice . filter p $ ms) ++ [last]
40+mapSC :: String -> (Case -> String) -> (Char -> Char) -> SpecialCasing
41+ -> [String]
42+mapSC which access twiddle (SC _ ms) =
43+ typ ++ (map nice . filter p $ ms) ++ [last]
3844 where
3945 typ = [which ++ "Mapping :: forall s. Char -> s -> Step (CC s) Char"
40− ,"{-# INLINE " ++ which ++ "Mapping #-}"]
46+ ,"{-# NOINLINE " ++ which ++ "Mapping #-}"]
4147 last = which ++ "Mapping c s = Yield (to" ++ ucFirst which ++ " c) (CC s '\\0' '\\0')"
4248 nice c = "-- " ++ name c ++ "\n" ++
4349 which ++ "Mapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
tests-and-benchmarks.markdownnew file+63
@@ -0,0 +1,63 @@
1+Tests and benchmarks
2+====================
3+
4+Prerequisites
5+-------------
6+
7+To run the tests and benchmarks, you will need the test data, which
8+you can clone from one of the following locations:
9+
10+* Mercurial master repository:
11+ [bitbucket.org/bos/text-test-data](https://bitbucket.org/bos/text-test-data)
12+
13+* Git mirror repository:
14+ [github.com/bos/text-test-data](https://github.com/bos/text-test-data)
15+
16+You should clone that repository into the `tests` subdirectory (your
17+clone must be named `text-test-data` locally), then run `make -C
18+tests/text-test-data` to uncompress the test files. Many tests and
19+benchmarks will fail if the test files are missing.
20+
21+Functional tests
22+----------------
23+
24+The functional tests are located in the `tests` subdirectory. An overview of
25+what's in that directory:
26+
27+ Makefile Has targets for common tasks
28+ Tests Source files of the testing code
29+ scripts Various utility scripts
30+ text-tests.cabal Cabal file that compiles all benchmarks
31+
32+The `text-tests.cabal` builds:
33+
34+- A copy of the text library, sharing the source code, but exposing all internal
35+ modules, for testing purposes
36+- The different test suites
37+
38+To compile, run all tests, and generate a coverage report, simply use `make`.
39+
40+Benchmarks
41+----------
42+
43+The benchmarks are located in the `benchmarks` subdirectory. An overview of
44+what's in that directory:
45+
46+ Makefile Has targets for common tasks
47+ haskell Source files of the haskell benchmarks
48+ python Python implementations of some benchmarks
49+ ruby Ruby implementations of some benchmarks
50+ text-benchmarks.cabal Cabal file which compiles all benchmarks
51+
52+To compile the benchmarks, navigate to the `benchmarks` subdirectory and run
53+`cabal configure && cabal build`. Then, you can run the benchmarks using:
54+
55+ ./dist/build/text-benchmarks/text-benchmarks
56+
57+However, since there's quite a lot of benchmarks, you usually don't want to
58+run them all. Instead, use the `-l` flag to get a list of benchmarks:
59+
60+ ./dist/build/text-benchmarks/text-benchmarks
61+
62+And run the ones you want to inspect. If you want to configure the benchmarks
63+further, the exact parameters can be changed in `Benchmarks.hs`.
tests/.ghcinew file+1
@@ -0,0 +1 @@
1+:set -DHAVE_DEEPSEQ -isrc -i../..
tests/Benchmarks.hsdeleted−463
@@ -1,463 +0,0 @@
1−{-# LANGUAGE BangPatterns, GADTs, MagicHash #-}
2−
3−import qualified Data.ByteString.Char8 as BS
4−import qualified Data.ByteString.Lazy.Char8 as BL
5−import qualified Data.ByteString.Lazy.Internal as BL
6−import Control.Monad.Trans (liftIO)
7−import Control.Exception (evaluate)
8−import Criterion.Main
9−import Data.Char
10−import Data.Monoid (mappend, mempty)
11−import qualified Data.ByteString.UTF8 as UTF8
12−import qualified Data.Text as TS
13−import qualified Data.Text.IO as TS
14−import qualified Data.Text.Lazy as TL
15−import qualified Data.Text.Lazy.Builder as TB
16−import qualified Data.Text.Lazy.IO as TL
17−import qualified Data.List as L
18−import qualified Data.Text.Encoding as TS
19−import qualified Data.Text.Lazy.Encoding as TL
20−import qualified Criterion.MultiMap as M
21−import Control.DeepSeq
22−import Criterion.Config
23−import GHC.Base
24−
25−
26−myConfig
27− | False = defaultConfig {
28− -- Always display an 800x600 window.
29− cfgPlot = M.singleton KernelDensity (Window 800 600)
30− }
31− | otherwise = defaultConfig
32−
33−instance NFData BS.ByteString
34−
35−instance NFData BL.ByteString where
36− rnf BL.Empty = ()
37− rnf (BL.Chunk _ ts) = rnf ts
38−
39−data B where
40− B :: NFData a => a -> B
41−
42−instance NFData B where
43− rnf (B b) = rnf b
44−
45−main = do
46− let dataFile = "text/test/russian.txt"
47− bsa <- BS.readFile dataFile
48− let tsa = TS.decodeUtf8 bsa
49− tsb = TS.toUpper tsa
50− tla = TL.fromChunks (TS.chunksOf 16376 tsa)
51− tlb = TL.fromChunks (TS.chunksOf 16376 tsb)
52− bsb = TS.encodeUtf8 tsb
53− bla = BL.fromChunks (chunksOf 16376 bsa)
54− blb = BL.fromChunks (chunksOf 16376 bsb)
55− bsa_len = BS.length bsa
56− tsa_len = TS.length tsa
57− bla_len = BL.length bla
58− tla_len = TL.length tla
59− la = UTF8.toString bsa
60− la_len = L.length la
61− tsb_len = TS.length tsb
62− lb = TS.unpack tsb
63− bsl = BS.lines bsa
64− bll = BL.lines bla
65− tsl = TS.lines tsa
66− tll = TL.lines tla
67− ll = L.lines la
68− defaultMainWith
69− myConfig
70− (liftIO . evaluate $
71− rnf [B tsa, B tsb, B tla, B tlb, B bsa, B bsb, B bla, B blb,
72− B bsa_len, B tsa_len, B bla_len, B tla_len, B la, B la_len,
73− B tsb_len, B lb, B bsl, B bll, B tsl, B tll, B ll])
74− [
75− bgroup "append" [
76− bench "ts" $ nf (TS.append tsb) tsa
77− , bench "tl" $ nf (TL.append tlb) tla
78− , bench "bs" $ nf (BS.append bsb) bsa
79− , bench "bl" $ nf (BL.append blb) bla
80− , bench "l" $ nf ((++) lb) la
81− ],
82− bgroup "concat" [
83− bench "ts" $ nf TS.concat tsl
84− , bench "tl" $ nf TL.concat tll
85− , bench "bs" $ nf BS.concat bsl
86− , bench "bl" $ nf BL.concat bll
87− , bench "l" $ nf L.concat ll
88− ],
89− bgroup "cons" [
90− bench "ts" $ nf (TS.cons c) tsa
91− , bench "tl" $ nf (TL.cons c) tla
92− , bench "bs" $ nf (BS.cons c) bsa
93− , bench "bl" $ nf (BL.cons c) bla
94− , bench "l" $ nf (c:) la
95− ],
96− bgroup "concatMap" [
97− bench "ts" $ nf (TS.concatMap (TS.replicate 3 . TS.singleton)) tsa
98− , bench "tl" $ nf (TL.concatMap (TL.replicate 3 . TL.singleton)) tla
99− , bench "bs" $ nf (BS.concatMap (BS.replicate 3)) bsa
100− , bench "bl" $ nf (BL.concatMap (BL.replicate 3)) bla
101− , bench "l" $ nf (L.concatMap (L.replicate 3 . (:[]))) la
102− ],
103− bgroup "decode" [
104− bench "ts" $ nf TS.decodeUtf8 bsa
105− , bench "tl" $ nf TL.decodeUtf8 bla
106− , bench "bs" $ nf BS.unpack bsa
107− , bench "bl" $ nf BL.unpack bla
108− , bench "l" $ nf UTF8.toString bsa
109− ],
110− bgroup "drop" [
111− bench "ts" $ nf (TS.drop (tsa_len `div` 3)) tsa
112− , bench "tl" $ nf (TL.drop (tla_len `div` 3)) tla
113− , bench "bs" $ nf (BS.drop (bsa_len `div` 3)) bsa
114− , bench "bl" $ nf (BL.drop (bla_len `div` 3)) bla
115− , bench "l" $ nf (L.drop (la_len `div` 3)) la
116− ],
117− bgroup "encode" [
118− bench "ts" $ nf TS.encodeUtf8 tsa
119− , bench "tl" $ nf TL.encodeUtf8 tla
120− , bench "bs" $ nf BS.pack la
121− , bench "bl" $ nf BL.pack la
122− , bench "l" $ nf UTF8.fromString la
123− ],
124− bgroup "filter" [
125− bench "ts" $ nf (TS.filter p0) tsa
126− , bench "tl" $ nf (TL.filter p0) tla
127− , bench "bs" $ nf (BS.filter p0) bsa
128− , bench "bl" $ nf (BL.filter p0) bla
129− , bench "l" $ nf (L.filter p0) la
130− ],
131− bgroup "filter.filter" [
132− bench "ts" $ nf (TS.filter p1 . TS.filter p0) tsa
133− , bench "tl" $ nf (TL.filter p1 . TL.filter p0) tla
134− , bench "bs" $ nf (BS.filter p1 . BS.filter p0) bsa
135− , bench "bl" $ nf (BL.filter p1 . BL.filter p0) bla
136− , bench "l" $ nf (L.filter p1 . L.filter p0) la
137− ],
138− bgroup "foldl'" [
139− bench "ts" $ nf (TS.foldl' len 0) tsa
140− , bench "tl" $ nf (TL.foldl' len 0) tla
141− , bench "bs" $ nf (BS.foldl' len 0) bsa
142− , bench "bl" $ nf (BL.foldl' len 0) bla
143− , bench "l" $ nf (L.foldl' len 0) la
144− ],
145− bgroup "foldr" [
146− bench "ts" $ nf (L.length . TS.foldr (:) []) tsa
147− , bench "tl" $ nf (L.length . TL.foldr (:) []) tla
148− , bench "bs" $ nf (L.length . BS.foldr (:) []) bsa
149− , bench "bl" $ nf (L.length . BL.foldr (:) []) bla
150− , bench "l" $ nf (L.length . L.foldr (:) []) la
151− ],
152− bgroup "head" [
153− bench "ts" $ nf TS.head tsa
154− , bench "tl" $ nf TL.head tla
155− , bench "bs" $ nf BS.head bsa
156− , bench "bl" $ nf BL.head bla
157− , bench "l" $ nf L.head la
158− ],
159− bgroup "init" [
160− bench "ts" $ nf TS.init tsa
161− , bench "tl" $ nf TL.init tla
162− , bench "bs" $ nf BS.init bsa
163− , bench "bl" $ nf BL.init bla
164− , bench "l" $ nf L.init la
165− ],
166− bgroup "intercalate" [
167− bench "ts" $ nf (TS.intercalate tsw) tsl
168− , bench "tl" $ nf (TL.intercalate tlw) tll
169− , bench "bs" $ nf (BS.intercalate bsw) bsl
170− , bench "bl" $ nf (BL.intercalate blw) bll
171− , bench "l" $ nf (L.intercalate lw) ll
172− ],
173− bgroup "intersperse" [
174− bench "ts" $ nf (TS.intersperse c) tsa
175− , bench "tl" $ nf (TL.intersperse c) tla
176− , bench "bs" $ nf (BS.intersperse c) bsa
177− , bench "bl" $ nf (BL.intersperse c) bla
178− , bench "l" $ nf (L.intersperse c) la
179− ],
180− bgroup "isInfixOf" [
181− bench "ts" $ nf (TS.isInfixOf tsw) tsa
182− , bench "tl" $ nf (TL.isInfixOf tlw) tla
183− , bench "bs" $ nf (BS.isInfixOf bsw) bsa
184− -- no isInfixOf for lazy bytestrings
185− , bench "l" $ nf (L.isInfixOf lw) la
186− ],
187− bgroup "last" [
188− bench "ts" $ nf TS.last tsa
189− , bench "tl" $ nf TL.last tla
190− , bench "bs" $ nf BS.last bsa
191− , bench "bl" $ nf BL.last bla
192− , bench "l" $ nf L.last la
193− ],
194− bgroup "map" [
195− bench "ts" $ nf (TS.map f) tsa
196− , bench "tl" $ nf (TL.map f) tla
197− , bench "bs" $ nf (BS.map f) bsa
198− , bench "bl" $ nf (BL.map f) bla
199− , bench "l" $ nf (L.map f) la
200− ],
201− bgroup "mapAccumL" [
202− bench "ts" $ nf (TS.mapAccumL g 0) tsa
203− , bench "tl" $ nf (TL.mapAccumL g 0) tla
204− , bench "bs" $ nf (BS.mapAccumL g 0) bsa
205− , bench "bl" $ nf (BL.mapAccumL g 0) bla
206− , bench "l" $ nf (L.mapAccumL g 0) la
207− ],
208− bgroup "mapAccumR" [
209− bench "ts" $ nf (TS.mapAccumR g 0) tsa
210− , bench "tl" $ nf (TL.mapAccumR g 0) tla
211− , bench "bs" $ nf (BS.mapAccumR g 0) bsa
212− , bench "bl" $ nf (BL.mapAccumR g 0) bla
213− , bench "l" $ nf (L.mapAccumR g 0) la
214− ],
215− bgroup "map.map" [
216− bench "ts" $ nf (TS.map f . TS.map f) tsa
217− , bench "tl" $ nf (TL.map f . TL.map f) tla
218− , bench "bs" $ nf (BS.map f . BS.map f) bsa
219− , bench "bl" $ nf (BL.map f . BL.map f) bla
220− , bench "l" $ nf (L.map f . L.map f) la
221− ],
222− bgroup "readFile" [
223− bench "ts" $ TS.readFile dataFile
224− , bench "tl" $ nfIO (TL.readFile dataFile)
225− , bench "bs" $ BS.readFile dataFile
226− , bench "bl" $ nfIO (BL.length `fmap` BL.readFile dataFile)
227− , bench "l" $ nfIO (length `fmap` readFile dataFile)
228− ],
229− bgroup "replicate char" [
230− bench "ts" $ nf (TS.replicate bsa_len) (TS.singleton c)
231− , bench "tl" $ nf (TL.replicate (fromIntegral bsa_len)) (TL.singleton c)
232− , bench "bs" $ nf (BS.replicate bsa_len) c
233− , bench "bl" $ nf (BL.replicate (fromIntegral bsa_len)) c
234− , bench "l" $ nf (L.replicate bsa_len) c
235− ],
236− bgroup "replicate string" [
237− bench "ts" $ nf (TS.replicate (bsa_len `div` TS.length tsw)) tsw
238− , bench "tl" $ nf (TL.replicate (fromIntegral bsa_len `div` TL.length tlw)) tlw
239− , bench "l" $ nf (replicat (bsa_len `div` TS.length tsw)) lw
240− ],
241− bgroup "reverse" [
242− bench "ts" $ nf TS.reverse tsa
243− , bench "tl" $ nf TL.reverse tla
244− , bench "bs" $ nf BS.reverse bsa
245− , bench "bl" $ nf BL.reverse bla
246− , bench "l" $ nf L.reverse la
247− ],
248− bgroup "take" [
249− bench "ts" $ nf (TS.take (tsa_len `div` 3)) tsa
250− , bench "tl" $ nf (TL.take (tla_len `div` 3)) tla
251− , bench "bs" $ nf (BS.take (bsa_len `div` 3)) bsa
252− , bench "bl" $ nf (BL.take (bla_len `div` 3)) bla
253− , bench "l" $ nf (L.take (la_len `div` 3)) la
254− ],
255− bgroup "tail" [
256− bench "ts" $ nf TS.tail tsa
257− , bench "tl" $ nf TL.tail tla
258− , bench "bs" $ nf BS.tail bsa
259− , bench "bl" $ nf BL.tail bla
260− , bench "l" $ nf L.tail la
261− ],
262− bgroup "toLower" [
263− bench "ts" $ nf TS.toLower tsa
264− , bench "tl" $ nf TL.toLower tla
265− , bench "bs" $ nf (BS.map toLower) bsa
266− , bench "bl" $ nf (BL.map toLower) bla
267− , bench "l" $ nf (L.map toLower) la
268− ],
269− bgroup "toUpper" [
270− bench "ts" $ nf TS.toUpper tsa
271− , bench "tl" $ nf TL.toUpper tla
272− , bench "bs" $ nf (BS.map toUpper) bsa
273− , bench "bl" $ nf (BL.map toUpper) bla
274− , bench "l" $ nf (L.map toUpper) la
275− ],
276− bgroup "words" [
277− bench "ts" $ nf TS.words tsa
278− , bench "tl" $ nf TL.words tla
279− , bench "bs" $ nf BS.words bsa
280− , bench "bl" $ nf BL.words bla
281− , bench "l" $ nf L.words la
282− ],
283− bgroup "zipWith" [
284− bench "ts" $ nf (TS.zipWith min tsb) tsa
285− , bench "tl" $ nf (TL.zipWith min tlb) tla
286− , bench "bs" $ nf (BS.zipWith min bsb) bsa
287− , bench "bl" $ nf (BL.zipWith min blb) bla
288− , bench "l" $ nf (L.zipWith min lb) la
289− ],
290− bgroup "length" [
291− bgroup "cons" [
292− bench "ts" $ nf (TS.length . TS.cons c) tsa
293− , bench "tl" $ nf (TL.length . TL.cons c) tla
294− , bench "bs" $ nf (BS.length . BS.cons c) bsa
295− , bench "bl" $ nf (BL.length . BL.cons c) bla
296− , bench "l" $ nf (L.length . (:) c) la
297− ],
298− bgroup "decode" [
299− bench "ts" $ nf (TS.length . TS.decodeUtf8) bsa
300− , bench "tl" $ nf (TL.length . TL.decodeUtf8) bla
301− , bench "bs" $ nf (L.length . BS.unpack) bsa
302− , bench "bl" $ nf (L.length . BL.unpack) bla
303− , bench "utf8-string" $ nf (L.length . UTF8.toString) bsa
304− ],
305− bgroup "drop" [
306− bench "ts" $ nf (TS.length . TS.drop (tsa_len `div` 3)) tsa
307− , bench "tl" $ nf (TL.length . TL.drop (tla_len `div` 3)) tla
308− , bench "bs" $ nf (BS.length . BS.drop (bsa_len `div` 3)) bsa
309− , bench "bl" $ nf (BL.length . BL.drop (bla_len `div` 3)) bla
310− , bench "l" $ nf (L.length . L.drop (la_len `div` 3)) la
311− ],
312− bgroup "filter" [
313− bench "ts" $ nf (TS.length . TS.filter p0) tsa
314− , bench "tl" $ nf (TL.length . TL.filter p0) tla
315− , bench "bs" $ nf (BS.length . BS.filter p0) bsa
316− , bench "bl" $ nf (BL.length . BL.filter p0) bla
317− , bench "l" $ nf (L.length . L.filter p0) la
318− ],
319− bgroup "filter.filter" [
320− bench "ts" $ nf (TS.length . TS.filter p1 . TS.filter p0) tsa
321− , bench "tl" $ nf (TL.length . TL.filter p1 . TL.filter p0) tla
322− , bench "bs" $ nf (BS.length . BS.filter p1 . BS.filter p0) bsa
323− , bench "bl" $ nf (BL.length . BL.filter p1 . BL.filter p0) bla
324− , bench "l" $ nf (L.length . L.filter p1 . L.filter p0) la
325− ],
326− bgroup "init" [
327− bench "ts" $ nf (TS.length . TS.init) tsa
328− , bench "tl" $ nf (TL.length . TL.init) tla
329− , bench "bs" $ nf (BS.length . BS.init) bsa
330− , bench "bl" $ nf (BL.length . BL.init) bla
331− , bench "l" $ nf (L.length . L.init) la
332− ],
333− bgroup "intercalate" [
334− bench "ts" $ nf (TS.length . TS.intercalate tsw) tsl
335− , bench "tl" $ nf (TL.length . TL.intercalate tlw) tll
336− , bench "bs" $ nf (BS.length . BS.intercalate bsw) bsl
337− , bench "bl" $ nf (BL.length . BL.intercalate blw) bll
338− , bench "l" $ nf (L.length . L.intercalate lw) ll
339− ],
340− bgroup "intersperse" [
341− bench "ts" $ nf (TS.length . TS.intersperse c) tsa
342− , bench "tl" $ nf (TL.length . TL.intersperse c) tla
343− , bench "bs" $ nf (BS.length . BS.intersperse c) bsa
344− , bench "bl" $ nf (BL.length . BL.intersperse c) bla
345− , bench "l" $ nf (L.length . L.intersperse c) la
346− ],
347− bgroup "map" [
348− bench "ts" $ nf (TS.length . TS.map f) tsa
349− , bench "tl" $ nf (TL.length . TL.map f) tla
350− , bench "bs" $ nf (BS.length . BS.map f) bsa
351− , bench "bl" $ nf (BL.length . BL.map f) bla
352− , bench "l" $ nf (L.length . L.map f) la
353− ],
354− bgroup "map.map" [
355− bench "ts" $ nf (TS.length . TS.map f . TS.map f) tsa
356− , bench "tl" $ nf (TL.length . TL.map f . TL.map f) tla
357− , bench "bs" $ nf (BS.length . BS.map f . BS.map f) bsa
358− , bench "l" $ nf (L.length . L.map f . L.map f) la
359− ],
360− bgroup "replicate char" [
361− bench "ts" $ nf (TS.length . TS.replicate bsa_len) (TS.singleton c)
362− , bench "tl" $ nf (TL.length . TL.replicate (fromIntegral bsa_len)) (TL.singleton c)
363− , bench "bs" $ nf (BS.length . BS.replicate bsa_len) c
364− , bench "bl" $ nf (BL.length . BL.replicate (fromIntegral bsa_len)) c
365− , bench "l" $ nf (L.length . L.replicate bsa_len) c
366− ],
367− bgroup "replicate string" [
368− bench "ts" $ nf (TS.length . TS.replicate (bsa_len `div` TS.length tsw)) tsw
369− , bench "tl" $ nf (TL.length . TL.replicate (fromIntegral bsa_len `div` TL.length tlw)) tlw
370− , bench "l" $ nf (L.length . replicat (bsa_len `div` TS.length tsw)) lw
371− ],
372− bgroup "take" [
373− bench "ts" $ nf (TS.length . TS.take (tsa_len `div` 3)) tsa
374− , bench "tl" $ nf (TL.length . TL.take (tla_len `div` 3)) tla
375− , bench "bs" $ nf (BS.length . BS.take (bsa_len `div` 3)) bsa
376− , bench "bl" $ nf (BL.length . BL.take (bla_len `div` 3)) bla
377− , bench "l" $ nf (L.length . L.take (la_len `div` 3)) la
378− ],
379− bgroup "tail" [
380− bench "ts" $ nf (TS.length . TS.tail) tsa
381− , bench "tl" $ nf (TL.length . TL.tail) tla
382− , bench "bs" $ nf (BS.length . BS.tail) bsa
383− , bench "bl" $ nf (BL.length . BL.tail) bla
384− , bench "l" $ nf (L.length . L.tail) la
385− ],
386− bgroup "toLower" [
387− bench "ts" $ nf (TS.length . TS.toLower) tsa
388− , bench "tl" $ nf (TL.length . TL.toLower) tla
389− , bench "bs" $ nf (BS.length . BS.map toLower) bsa
390− , bench "bl" $ nf (BL.length . BL.map toLower) bla
391− , bench "l" $ nf (L.length . L.map toLower) la
392− ],
393− bgroup "toUpper" [
394− bench "ts" $ nf (TS.length . TS.toUpper) tsa
395− , bench "tl" $ nf (TL.length . TL.toUpper) tla
396− , bench "bs" $ nf (BS.length . BS.map toUpper) bsa
397− , bench "bl" $ nf (BL.length . BL.map toUpper) bla
398− , bench "l" $ nf (L.length . L.map toUpper) la
399− ],
400− bgroup "words" [
401− bench "ts" $ nf (L.length . TS.words) tsa
402− , bench "tl" $ nf (L.length . TL.words) tla
403− , bench "bs" $ nf (L.length . BS.words) bsa
404− , bench "bl" $ nf (L.length . BL.words) bla
405− , bench "l" $ nf (L.length . L.words) la
406− ],
407− bgroup "zipWith" [
408− bench "ts" $ nf (TS.length . TS.zipWith min tsb) tsa
409− , bench "tl" $ nf (TL.length . TL.zipWith min tlb) tla
410− , bench "bs" $ nf (L.length . BS.zipWith min bsb) bsa
411− , bench "bl" $ nf (L.length . BL.zipWith min blb) bla
412− , bench "l" $ nf (L.length . L.zipWith min lb) la
413− ]
414− ],
415− bgroup "builder" [
416− bench "mappend char" $ nf (TL.length . TB.toLazyText . mappendNChar 'a') 10000,
417− bench "mappend 8 char" $ nf (TL.length . TB.toLazyText . mappend8Char) 'a',
418− bench "mappend text" $ nf (TL.length . TB.toLazyText . mappendNText short) 10000
419− ]
420− ]
421− where
422− c = 'й'
423− p0 = (== c)
424− p1 = (/= 'д')
425− lw = "право"
426− bsw = UTF8.fromString lw
427− blw = BL.fromChunks [bsw]
428− tsw = TS.pack lw
429− tlw = TL.fromChunks [tsw]
430− f (C# c#) = C# (chr# (ord# c# +# 1#))
431− g (I# i#) (C# c#) = (I# (i# +# 1#), C# (chr# (ord# c# +# i#)))
432− len l _ = l + (1::Int)
433− replicat n = concat . L.replicate n
434− short = TS.pack "short"
435−
436−chunksOf :: Int -> BS.ByteString -> [BS.ByteString]
437−chunksOf k = go
438− where
439− go t = case BS.splitAt k t of
440− (a,b) | BS.null a -> []
441− | otherwise -> a : go b
442−
443−mappendNChar :: Char -> Int -> TB.Builder
444−mappendNChar c n = go 0
445− where
446− go i
447− | i < n = TB.singleton c `mappend` go (i+1)
448− | otherwise = mempty
449−
450−-- Gives more opportunity for inlining and elimination of unnecesary
451−-- bounds checks.
452−mappend8Char :: Char -> TB.Builder
453−mappend8Char c = TB.singleton c `mappend` TB.singleton c `mappend`
454− TB.singleton c `mappend` TB.singleton c `mappend`
455− TB.singleton c `mappend` TB.singleton c `mappend`
456− TB.singleton c `mappend` TB.singleton c
457−
458−mappendNText :: TS.Text -> Int -> TB.Builder
459−mappendNText t n = go 0
460− where
461− go i
462− | i < n = TB.fromText t `mappend` go (i+1)
463− | otherwise = mempty
tests/Chartem.hsdeleted−153
@@ -1,153 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
2−
3−import Data.Char
4−import Control.Monad (forM_)
5−import Data.Accessor ((^=))
6−import Data.Function
7−import Data.Maybe
8−import Data.List
9−import Debug.Trace
10−import Data.Text (Text)
11−import Data.Text.Encoding (decodeUtf8)
12−import Graphics.Rendering.Chart
13−import Graphics.Rendering.Chart.Gtk (renderableToWindow)
14−import System.Environment (getArgs)
15−import Text.Printf
16−import qualified Data.ByteString as B
17−import qualified Data.Map as M
18−import qualified Data.Text as T
19−
20−data Row = Row {
21− rowName :: !Text
22− , rowMean :: !Double
23− , rowMeanLB :: !Double
24− , rowMeanUB :: !Double
25− , rowStdDev :: !Double
26− , rowStdDevLB :: !Double
27− , rowStdDevUB :: !Double
28− } deriving (Show)
29−
30−parseRow :: Text -> Row
31−parseRow = f . T.split ","
32− where f [n,m,ml,mu,s,sl,su] = Row {
33− rowName = n
34− , rowMean = r m
35− , rowMeanLB = r ml
36− , rowMeanUB = r mu
37− , rowStdDev = r s
38− , rowStdDevLB = r sl
39− , rowStdDevUB = r su
40− }
41− r = read . T.unpack
42−
43−readCSV :: FilePath -> IO [Row]
44−readCSV = fmap (map parseRow . tail . T.lines . decodeUtf8) . B.readFile
45−
46−groupRows :: [Row] -> M.Map Text [Row]
47−groupRows = M.map (sortBy (compare `on` rowName)) . foldr f M.empty
48− where f r m = let (p,s) = T.breakEnd "/" (rowName r)
49− in M.insertWith' (++) (T.init . T.tail $ p)
50− [r { rowName = T.init s}] m
51−
52−main = do
53− args <- getArgs
54− groups <- mapM (fmap groupRows . readCSV) args
55− let dd = M.unionsWith (++) . map (M.map (:[])) $ groups
56− forM_ (M.toList dd) $ \(tdesc,rows) -> do
57− let desc = T.unpack tdesc
58− if False
59− then renderableToWindow (renderMark desc rows) 400 160
60− else renderableToPNGFile (renderMark desc rows) 400 160
61− (printf "time-%s.png" (map clean desc))
62− where clean '/' = '-'
63− clean c | isSpace c = '-'
64− | otherwise = c
65−
66−instance BarsPlotValue LogValue where
67− barsReference = LogValue 1e-300
68− barsAdd (LogValue a) (LogValue b) = LogValue (a * b)
69−
70−renderMark :: String -> [[Row]] -> Renderable ()
71−renderMark desc rows
72− | useLog = toRenderable linLayout
73− | otherwise = toRenderable logLayout
74− where
75− useLog = minimum (map minimum values) >= maximum (map maximum values) / 25
76− values = transpose . map (map rowMean) $ rows
77− keys = map git (head rows)
78− where git r = let n = T.unpack . rowName $ r
79− in maybe n id . flip lookup mappings $ n
80− mappings = [("bl", "lazy BS"), ("bs", "strict BS"), ("l", "list"),
81− ("tl", "lazy T"), ("ts", "strict T")]
82−
83− linLayout = layout1_title ^= "Timings for \"" ++ desc ++ "\""
84− $ layout1_plots ^= [ Left (plotBars linBars) ]
85− $ layout1_left_axis ^= linLeftAxis
86− $ layout1_bottom_axis ^= bottomAxis
87− $ defaultLayout1 :: Layout1 Double Double
88−
89− logLayout = layout1_title ^= "Timings for \"" ++ desc ++
90− "\" (log scale)"
91− $ layout1_plots ^= [ Left (plotBars logBars) ]
92− $ layout1_left_axis ^= logLeftAxis
93− $ layout1_bottom_axis ^= bottomAxis
94− $ defaultLayout1 :: Layout1 Double LogValue
95−
96− logLeftAxis = laxis_generate ^= autoScaledLogAxis logSecAxis
97− $ laxis_reverse ^= False
98− $ defaultLayoutAxis
99−
100− linLeftAxis = laxis_generate ^= autoScaledAxis linSecAxis
101− $ defaultLayoutAxis
102−
103− bottomAxis = laxis_generate ^= autoScaledAxis typeAxis
104− $ defaultLayoutAxis
105−
106− linBars = plot_bars_values ^= (zip [0.5,1.5..] values)
107− $ defaultPlotBars
108−
109− logBars = plot_bars_values ^= (zip [0.5,1.5..] . map (map LogValue) $ values)
110− $ defaultPlotBars
111−
112− typeAxis = la_labelf ^= (ix keys . floor)
113− $ la_nLabels ^= length keys
114− $ defaultLinearAxis
115−
116− ix (x:xs) n | n <= 0 = x
117− | otherwise = ix xs (n-1)
118− ix [] _ = ""
119−
120− linSecAxis = la_labelf ^= secs
121− $ defaultLinearAxis
122−
123− logSecAxis = loga_labelf ^= (secs . fromLV)
124− $ defaultLogAxis
125−
126− fromLV (LogValue v) = v
127−
128−-- | Try to render meaningful time-axis labels.
129−--
130−-- /FIXME/: Trouble is, we need to know the range of times for this to
131−-- work properly, so that we don't accidentally display consecutive
132−-- values that appear identical (e.g. \"43 ms, 43 ms\").
133−secs :: Double -> String
134−secs k
135− | k < 0 = '-' : secs (-k)
136− | k >= 1e9 = (k/1e9) `with` "Gs"
137− | k >= 1e6 = (k/1e6) `with` "Ms"
138− | k >= 1e4 = (k/1e3) `with` "Ks"
139− | k >= 1 = k `with` "s"
140− | k >= 1e-3 = (k*1e3) `with` "ms"
141− | k >= 1e-6 = (k*1e6) `with` "µs"
142− | k >= 1e-9 = (k*1e9) `with` "ns"
143− | k >= 1e-12 = (k*1e12) `with` "ps"
144− | otherwise = printf "%g s" k
145− where with (t :: Double) (u :: String)
146− | t >= 1e9 = printf "%.4g %s" t u
147− | t >= 1e6 = printf "%.0f %s" t u
148− | t >= 1e5 = printf "%.0f %s" t u
149− | t >= 1e4 = printf "%.0f %s" t u
150− | t >= 1e3 = printf "%.0f %s" t u
151− | t >= 1e2 = printf "%.0f %s" t u
152− | t >= 1e1 = printf "%.0f %s" t u
153− | otherwise = printf "%.0f %s" t u
tests/LiteralRuleTest.hsnew file+21
@@ -0,0 +1,21 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module LiteralRuleTest where
4+
5+import Data.Text (Text)
6+
7+-- This should produce 8 firings of the "TEXT literal" rule
8+strings :: [Text]
9+strings = [ "abstime", "aclitem", "bit", "bool", "box", "bpchar", "bytea", "char" ]
10+
11+-- This should produce 7 firings of the "TEXT literal UTF8" rule
12+utf8Strings :: [Text]
13+utf8Strings = [ "\0abstime", "\0aclitem", "\xfefe bit", "\0bool", "\0box", "\0bpchar", "\0bytea" ]
14+
15+-- This should produce 4 firings of the "TEXT empty literal" rule
16+empties :: [Text]
17+empties = [ "", "", "", "" ]
18+
19+-- This should produce 5 firings of the "TEXT empty literal" rule
20+--singletons :: [Text]
21+--singletons = [ "a", "b", "c", "d", "e" ]
tests/Makefile+29−86
@@ -1,97 +1,40 @@
1−version := $(shell awk '/^version:/{print $$2}' ../text.cabal)
2−ghc := ghc
3−ghc-opt-flags = -O0
4−ghc-base-flags := -funbox-strict-fields -hide-all-packages \
5− -package base -package mtl -package random -package directory \
6− -package criterion -package deepseq -DASSERTS -DHAVE_DEEPSEQ \
7− -package bytestring -ignore-package text \
8− -fno-ignore-asserts
9−ghc-test-flags := -package QuickCheck -package test-framework -package deepseq \
10− -package test-framework-quickcheck2 -package test-framework-hunit \
11− -package HUnit
12−ghc-base-flags += -Wall -fno-warn-orphans -fno-warn-missing-signatures
13−ghc-flags := $(ghc-base-flags) -i../dist/build -package-name text-$(version)
14−ghc-hpc-flags := $(ghc-base-flags) -fhpc -fno-ignore-asserts -odir hpcdir \
15− -hidir hpcdir -i..
16−lib := ../dist/build/libHStext-$(version).a
17−lib-srcs := $(shell grep '^ *Data' ../text.cabal | \
18− sed -e 's,\.,/,g' -e 's,$$,.hs,')
1+count = 1000
192
20−cabal := $(shell which cabal 2>/dev/null)
3+all: coverage literal-rule-test
214
22−all: bm qc coverage regressions
5+literal-rule-test:
6+ ./literal-rule-test.sh
237
24−lib: $(lib)
8+coverage: build coverage/hpc_index.html
259
26−$(lib): $(lib-srcs:%=../%)
27−ifeq ($(cabal),)
28− cd .. && runghc Setup configure --user --prefix=$(HOME)
29− cd .. && runghc Setup build
30−else
31− cd .. && cabal configure
32− cd .. && cabal build
33−endif
10+build: text-test-data
11+ cabal configure -fhpc
12+ cabal build
3413
35−Properties.o Regressions.o qc qc-hpc: ghc-flags += $(ghc-test-flags)
36−Properties.o: QuickCheckUtils.o SlowFunctions.o TestUtils.o
14+text-test-data:
15+ hg clone https://bitbucket.org/bos/text-test-data
16+ $(MAKE) -C text-test-data
3717
38−QuickCheckUtils.o: $(lib)
18+coverage/text-tests.tix:
19+ -mkdir -p coverage
20+ ./dist/build/text-tests/text-tests -a $(count)
21+ mv text-tests.tix $@
3922
40−qc: Properties.o QuickCheckUtils.o SlowFunctions.o TestUtils.o
41− $(ghc) $(ghc-flags) -threaded -o $@ $^ $(lib)
23+coverage/text-tests-stdio.tix:
24+ -mkdir -p coverage
25+ ./scripts/cover-stdio.sh ./dist/build/text-tests-stdio/text-tests-stdio
26+ mv text-tests-stdio.tix $@
4227
43−sb: SearchBench.o SlowFunctions.o
44− $(ghc) $(ghc-flags) -threaded -o $@ $^ $(lib)
28+coverage/coverage.tix: coverage/text-tests.tix coverage/text-tests-stdio.tix
29+ hpc combine --output=$@ \
30+ --exclude=Main \
31+ coverage/text-tests.tix \
32+ coverage/text-tests-stdio.tix
4533
46−qc-hpc: Properties.hs QuickCheckUtils.hs SlowFunctions.hs TestUtils.hs $(lib-srcs:%=../%)
47− -mkdir -p hpcdir
48− @rm -f $@.tix
49− $(ghc) $(ghc-hpc-flags) $(ghc-test-flags) $(ghc-opt-flags) -ihpcdir \
50− --make -threaded -o $@ $<
51−
52−stdio-hpc: StdioCoverage.hs $(lib-srcs:%=../%)
53− -mkdir -p hpcdir
54− @rm -f $@.tix
55− $(ghc) $(ghc-hpc-flags) $(ghc-test-flags) $(ghc-opt-flags) -ihpcdir \
56− --make -threaded -o $@ $<
57−
58−coverage: coverage-html/hpc_index.html
59−
60−coverage-html/hpc_index.html: qc-hpc stdio-hpc
61− @rm -f qc-hpc.tix stdio-hpc.tix coverage.tix
62− ./qc-hpc -a 100 +RTS -N
63− bash ./cover-stdio.sh
64− hpc combine --output=coverage.tix --exclude=Main \
65− qc-hpc.tix stdio-hpc.tix
66− hpc markup coverage --exclude=Main --exclude=Properties --exclude=Main \
67− --exclude=Data.Text.Fusion.CaseMapping --exclude StdioCoverage \
68− --exclude=SlowFunctions --exclude=TestUtils \
69− --exclude=QuickCheckUtils --srcdir=.. --srcdir=. --destdir=$(dir $@)
70− @echo xdg-open $@
71−
72−Regressions.o: TestUtils.o
73−
74−regressions: Regressions.o TestUtils.o
75− $(ghc) $(ghc-test-flags) -o $@ $^ $(lib)
76−
77−Benchmarks.o: ghc-opt-flags = -O
78−bm Benchmarks.o: ghc-flags += -package utf8-string
79−bm: Benchmarks.o
80− $(ghc) $(ghc-flags) -o $@ $^ $(lib)
81−
82−SlowFunctions.o: ghc-opt-flags = -O2
83−SearchBench.o: ghc-opt-flags = -O
84−%.o: %.hs
85− $(ghc) $(ghc-flags) $(ghc-opt-flags) -c -o $@ $<
86−
87−hpcdir/%.o: %.hs
88− $(ghc) $(ghc-hpc-flags) $(ghc-opt-flags) --make -c -o $@ $<
89−
90−.PHONY: testdata
91−testdata: text-testdata.tar.bz2
92−
93−text-testdata.tar.bz2:
94− curl -O http://projects.haskell.org/text/text-testdata.tar.bz2
34+coverage/hpc_index.html: coverage/coverage.tix
35+ hpc markup --destdir=coverage coverage/coverage.tix
9536
9637clean:
97− -rm -rf *.o *.hi *.tix bm qc qc-hpc stdio-hpc hpcdir .hpc coverage-html
38+ rm -rf dist coverage .hpc
39+
40+.PHONY: build coverage all literal-rule-test
tests/Properties.hsdeleted−1228
@@ -1,1228 +0,0 @@
1−{-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings,
2− ScopedTypeVariables, TypeSynonymInstances #-}
3−{-# OPTIONS_GHC -fno-enable-rewrite-rules #-}
4−
5−import Test.QuickCheck
6−import Test.QuickCheck.Monadic
7−import Text.Show.Functions ()
8−
9−import qualified Data.Bits as Bits (shiftL, shiftR)
10−import Numeric (showHex)
11−import Data.Char (chr, isDigit, isHexDigit, isLower, isSpace, isUpper, ord)
12−import Data.Monoid (Monoid(..))
13−import Data.String (fromString)
14−import Debug.Trace (trace)
15−import Control.Arrow ((***), second)
16−import Control.DeepSeq
17−import Data.Word (Word8, Word16, Word32)
18−import qualified Data.Text as T
19−import qualified Data.Text.IO as T
20−import qualified Data.Text.Lazy as TL
21−import qualified Data.Text.Lazy.IO as TL
22−import qualified Data.Text.Lazy.Internal as TL
23−import qualified Data.Text.Lazy.Builder as TB
24−import qualified Data.Text.Encoding as E
25−import Data.Text.Read as T
26−import Data.Text.Lazy.Read as TL
27−import Data.Text.Encoding.Error
28−import Control.Exception (SomeException, bracket, catch, evaluate, try)
29−import Data.Text.Foreign
30−import qualified Data.Text.Fusion as S
31−import qualified Data.Text.Fusion.Common as S
32−import Data.Text.Fusion.Size
33−import qualified Data.Text.Lazy.Encoding as EL
34−import qualified Data.Text.Lazy.Fusion as SL
35−import qualified Data.Text.UnsafeShift as U
36−import qualified Data.List as L
37−import Prelude hiding (catch, replicate)
38−import System.IO
39−import System.IO.Unsafe (unsafePerformIO)
40−import Test.Framework (defaultMain, testGroup)
41−import Test.Framework.Providers.QuickCheck2 (testProperty)
42−import Data.Text.Search (indices)
43−import qualified Data.Text.Lazy.Search as S (indices)
44−import qualified SlowFunctions as Slow
45−
46−import QuickCheckUtils (NotEmpty(..), genUnicode, small, unsquare)
47−import TestUtils (withRedirect, withTempFile)
48−
49−-- Ensure that two potentially bottom values (in the sense of crashing
50−-- for some inputs, not looping infinitely) either both crash, or both
51−-- give comparable results for some input.
52−(=^=) :: (Eq a, Show a) => a -> a -> Bool
53−{-# NOINLINE (=^=) #-}
54−i =^= j = unsafePerformIO $ do
55− x <- try (evaluate i)
56− y <- try (evaluate j)
57− case (x,y) of
58− (Left (_ :: SomeException), Left (_ :: SomeException))
59− -> return True
60− (Right a, Right b) -> return (a == b)
61− e -> trace ("*** Divergence: " ++ show e) return False
62−infix 4 =^=
63−
64−t_pack_unpack = (T.unpack . T.pack) `eq` id
65−tl_pack_unpack = (TL.unpack . TL.pack) `eq` id
66−t_stream_unstream = (S.unstream . S.stream) `eq` id
67−tl_stream_unstream = (SL.unstream . SL.stream) `eq` id
68−t_reverse_stream t = (S.reverse . S.reverseStream) t == t
69−t_singleton c = [c] == (T.unpack . T.singleton) c
70−tl_singleton c = [c] == (TL.unpack . TL.singleton) c
71−tl_unstreamChunks x = f 11 x == f 1000 x
72− where f n = SL.unstreamChunks n . S.streamList
73−tl_chunk_unchunk = (TL.fromChunks . TL.toChunks) `eq` id
74−tl_from_to_strict = (TL.fromStrict . TL.toStrict) `eq` id
75−
76−t_ascii t = E.decodeASCII (E.encodeUtf8 a) == a
77− where a = T.map (\c -> chr (ord c `mod` 128)) t
78−tl_ascii t = EL.decodeASCII (EL.encodeUtf8 a) == a
79− where a = TL.map (\c -> chr (ord c `mod` 128)) t
80−t_utf8 = forAll genUnicode $ (E.decodeUtf8 . E.encodeUtf8) `eq` id
81−tl_utf8 = forAll genUnicode $ (EL.decodeUtf8 . EL.encodeUtf8) `eq` id
82−t_utf16LE = forAll genUnicode $ (E.decodeUtf16LE . E.encodeUtf16LE) `eq` id
83−tl_utf16LE = forAll genUnicode $ (EL.decodeUtf16LE . EL.encodeUtf16LE) `eq` id
84−t_utf16BE = forAll genUnicode $ (E.decodeUtf16BE . E.encodeUtf16BE) `eq` id
85−tl_utf16BE = forAll genUnicode $ (EL.decodeUtf16BE . EL.encodeUtf16BE) `eq` id
86−t_utf32LE = forAll genUnicode $ (E.decodeUtf32LE . E.encodeUtf32LE) `eq` id
87−tl_utf32LE = forAll genUnicode $ (EL.decodeUtf32LE . EL.encodeUtf32LE) `eq` id
88−t_utf32BE = forAll genUnicode $ (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id
89−tl_utf32BE = forAll genUnicode $ (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id
90−
91−data DecodeErr = DE String OnDecodeError
92−
93−instance Show DecodeErr where
94− show (DE d _) = "DE " ++ d
95−
96−instance Arbitrary DecodeErr where
97− arbitrary = oneof [ return $ DE "lenient" lenientDecode
98− , return $ DE "ignore" ignore
99− , return $ DE "strict" strictDecode
100− , DE "replace" `fmap` arbitrary ]
101−
102−-- This is a poor attempt to ensure that the error handling paths on
103−-- decode are exercised in some way. Proper testing would be rather
104−-- more involved.
105−t_utf8_err (DE _ de) bs = monadicIO $ do
106− l <- run $ let len = T.length (E.decodeUtf8With de bs)
107− in (len `seq` return (Right len)) `catch`
108− (\(e::UnicodeException) -> return (Left e))
109− case l of
110− Left err -> assert $ length (show err) >= 0
111− Right n -> assert $ n >= 0
112−
113−class Stringy s where
114− packS :: String -> s
115− unpackS :: s -> String
116− splitAtS :: Int -> s -> (s,s)
117− packSChunkSize :: Int -> String -> s
118− packSChunkSize _ = packS
119−
120−instance Stringy String where
121− packS = id
122− unpackS = id
123− splitAtS = splitAt
124−
125−instance Stringy (S.Stream Char) where
126− packS = S.streamList
127− unpackS = S.unstreamList
128− splitAtS n s = (S.take n s, S.drop n s)
129−
130−instance Stringy T.Text where
131− packS = T.pack
132− unpackS = T.unpack
133− splitAtS = T.splitAt
134−
135−instance Stringy TL.Text where
136− packSChunkSize k = SL.unstreamChunks k . S.streamList
137− packS = TL.pack
138− unpackS = TL.unpack
139− splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .
140− TL.splitAt . fromIntegral
141−
142−-- Do two functions give the same answer?
143−eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
144−eq a b s = a s =^= b s
145−
146−-- What about with the RHS packed?
147−eqP :: (Eq a, Show a, Stringy s) =>
148− (String -> a) -> (s -> a) -> String -> Word8 -> Bool
149−eqP f g s w = eql "orig" (f s) (g t) &&
150− eql "mini" (f s) (g mini) &&
151− eql "head" (f sa) (g ta) &&
152− eql "tail" (f sb) (g tb)
153− where t = packS s
154− mini = packSChunkSize 10 s
155− (sa,sb) = splitAt m s
156− (ta,tb) = splitAtS m t
157− l = length s
158− m | l == 0 = n
159− | otherwise = n `mod` l
160− n = fromIntegral w
161− eql d a b
162− | a =^= b = True
163− | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
164−
165−s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList)
166− where _types = s :: String
167−sf_Eq p s =
168− ((L.filter p s==) . L.filter p) `eq`
169− (((S.filter p $ S.streamList s)==) . S.filter p . S.streamList)
170−t_Eq s = (s==) `eq` ((T.pack s==) . T.pack)
171−tl_Eq s = (s==) `eq` ((TL.pack s==) . TL.pack)
172−s_Ord s = (compare s) `eq` (compare (S.streamList s) . S.streamList)
173− where _types = s :: String
174−sf_Ord p s =
175− ((compare $ L.filter p s) . L.filter p) `eq`
176− (compare (S.filter p $ S.streamList s) . S.filter p . S.streamList)
177−t_Ord s = (compare s) `eq` (compare (T.pack s) . T.pack)
178−tl_Ord s = (compare s) `eq` (compare (TL.pack s) . TL.pack)
179−t_Read = id `eq` (T.unpack . read . show)
180−tl_Read = id `eq` (TL.unpack . read . show)
181−t_Show = show `eq` (show . T.pack)
182−tl_Show = show `eq` (show . TL.pack)
183−t_mappend s = mappend s`eqP` (unpackS . mappend (T.pack s))
184−tl_mappend s = mappend s`eqP` (unpackS . mappend (TL.pack s))
185−t_mconcat = mconcat `eq` (unpackS . mconcat . L.map T.pack)
186−tl_mconcat = mconcat `eq` (unpackS . mconcat . L.map TL.pack)
187−t_mempty = mempty == (unpackS (mempty :: T.Text))
188−tl_mempty = mempty == (unpackS (mempty :: TL.Text))
189−t_IsString = fromString `eqP` (T.unpack . fromString)
190−tl_IsString = fromString `eqP` (TL.unpack . fromString)
191−
192−s_cons x = (x:) `eqP` (unpackS . S.cons x)
193−s_cons_s x = (x:) `eqP` (unpackS . S.unstream . S.cons x)
194−sf_cons p x = ((x:) . L.filter p) `eqP` (unpackS . S.cons x . S.filter p)
195−t_cons x = (x:) `eqP` (unpackS . T.cons x)
196−tl_cons x = (x:) `eqP` (unpackS . TL.cons x)
197−s_snoc x = (++ [x]) `eqP` (unpackS . (flip S.snoc) x)
198−t_snoc x = (++ [x]) `eqP` (unpackS . (flip T.snoc) x)
199−tl_snoc x = (++ [x]) `eqP` (unpackS . (flip TL.snoc) x)
200−s_append s = (s++) `eqP` (unpackS . S.append (S.streamList s))
201−s_append_s s = (s++) `eqP`
202− (unpackS . S.unstream . S.append (S.streamList s))
203−sf_append p s = (L.filter p s++) `eqP`
204− (unpackS . S.append (S.filter p $ S.streamList s))
205−t_append s = (s++) `eqP` (unpackS . T.append (packS s))
206−
207−uncons (x:xs) = Just (x,xs)
208−uncons _ = Nothing
209−
210−s_uncons = uncons `eqP` (fmap (second unpackS) . S.uncons)
211−sf_uncons p = (uncons . L.filter p) `eqP`
212− (fmap (second unpackS) . S.uncons . S.filter p)
213−t_uncons = uncons `eqP` (fmap (second unpackS) . T.uncons)
214−tl_uncons = uncons `eqP` (fmap (second unpackS) . TL.uncons)
215−s_head = head `eqP` S.head
216−sf_head p = (head . L.filter p) `eqP` (S.head . S.filter p)
217−t_head = head `eqP` T.head
218−tl_head = head `eqP` TL.head
219−s_last = last `eqP` S.last
220−sf_last p = (last . L.filter p) `eqP` (S.last . S.filter p)
221−t_last = last `eqP` T.last
222−tl_last = last `eqP` TL.last
223−s_tail = tail `eqP` (unpackS . S.tail)
224−s_tail_s = tail `eqP` (unpackS . S.unstream . S.tail)
225−sf_tail p = (tail . L.filter p) `eqP` (unpackS . S.tail . S.filter p)
226−t_tail = tail `eqP` (unpackS . T.tail)
227−tl_tail = tail `eqP` (unpackS . TL.tail)
228−s_init = init `eqP` (unpackS . S.init)
229−s_init_s = init `eqP` (unpackS . S.unstream . S.init)
230−sf_init p = (init . L.filter p) `eqP` (unpackS . S.init . S.filter p)
231−t_init = init `eqP` (unpackS . T.init)
232−tl_init = init `eqP` (unpackS . TL.init)
233−s_null = null `eqP` S.null
234−sf_null p = (null . L.filter p) `eqP` (S.null . S.filter p)
235−t_null = null `eqP` T.null
236−tl_null = null `eqP` TL.null
237−s_length = length `eqP` S.length
238−sf_length p = (length . L.filter p) `eqP` (S.length . S.filter p)
239−sl_length = (fromIntegral . length) `eqP` SL.length
240−t_length = length `eqP` T.length
241−tl_length = L.genericLength `eqP` TL.length
242−t_compareLength t = (compare (T.length t)) `eq` T.compareLength t
243−tl_compareLength t= (compare (TL.length t)) `eq` TL.compareLength t
244−
245−s_map f = map f `eqP` (unpackS . S.map f)
246−s_map_s f = map f `eqP` (unpackS . S.unstream . S.map f)
247−sf_map p f = (map f . L.filter p) `eqP` (unpackS . S.map f . S.filter p)
248−t_map f = map f `eqP` (unpackS . T.map f)
249−tl_map f = map f `eqP` (unpackS . TL.map f)
250−t_intercalate c = L.intercalate c `eq`
251− (unpackS . T.intercalate (packS c) . map packS)
252−tl_intercalate c = L.intercalate c `eq`
253− (unpackS . TL.intercalate (TL.pack c) . map TL.pack)
254−s_intersperse c = L.intersperse c `eqP`
255− (unpackS . S.intersperse c)
256−s_intersperse_s c = L.intersperse c `eqP`
257− (unpackS . S.unstream . S.intersperse c)
258−sf_intersperse p c= (L.intersperse c . L.filter p) `eqP`
259− (unpackS . S.intersperse c . S.filter p)
260−t_intersperse c = L.intersperse c `eqP` (unpackS . T.intersperse c)
261−tl_intersperse c = L.intersperse c `eqP` (unpackS . TL.intersperse c)
262−t_transpose = L.transpose `eq` (map unpackS . T.transpose . map packS)
263−tl_transpose = L.transpose `eq` (map unpackS . TL.transpose . map TL.pack)
264−t_reverse = L.reverse `eqP` (unpackS . T.reverse)
265−tl_reverse = L.reverse `eqP` (unpackS . TL.reverse)
266−t_reverse_short n = L.reverse `eqP` (unpackS . S.reverse . shorten n . S.stream)
267−
268−t_replace s d = (L.intercalate d . splitOn s) `eqP`
269− (unpackS . T.replace (T.pack s) (T.pack d))
270−tl_replace s d = (L.intercalate d . splitOn s) `eqP`
271− (unpackS . TL.replace (TL.pack s) (TL.pack d))
272−
273−splitOn :: (Eq a) => [a] -> [a] -> [[a]]
274−splitOn pat src0
275− | l == 0 = error "empty"
276− | otherwise = go src0
277− where
278− l = length pat
279− go src = search 0 src
280− where
281− search _ [] = [src]
282− search !n s@(_:s')
283− | pat `L.isPrefixOf` s = take n src : go (drop l s)
284− | otherwise = search (n+1) s'
285−
286−s_toCaseFold_length xs = S.length (S.toCaseFold s) >= length xs
287− where s = S.streamList xs
288−sf_toCaseFold_length p xs =
289− (S.length . S.toCaseFold . S.filter p $ s) >= (length . L.filter p $ xs)
290− where s = S.streamList xs
291−t_toCaseFold_length t = T.length (T.toCaseFold t) >= T.length t
292−tl_toCaseFold_length t = TL.length (TL.toCaseFold t) >= TL.length t
293−t_toLower_length t = T.length (T.toLower t) >= T.length t
294−t_toLower_lower t = p (T.toLower t) >= p t
295− where p = T.length . T.filter isLower
296−tl_toLower_lower t = p (TL.toLower t) >= p t
297− where p = TL.length . TL.filter isLower
298−t_toUpper_length t = T.length (T.toUpper t) >= T.length t
299−t_toUpper_upper t = p (T.toUpper t) >= p t
300− where p = T.length . T.filter isUpper
301−tl_toUpper_upper t = p (TL.toUpper t) >= p t
302− where p = TL.length . TL.filter isUpper
303−
304−justifyLeft k c xs = xs ++ L.replicate (k - length xs) c
305−justifyRight m n xs = L.replicate (m - length xs) n ++ xs
306−center k c xs
307− | len >= k = xs
308− | otherwise = L.replicate l c ++ xs ++ L.replicate r c
309− where len = length xs
310− d = k - len
311− r = d `div` 2
312− l = d - r
313−
314−s_justifyLeft k c = justifyLeft j c `eqP` (unpackS . S.justifyLeftI j c)
315− where j = fromIntegral (k :: Word8)
316−s_justifyLeft_s k c = justifyLeft j c `eqP`
317− (unpackS . S.unstream . S.justifyLeftI j c)
318− where j = fromIntegral (k :: Word8)
319−sf_justifyLeft p k c = (justifyLeft j c . L.filter p) `eqP`
320− (unpackS . S.justifyLeftI j c . S.filter p)
321− where j = fromIntegral (k :: Word8)
322−t_justifyLeft k c = justifyLeft j c `eqP` (unpackS . T.justifyLeft j c)
323− where j = fromIntegral (k :: Word8)
324−tl_justifyLeft k c = justifyLeft j c `eqP`
325− (unpackS . TL.justifyLeft (fromIntegral j) c)
326− where j = fromIntegral (k :: Word8)
327−t_justifyRight k c = justifyRight j c `eqP` (unpackS . T.justifyRight j c)
328− where j = fromIntegral (k :: Word8)
329−tl_justifyRight k c = justifyRight j c `eqP`
330− (unpackS . TL.justifyRight (fromIntegral j) c)
331− where j = fromIntegral (k :: Word8)
332−t_center k c = center j c `eqP` (unpackS . T.center j c)
333− where j = fromIntegral (k :: Word8)
334−tl_center k c = center j c `eqP` (unpackS . TL.center (fromIntegral j) c)
335− where j = fromIntegral (k :: Word8)
336−
337−sf_foldl p f z = (L.foldl f z . L.filter p) `eqP` (S.foldl f z . S.filter p)
338− where _types = f :: Char -> Char -> Char
339−t_foldl f z = L.foldl f z `eqP` (T.foldl f z)
340− where _types = f :: Char -> Char -> Char
341−tl_foldl f z = L.foldl f z `eqP` (TL.foldl f z)
342− where _types = f :: Char -> Char -> Char
343−sf_foldl' p f z = (L.foldl' f z . L.filter p) `eqP`
344− (S.foldl' f z . S.filter p)
345− where _types = f :: Char -> Char -> Char
346−t_foldl' f z = L.foldl' f z `eqP` T.foldl' f z
347− where _types = f :: Char -> Char -> Char
348−tl_foldl' f z = L.foldl' f z `eqP` TL.foldl' f z
349− where _types = f :: Char -> Char -> Char
350−sf_foldl1 p f = (L.foldl1 f . L.filter p) `eqP` (S.foldl1 f . S.filter p)
351−t_foldl1 f = L.foldl1 f `eqP` T.foldl1 f
352−tl_foldl1 f = L.foldl1 f `eqP` TL.foldl1 f
353−sf_foldl1' p f = (L.foldl1' f . L.filter p) `eqP` (S.foldl1' f . S.filter p)
354−t_foldl1' f = L.foldl1' f `eqP` T.foldl1' f
355−tl_foldl1' f = L.foldl1' f `eqP` TL.foldl1' f
356−sf_foldr p f z = (L.foldr f z . L.filter p) `eqP` (S.foldr f z . S.filter p)
357− where _types = f :: Char -> Char -> Char
358−t_foldr f z = L.foldr f z `eqP` T.foldr f z
359− where _types = f :: Char -> Char -> Char
360−tl_foldr f z = L.foldr f z `eqP` TL.foldr f z
361− where _types = f :: Char -> Char -> Char
362−sf_foldr1 p f = (L.foldr1 f . L.filter p) `eqP` (S.foldr1 f . S.filter p)
363−t_foldr1 f = L.foldr1 f `eqP` T.foldr1 f
364−tl_foldr1 f = L.foldr1 f `eqP` TL.foldr1 f
365−
366−s_concat_s = L.concat `eq` (unpackS . S.unstream . S.concat . map packS)
367−sf_concat p = (L.concat . map (L.filter p)) `eq`
368− (unpackS . S.concat . map (S.filter p . packS))
369−t_concat = L.concat `eq` (unpackS . T.concat . map packS)
370−tl_concat = L.concat `eq` (unpackS . TL.concat . map TL.pack)
371−sf_concatMap p f = unsquare $ (L.concatMap f . L.filter p) `eqP`
372− (unpackS . S.concatMap (packS . f) . S.filter p)
373−t_concatMap f = unsquare $
374− L.concatMap f `eqP` (unpackS . T.concatMap (packS . f))
375−tl_concatMap f = unsquare $
376− L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f))
377−sf_any q p = (L.any p . L.filter q) `eqP` (S.any p . S.filter q)
378−t_any p = L.any p `eqP` T.any p
379−tl_any p = L.any p `eqP` TL.any p
380−sf_all q p = (L.all p . L.filter q) `eqP` (S.all p . S.filter q)
381−t_all p = L.all p `eqP` T.all p
382−tl_all p = L.all p `eqP` TL.all p
383−sf_maximum p = (L.maximum . L.filter p) `eqP` (S.maximum . S.filter p)
384−t_maximum = L.maximum `eqP` T.maximum
385−tl_maximum = L.maximum `eqP` TL.maximum
386−sf_minimum p = (L.minimum . L.filter p) `eqP` (S.minimum . S.filter p)
387−t_minimum = L.minimum `eqP` T.minimum
388−tl_minimum = L.minimum `eqP` TL.minimum
389−
390−sf_scanl p f z = (L.scanl f z . L.filter p) `eqP`
391− (unpackS . S.scanl f z . S.filter p)
392−t_scanl f z = L.scanl f z `eqP` (unpackS . T.scanl f z)
393−tl_scanl f z = L.scanl f z `eqP` (unpackS . TL.scanl f z)
394−t_scanl1 f = L.scanl1 f `eqP` (unpackS . T.scanl1 f)
395−tl_scanl1 f = L.scanl1 f `eqP` (unpackS . TL.scanl1 f)
396−t_scanr f z = L.scanr f z `eqP` (unpackS . T.scanr f z)
397−tl_scanr f z = L.scanr f z `eqP` (unpackS . TL.scanr f z)
398−t_scanr1 f = L.scanr1 f `eqP` (unpackS . T.scanr1 f)
399−tl_scanr1 f = L.scanr1 f `eqP` (unpackS . TL.scanr1 f)
400−
401−t_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . T.mapAccumL f z)
402− where _types = f :: Int -> Char -> (Int,Char)
403−tl_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . TL.mapAccumL f z)
404− where _types = f :: Int -> Char -> (Int,Char)
405−t_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . T.mapAccumR f z)
406− where _types = f :: Int -> Char -> (Int,Char)
407−tl_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . TL.mapAccumR f z)
408− where _types = f :: Int -> Char -> (Int,Char)
409−
410−replicate n l = concat (L.replicate n l)
411−
412−t_replicate n = replicate m `eq` (unpackS . T.replicate m . packS)
413− where m = fromIntegral (n :: Word8)
414−tl_replicate n = replicate m `eq`
415− (unpackS . TL.replicate (fromIntegral m) . packS)
416− where m = fromIntegral (n :: Word8)
417−
418−unf :: Int -> Char -> Maybe (Char, Char)
419−unf n c | fromEnum c * 100 > n = Nothing
420− | otherwise = Just (c, succ c)
421−
422−t_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . T.unfoldr (unf m))
423− where m = fromIntegral (n :: Word16)
424−tl_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . TL.unfoldr (unf m))
425− where m = fromIntegral (n :: Word16)
426−t_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`
427− (unpackS . T.unfoldrN i (unf j))
428− where i = fromIntegral (n :: Word16)
429− j = fromIntegral (m :: Word16)
430−tl_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`
431− (unpackS . TL.unfoldrN (fromIntegral i) (unf j))
432− where i = fromIntegral (n :: Word16)
433− j = fromIntegral (m :: Word16)
434−
435−unpack2 :: (Stringy s) => (s,s) -> (String,String)
436−unpack2 = unpackS *** unpackS
437−
438−s_take n = L.take n `eqP` (unpackS . S.take n)
439−s_take_s m = L.take n `eqP` (unpackS . S.unstream . S.take n)
440− where n = small m
441−sf_take p n = (L.take n . L.filter p) `eqP`
442− (unpackS . S.take n . S.filter p)
443−t_take n = L.take n `eqP` (unpackS . T.take n)
444−tl_take n = L.take n `eqP` (unpackS . TL.take (fromIntegral n))
445−s_drop n = L.drop n `eqP` (unpackS . S.drop n)
446−s_drop_s m = L.drop n `eqP` (unpackS . S.unstream . S.drop n)
447− where n = small m
448−sf_drop p n = (L.drop n . L.filter p) `eqP`
449− (unpackS . S.drop n . S.filter p)
450−t_drop n = L.drop n `eqP` (unpackS . T.drop n)
451−tl_drop n = L.drop n `eqP` (unpackS . TL.drop (fromIntegral n))
452−s_take_drop m = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)
453− where n = small m
454−s_take_drop_s m = (L.take n . L.drop n) `eqP`
455− (unpackS . S.unstream . S.take n . S.drop n)
456− where n = small m
457−s_takeWhile p = L.takeWhile p `eqP` (unpackS . S.takeWhile p)
458−s_takeWhile_s p = L.takeWhile p `eqP` (unpackS . S.unstream . S.takeWhile p)
459−sf_takeWhile q p = (L.takeWhile p . L.filter q) `eqP`
460− (unpackS . S.takeWhile p . S.filter q)
461−t_takeWhile p = L.takeWhile p `eqP` (unpackS . T.takeWhile p)
462−tl_takeWhile p = L.takeWhile p `eqP` (unpackS . TL.takeWhile p)
463−s_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)
464−s_dropWhile_s p = L.dropWhile p `eqP` (unpackS . S.unstream . S.dropWhile p)
465−sf_dropWhile q p = (L.dropWhile p . L.filter q) `eqP`
466− (unpackS . S.dropWhile p . S.filter q)
467−t_dropWhile p = L.dropWhile p `eqP` (unpackS . T.dropWhile p)
468−tl_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)
469−t_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`
470− (unpackS . T.dropWhileEnd p)
471−tl_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`
472− (unpackS . TL.dropWhileEnd p)
473−t_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)
474− `eqP` (unpackS . T.dropAround p)
475−tl_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)
476− `eqP` (unpackS . TL.dropAround p)
477−t_stripStart = T.dropWhile isSpace `eq` T.stripStart
478−tl_stripStart = TL.dropWhile isSpace `eq` TL.stripStart
479−t_stripEnd = T.dropWhileEnd isSpace `eq` T.stripEnd
480−tl_stripEnd = TL.dropWhileEnd isSpace `eq` TL.stripEnd
481−t_strip = T.dropAround isSpace `eq` T.strip
482−tl_strip = TL.dropAround isSpace `eq` TL.strip
483−t_splitAt n = L.splitAt n `eqP` (unpack2 . T.splitAt n)
484−tl_splitAt n = L.splitAt n `eqP` (unpack2 . TL.splitAt (fromIntegral n))
485−t_span p = L.span p `eqP` (unpack2 . T.span p)
486−tl_span p = L.span p `eqP` (unpack2 . TL.span p)
487−
488−t_breakOn_id s = squid `eq` (uncurry T.append . T.breakOn s)
489− where squid t | T.null s = error "empty"
490− | otherwise = t
491−tl_breakOn_id s = squid `eq` (uncurry TL.append . TL.breakOn s)
492− where squid t | TL.null s = error "empty"
493− | otherwise = t
494−t_breakOn_start (NotEmpty s) t = let (_,m) = T.breakOn s t
495− in T.null m || s `T.isPrefixOf` m
496−tl_breakOn_start (NotEmpty s) t = let (_,m) = TL.breakOn s t
497− in TL.null m || s `TL.isPrefixOf` m
498−t_breakOnEnd_end (NotEmpty s) t = let (m,_) = T.breakOnEnd s t
499− in T.null m || s `T.isSuffixOf` m
500−tl_breakOnEnd_end (NotEmpty s) t = let (m,_) = TL.breakOnEnd s t
501− in TL.null m || s `TL.isSuffixOf` m
502−t_break p = L.break p `eqP` (unpack2 . T.break p)
503−tl_break p = L.break p `eqP` (unpack2 . TL.break p)
504−t_group = L.group `eqP` (map unpackS . T.group)
505−tl_group = L.group `eqP` (map unpackS . TL.group)
506−t_groupBy p = L.groupBy p `eqP` (map unpackS . T.groupBy p)
507−tl_groupBy p = L.groupBy p `eqP` (map unpackS . TL.groupBy p)
508−t_inits = L.inits `eqP` (map unpackS . T.inits)
509−tl_inits = L.inits `eqP` (map unpackS . TL.inits)
510−t_tails = L.tails `eqP` (map unpackS . T.tails)
511−tl_tails = L.tails `eqP` (map unpackS . TL.tails)
512−t_findAppendId (NotEmpty s) = unsquare $ \ts ->
513− let t = T.intercalate s ts
514− in all (==t) $ map (uncurry T.append) (T.breakOnAll s t)
515−tl_findAppendId (NotEmpty s) = unsquare $ \ts ->
516− let t = TL.intercalate s ts
517− in all (==t) $ map (uncurry TL.append) (TL.breakOnAll s t)
518−t_findContains (NotEmpty s) = all (T.isPrefixOf s . snd) . T.breakOnAll s .
519− T.intercalate s
520−tl_findContains (NotEmpty s) = all (TL.isPrefixOf s . snd) .
521− TL.breakOnAll s . TL.intercalate s
522−sl_filterCount c = (L.genericLength . L.filter (==c)) `eqP` SL.countChar c
523−t_findCount s = (L.length . T.breakOnAll s) `eq` T.count s
524−tl_findCount s = (L.genericLength . TL.breakOnAll s) `eq` TL.count s
525−
526−t_splitOn_split s = (T.splitOn s `eq` Slow.splitOn s) . T.intercalate s
527−tl_splitOn_split s = ((TL.splitOn (TL.fromStrict s) . TL.fromStrict) `eq`
528− (map TL.fromStrict . T.splitOn s)) . T.intercalate s
529−t_splitOn_i (NotEmpty t) = id `eq` (T.intercalate t . T.splitOn t)
530−tl_splitOn_i (NotEmpty t) = id `eq` (TL.intercalate t . TL.splitOn t)
531−
532−t_split p = split p `eqP` (map unpackS . T.split p)
533−t_split_count c = (L.length . T.split (==c)) `eq`
534− ((1+) . T.count (T.singleton c))
535−t_split_splitOn c = T.split (==c) `eq` T.splitOn (T.singleton c)
536−tl_split p = split p `eqP` (map unpackS . TL.split p)
537−
538−split :: (a -> Bool) -> [a] -> [[a]]
539−split _ [] = [[]]
540−split p xs = loop xs
541− where loop s | null s' = [l]
542− | otherwise = l : loop (tail s')
543− where (l, s') = break p s
544−
545−t_chunksOf_same_lengths k = all ((==k) . T.length) . ini . T.chunksOf k
546− where ini [] = []
547− ini xs = init xs
548−
549−t_chunksOf_length k t = len == T.length t || (k <= 0 && len == 0)
550− where len = L.sum . L.map T.length $ T.chunksOf k t
551−
552−tl_chunksOf k = T.chunksOf k `eq` (map (T.concat . TL.toChunks) .
553− TL.chunksOf (fromIntegral k) . TL.fromStrict)
554−
555−t_lines = L.lines `eqP` (map unpackS . T.lines)
556−tl_lines = L.lines `eqP` (map unpackS . TL.lines)
557−{-
558−t_lines' = lines' `eqP` (map unpackS . T.lines')
559− where lines' "" = []
560− lines' s = let (l, s') = break eol s
561− in l : case s' of
562− [] -> []
563− ('\r':'\n':s'') -> lines' s''
564− (_:s'') -> lines' s''
565− eol c = c == '\r' || c == '\n'
566−-}
567−t_words = L.words `eqP` (map unpackS . T.words)
568−
569−tl_words = L.words `eqP` (map unpackS . TL.words)
570−t_unlines = L.unlines `eq` (unpackS . T.unlines . map packS)
571−tl_unlines = L.unlines `eq` (unpackS . TL.unlines . map packS)
572−t_unwords = L.unwords `eq` (unpackS . T.unwords . map packS)
573−tl_unwords = L.unwords `eq` (unpackS . TL.unwords . map packS)
574−
575−s_isPrefixOf s = L.isPrefixOf s `eqP`
576− (S.isPrefixOf (S.stream $ packS s) . S.stream)
577−sf_isPrefixOf p s = (L.isPrefixOf s . L.filter p) `eqP`
578− (S.isPrefixOf (S.stream $ packS s) . S.filter p . S.stream)
579−t_isPrefixOf s = L.isPrefixOf s`eqP` T.isPrefixOf (packS s)
580−tl_isPrefixOf s = L.isPrefixOf s`eqP` TL.isPrefixOf (packS s)
581−t_isSuffixOf s = L.isSuffixOf s`eqP` T.isSuffixOf (packS s)
582−tl_isSuffixOf s = L.isSuffixOf s`eqP` TL.isSuffixOf (packS s)
583−t_isInfixOf s = L.isInfixOf s `eqP` T.isInfixOf (packS s)
584−tl_isInfixOf s = L.isInfixOf s `eqP` TL.isInfixOf (packS s)
585−
586−t_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` T.stripPrefix (packS s)
587−tl_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` TL.stripPrefix (packS s)
588−
589−stripSuffix p t = reverse `fmap` L.stripPrefix (reverse p) (reverse t)
590−
591−t_stripSuffix s = (fmap packS . stripSuffix s) `eqP` T.stripSuffix (packS s)
592−tl_stripSuffix s = (fmap packS . stripSuffix s) `eqP` TL.stripSuffix (packS s)
593−
594−commonPrefixes a0@(_:_) b0@(_:_) = Just (go a0 b0 [])
595− where go (a:as) (b:bs) ps
596− | a == b = go as bs (a:ps)
597− go as bs ps = (reverse ps,as,bs)
598−commonPrefixes _ _ = Nothing
599−
600−t_commonPrefixes a b (NonEmpty p)
601− = commonPrefixes pa pb ==
602− repack `fmap` T.commonPrefixes (packS pa) (packS pb)
603− where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)
604− pa = p ++ a
605− pb = p ++ b
606−
607−tl_commonPrefixes a b (NonEmpty p)
608− = commonPrefixes pa pb ==
609− repack `fmap` TL.commonPrefixes (packS pa) (packS pb)
610− where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)
611− pa = p ++ a
612− pb = p ++ b
613−
614−sf_elem p c = (L.elem c . L.filter p) `eqP` (S.elem c . S.filter p)
615−sf_filter q p = (L.filter p . L.filter q) `eqP`
616− (unpackS . S.filter p . S.filter q)
617−t_filter p = L.filter p `eqP` (unpackS . T.filter p)
618−tl_filter p = L.filter p `eqP` (unpackS . TL.filter p)
619−sf_findBy q p = (L.find p . L.filter q) `eqP` (S.findBy p . S.filter q)
620−t_find p = L.find p `eqP` T.find p
621−tl_find p = L.find p `eqP` TL.find p
622−t_partition p = L.partition p `eqP` (unpack2 . T.partition p)
623−tl_partition p = L.partition p `eqP` (unpack2 . TL.partition p)
624−
625−sf_index p s = forAll (choose (-l,l*2))
626− ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))
627− where l = L.length s
628−t_index s = forAll (choose (-l,l*2)) ((s L.!!) `eq` T.index (packS s))
629− where l = L.length s
630−
631−tl_index s = forAll (choose (-l,l*2))
632− ((s L.!!) `eq` (TL.index (packS s) . fromIntegral))
633− where l = L.length s
634−
635−t_findIndex p = L.findIndex p `eqP` T.findIndex p
636−t_count (NotEmpty t) = (subtract 1 . L.length . T.splitOn t) `eq` T.count t
637−tl_count (NotEmpty t) = (subtract 1 . L.genericLength . TL.splitOn t) `eq`
638− TL.count t
639−t_zip s = L.zip s `eqP` T.zip (packS s)
640−tl_zip s = L.zip s `eqP` TL.zip (packS s)
641−sf_zipWith p c s = (L.zipWith c (L.filter p s) . L.filter p) `eqP`
642− (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p)
643−t_zipWith c s = L.zipWith c s `eqP` (unpackS . T.zipWith c (packS s))
644−tl_zipWith c s = L.zipWith c s `eqP` (unpackS . TL.zipWith c (packS s))
645−
646−t_indices (NotEmpty s) = Slow.indices s `eq` indices s
647−tl_indices (NotEmpty s) = lazyIndices s `eq` S.indices s
648− where lazyIndices ss t = map fromIntegral $ Slow.indices (conc ss) (conc t)
649− conc = T.concat . TL.toChunks
650−t_indices_occurs (NotEmpty t) ts = let s = T.intercalate t ts
651− in Slow.indices t s == indices t s
652−
653−-- Bit shifts.
654−shiftL w = forAll (choose (0,width-1)) $ \k -> Bits.shiftL w k == U.shiftL w k
655− where width = round (log (fromIntegral m) / log 2 :: Double)
656− (m,_) = (maxBound, m == w)
657−shiftR w = forAll (choose (0,width-1)) $ \k -> Bits.shiftR w k == U.shiftR w k
658− where width = round (log (fromIntegral m) / log 2 :: Double)
659− (m,_) = (maxBound, m == w)
660−
661−shiftL_Int = shiftL :: Int -> Property
662−shiftL_Word16 = shiftL :: Word16 -> Property
663−shiftL_Word32 = shiftL :: Word32 -> Property
664−shiftR_Int = shiftR :: Int -> Property
665−shiftR_Word16 = shiftR :: Word16 -> Property
666−shiftR_Word32 = shiftR :: Word32 -> Property
667−
668−-- Builder.
669−
670−t_builderSingleton = id `eqP`
671− (unpackS . TB.toLazyText . mconcat . map TB.singleton)
672−t_builderFromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat .
673− map (TB.fromText . packS))
674−t_builderAssociative s1 s2 s3 =
675− TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==
676− TB.toLazyText ((b1 `mappend` b2) `mappend` b3)
677− where b1 = TB.fromText (packS s1)
678− b2 = TB.fromText (packS s2)
679− b3 = TB.fromText (packS s3)
680−
681−-- Reading.
682−
683−t_decimal (n::Int) s =
684− T.signed T.decimal (T.pack (show n) `T.append` t) == Right (n,t)
685− where t = T.dropWhile isDigit s
686−tl_decimal (n::Int) s =
687− TL.signed TL.decimal (TL.pack (show n) `TL.append` t) == Right (n,t)
688− where t = TL.dropWhile isDigit s
689−t_hexadecimal (n::Positive Int) s ox =
690− T.hexadecimal (T.concat [p, T.pack (showHex n ""), t]) == Right (n,t)
691− where t = T.dropWhile isHexDigit s
692− p = if ox then "0x" else ""
693−tl_hexadecimal (n::Positive Int) s ox =
694− TL.hexadecimal (TL.concat [p, TL.pack (showHex n ""), t]) == Right (n,t)
695− where t = TL.dropWhile isHexDigit s
696− p = if ox then "0x" else ""
697−
698−isFloaty c = c `elem` "+-.0123456789eE"
699−
700−t_read_rational p tol (n::Double) s =
701− case p (T.pack (show n) `T.append` t) of
702− Left _err -> False
703− Right (n',t') -> t == t' && abs (n-n') <= tol
704− where t = T.dropWhile isFloaty s
705−
706−tl_read_rational p tol (n::Double) s =
707− case p (TL.pack (show n) `TL.append` t) of
708− Left _err -> False
709− Right (n',t') -> t == t' && abs (n-n') <= tol
710− where t = TL.dropWhile isFloaty s
711−
712−t_double = t_read_rational T.double 1e-13
713−tl_double = tl_read_rational TL.double 1e-13
714−t_rational = t_read_rational T.rational 1e-16
715−tl_rational = tl_read_rational TL.rational 1e-16
716−
717−-- Input and output.
718−
719−-- Work around lack of Show instance for TextEncoding.
720−data Encoding = E String TextEncoding
721−
722−instance Show Encoding where show (E n _) = "utf" ++ n
723−
724−instance Arbitrary Encoding where
725− arbitrary = oneof . map return $
726− [ E "8" utf8, E "8_bom" utf8_bom, E "16" utf16, E "16le" utf16le,
727− E "16be" utf16be, E "32" utf32, E "32le" utf32le, E "32be" utf32be ]
728−
729−windowsNewlineMode = NewlineMode { inputNL = CRLF, outputNL = CRLF }
730−
731−instance Show Newline where
732− show CRLF = "CRLF"
733− show LF = "LF"
734−
735−instance Show NewlineMode where
736− show (NewlineMode i o) = "NewlineMode { inputNL = " ++ show i ++
737− ", outputNL = " ++ show o ++ " }"
738−
739−instance Arbitrary NewlineMode where
740− arbitrary = oneof . map return $
741− [ noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
742− windowsNewlineMode ]
743−
744−instance Arbitrary BufferMode where
745− arbitrary = oneof [ return NoBuffering,
746− return LineBuffering,
747− return (BlockBuffering Nothing),
748− (BlockBuffering . Just . (+1) . fromIntegral) `fmap`
749− (arbitrary :: Gen Word16) ]
750−
751−-- This test harness is complex! What property are we checking?
752−--
753−-- Reading after writing a multi-line file should give the same
754−-- results as were written.
755−--
756−-- What do we vary while checking this property?
757−-- * The lines themselves, scrubbed to contain neither CR nor LF. (By
758−-- working with a list of lines, we ensure that the data will
759−-- sometimes contain line endings.)
760−-- * Encoding.
761−-- * Newline translation mode.
762−-- * Buffering.
763−write_read unline filt writer reader (E _ enc) nl buf ts =
764− monadicIO $ assert . (==t) =<< run act
765− where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
766− act = withTempFile $ \path h -> do
767− hSetEncoding h enc
768− hSetNewlineMode h nl
769− hSetBuffering h buf
770− () <- writer h t
771− hClose h
772− bracket (openFile path ReadMode) hClose $ \h' -> do
773− hSetEncoding h' enc
774− hSetNewlineMode h' nl
775− hSetBuffering h' buf
776− r <- reader h'
777− r `deepseq` return r
778−
779−t_put_get = write_read T.unlines T.filter put get
780− where put h = withRedirect h stdout . T.putStr
781− get h = withRedirect h stdin T.getContents
782−tl_put_get = write_read TL.unlines TL.filter put get
783− where put h = withRedirect h stdout . TL.putStr
784− get h = withRedirect h stdin TL.getContents
785−t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents
786−tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents
787−
788−t_write_read_line e m b t = write_read head T.filter T.hPutStrLn
789− T.hGetLine e m b [t]
790−tl_write_read_line e m b t = write_read head TL.filter TL.hPutStrLn
791− TL.hGetLine e m b [t]
792−
793−-- Low-level.
794−
795−t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t
796−t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t
797−t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) == t
798− where n = small m
799−t_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)
800−
801−-- Regression tests.
802−s_filter_eq s = S.filter p t == S.streamList (filter p s)
803− where p = (/= S.last t)
804− t = S.streamList s
805−
806−-- Make a stream appear shorter than it really is, to ensure that
807−-- functions that consume inaccurately sized streams behave
808−-- themselves.
809−shorten :: Int -> S.Stream a -> S.Stream a
810−shorten n t@(S.Stream arr off len)
811− | n > 0 = S.Stream arr off (smaller (exactSize n) len)
812− | otherwise = t
813−
814−main = defaultMain tests
815−
816−tests = [
817− testGroup "creation/elimination" [
818− testProperty "t_pack_unpack" t_pack_unpack,
819− testProperty "tl_pack_unpack" tl_pack_unpack,
820− testProperty "t_stream_unstream" t_stream_unstream,
821− testProperty "tl_stream_unstream" tl_stream_unstream,
822− testProperty "t_reverse_stream" t_reverse_stream,
823− testProperty "t_singleton" t_singleton,
824− testProperty "tl_singleton" tl_singleton,
825− testProperty "tl_unstreamChunks" tl_unstreamChunks,
826− testProperty "tl_chunk_unchunk" tl_chunk_unchunk,
827− testProperty "tl_from_to_strict" tl_from_to_strict
828− ],
829−
830− testGroup "transcoding" [
831− testProperty "t_ascii" t_ascii,
832− testProperty "tl_ascii" tl_ascii,
833− testProperty "t_utf8" t_utf8,
834− testProperty "tl_utf8" tl_utf8,
835− testProperty "t_utf16LE" t_utf16LE,
836− testProperty "tl_utf16LE" tl_utf16LE,
837− testProperty "t_utf16BE" t_utf16BE,
838− testProperty "tl_utf16BE" tl_utf16BE,
839− testProperty "t_utf32LE" t_utf32LE,
840− testProperty "tl_utf32LE" tl_utf32LE,
841− testProperty "t_utf32BE" t_utf32BE,
842− testProperty "tl_utf32BE" tl_utf32BE,
843− testGroup "errors" [
844− testProperty "t_utf8_err" t_utf8_err
845− ]
846− ],
847−
848− testGroup "instances" [
849− testProperty "s_Eq" s_Eq,
850− testProperty "sf_Eq" sf_Eq,
851− testProperty "t_Eq" t_Eq,
852− testProperty "tl_Eq" tl_Eq,
853− testProperty "s_Ord" s_Ord,
854− testProperty "sf_Ord" sf_Ord,
855− testProperty "t_Ord" t_Ord,
856− testProperty "tl_Ord" tl_Ord,
857− testProperty "t_Read" t_Read,
858− testProperty "tl_Read" tl_Read,
859− testProperty "t_Show" t_Show,
860− testProperty "tl_Show" tl_Show,
861− testProperty "t_mappend" t_mappend,
862− testProperty "tl_mappend" tl_mappend,
863− testProperty "t_mconcat" t_mconcat,
864− testProperty "tl_mconcat" tl_mconcat,
865− testProperty "t_mempty" t_mempty,
866− testProperty "tl_mempty" tl_mempty,
867− testProperty "t_IsString" t_IsString,
868− testProperty "tl_IsString" tl_IsString
869− ],
870−
871− testGroup "basics" [
872− testProperty "s_cons" s_cons,
873− testProperty "s_cons_s" s_cons_s,
874− testProperty "sf_cons" sf_cons,
875− testProperty "t_cons" t_cons,
876− testProperty "tl_cons" tl_cons,
877− testProperty "s_snoc" s_snoc,
878− testProperty "t_snoc" t_snoc,
879− testProperty "tl_snoc" tl_snoc,
880− testProperty "s_append" s_append,
881− testProperty "s_append_s" s_append_s,
882− testProperty "sf_append" sf_append,
883− testProperty "t_append" t_append,
884− testProperty "s_uncons" s_uncons,
885− testProperty "sf_uncons" sf_uncons,
886− testProperty "t_uncons" t_uncons,
887− testProperty "tl_uncons" tl_uncons,
888− testProperty "s_head" s_head,
889− testProperty "sf_head" sf_head,
890− testProperty "t_head" t_head,
891− testProperty "tl_head" tl_head,
892− testProperty "s_last" s_last,
893− testProperty "sf_last" sf_last,
894− testProperty "t_last" t_last,
895− testProperty "tl_last" tl_last,
896− testProperty "s_tail" s_tail,
897− testProperty "s_tail_s" s_tail_s,
898− testProperty "sf_tail" sf_tail,
899− testProperty "t_tail" t_tail,
900− testProperty "tl_tail" tl_tail,
901− testProperty "s_init" s_init,
902− testProperty "s_init_s" s_init_s,
903− testProperty "sf_init" sf_init,
904− testProperty "t_init" t_init,
905− testProperty "tl_init" tl_init,
906− testProperty "s_null" s_null,
907− testProperty "sf_null" sf_null,
908− testProperty "t_null" t_null,
909− testProperty "tl_null" tl_null,
910− testProperty "s_length" s_length,
911− testProperty "sf_length" sf_length,
912− testProperty "sl_length" sl_length,
913− testProperty "t_length" t_length,
914− testProperty "tl_length" tl_length,
915− testProperty "t_compareLength" t_compareLength,
916− testProperty "tl_compareLength" tl_compareLength
917− ],
918−
919− testGroup "transformations" [
920− testProperty "s_map" s_map,
921− testProperty "s_map_s" s_map_s,
922− testProperty "sf_map" sf_map,
923− testProperty "t_map" t_map,
924− testProperty "tl_map" tl_map,
925− testProperty "t_intercalate" t_intercalate,
926− testProperty "tl_intercalate" tl_intercalate,
927− testProperty "s_intersperse" s_intersperse,
928− testProperty "s_intersperse_s" s_intersperse_s,
929− testProperty "sf_intersperse" sf_intersperse,
930− testProperty "t_intersperse" t_intersperse,
931− testProperty "tl_intersperse" tl_intersperse,
932− testProperty "t_transpose" t_transpose,
933− testProperty "tl_transpose" tl_transpose,
934− testProperty "t_reverse" t_reverse,
935− testProperty "tl_reverse" tl_reverse,
936− testProperty "t_reverse_short" t_reverse_short,
937− testProperty "t_replace" t_replace,
938− testProperty "tl_replace" tl_replace,
939−
940− testGroup "case conversion" [
941− testProperty "s_toCaseFold_length" s_toCaseFold_length,
942− testProperty "sf_toCaseFold_length" sf_toCaseFold_length,
943− testProperty "t_toCaseFold_length" t_toCaseFold_length,
944− testProperty "tl_toCaseFold_length" tl_toCaseFold_length,
945− testProperty "t_toLower_length" t_toLower_length,
946− testProperty "t_toLower_lower" t_toLower_lower,
947− testProperty "tl_toLower_lower" tl_toLower_lower,
948− testProperty "t_toUpper_length" t_toUpper_length,
949− testProperty "t_toUpper_upper" t_toUpper_upper,
950− testProperty "tl_toUpper_upper" tl_toUpper_upper
951− ],
952−
953− testGroup "justification" [
954− testProperty "s_justifyLeft" s_justifyLeft,
955− testProperty "s_justifyLeft_s" s_justifyLeft_s,
956− testProperty "sf_justifyLeft" sf_justifyLeft,
957− testProperty "t_justifyLeft" t_justifyLeft,
958− testProperty "tl_justifyLeft" tl_justifyLeft,
959− testProperty "t_justifyRight" t_justifyRight,
960− testProperty "tl_justifyRight" tl_justifyRight,
961− testProperty "t_center" t_center,
962− testProperty "tl_center" tl_center
963− ]
964− ],
965−
966− testGroup "folds" [
967− testProperty "sf_foldl" sf_foldl,
968− testProperty "t_foldl" t_foldl,
969− testProperty "tl_foldl" tl_foldl,
970− testProperty "sf_foldl'" sf_foldl',
971− testProperty "t_foldl'" t_foldl',
972− testProperty "tl_foldl'" tl_foldl',
973− testProperty "sf_foldl1" sf_foldl1,
974− testProperty "t_foldl1" t_foldl1,
975− testProperty "tl_foldl1" tl_foldl1,
976− testProperty "t_foldl1'" t_foldl1',
977− testProperty "sf_foldl1'" sf_foldl1',
978− testProperty "tl_foldl1'" tl_foldl1',
979− testProperty "sf_foldr" sf_foldr,
980− testProperty "t_foldr" t_foldr,
981− testProperty "tl_foldr" tl_foldr,
982− testProperty "sf_foldr1" sf_foldr1,
983− testProperty "t_foldr1" t_foldr1,
984− testProperty "tl_foldr1" tl_foldr1,
985−
986− testGroup "special" [
987− testProperty "s_concat_s" s_concat_s,
988− testProperty "sf_concat" sf_concat,
989− testProperty "t_concat" t_concat,
990− testProperty "tl_concat" tl_concat,
991− testProperty "sf_concatMap" sf_concatMap,
992− testProperty "t_concatMap" t_concatMap,
993− testProperty "tl_concatMap" tl_concatMap,
994− testProperty "sf_any" sf_any,
995− testProperty "t_any" t_any,
996− testProperty "tl_any" tl_any,
997− testProperty "sf_all" sf_all,
998− testProperty "t_all" t_all,
999− testProperty "tl_all" tl_all,
1000− testProperty "sf_maximum" sf_maximum,
1001− testProperty "t_maximum" t_maximum,
1002− testProperty "tl_maximum" tl_maximum,
1003− testProperty "sf_minimum" sf_minimum,
1004− testProperty "t_minimum" t_minimum,
1005− testProperty "tl_minimum" tl_minimum
1006− ]
1007− ],
1008−
1009− testGroup "construction" [
1010− testGroup "scans" [
1011− testProperty "sf_scanl" sf_scanl,
1012− testProperty "t_scanl" t_scanl,
1013− testProperty "tl_scanl" tl_scanl,
1014− testProperty "t_scanl1" t_scanl1,
1015− testProperty "tl_scanl1" tl_scanl1,
1016− testProperty "t_scanr" t_scanr,
1017− testProperty "tl_scanr" tl_scanr,
1018− testProperty "t_scanr1" t_scanr1,
1019− testProperty "tl_scanr1" tl_scanr1
1020− ],
1021−
1022− testGroup "mapAccum" [
1023− testProperty "t_mapAccumL" t_mapAccumL,
1024− testProperty "tl_mapAccumL" tl_mapAccumL,
1025− testProperty "t_mapAccumR" t_mapAccumR,
1026− testProperty "tl_mapAccumR" tl_mapAccumR
1027− ],
1028−
1029− testGroup "unfolds" [
1030− testProperty "t_replicate" t_replicate,
1031− testProperty "tl_replicate" tl_replicate,
1032− testProperty "t_unfoldr" t_unfoldr,
1033− testProperty "tl_unfoldr" tl_unfoldr,
1034− testProperty "t_unfoldrN" t_unfoldrN,
1035− testProperty "tl_unfoldrN" tl_unfoldrN
1036− ]
1037− ],
1038−
1039− testGroup "substrings" [
1040− testGroup "breaking" [
1041− testProperty "s_take" s_take,
1042− testProperty "s_take_s" s_take_s,
1043− testProperty "sf_take" sf_take,
1044− testProperty "t_take" t_take,
1045− testProperty "tl_take" tl_take,
1046− testProperty "s_drop" s_drop,
1047− testProperty "s_drop_s" s_drop_s,
1048− testProperty "sf_drop" sf_drop,
1049− testProperty "t_drop" t_drop,
1050− testProperty "tl_drop" tl_drop,
1051− testProperty "s_take_drop" s_take_drop,
1052− testProperty "s_take_drop_s" s_take_drop_s,
1053− testProperty "s_takeWhile" s_takeWhile,
1054− testProperty "s_takeWhile_s" s_takeWhile_s,
1055− testProperty "sf_takeWhile" sf_takeWhile,
1056− testProperty "t_takeWhile" t_takeWhile,
1057− testProperty "tl_takeWhile" tl_takeWhile,
1058− testProperty "sf_dropWhile" sf_dropWhile,
1059− testProperty "s_dropWhile" s_dropWhile,
1060− testProperty "s_dropWhile_s" s_dropWhile_s,
1061− testProperty "t_dropWhile" t_dropWhile,
1062− testProperty "tl_dropWhile" tl_dropWhile,
1063− testProperty "t_dropWhileEnd" t_dropWhileEnd,
1064− testProperty "tl_dropWhileEnd" tl_dropWhileEnd,
1065− testProperty "t_dropAround" t_dropAround,
1066− testProperty "tl_dropAround" tl_dropAround,
1067− testProperty "t_stripStart" t_stripStart,
1068− testProperty "tl_stripStart" tl_stripStart,
1069− testProperty "t_stripEnd" t_stripEnd,
1070− testProperty "tl_stripEnd" tl_stripEnd,
1071− testProperty "t_strip" t_strip,
1072− testProperty "tl_strip" tl_strip,
1073− testProperty "t_splitAt" t_splitAt,
1074− testProperty "tl_splitAt" tl_splitAt,
1075− testProperty "t_span" t_span,
1076− testProperty "tl_span" tl_span,
1077− testProperty "t_breakOn_id" t_breakOn_id,
1078− testProperty "tl_breakOn_id" tl_breakOn_id,
1079− testProperty "t_breakOn_start" t_breakOn_start,
1080− testProperty "tl_breakOn_start" tl_breakOn_start,
1081− testProperty "t_breakOnEnd_end" t_breakOnEnd_end,
1082− testProperty "tl_breakOnEnd_end" tl_breakOnEnd_end,
1083− testProperty "t_break" t_break,
1084− testProperty "tl_break" tl_break,
1085− testProperty "t_group" t_group,
1086− testProperty "tl_group" tl_group,
1087− testProperty "t_groupBy" t_groupBy,
1088− testProperty "tl_groupBy" tl_groupBy,
1089− testProperty "t_inits" t_inits,
1090− testProperty "tl_inits" tl_inits,
1091− testProperty "t_tails" t_tails,
1092− testProperty "tl_tails" tl_tails
1093− ],
1094−
1095− testGroup "breaking many" [
1096− testProperty "t_findAppendId" t_findAppendId,
1097− testProperty "tl_findAppendId" tl_findAppendId,
1098− testProperty "t_findContains" t_findContains,
1099− testProperty "tl_findContains" tl_findContains,
1100− testProperty "sl_filterCount" sl_filterCount,
1101− testProperty "t_findCount" t_findCount,
1102− testProperty "tl_findCount" tl_findCount,
1103− testProperty "t_splitOn_split" t_splitOn_split,
1104− testProperty "tl_splitOn_split" tl_splitOn_split,
1105− testProperty "t_splitOn_i" t_splitOn_i,
1106− testProperty "tl_splitOn_i" tl_splitOn_i,
1107− testProperty "t_split" t_split,
1108− testProperty "t_split_count" t_split_count,
1109− testProperty "t_split_splitOn" t_split_splitOn,
1110− testProperty "tl_split" tl_split,
1111− testProperty "t_chunksOf_same_lengths" t_chunksOf_same_lengths,
1112− testProperty "t_chunksOf_length" t_chunksOf_length,
1113− testProperty "tl_chunksOf" tl_chunksOf
1114− ],
1115−
1116− testGroup "lines and words" [
1117− testProperty "t_lines" t_lines,
1118− testProperty "tl_lines" tl_lines,
1119− --testProperty "t_lines'" t_lines',
1120− testProperty "t_words" t_words,
1121− testProperty "tl_words" tl_words,
1122− testProperty "t_unlines" t_unlines,
1123− testProperty "tl_unlines" tl_unlines,
1124− testProperty "t_unwords" t_unwords,
1125− testProperty "tl_unwords" tl_unwords
1126− ]
1127− ],
1128−
1129− testGroup "predicates" [
1130− testProperty "s_isPrefixOf" s_isPrefixOf,
1131− testProperty "sf_isPrefixOf" sf_isPrefixOf,
1132− testProperty "t_isPrefixOf" t_isPrefixOf,
1133− testProperty "tl_isPrefixOf" tl_isPrefixOf,
1134− testProperty "t_isSuffixOf" t_isSuffixOf,
1135− testProperty "tl_isSuffixOf" tl_isSuffixOf,
1136− testProperty "t_isInfixOf" t_isInfixOf,
1137− testProperty "tl_isInfixOf" tl_isInfixOf,
1138−
1139− testGroup "view" [
1140− testProperty "t_stripPrefix" t_stripPrefix,
1141− testProperty "tl_stripPrefix" tl_stripPrefix,
1142− testProperty "t_stripSuffix" t_stripSuffix,
1143− testProperty "tl_stripSuffix" tl_stripSuffix,
1144− testProperty "t_commonPrefixes" t_commonPrefixes,
1145− testProperty "tl_commonPrefixes" tl_commonPrefixes
1146− ]
1147− ],
1148−
1149− testGroup "searching" [
1150− testProperty "sf_elem" sf_elem,
1151− testProperty "sf_filter" sf_filter,
1152− testProperty "t_filter" t_filter,
1153− testProperty "tl_filter" tl_filter,
1154− testProperty "sf_findBy" sf_findBy,
1155− testProperty "t_find" t_find,
1156− testProperty "tl_find" tl_find,
1157− testProperty "t_partition" t_partition,
1158− testProperty "tl_partition" tl_partition
1159− ],
1160−
1161− testGroup "indexing" [
1162− testProperty "sf_index" sf_index,
1163− testProperty "t_index" t_index,
1164− testProperty "tl_index" tl_index,
1165− testProperty "t_findIndex" t_findIndex,
1166− testProperty "t_count" t_count,
1167− testProperty "tl_count" tl_count,
1168− testProperty "t_indices" t_indices,
1169− testProperty "tl_indices" tl_indices,
1170− testProperty "t_indices_occurs" t_indices_occurs
1171− ],
1172−
1173− testGroup "zips" [
1174− testProperty "t_zip" t_zip,
1175− testProperty "tl_zip" tl_zip,
1176− testProperty "sf_zipWith" sf_zipWith,
1177− testProperty "t_zipWith" t_zipWith,
1178− testProperty "tl_zipWith" tl_zipWith
1179− ],
1180−
1181− testGroup "regressions" [
1182− testProperty "s_filter_eq" s_filter_eq
1183− ],
1184−
1185− testGroup "shifts" [
1186− testProperty "shiftL_Int" shiftL_Int,
1187− testProperty "shiftL_Word16" shiftL_Word16,
1188− testProperty "shiftL_Word32" shiftL_Word32,
1189− testProperty "shiftR_Int" shiftR_Int,
1190− testProperty "shiftR_Word16" shiftR_Word16,
1191− testProperty "shiftR_Word32" shiftR_Word32
1192− ],
1193−
1194− testGroup "builder" [
1195− testProperty "t_builderSingleton" t_builderSingleton,
1196− testProperty "t_builderFromText" t_builderFromText,
1197− testProperty "t_builderAssociative" t_builderAssociative
1198− ],
1199−
1200− testGroup "read" [
1201− testProperty "t_decimal" t_decimal,
1202− testProperty "tl_decimal" tl_decimal,
1203− testProperty "t_hexadecimal" t_hexadecimal,
1204− testProperty "tl_hexadecimal" tl_hexadecimal,
1205− testProperty "t_double" t_double,
1206− testProperty "tl_double" tl_double,
1207− testProperty "t_rational" t_rational,
1208− testProperty "tl_rational" tl_rational
1209− ],
1210−
1211− testGroup "input-output" [
1212− testProperty "t_write_read" t_write_read,
1213− testProperty "tl_write_read" tl_write_read,
1214− testProperty "t_write_read_line" t_write_read_line,
1215− testProperty "tl_write_read_line" tl_write_read_line
1216− -- These tests are subject to I/O race conditions when run under
1217− -- test-framework-quickcheck2.
1218− -- testProperty "t_put_get" t_put_get
1219− -- testProperty "tl_put_get" tl_put_get
1220− ],
1221−
1222− testGroup "lowlevel" [
1223− testProperty "t_dropWord16" t_dropWord16,
1224− testProperty "t_takeWord16" t_takeWord16,
1225− testProperty "t_take_drop_16" t_take_drop_16,
1226− testProperty "t_use_from" t_use_from
1227− ]
1228− ]
tests/QuickCheckUtils.hsdeleted−155
@@ -1,155 +0,0 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−
3−module QuickCheckUtils where
4−
5−import Control.Arrow (first)
6−import Data.Char (chr)
7−import Data.Bits ((.&.))
8−import Data.String (IsString, fromString)
9−import qualified Data.Text as T
10−import Data.Text.Foreign (I16)
11−import qualified Data.Text.Lazy as TL
12−import System.Random (Random(..), RandomGen)
13−import Test.QuickCheck hiding ((.&.))
14−import qualified Data.ByteString as B
15−
16−instance Random I16 where
17− randomR = integralRandomR
18− random = randomR (minBound,maxBound)
19−
20−instance Arbitrary I16 where
21− arbitrary = choose (minBound,maxBound)
22−
23−instance Arbitrary B.ByteString where
24− arbitrary = B.pack `fmap` arbitrary
25−
26−genUnicode :: IsString a => Gen a
27−genUnicode = fmap fromString string where
28− string = sized $ \n ->
29− do k <- choose (0,n)
30− sequence [ char | _ <- [1..k] ]
31−
32− excluding :: [a -> Bool] -> Gen a -> Gen a
33− excluding bad gen = loop
34− where
35− loop = do
36− x <- gen
37− if or (map ($ x) bad)
38− then loop
39− else return x
40−
41− reserved = [lowSurrogate, highSurrogate, noncharacter]
42− lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF
43− highSurrogate c = c >= 0xD800 && c <= 0xDBFF
44− noncharacter c = masked == 0xFFFE || masked == 0xFFFF
45− where
46− masked = c .&. 0xFFFF
47−
48− ascii = choose (0,0x7F)
49− plane0 = choose (0xF0, 0xFFFF)
50− plane1 = oneof [ choose (0x10000, 0x10FFF)
51− , choose (0x11000, 0x11FFF)
52− , choose (0x12000, 0x12FFF)
53− , choose (0x13000, 0x13FFF)
54− , choose (0x1D000, 0x1DFFF)
55− , choose (0x1F000, 0x1FFFF)
56− ]
57− plane2 = oneof [ choose (0x20000, 0x20FFF)
58− , choose (0x21000, 0x21FFF)
59− , choose (0x22000, 0x22FFF)
60− , choose (0x23000, 0x23FFF)
61− , choose (0x24000, 0x24FFF)
62− , choose (0x25000, 0x25FFF)
63− , choose (0x26000, 0x26FFF)
64− , choose (0x27000, 0x27FFF)
65− , choose (0x28000, 0x28FFF)
66− , choose (0x29000, 0x29FFF)
67− , choose (0x2A000, 0x2AFFF)
68− , choose (0x2B000, 0x2BFFF)
69− , choose (0x2F000, 0x2FFFF)
70− ]
71− plane14 = choose (0xE0000, 0xE0FFF)
72− planes = [ascii, plane0, plane1, plane2, plane14]
73−
74− char = chr `fmap` excluding reserved (oneof planes)
75−
76−-- For tests that have O(n^2) running times or input sizes, resize
77−-- their inputs to the square root of the originals.
78−unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property
79−unsquare = forAll smallArbitrary
80−
81−smallArbitrary :: (Arbitrary a, Show a) => Gen a
82−smallArbitrary = sized $ \n -> resize (smallish n) arbitrary
83− where smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
84−
85−instance Arbitrary T.Text where
86− arbitrary = T.pack `fmap` arbitrary
87−
88−instance Arbitrary TL.Text where
89− arbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary
90−
91−newtype NotEmpty a = NotEmpty { notEmpty :: a }
92− deriving (Eq, Ord)
93−
94−instance Show a => Show (NotEmpty a) where
95− show (NotEmpty a) = show a
96−
97−instance Functor NotEmpty where
98− fmap f (NotEmpty a) = NotEmpty (f a)
99−
100−instance Arbitrary a => Arbitrary (NotEmpty [a]) where
101− arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
102−
103−instance Arbitrary (NotEmpty T.Text) where
104− arbitrary = (fmap T.pack) `fmap` arbitrary
105−
106−instance Arbitrary (NotEmpty TL.Text) where
107− arbitrary = (fmap TL.pack) `fmap` arbitrary
108−
109−instance Arbitrary (NotEmpty B.ByteString) where
110− arbitrary = (fmap B.pack) `fmap` arbitrary
111−
112−data Small = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7
113− | S8 | S9 | S10 | S11 | S12 | S13 | S14 | S15
114− | S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23
115− | S24 | S25 | S26 | S27 | S28 | S29 | S30 | S31
116− deriving (Eq, Ord, Enum, Bounded)
117−
118−small :: Integral a => Small -> a
119−small = fromIntegral . fromEnum
120−
121−intf f a b = toEnum ((fromEnum a `f` fromEnum b) `mod` 32)
122−
123−instance Show Small where
124− show = show . fromEnum
125−
126−instance Read Small where
127− readsPrec n = map (first toEnum) . readsPrec n
128−
129−instance Num Small where
130− fromInteger = toEnum . fromIntegral
131− signum _ = 1
132− abs = id
133− (+) = intf (+)
134− (-) = intf (-)
135− (*) = intf (*)
136−
137−instance Real Small where
138− toRational = toRational . fromEnum
139−
140−instance Integral Small where
141− toInteger = toInteger . fromEnum
142− quotRem a b = (toEnum x, toEnum y)
143− where (x, y) = fromEnum a `quotRem` fromEnum b
144−
145−instance Random Small where
146− randomR = integralRandomR
147− random = randomR (minBound,maxBound)
148−
149−instance Arbitrary Small where
150− arbitrary = choose (minBound,maxBound)
151−
152−integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
153−integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
154− fromIntegral b :: Integer) g of
155− (x,h) -> (fromIntegral x, h)
tests/READMEdeleted−2
@@ -1,2 +0,0 @@
1−You also need the test data from:
2−http://projects.haskell.org/text/text-testdata.tar.bz2
tests/SearchBench.hsdeleted−115
@@ -1,115 +0,0 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2−
3−import Criterion.Main
4−import Data.Text.Encoding
5−import Data.Text.Search
6−import qualified Data.ByteString.Char8 as B
7−import qualified Data.Text as T
8−import qualified SlowFunctions as Slow
9−
10−main = defaultMain [
11− bench "big/fast" $ (length . search indices)
12− , bench "big/slow" $ (length . search Slow.indices)
13− , bench "big/bytestring" $ (length . searchBS)
14− , bench "dna/fast" $ (length . searchDNA indices)
15− , bench "dna/slow" $ (length . searchDNA Slow.indices)
16− , bench "dna/bytestring" $ (length . searchDNABS)
17− ]
18−
19−search f n = f needle' haystack
20− where
21− needle' = T.drop (n `mod` 20) needle
22− needle = T.replicate 10 "abcdefghijklmnopqrstuvwxyz"
23− haystack = T.replicate 100 $
24− T.concat [ T.replicate 1000 "def"
25− , needle
26− , T.replicate 1000 "123"
27− ]
28−
29−searchDNA f n = f needle haystack
30− where
31− needle = T.take 4 . T.drop (n `mod` (T.length dna - 4)) $ dna
32− haystack = T.replicate 100 dna
33−
34−replicateBS n = B.concat . replicate n
35−
36−searchBS n = indicesBS needle' haystack
37− where
38− needle' = B.drop (n `mod` 20) needle
39− needle = replicateBS 10 "abcdefghijklmnopqrstuvwxyz"
40− haystack = replicateBS 100 $
41− B.concat [ replicateBS 1000 "def"
42− , needle
43− , replicateBS 1000 "123"
44− ]
45−
46−searchDNABS n = indicesBS needle haystack
47− where
48− needle = B.take 4 . B.drop (n `mod` (B.length bdna - 4)) $ bdna
49− haystack = replicateBS 100 bdna
50−
51−indicesBS :: B.ByteString -> B.ByteString -> [Int]
52−indicesBS pat
53− | B.null pat = error "empty"
54− | otherwise = go 0
55− where
56− l = B.length pat
57− go !i src = case B.breakSubstring pat src of
58− (h,t) | B.null t -> []
59− | otherwise -> i' : go (i'+l) (B.drop l t)
60− where i' = i + B.length h
61−
62−dna = decodeASCII bdna
63−
64−bdna :: B.ByteString
65−bdna = "\
66−\CGTAACAAGGTTTCCGTAGGTGAACCTGCGGAAGGATCATTGTTGAGATCACATAATAATTGATCGGGTT\
67−\AATCTGGAGGATCTGTTTACTTTGGTCACCCATGAGCATTTGCTGTTGAAGTGACCTAGAATTGCCATCG\
68−\AGCCTCCTTGGGAGCTTTCTTGTTGGCGAGATCTAAACCCTTGCCCGGCGCAGTTTTGCTCCAAGTCGTT\
69−\TGACACATAATTGGTGAAGGGGGTGGCATCCTTCCCTGACCCTCCCCCAACTATTTTTTTAACAACTCTC\
70−\AGCAACGGAGACTCAGTCTTCGGCAAATGCGATAAATGGTGTGAATTGCAGAATCCCGTGCACCATCGAG\
71−\TCTTTGAACGCAAGTTGCGCCCGAGGCCATCAGGCCAAGGGCACGCCTGCCTGGGCATTGCGAGTCATAT\
72−\CTCTCCCTTAACGAGGCTGTCCATACATACTGTTCAGCCGGTGCGGATGTGAGTTTGGCCCCTTGTTCTT\
73−\TGGTACGGGGGGTCTAAGAGCTGCATGGGCTTTTGATGGTCCTAAATACGGCAAGAGGTGGACGAACTAT\
74−\GCTACAACAAAATTGTTGTGCAGAGGCCCCGGGTTGTCGTATTAGATGGGCCACCGTAATCTGAAGACCC\
75−\TTTTGAACCCCATTGGAGGCCCATCAACCCATGATCAGTTGATGGCCATTTGGTTGCGACCCCAGGTCAG\
76−\GTGAGCAACAGCTGTCGTAACAAGGTTTCCGTAGGGTGAACTGCGGAAGGATCATTGTTGAGATCACATA\
77−\ATAATTGATCGAGTTAATCTGGAGGATCTGTTTACTTGGGTCACCCATGGGCATTTGCTGTTGAAGTGAC\
78−\CTAGATTTGCCATCGAGCCTCCTTGGGAGCATCCTTGTTGGCGATATCTAAACCCTCAATTTTTCCCCCA\
79−\ATCAAATTACACAAAATTGGTGGAGGGGGTGGCATTCTTCCCTTACCCTCCCCCAAATATTTTTTTAACA\
80−\ACTCTCAGCAACGGATATCTCAGCTCTTGCATCGATGAAGAACCCACCGAAATGCGATAAATGGTGTGAA\
81−\TTGCAGAATCCCGTGAACCATCGAGTCTTTGAACGCAAGTTGCGCCCGAGGCCATCAGGCCAAGGGCACG\
82−\CCTGCCTGGGCATTGCGAGTCATATCTCTCCCTTAACGAGGCTGTCCATACATACTGTTCAGCCGGTGCG\
83−\GATGTGAGTTTGGCCCCTTGTTCTTTGGTACGGGGGGTCTAAGAGATGCATGGGCTTTTGATGGTCCTAA\
84−\ATACGGCAAGAGGTGGACGAACTATGCTACAACAAAATTGTTGTGCAAAGGCCCCGGGTTGTCGTATAAG\
85−\ATGGGCCACCGATATCTGAAGACCCTTTTGGACCCCATTGGAGCCCATCAACCCATGTCAGTTGATGGCC\
86−\ATTCGTAACAAGGTTTCCGTAGGTGAACCTGCGGAAGGATCATTGTTGAGATCACATAATAATTGATCGA\
87−\GTTAATCTGGAGGATCTGTTTACTTGGGTCACCCATGGGCATTTGCTGTTGAAGTGACCTAGATTTGCCA\
88−\TCGAGCCTCCTTGGGAGCTTTCTTGTTGGCGATATCTAAACCCTTGCCCGGCAGAGTTTTGGGAATCCCG\
89−\TGAACCATCGAGTCTTTGAACGCAAGTTGCGCCCGAGGCCATCAGGCCAAGGGCACGCCTGCCTGGGCAT\
90−\TGCGAGTCATATCTCTCCCTTAACGAGGCTGTCCATACACACCTGTTCAGCCGGTGCGGATGTGAGTTTG\
91−\GCCCCTTGTTCTTTGGTACGGGGGGTCTAAGAGCTGCATGGGCTTTTGATGGTCCTAAATACGGCAAGAG\
92−\GTGGACGAACTATGCTACAACAAAATTGTTGTGCAAAGGCCCCGGGTTGTCGTATTAGATGGGCCACCAT\
93−\AATCTGAAGACCCTTTTGAACCCCATTGGAGGCCCATCAACCCATGATCAGTTGATGGCCATTTGGTTGC\
94−\GACCCAGTCAGGTGAGGGTAGGTGAACCTGCGGAAGGATCATTGTTGAGATCACATAATAATTGATCGAG\
95−\TTAATCTGGAGGATCTGTTTACTTTGGTCACCCATGGGCATTTGCTGTTGAAGTGACCTAGATTTGCCAT\
96−\CGAGCCTCCTTGGGAGCTTTCTTGTTGGCGAGATCTAAACCCTTGCCCGGCGGAGTTTGGCGCCAAGTCA\
97−\TATGACACATAATTGGTGAAGGGGGTGGCATCCTGCCCTGACCCTCCCCAAATTATTTTTTTAACAACTC\
98−\TCAGCAACGGATATCTCGGCTCTTGCATCGATGAAGAACGCAGCGAAATGCGATAAATGGTGTGAATTGC\
99−\AGAATCCCGTGAACCATCGAGTCTTTGGAACGCAAGTTGCGCCCGAGGCCATCAGGCCAAGGGCACGCCT\
100−\GCCTGGGCATTGGGAATCATATCTCTCCCCTAACGAGGCTATCCAAACATACTGTTCATCCGGTGCGGAT\
101−\GTGAGTTTGGCCCCTTGTTCTTTGGTACCGGGGGTCTAAGAGCTGCATGGGCATTTGATGGTCCTCAAAA\
102−\CGGCAAGAGGTGGACGAACTATGCCACAACAAAATTGTTGTCCCAAGGCCCCGGGTTGTCGTATTAGATG\
103−\GGCCACCGTAACCTGAAGACCCTTTTGAACCCCATTGGAGGCCCATCAACCCATGATCAGTTGATGACCA\
104−\TTTGTTGCGACCCCAGTCAGCTGAGCAACCCGCTGAGTGGAAGGTCATTGCCGATATCACATAATAATTG\
105−\ATCGAGTTAATCTGGAGGATCTGTTTACTTGGTCACCCATGAGCATTTGCTGTTGAAGTGACCTAGATTT\
106−\GCCATCGAGCCTCCTTGGGAGTTTTCTTGTTGGCGAGATCTAAACCCTTGCCCGGCGGAGTTGTGCGCCA\
107−\AGTCATATGACACATAATTGGTGAAGGGGGTGGCATCCTGCCCTGACCCTCCCCAAATTATTTTTTTAAC\
108−\AACTCTCAGCAACGGATATCTCGGCTCTTGCATCGATGAAGAACGCAGCGAAATGCGATAAATGGTGTGA\
109−\ATTGCAGAATCCCGTGAACCATCGAGTCTTTGAACGCAAGTTGCGCCCGAGGCCATCAGGCCAAGGGCAC\
110−\GCCTGCCTGGGCATTGCGAGTCATATCTCTCCCTTAACGAGGCTGTCCATACATACTGTTCATCCGGTGC\
111−\GGATGTGAGTTTGGCCCCTTGTTCTTTGGTACGGGGGGTCTAAGAGCTGCATGGGCATTTGATGGTCCTC\
112−\AAAACGGCAAGAGGTGGACGAACTATGCTACAACCAAATTGTTGTCCCAAGGCCCCGGGTTGTCGTATTA\
113−\GATGGGCCACCGTAACCTGAAGACCCTTTTGAACCCCATTGGAGGCCCATCAACCCATGATCAGTTGATG\
114−\ACCATGTGTTGCGACCCCAGTCAGCTGAGCAACGCGCTGAGCGTAACAAGGTTTCCGTAGGTGGACCTCC\
115−\GGGAGGATCATTGTTGAGATCACATAATAATTGATCGAGGTAATCTGGAGGATCTGCATATTTTGGTCAC"
tests/TestUtils.hsdeleted−31
@@ -1,31 +0,0 @@
1−module TestUtils
2− (
3− withRedirect
4− , withTempFile
5− ) where
6−
7−import Control.Exception (bracket, bracket_)
8−import Control.Monad (when)
9−import GHC.IO.Handle.Internals (withHandle)
10−import System.Directory (removeFile)
11−import System.IO
12−
13−withTempFile :: (FilePath -> Handle -> IO a) -> IO a
14−withTempFile = bracket (openTempFile "." "crashy.txt") cleanupTemp . uncurry
15− where
16− cleanupTemp (path,h) = do
17− open <- hIsOpen h
18− when open (hClose h)
19− removeFile path
20−
21−withRedirect :: Handle -> Handle -> IO a -> IO a
22−withRedirect tmp h = bracket_ swap swap
23− where
24− whenM p a = p >>= (`when` a)
25− swap = do
26− whenM (hIsOpen tmp) $ whenM (hIsWritable tmp) $ hFlush tmp
27− whenM (hIsOpen h) $ whenM (hIsWritable h) $ hFlush h
28− withHandle "spam" tmp $ \tmph -> do
29− hh <- withHandle "spam" h $ \hh ->
30− return (tmph,hh)
31− return (hh,())
tests/Tests.hsnew file+13
@@ -0,0 +1,13 @@
1+-- | Provides a simple main function which runs all the tests
2+--
3+module Main
4+ ( main
5+ ) where
6+
7+import Test.Framework (defaultMain)
8+
9+import qualified Tests.Properties as Properties
10+import qualified Tests.Regressions as Regressions
11+
12+main :: IO ()
13+main = defaultMain [Properties.tests, Regressions.tests]
tests/StdioCoverage.hs → tests/Tests/IO.hsrenamed+12−3
@@ -1,11 +1,20 @@
1+-- | Program which exposes some haskell functions as an exutable. The results
2+-- and coverage of this module is meant to be checked using a shell script.
3+--
4+module Main
5+ (
6+ main
7+ ) where
8+
9+import System.Environment (getArgs)
10+import System.Exit (exitFailure)
11+import System.IO (hPutStrLn, stderr)
112import qualified Data.Text as T
213import qualified Data.Text.IO as T
314import qualified Data.Text.Lazy as TL
415import qualified Data.Text.Lazy.IO as TL
5−import System.Environment (getArgs)
6−import System.Exit (exitFailure)
7−import System.IO (hPutStrLn, stderr)
816
17+main :: IO ()
918main = do
1019 args <- getArgs
1120 case args of
tests/Tests/Properties.hsnew file+1363
@@ -0,0 +1,1363 @@
1+-- | QuickCheck properties for the text library.
2+
3+{-# LANGUAGE BangPatterns, FlexibleInstances, OverloadedStrings,
4+ ScopedTypeVariables, TypeSynonymInstances #-}
5+{-# OPTIONS_GHC -fno-enable-rewrite-rules -fno-warn-missing-signatures #-}
6+module Tests.Properties
7+ (
8+ tests
9+ ) where
10+
11+import Control.Applicative ((<$>), (<*>))
12+import Control.Arrow ((***), second)
13+import Data.Bits ((.&.))
14+import Data.Char (chr, isDigit, isHexDigit, isLower, isSpace, isUpper, ord)
15+import Data.Int (Int8, Int16, Int32, Int64)
16+import Data.Monoid (Monoid(..))
17+import Data.String (IsString(fromString))
18+import Data.Text.Encoding.Error
19+import Data.Text.Foreign
20+import Data.Text.Internal.Encoding.Utf8
21+import Data.Text.Internal.Fusion.Size
22+import Data.Text.Internal.Search (indices)
23+import Data.Text.Lazy.Read as TL
24+import Data.Text.Read as T
25+import Data.Word (Word, Word8, Word16, Word32, Word64)
26+import Numeric (showEFloat, showFFloat, showGFloat, showHex)
27+import Prelude hiding (replicate)
28+import Test.Framework (Test, testGroup)
29+import Test.Framework.Providers.QuickCheck2 (testProperty)
30+import Test.QuickCheck hiding ((.&.))
31+import Test.QuickCheck.Monadic
32+import Test.QuickCheck.Property (Property(..))
33+import Tests.QuickCheckUtils
34+import Tests.Utils
35+import Text.Show.Functions ()
36+import qualified Control.Exception as Exception
37+import qualified Data.Bits as Bits (shiftL, shiftR)
38+import qualified Data.ByteString as B
39+import qualified Data.ByteString.Lazy as BL
40+import qualified Data.List as L
41+import qualified Data.Text as T
42+import qualified Data.Text.Encoding as E
43+import qualified Data.Text.IO as T
44+import qualified Data.Text.Internal.Fusion as S
45+import qualified Data.Text.Internal.Fusion.Common as S
46+import qualified Data.Text.Internal.Lazy.Fusion as SL
47+import qualified Data.Text.Internal.Lazy.Search as S (indices)
48+import qualified Data.Text.Internal.Unsafe.Shift as U
49+import qualified Data.Text.Lazy as TL
50+import qualified Data.Text.Lazy.Builder as TB
51+import qualified Data.Text.Lazy.Builder.Int as TB
52+import qualified Data.Text.Lazy.Builder.RealFloat as TB
53+import qualified Data.Text.Lazy.Encoding as EL
54+import qualified Data.Text.Lazy.IO as TL
55+import qualified System.IO as IO
56+import qualified Tests.Properties.Mul as Mul
57+import qualified Tests.SlowFunctions as Slow
58+
59+t_pack_unpack = (T.unpack . T.pack) `eq` id
60+tl_pack_unpack = (TL.unpack . TL.pack) `eq` id
61+t_stream_unstream = (S.unstream . S.stream) `eq` id
62+tl_stream_unstream = (SL.unstream . SL.stream) `eq` id
63+t_reverse_stream t = (S.reverse . S.reverseStream) t == t
64+t_singleton c = [c] == (T.unpack . T.singleton) c
65+tl_singleton c = [c] == (TL.unpack . TL.singleton) c
66+tl_unstreamChunks x = f 11 x == f 1000 x
67+ where f n = SL.unstreamChunks n . S.streamList
68+tl_chunk_unchunk = (TL.fromChunks . TL.toChunks) `eq` id
69+tl_from_to_strict = (TL.fromStrict . TL.toStrict) `eq` id
70+
71+-- Note: this silently truncates code-points > 255 to 8-bit due to 'B.pack'
72+encodeL1 :: T.Text -> B.ByteString
73+encodeL1 = B.pack . map (fromIntegral . fromEnum) . T.unpack
74+encodeLazyL1 :: TL.Text -> BL.ByteString
75+encodeLazyL1 = BL.fromChunks . map encodeL1 . TL.toChunks
76+
77+t_ascii t = E.decodeASCII (E.encodeUtf8 a) == a
78+ where a = T.map (\c -> chr (ord c `mod` 128)) t
79+tl_ascii t = EL.decodeASCII (EL.encodeUtf8 a) == a
80+ where a = TL.map (\c -> chr (ord c `mod` 128)) t
81+t_latin1 t = E.decodeLatin1 (encodeL1 a) == a
82+ where a = T.map (\c -> chr (ord c `mod` 256)) t
83+tl_latin1 t = EL.decodeLatin1 (encodeLazyL1 a) == a
84+ where a = TL.map (\c -> chr (ord c `mod` 256)) t
85+t_utf8 = forAll genUnicode $ (E.decodeUtf8 . E.encodeUtf8) `eq` id
86+t_utf8' = forAll genUnicode $ (E.decodeUtf8' . E.encodeUtf8) `eq` (id . Right)
87+tl_utf8 = forAll genUnicode $ (EL.decodeUtf8 . EL.encodeUtf8) `eq` id
88+tl_utf8' = forAll genUnicode $ (EL.decodeUtf8' . EL.encodeUtf8) `eq` (id . Right)
89+t_utf16LE = forAll genUnicode $ (E.decodeUtf16LE . E.encodeUtf16LE) `eq` id
90+tl_utf16LE = forAll genUnicode $ (EL.decodeUtf16LE . EL.encodeUtf16LE) `eq` id
91+t_utf16BE = forAll genUnicode $ (E.decodeUtf16BE . E.encodeUtf16BE) `eq` id
92+tl_utf16BE = forAll genUnicode $ (EL.decodeUtf16BE . EL.encodeUtf16BE) `eq` id
93+t_utf32LE = forAll genUnicode $ (E.decodeUtf32LE . E.encodeUtf32LE) `eq` id
94+tl_utf32LE = forAll genUnicode $ (EL.decodeUtf32LE . EL.encodeUtf32LE) `eq` id
95+t_utf32BE = forAll genUnicode $ (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id
96+tl_utf32BE = forAll genUnicode $ (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id
97+
98+t_utf8_incr = forAll genUnicode $ \s (Positive n) -> (recode n `eq` id) s
99+ where recode n = T.concat . map fst . feedChunksOf n E.streamDecodeUtf8 .
100+ E.encodeUtf8
101+
102+feedChunksOf :: Int -> (B.ByteString -> E.Decoding) -> B.ByteString
103+ -> [(T.Text, B.ByteString)]
104+feedChunksOf n f bs
105+ | B.null bs = []
106+ | otherwise = let (x,y) = B.splitAt n bs
107+ E.Some t b f' = f x
108+ in (t,b) : feedChunksOf n f' y
109+
110+t_utf8_undecoded = forAll genUnicode $ \t ->
111+ let b = E.encodeUtf8 t
112+ ls = concatMap (leftover . E.encodeUtf8 . T.singleton) . T.unpack $ t
113+ leftover = (++ [B.empty]) . init . tail . B.inits
114+ in (map snd . feedChunksOf 1 E.streamDecodeUtf8) b == ls
115+
116+data Badness = Solo | Leading | Trailing
117+ deriving (Eq, Show)
118+
119+instance Arbitrary Badness where
120+ arbitrary = elements [Solo, Leading, Trailing]
121+
122+t_utf8_err :: Badness -> DecodeErr -> Property
123+t_utf8_err bad de = do
124+ let gen = case bad of
125+ Solo -> genInvalidUTF8
126+ Leading -> B.append <$> genInvalidUTF8 <*> genUTF8
127+ Trailing -> B.append <$> genUTF8 <*> genInvalidUTF8
128+ genUTF8 = E.encodeUtf8 <$> genUnicode
129+ forAll gen $ \bs -> MkProperty $ do
130+ onErr <- genDecodeErr de
131+ unProperty . monadicIO $ do
132+ l <- run $ let len = T.length (E.decodeUtf8With onErr bs)
133+ in (len `seq` return (Right len)) `Exception.catch`
134+ (\(e::UnicodeException) -> return (Left e))
135+ assert $ case l of
136+ Left err -> length (show err) >= 0
137+ Right _ -> de /= Strict
138+
139+t_utf8_err' :: B.ByteString -> Property
140+t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of
141+ Left err -> length (show err) >= 0
142+ Right t -> T.length t >= 0
143+
144+genInvalidUTF8 :: Gen B.ByteString
145+genInvalidUTF8 = B.pack <$> oneof [
146+ -- invalid leading byte of a 2-byte sequence
147+ (:) <$> choose (0xC0, 0xC1) <*> upTo 1 contByte
148+ -- invalid leading byte of a 4-byte sequence
149+ , (:) <$> choose (0xF5, 0xFF) <*> upTo 3 contByte
150+ -- 4-byte sequence greater than U+10FFFF
151+ , do k <- choose (0x11, 0x13)
152+ let w0 = 0xF0 + (k `Bits.shiftR` 2)
153+ w1 = 0x80 + ((k .&. 3) `Bits.shiftL` 4)
154+ ([w0,w1]++) <$> vectorOf 2 contByte
155+ -- continuation bytes without a start byte
156+ , listOf1 contByte
157+ -- short 2-byte sequence
158+ , (:[]) <$> choose (0xC2, 0xDF)
159+ -- short 3-byte sequence
160+ , (:) <$> choose (0xE0, 0xEF) <*> upTo 1 contByte
161+ -- short 4-byte sequence
162+ , (:) <$> choose (0xF0, 0xF4) <*> upTo 2 contByte
163+ -- overlong encoding
164+ , do k <- choose (0,0xFFFF)
165+ let c = chr k
166+ case k of
167+ _ | k < 0x80 -> oneof [ let (w,x) = ord2 c in return [w,x]
168+ , let (w,x,y) = ord3 c in return [w,x,y]
169+ , let (w,x,y,z) = ord4 c in return [w,x,y,z] ]
170+ | k < 0x7FF -> oneof [ let (w,x,y) = ord3 c in return [w,x,y]
171+ , let (w,x,y,z) = ord4 c in return [w,x,y,z] ]
172+ | otherwise -> let (w,x,y,z) = ord4 c in return [w,x,y,z]
173+ ]
174+ where
175+ contByte = (0x80 +) <$> choose (0, 0x3f)
176+ upTo n gen = do
177+ k <- choose (0,n)
178+ vectorOf k gen
179+
180+s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList)
181+ where _types = s :: String
182+sf_Eq p s =
183+ ((L.filter p s==) . L.filter p) `eq`
184+ (((S.filter p $ S.streamList s)==) . S.filter p . S.streamList)
185+t_Eq s = (s==) `eq` ((T.pack s==) . T.pack)
186+tl_Eq s = (s==) `eq` ((TL.pack s==) . TL.pack)
187+s_Ord s = (compare s) `eq` (compare (S.streamList s) . S.streamList)
188+ where _types = s :: String
189+sf_Ord p s =
190+ ((compare $ L.filter p s) . L.filter p) `eq`
191+ (compare (S.filter p $ S.streamList s) . S.filter p . S.streamList)
192+t_Ord s = (compare s) `eq` (compare (T.pack s) . T.pack)
193+tl_Ord s = (compare s) `eq` (compare (TL.pack s) . TL.pack)
194+t_Read = id `eq` (T.unpack . read . show)
195+tl_Read = id `eq` (TL.unpack . read . show)
196+t_Show = show `eq` (show . T.pack)
197+tl_Show = show `eq` (show . TL.pack)
198+t_mappend s = mappend s`eqP` (unpackS . mappend (T.pack s))
199+tl_mappend s = mappend s`eqP` (unpackS . mappend (TL.pack s))
200+t_mconcat = unsquare $
201+ mconcat `eq` (unpackS . mconcat . L.map T.pack)
202+tl_mconcat = unsquare $
203+ mconcat `eq` (unpackS . mconcat . L.map TL.pack)
204+t_mempty = mempty == (unpackS (mempty :: T.Text))
205+tl_mempty = mempty == (unpackS (mempty :: TL.Text))
206+t_IsString = fromString `eqP` (T.unpack . fromString)
207+tl_IsString = fromString `eqP` (TL.unpack . fromString)
208+
209+s_cons x = (x:) `eqP` (unpackS . S.cons x)
210+s_cons_s x = (x:) `eqP` (unpackS . S.unstream . S.cons x)
211+sf_cons p x = ((x:) . L.filter p) `eqP` (unpackS . S.cons x . S.filter p)
212+t_cons x = (x:) `eqP` (unpackS . T.cons x)
213+tl_cons x = (x:) `eqP` (unpackS . TL.cons x)
214+s_snoc x = (++ [x]) `eqP` (unpackS . (flip S.snoc) x)
215+t_snoc x = (++ [x]) `eqP` (unpackS . (flip T.snoc) x)
216+tl_snoc x = (++ [x]) `eqP` (unpackS . (flip TL.snoc) x)
217+s_append s = (s++) `eqP` (unpackS . S.append (S.streamList s))
218+s_append_s s = (s++) `eqP`
219+ (unpackS . S.unstream . S.append (S.streamList s))
220+sf_append p s = (L.filter p s++) `eqP`
221+ (unpackS . S.append (S.filter p $ S.streamList s))
222+t_append s = (s++) `eqP` (unpackS . T.append (packS s))
223+
224+uncons (x:xs) = Just (x,xs)
225+uncons _ = Nothing
226+
227+s_uncons = uncons `eqP` (fmap (second unpackS) . S.uncons)
228+sf_uncons p = (uncons . L.filter p) `eqP`
229+ (fmap (second unpackS) . S.uncons . S.filter p)
230+t_uncons = uncons `eqP` (fmap (second unpackS) . T.uncons)
231+tl_uncons = uncons `eqP` (fmap (second unpackS) . TL.uncons)
232+s_head = head `eqP` S.head
233+sf_head p = (head . L.filter p) `eqP` (S.head . S.filter p)
234+t_head = head `eqP` T.head
235+tl_head = head `eqP` TL.head
236+s_last = last `eqP` S.last
237+sf_last p = (last . L.filter p) `eqP` (S.last . S.filter p)
238+t_last = last `eqP` T.last
239+tl_last = last `eqP` TL.last
240+s_tail = tail `eqP` (unpackS . S.tail)
241+s_tail_s = tail `eqP` (unpackS . S.unstream . S.tail)
242+sf_tail p = (tail . L.filter p) `eqP` (unpackS . S.tail . S.filter p)
243+t_tail = tail `eqP` (unpackS . T.tail)
244+tl_tail = tail `eqP` (unpackS . TL.tail)
245+s_init = init `eqP` (unpackS . S.init)
246+s_init_s = init `eqP` (unpackS . S.unstream . S.init)
247+sf_init p = (init . L.filter p) `eqP` (unpackS . S.init . S.filter p)
248+t_init = init `eqP` (unpackS . T.init)
249+tl_init = init `eqP` (unpackS . TL.init)
250+s_null = null `eqP` S.null
251+sf_null p = (null . L.filter p) `eqP` (S.null . S.filter p)
252+t_null = null `eqP` T.null
253+tl_null = null `eqP` TL.null
254+s_length = length `eqP` S.length
255+sf_length p = (length . L.filter p) `eqP` (S.length . S.filter p)
256+sl_length = (fromIntegral . length) `eqP` SL.length
257+t_length = length `eqP` T.length
258+tl_length = L.genericLength `eqP` TL.length
259+t_compareLength t = (compare (T.length t)) `eq` T.compareLength t
260+tl_compareLength t= (compare (TL.length t)) `eq` TL.compareLength t
261+
262+s_map f = map f `eqP` (unpackS . S.map f)
263+s_map_s f = map f `eqP` (unpackS . S.unstream . S.map f)
264+sf_map p f = (map f . L.filter p) `eqP` (unpackS . S.map f . S.filter p)
265+t_map f = map f `eqP` (unpackS . T.map f)
266+tl_map f = map f `eqP` (unpackS . TL.map f)
267+s_intercalate c = unsquare $
268+ L.intercalate c `eq`
269+ (unpackS . S.intercalate (packS c) . map packS)
270+t_intercalate c = unsquare $
271+ L.intercalate c `eq`
272+ (unpackS . T.intercalate (packS c) . map packS)
273+tl_intercalate c = unsquare $
274+ L.intercalate c `eq`
275+ (unpackS . TL.intercalate (TL.pack c) . map TL.pack)
276+s_intersperse c = L.intersperse c `eqP`
277+ (unpackS . S.intersperse c)
278+s_intersperse_s c = L.intersperse c `eqP`
279+ (unpackS . S.unstream . S.intersperse c)
280+sf_intersperse p c= (L.intersperse c . L.filter p) `eqP`
281+ (unpackS . S.intersperse c . S.filter p)
282+t_intersperse c = unsquare $
283+ L.intersperse c `eqP` (unpackS . T.intersperse c)
284+tl_intersperse c = unsquare $
285+ L.intersperse c `eqP` (unpackS . TL.intersperse c)
286+t_transpose = unsquare $
287+ L.transpose `eq` (map unpackS . T.transpose . map packS)
288+tl_transpose = unsquare $
289+ L.transpose `eq` (map unpackS . TL.transpose . map TL.pack)
290+t_reverse = L.reverse `eqP` (unpackS . T.reverse)
291+tl_reverse = L.reverse `eqP` (unpackS . TL.reverse)
292+t_reverse_short n = L.reverse `eqP` (unpackS . S.reverse . shorten n . S.stream)
293+
294+t_replace s d = (L.intercalate d . splitOn s) `eqP`
295+ (unpackS . T.replace (T.pack s) (T.pack d))
296+tl_replace s d = (L.intercalate d . splitOn s) `eqP`
297+ (unpackS . TL.replace (TL.pack s) (TL.pack d))
298+
299+splitOn :: (Eq a) => [a] -> [a] -> [[a]]
300+splitOn pat src0
301+ | l == 0 = error "splitOn: empty"
302+ | otherwise = go src0
303+ where
304+ l = length pat
305+ go src = search 0 src
306+ where
307+ search _ [] = [src]
308+ search !n s@(_:s')
309+ | pat `L.isPrefixOf` s = take n src : go (drop l s)
310+ | otherwise = search (n+1) s'
311+
312+s_toCaseFold_length xs = S.length (S.toCaseFold s) >= length xs
313+ where s = S.streamList xs
314+sf_toCaseFold_length p xs =
315+ (S.length . S.toCaseFold . S.filter p $ s) >= (length . L.filter p $ xs)
316+ where s = S.streamList xs
317+t_toCaseFold_length t = T.length (T.toCaseFold t) >= T.length t
318+tl_toCaseFold_length t = TL.length (TL.toCaseFold t) >= TL.length t
319+t_toLower_length t = T.length (T.toLower t) >= T.length t
320+t_toLower_lower t = p (T.toLower t) >= p t
321+ where p = T.length . T.filter isLower
322+tl_toLower_lower t = p (TL.toLower t) >= p t
323+ where p = TL.length . TL.filter isLower
324+t_toUpper_length t = T.length (T.toUpper t) >= T.length t
325+t_toUpper_upper t = p (T.toUpper t) >= p t
326+ where p = T.length . T.filter isUpper
327+tl_toUpper_upper t = p (TL.toUpper t) >= p t
328+ where p = TL.length . TL.filter isUpper
329+
330+justifyLeft k c xs = xs ++ L.replicate (k - length xs) c
331+justifyRight m n xs = L.replicate (m - length xs) n ++ xs
332+center k c xs
333+ | len >= k = xs
334+ | otherwise = L.replicate l c ++ xs ++ L.replicate r c
335+ where len = length xs
336+ d = k - len
337+ r = d `div` 2
338+ l = d - r
339+
340+s_justifyLeft k c = justifyLeft j c `eqP` (unpackS . S.justifyLeftI j c)
341+ where j = fromIntegral (k :: Word8)
342+s_justifyLeft_s k c = justifyLeft j c `eqP`
343+ (unpackS . S.unstream . S.justifyLeftI j c)
344+ where j = fromIntegral (k :: Word8)
345+sf_justifyLeft p k c = (justifyLeft j c . L.filter p) `eqP`
346+ (unpackS . S.justifyLeftI j c . S.filter p)
347+ where j = fromIntegral (k :: Word8)
348+t_justifyLeft k c = justifyLeft j c `eqP` (unpackS . T.justifyLeft j c)
349+ where j = fromIntegral (k :: Word8)
350+tl_justifyLeft k c = justifyLeft j c `eqP`
351+ (unpackS . TL.justifyLeft (fromIntegral j) c)
352+ where j = fromIntegral (k :: Word8)
353+t_justifyRight k c = justifyRight j c `eqP` (unpackS . T.justifyRight j c)
354+ where j = fromIntegral (k :: Word8)
355+tl_justifyRight k c = justifyRight j c `eqP`
356+ (unpackS . TL.justifyRight (fromIntegral j) c)
357+ where j = fromIntegral (k :: Word8)
358+t_center k c = center j c `eqP` (unpackS . T.center j c)
359+ where j = fromIntegral (k :: Word8)
360+tl_center k c = center j c `eqP` (unpackS . TL.center (fromIntegral j) c)
361+ where j = fromIntegral (k :: Word8)
362+
363+sf_foldl p f z = (L.foldl f z . L.filter p) `eqP` (S.foldl f z . S.filter p)
364+ where _types = f :: Char -> Char -> Char
365+t_foldl f z = L.foldl f z `eqP` (T.foldl f z)
366+ where _types = f :: Char -> Char -> Char
367+tl_foldl f z = L.foldl f z `eqP` (TL.foldl f z)
368+ where _types = f :: Char -> Char -> Char
369+sf_foldl' p f z = (L.foldl' f z . L.filter p) `eqP`
370+ (S.foldl' f z . S.filter p)
371+ where _types = f :: Char -> Char -> Char
372+t_foldl' f z = L.foldl' f z `eqP` T.foldl' f z
373+ where _types = f :: Char -> Char -> Char
374+tl_foldl' f z = L.foldl' f z `eqP` TL.foldl' f z
375+ where _types = f :: Char -> Char -> Char
376+sf_foldl1 p f = (L.foldl1 f . L.filter p) `eqP` (S.foldl1 f . S.filter p)
377+t_foldl1 f = L.foldl1 f `eqP` T.foldl1 f
378+tl_foldl1 f = L.foldl1 f `eqP` TL.foldl1 f
379+sf_foldl1' p f = (L.foldl1' f . L.filter p) `eqP` (S.foldl1' f . S.filter p)
380+t_foldl1' f = L.foldl1' f `eqP` T.foldl1' f
381+tl_foldl1' f = L.foldl1' f `eqP` TL.foldl1' f
382+sf_foldr p f z = (L.foldr f z . L.filter p) `eqP` (S.foldr f z . S.filter p)
383+ where _types = f :: Char -> Char -> Char
384+t_foldr f z = L.foldr f z `eqP` T.foldr f z
385+ where _types = f :: Char -> Char -> Char
386+tl_foldr f z = unsquare $
387+ L.foldr f z `eqP` TL.foldr f z
388+ where _types = f :: Char -> Char -> Char
389+sf_foldr1 p f = unsquare $
390+ (L.foldr1 f . L.filter p) `eqP` (S.foldr1 f . S.filter p)
391+t_foldr1 f = L.foldr1 f `eqP` T.foldr1 f
392+tl_foldr1 f = unsquare $
393+ L.foldr1 f `eqP` TL.foldr1 f
394+
395+s_concat_s = unsquare $
396+ L.concat `eq` (unpackS . S.unstream . S.concat . map packS)
397+sf_concat p = unsquare $
398+ (L.concat . map (L.filter p)) `eq`
399+ (unpackS . S.concat . map (S.filter p . packS))
400+t_concat = unsquare $
401+ L.concat `eq` (unpackS . T.concat . map packS)
402+tl_concat = unsquare $
403+ L.concat `eq` (unpackS . TL.concat . map TL.pack)
404+sf_concatMap p f = unsquare $ (L.concatMap f . L.filter p) `eqP`
405+ (unpackS . S.concatMap (packS . f) . S.filter p)
406+t_concatMap f = unsquare $
407+ L.concatMap f `eqP` (unpackS . T.concatMap (packS . f))
408+tl_concatMap f = unsquare $
409+ L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f))
410+sf_any q p = (L.any p . L.filter q) `eqP` (S.any p . S.filter q)
411+t_any p = L.any p `eqP` T.any p
412+tl_any p = L.any p `eqP` TL.any p
413+sf_all q p = (L.all p . L.filter q) `eqP` (S.all p . S.filter q)
414+t_all p = L.all p `eqP` T.all p
415+tl_all p = L.all p `eqP` TL.all p
416+sf_maximum p = (L.maximum . L.filter p) `eqP` (S.maximum . S.filter p)
417+t_maximum = L.maximum `eqP` T.maximum
418+tl_maximum = L.maximum `eqP` TL.maximum
419+sf_minimum p = (L.minimum . L.filter p) `eqP` (S.minimum . S.filter p)
420+t_minimum = L.minimum `eqP` T.minimum
421+tl_minimum = L.minimum `eqP` TL.minimum
422+
423+sf_scanl p f z = (L.scanl f z . L.filter p) `eqP`
424+ (unpackS . S.scanl f z . S.filter p)
425+t_scanl f z = L.scanl f z `eqP` (unpackS . T.scanl f z)
426+tl_scanl f z = L.scanl f z `eqP` (unpackS . TL.scanl f z)
427+t_scanl1 f = L.scanl1 f `eqP` (unpackS . T.scanl1 f)
428+tl_scanl1 f = L.scanl1 f `eqP` (unpackS . TL.scanl1 f)
429+t_scanr f z = L.scanr f z `eqP` (unpackS . T.scanr f z)
430+tl_scanr f z = L.scanr f z `eqP` (unpackS . TL.scanr f z)
431+t_scanr1 f = L.scanr1 f `eqP` (unpackS . T.scanr1 f)
432+tl_scanr1 f = L.scanr1 f `eqP` (unpackS . TL.scanr1 f)
433+
434+t_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . T.mapAccumL f z)
435+ where _types = f :: Int -> Char -> (Int,Char)
436+tl_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . TL.mapAccumL f z)
437+ where _types = f :: Int -> Char -> (Int,Char)
438+t_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . T.mapAccumR f z)
439+ where _types = f :: Int -> Char -> (Int,Char)
440+tl_mapAccumR f z = L.mapAccumR f z `eqP` (second unpackS . TL.mapAccumR f z)
441+ where _types = f :: Int -> Char -> (Int,Char)
442+
443+tl_repeat n = (L.take m . L.repeat) `eq`
444+ (unpackS . TL.take (fromIntegral m) . TL.repeat)
445+ where m = fromIntegral (n :: Word8)
446+
447+replicate n l = concat (L.replicate n l)
448+
449+s_replicate n = replicate m `eq`
450+ (unpackS . S.replicateI (fromIntegral m) . packS)
451+ where m = fromIntegral (n :: Word8)
452+t_replicate n = replicate m `eq` (unpackS . T.replicate m . packS)
453+ where m = fromIntegral (n :: Word8)
454+tl_replicate n = replicate m `eq`
455+ (unpackS . TL.replicate (fromIntegral m) . packS)
456+ where m = fromIntegral (n :: Word8)
457+
458+tl_cycle n = (L.take m . L.cycle) `eq`
459+ (unpackS . TL.take (fromIntegral m) . TL.cycle . packS)
460+ where m = fromIntegral (n :: Word8)
461+
462+tl_iterate f n = (L.take m . L.iterate f) `eq`
463+ (unpackS . TL.take (fromIntegral m) . TL.iterate f)
464+ where m = fromIntegral (n :: Word8)
465+
466+unf :: Int -> Char -> Maybe (Char, Char)
467+unf n c | fromEnum c * 100 > n = Nothing
468+ | otherwise = Just (c, succ c)
469+
470+t_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . T.unfoldr (unf m))
471+ where m = fromIntegral (n :: Word16)
472+tl_unfoldr n = L.unfoldr (unf m) `eq` (unpackS . TL.unfoldr (unf m))
473+ where m = fromIntegral (n :: Word16)
474+t_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`
475+ (unpackS . T.unfoldrN i (unf j))
476+ where i = fromIntegral (n :: Word16)
477+ j = fromIntegral (m :: Word16)
478+tl_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq`
479+ (unpackS . TL.unfoldrN (fromIntegral i) (unf j))
480+ where i = fromIntegral (n :: Word16)
481+ j = fromIntegral (m :: Word16)
482+
483+unpack2 :: (Stringy s) => (s,s) -> (String,String)
484+unpack2 = unpackS *** unpackS
485+
486+s_take n = L.take n `eqP` (unpackS . S.take n)
487+s_take_s m = L.take n `eqP` (unpackS . S.unstream . S.take n)
488+ where n = small m
489+sf_take p n = (L.take n . L.filter p) `eqP`
490+ (unpackS . S.take n . S.filter p)
491+t_take n = L.take n `eqP` (unpackS . T.take n)
492+t_takeEnd n = (L.reverse . L.take n . L.reverse) `eqP`
493+ (unpackS . T.takeEnd n)
494+tl_take n = L.take n `eqP` (unpackS . TL.take (fromIntegral n))
495+tl_takeEnd n = (L.reverse . L.take (fromIntegral n) . L.reverse) `eqP`
496+ (unpackS . TL.takeEnd n)
497+s_drop n = L.drop n `eqP` (unpackS . S.drop n)
498+s_drop_s m = L.drop n `eqP` (unpackS . S.unstream . S.drop n)
499+ where n = small m
500+sf_drop p n = (L.drop n . L.filter p) `eqP`
501+ (unpackS . S.drop n . S.filter p)
502+t_drop n = L.drop n `eqP` (unpackS . T.drop n)
503+t_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`
504+ (unpackS . T.dropEnd n)
505+tl_drop n = L.drop n `eqP` (unpackS . TL.drop (fromIntegral n))
506+tl_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`
507+ (unpackS . TL.dropEnd (fromIntegral n))
508+s_take_drop m = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)
509+ where n = small m
510+s_take_drop_s m = (L.take n . L.drop n) `eqP`
511+ (unpackS . S.unstream . S.take n . S.drop n)
512+ where n = small m
513+s_takeWhile p = L.takeWhile p `eqP` (unpackS . S.takeWhile p)
514+s_takeWhile_s p = L.takeWhile p `eqP` (unpackS . S.unstream . S.takeWhile p)
515+sf_takeWhile q p = (L.takeWhile p . L.filter q) `eqP`
516+ (unpackS . S.takeWhile p . S.filter q)
517+t_takeWhile p = L.takeWhile p `eqP` (unpackS . T.takeWhile p)
518+tl_takeWhile p = L.takeWhile p `eqP` (unpackS . TL.takeWhile p)
519+t_takeWhileEnd p = (L.reverse . L.takeWhile p . L.reverse) `eqP`
520+ (unpackS . T.takeWhileEnd p)
521+tl_takeWhileEnd p = (L.reverse . L.takeWhile p . L.reverse) `eqP`
522+ (unpackS . TL.takeWhileEnd p)
523+s_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)
524+s_dropWhile_s p = L.dropWhile p `eqP` (unpackS . S.unstream . S.dropWhile p)
525+sf_dropWhile q p = (L.dropWhile p . L.filter q) `eqP`
526+ (unpackS . S.dropWhile p . S.filter q)
527+t_dropWhile p = L.dropWhile p `eqP` (unpackS . T.dropWhile p)
528+tl_dropWhile p = L.dropWhile p `eqP` (unpackS . S.dropWhile p)
529+t_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`
530+ (unpackS . T.dropWhileEnd p)
531+tl_dropWhileEnd p = (L.reverse . L.dropWhile p . L.reverse) `eqP`
532+ (unpackS . TL.dropWhileEnd p)
533+t_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)
534+ `eqP` (unpackS . T.dropAround p)
535+tl_dropAround p = (L.dropWhile p . L.reverse . L.dropWhile p . L.reverse)
536+ `eqP` (unpackS . TL.dropAround p)
537+t_stripStart = T.dropWhile isSpace `eq` T.stripStart
538+tl_stripStart = TL.dropWhile isSpace `eq` TL.stripStart
539+t_stripEnd = T.dropWhileEnd isSpace `eq` T.stripEnd
540+tl_stripEnd = TL.dropWhileEnd isSpace `eq` TL.stripEnd
541+t_strip = T.dropAround isSpace `eq` T.strip
542+tl_strip = TL.dropAround isSpace `eq` TL.strip
543+t_splitAt n = L.splitAt n `eqP` (unpack2 . T.splitAt n)
544+tl_splitAt n = L.splitAt n `eqP` (unpack2 . TL.splitAt (fromIntegral n))
545+t_span p = L.span p `eqP` (unpack2 . T.span p)
546+tl_span p = L.span p `eqP` (unpack2 . TL.span p)
547+
548+t_breakOn_id s = squid `eq` (uncurry T.append . T.breakOn s)
549+ where squid t | T.null s = error "empty"
550+ | otherwise = t
551+tl_breakOn_id s = squid `eq` (uncurry TL.append . TL.breakOn s)
552+ where squid t | TL.null s = error "empty"
553+ | otherwise = t
554+t_breakOn_start (NotEmpty s) t =
555+ let (k,m) = T.breakOn s t
556+ in k `T.isPrefixOf` t && (T.null m || s `T.isPrefixOf` m)
557+tl_breakOn_start (NotEmpty s) t =
558+ let (k,m) = TL.breakOn s t
559+ in k `TL.isPrefixOf` t && TL.null m || s `TL.isPrefixOf` m
560+t_breakOnEnd_end (NotEmpty s) t =
561+ let (m,k) = T.breakOnEnd s t
562+ in k `T.isSuffixOf` t && (T.null m || s `T.isSuffixOf` m)
563+tl_breakOnEnd_end (NotEmpty s) t =
564+ let (m,k) = TL.breakOnEnd s t
565+ in k `TL.isSuffixOf` t && (TL.null m || s `TL.isSuffixOf` m)
566+t_break p = L.break p `eqP` (unpack2 . T.break p)
567+tl_break p = L.break p `eqP` (unpack2 . TL.break p)
568+t_group = L.group `eqP` (map unpackS . T.group)
569+tl_group = L.group `eqP` (map unpackS . TL.group)
570+t_groupBy p = L.groupBy p `eqP` (map unpackS . T.groupBy p)
571+tl_groupBy p = L.groupBy p `eqP` (map unpackS . TL.groupBy p)
572+t_inits = L.inits `eqP` (map unpackS . T.inits)
573+tl_inits = L.inits `eqP` (map unpackS . TL.inits)
574+t_tails = L.tails `eqP` (map unpackS . T.tails)
575+tl_tails = unsquare $
576+ L.tails `eqP` (map unpackS . TL.tails)
577+t_findAppendId = unsquare $ \(NotEmpty s) ts ->
578+ let t = T.intercalate s ts
579+ in all (==t) $ map (uncurry T.append) (T.breakOnAll s t)
580+tl_findAppendId = unsquare $ \(NotEmpty s) ts ->
581+ let t = TL.intercalate s ts
582+ in all (==t) $ map (uncurry TL.append) (TL.breakOnAll s t)
583+t_findContains = unsquare $ \(NotEmpty s) ->
584+ all (T.isPrefixOf s . snd) . T.breakOnAll s . T.intercalate s
585+tl_findContains = unsquare $ \(NotEmpty s) -> all (TL.isPrefixOf s . snd) .
586+ TL.breakOnAll s . TL.intercalate s
587+sl_filterCount c = (L.genericLength . L.filter (==c)) `eqP` SL.countChar c
588+t_findCount s = (L.length . T.breakOnAll s) `eq` T.count s
589+tl_findCount s = (L.genericLength . TL.breakOnAll s) `eq` TL.count s
590+
591+t_splitOn_split s = unsquare $
592+ (T.splitOn s `eq` Slow.splitOn s) . T.intercalate s
593+tl_splitOn_split s = unsquare $
594+ ((TL.splitOn (TL.fromStrict s) . TL.fromStrict) `eq`
595+ (map TL.fromStrict . T.splitOn s)) . T.intercalate s
596+t_splitOn_i (NotEmpty t) = id `eq` (T.intercalate t . T.splitOn t)
597+tl_splitOn_i (NotEmpty t) = id `eq` (TL.intercalate t . TL.splitOn t)
598+
599+t_split p = split p `eqP` (map unpackS . T.split p)
600+t_split_count c = (L.length . T.split (==c)) `eq`
601+ ((1+) . T.count (T.singleton c))
602+t_split_splitOn c = T.split (==c) `eq` T.splitOn (T.singleton c)
603+tl_split p = split p `eqP` (map unpackS . TL.split p)
604+
605+split :: (a -> Bool) -> [a] -> [[a]]
606+split _ [] = [[]]
607+split p xs = loop xs
608+ where loop s | null s' = [l]
609+ | otherwise = l : loop (tail s')
610+ where (l, s') = break p s
611+
612+t_chunksOf_same_lengths k = all ((==k) . T.length) . ini . T.chunksOf k
613+ where ini [] = []
614+ ini xs = init xs
615+
616+t_chunksOf_length k t = len == T.length t || (k <= 0 && len == 0)
617+ where len = L.sum . L.map T.length $ T.chunksOf k t
618+
619+tl_chunksOf k = T.chunksOf k `eq` (map (T.concat . TL.toChunks) .
620+ TL.chunksOf (fromIntegral k) . TL.fromStrict)
621+
622+t_lines = L.lines `eqP` (map unpackS . T.lines)
623+tl_lines = L.lines `eqP` (map unpackS . TL.lines)
624+{-
625+t_lines' = lines' `eqP` (map unpackS . T.lines')
626+ where lines' "" = []
627+ lines' s = let (l, s') = break eol s
628+ in l : case s' of
629+ [] -> []
630+ ('\r':'\n':s'') -> lines' s''
631+ (_:s'') -> lines' s''
632+ eol c = c == '\r' || c == '\n'
633+-}
634+t_words = L.words `eqP` (map unpackS . T.words)
635+
636+tl_words = L.words `eqP` (map unpackS . TL.words)
637+t_unlines = unsquare $
638+ L.unlines `eq` (unpackS . T.unlines . map packS)
639+tl_unlines = unsquare $
640+ L.unlines `eq` (unpackS . TL.unlines . map packS)
641+t_unwords = unsquare $
642+ L.unwords `eq` (unpackS . T.unwords . map packS)
643+tl_unwords = unsquare $
644+ L.unwords `eq` (unpackS . TL.unwords . map packS)
645+
646+s_isPrefixOf s = L.isPrefixOf s `eqP`
647+ (S.isPrefixOf (S.stream $ packS s) . S.stream)
648+sf_isPrefixOf p s = (L.isPrefixOf s . L.filter p) `eqP`
649+ (S.isPrefixOf (S.stream $ packS s) . S.filter p . S.stream)
650+t_isPrefixOf s = L.isPrefixOf s`eqP` T.isPrefixOf (packS s)
651+tl_isPrefixOf s = L.isPrefixOf s`eqP` TL.isPrefixOf (packS s)
652+t_isSuffixOf s = L.isSuffixOf s`eqP` T.isSuffixOf (packS s)
653+tl_isSuffixOf s = L.isSuffixOf s`eqP` TL.isSuffixOf (packS s)
654+t_isInfixOf s = L.isInfixOf s `eqP` T.isInfixOf (packS s)
655+tl_isInfixOf s = L.isInfixOf s `eqP` TL.isInfixOf (packS s)
656+
657+t_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` T.stripPrefix (packS s)
658+tl_stripPrefix s = (fmap packS . L.stripPrefix s) `eqP` TL.stripPrefix (packS s)
659+
660+stripSuffix p t = reverse `fmap` L.stripPrefix (reverse p) (reverse t)
661+
662+t_stripSuffix s = (fmap packS . stripSuffix s) `eqP` T.stripSuffix (packS s)
663+tl_stripSuffix s = (fmap packS . stripSuffix s) `eqP` TL.stripSuffix (packS s)
664+
665+commonPrefixes a0@(_:_) b0@(_:_) = Just (go a0 b0 [])
666+ where go (a:as) (b:bs) ps
667+ | a == b = go as bs (a:ps)
668+ go as bs ps = (reverse ps,as,bs)
669+commonPrefixes _ _ = Nothing
670+
671+t_commonPrefixes a b (NonEmpty p)
672+ = commonPrefixes pa pb ==
673+ repack `fmap` T.commonPrefixes (packS pa) (packS pb)
674+ where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)
675+ pa = p ++ a
676+ pb = p ++ b
677+
678+tl_commonPrefixes a b (NonEmpty p)
679+ = commonPrefixes pa pb ==
680+ repack `fmap` TL.commonPrefixes (packS pa) (packS pb)
681+ where repack (x,y,z) = (unpackS x,unpackS y,unpackS z)
682+ pa = p ++ a
683+ pb = p ++ b
684+
685+sf_elem p c = (L.elem c . L.filter p) `eqP` (S.elem c . S.filter p)
686+sf_filter q p = (L.filter p . L.filter q) `eqP`
687+ (unpackS . S.filter p . S.filter q)
688+t_filter p = L.filter p `eqP` (unpackS . T.filter p)
689+tl_filter p = L.filter p `eqP` (unpackS . TL.filter p)
690+sf_findBy q p = (L.find p . L.filter q) `eqP` (S.findBy p . S.filter q)
691+t_find p = L.find p `eqP` T.find p
692+tl_find p = L.find p `eqP` TL.find p
693+t_partition p = L.partition p `eqP` (unpack2 . T.partition p)
694+tl_partition p = L.partition p `eqP` (unpack2 . TL.partition p)
695+
696+sf_index p s = forAll (choose (-l,l*2))
697+ ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))
698+ where l = L.length s
699+t_index s = forAll (choose (-l,l*2)) ((s L.!!) `eq` T.index (packS s))
700+ where l = L.length s
701+
702+tl_index s = forAll (choose (-l,l*2))
703+ ((s L.!!) `eq` (TL.index (packS s) . fromIntegral))
704+ where l = L.length s
705+
706+t_findIndex p = L.findIndex p `eqP` T.findIndex p
707+t_count (NotEmpty t) = (subtract 1 . L.length . T.splitOn t) `eq` T.count t
708+tl_count (NotEmpty t) = (subtract 1 . L.genericLength . TL.splitOn t) `eq`
709+ TL.count t
710+t_zip s = L.zip s `eqP` T.zip (packS s)
711+tl_zip s = L.zip s `eqP` TL.zip (packS s)
712+sf_zipWith p c s = (L.zipWith c (L.filter p s) . L.filter p) `eqP`
713+ (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p)
714+t_zipWith c s = L.zipWith c s `eqP` (unpackS . T.zipWith c (packS s))
715+tl_zipWith c s = L.zipWith c s `eqP` (unpackS . TL.zipWith c (packS s))
716+
717+t_indices (NotEmpty s) = Slow.indices s `eq` indices s
718+tl_indices (NotEmpty s) = lazyIndices s `eq` S.indices s
719+ where lazyIndices ss t = map fromIntegral $ Slow.indices (conc ss) (conc t)
720+ conc = T.concat . TL.toChunks
721+t_indices_occurs = unsquare $ \(NotEmpty t) ts ->
722+ let s = T.intercalate t ts
723+ in Slow.indices t s == indices t s
724+
725+-- Bit shifts.
726+shiftL w = forAll (choose (0,width-1)) $ \k -> Bits.shiftL w k == U.shiftL w k
727+ where width = round (log (fromIntegral m) / log 2 :: Double)
728+ (m,_) = (maxBound, m == w)
729+shiftR w = forAll (choose (0,width-1)) $ \k -> Bits.shiftR w k == U.shiftR w k
730+ where width = round (log (fromIntegral m) / log 2 :: Double)
731+ (m,_) = (maxBound, m == w)
732+
733+shiftL_Int = shiftL :: Int -> Property
734+shiftL_Word16 = shiftL :: Word16 -> Property
735+shiftL_Word32 = shiftL :: Word32 -> Property
736+shiftR_Int = shiftR :: Int -> Property
737+shiftR_Word16 = shiftR :: Word16 -> Property
738+shiftR_Word32 = shiftR :: Word32 -> Property
739+
740+-- Builder.
741+
742+tb_singleton = id `eqP`
743+ (unpackS . TB.toLazyText . mconcat . map TB.singleton)
744+tb_fromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat .
745+ map (TB.fromText . packS))
746+tb_associative s1 s2 s3 =
747+ TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==
748+ TB.toLazyText ((b1 `mappend` b2) `mappend` b3)
749+ where b1 = TB.fromText (packS s1)
750+ b2 = TB.fromText (packS s2)
751+ b3 = TB.fromText (packS s3)
752+
753+-- Numeric builder stuff.
754+
755+tb_decimal :: (Integral a, Show a) => a -> Bool
756+tb_decimal = (TB.toLazyText . TB.decimal) `eq` (TL.pack . show)
757+
758+tb_decimal_integer (a::Integer) = tb_decimal a
759+tb_decimal_integer_big (Big a) = tb_decimal a
760+tb_decimal_int (a::Int) = tb_decimal a
761+tb_decimal_int8 (a::Int8) = tb_decimal a
762+tb_decimal_int16 (a::Int16) = tb_decimal a
763+tb_decimal_int32 (a::Int32) = tb_decimal a
764+tb_decimal_int64 (a::Int64) = tb_decimal a
765+tb_decimal_word (a::Word) = tb_decimal a
766+tb_decimal_word8 (a::Word8) = tb_decimal a
767+tb_decimal_word16 (a::Word16) = tb_decimal a
768+tb_decimal_word32 (a::Word32) = tb_decimal a
769+tb_decimal_word64 (a::Word64) = tb_decimal a
770+
771+tb_decimal_big_int (BigBounded (a::Int)) = tb_decimal a
772+tb_decimal_big_int64 (BigBounded (a::Int64)) = tb_decimal a
773+tb_decimal_big_word (BigBounded (a::Word)) = tb_decimal a
774+tb_decimal_big_word64 (BigBounded (a::Word64)) = tb_decimal a
775+
776+tb_hex :: (Integral a, Show a) => a -> Bool
777+tb_hex = (TB.toLazyText . TB.hexadecimal) `eq` (TL.pack . flip showHex "")
778+
779+tb_hexadecimal_integer (a::Integer) = tb_hex a
780+tb_hexadecimal_int (a::Int) = tb_hex a
781+tb_hexadecimal_int8 (a::Int8) = tb_hex a
782+tb_hexadecimal_int16 (a::Int16) = tb_hex a
783+tb_hexadecimal_int32 (a::Int32) = tb_hex a
784+tb_hexadecimal_int64 (a::Int64) = tb_hex a
785+tb_hexadecimal_word (a::Word) = tb_hex a
786+tb_hexadecimal_word8 (a::Word8) = tb_hex a
787+tb_hexadecimal_word16 (a::Word16) = tb_hex a
788+tb_hexadecimal_word32 (a::Word32) = tb_hex a
789+tb_hexadecimal_word64 (a::Word64) = tb_hex a
790+
791+tb_realfloat :: (RealFloat a, Show a) => a -> Bool
792+tb_realfloat = (TB.toLazyText . TB.realFloat) `eq` (TL.pack . show)
793+
794+tb_realfloat_float (a::Float) = tb_realfloat a
795+tb_realfloat_double (a::Double) = tb_realfloat a
796+
797+showFloat :: (RealFloat a) => TB.FPFormat -> Maybe Int -> a -> ShowS
798+showFloat TB.Exponent = showEFloat
799+showFloat TB.Fixed = showFFloat
800+showFloat TB.Generic = showGFloat
801+
802+tb_formatRealFloat :: (RealFloat a, Show a) =>
803+ a -> TB.FPFormat -> Precision a -> Property
804+tb_formatRealFloat a fmt prec =
805+ TB.formatRealFloat fmt p a ===
806+ TB.fromString (showFloat fmt p a "")
807+ where p = precision a prec
808+
809+tb_formatRealFloat_float (a::Float) = tb_formatRealFloat a
810+tb_formatRealFloat_double (a::Double) = tb_formatRealFloat a
811+
812+-- Reading.
813+
814+t_decimal (n::Int) s =
815+ T.signed T.decimal (T.pack (show n) `T.append` t) == Right (n,t)
816+ where t = T.dropWhile isDigit s
817+tl_decimal (n::Int) s =
818+ TL.signed TL.decimal (TL.pack (show n) `TL.append` t) == Right (n,t)
819+ where t = TL.dropWhile isDigit s
820+t_hexadecimal m s ox =
821+ T.hexadecimal (T.concat [p, T.pack (showHex n ""), t]) == Right (n,t)
822+ where t = T.dropWhile isHexDigit s
823+ p = if ox then "0x" else ""
824+ n = getPositive m :: Int
825+tl_hexadecimal m s ox =
826+ TL.hexadecimal (TL.concat [p, TL.pack (showHex n ""), t]) == Right (n,t)
827+ where t = TL.dropWhile isHexDigit s
828+ p = if ox then "0x" else ""
829+ n = getPositive m :: Int
830+
831+isFloaty c = c `elem` ("+-.0123456789eE" :: String)
832+
833+t_read_rational p tol (n::Double) s =
834+ case p (T.pack (show n) `T.append` t) of
835+ Left _err -> False
836+ Right (n',t') -> t == t' && abs (n-n') <= tol
837+ where t = T.dropWhile isFloaty s
838+
839+tl_read_rational p tol (n::Double) s =
840+ case p (TL.pack (show n) `TL.append` t) of
841+ Left _err -> False
842+ Right (n',t') -> t == t' && abs (n-n') <= tol
843+ where t = TL.dropWhile isFloaty s
844+
845+t_double = t_read_rational T.double 1e-13
846+tl_double = tl_read_rational TL.double 1e-13
847+t_rational = t_read_rational T.rational 1e-16
848+tl_rational = tl_read_rational TL.rational 1e-16
849+
850+-- Input and output.
851+
852+t_put_get = write_read T.unlines T.filter put get
853+ where put h = withRedirect h IO.stdout . T.putStr
854+ get h = withRedirect h IO.stdin T.getContents
855+tl_put_get = write_read TL.unlines TL.filter put get
856+ where put h = withRedirect h IO.stdout . TL.putStr
857+ get h = withRedirect h IO.stdin TL.getContents
858+t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents
859+tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents
860+
861+t_write_read_line e m b t = write_read head T.filter T.hPutStrLn
862+ T.hGetLine e m b [t]
863+tl_write_read_line e m b t = write_read head TL.filter TL.hPutStrLn
864+ TL.hGetLine e m b [t]
865+
866+-- Low-level.
867+
868+t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t
869+t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t
870+t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) == t
871+ where n = small m
872+t_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)
873+
874+t_copy t = T.copy t == t
875+
876+-- Regression tests.
877+s_filter_eq s = S.filter p t == S.streamList (filter p s)
878+ where p = (/= S.last t)
879+ t = S.streamList s
880+
881+-- Make a stream appear shorter than it really is, to ensure that
882+-- functions that consume inaccurately sized streams behave
883+-- themselves.
884+shorten :: Int -> S.Stream a -> S.Stream a
885+shorten n t@(S.Stream arr off len)
886+ | n > 0 = S.Stream arr off (smaller (exactSize n) len)
887+ | otherwise = t
888+
889+tests :: Test
890+tests =
891+ testGroup "Properties" [
892+ testGroup "creation/elimination" [
893+ testProperty "t_pack_unpack" t_pack_unpack,
894+ testProperty "tl_pack_unpack" tl_pack_unpack,
895+ testProperty "t_stream_unstream" t_stream_unstream,
896+ testProperty "tl_stream_unstream" tl_stream_unstream,
897+ testProperty "t_reverse_stream" t_reverse_stream,
898+ testProperty "t_singleton" t_singleton,
899+ testProperty "tl_singleton" tl_singleton,
900+ testProperty "tl_unstreamChunks" tl_unstreamChunks,
901+ testProperty "tl_chunk_unchunk" tl_chunk_unchunk,
902+ testProperty "tl_from_to_strict" tl_from_to_strict
903+ ],
904+
905+ testGroup "transcoding" [
906+ testProperty "t_ascii" t_ascii,
907+ testProperty "tl_ascii" tl_ascii,
908+ testProperty "t_latin1" t_latin1,
909+ testProperty "tl_latin1" tl_latin1,
910+ testProperty "t_utf8" t_utf8,
911+ testProperty "t_utf8'" t_utf8',
912+ testProperty "t_utf8_incr" t_utf8_incr,
913+ testProperty "t_utf8_undecoded" t_utf8_undecoded,
914+ testProperty "tl_utf8" tl_utf8,
915+ testProperty "tl_utf8'" tl_utf8',
916+ testProperty "t_utf16LE" t_utf16LE,
917+ testProperty "tl_utf16LE" tl_utf16LE,
918+ testProperty "t_utf16BE" t_utf16BE,
919+ testProperty "tl_utf16BE" tl_utf16BE,
920+ testProperty "t_utf32LE" t_utf32LE,
921+ testProperty "tl_utf32LE" tl_utf32LE,
922+ testProperty "t_utf32BE" t_utf32BE,
923+ testProperty "tl_utf32BE" tl_utf32BE,
924+ testGroup "errors" [
925+ testProperty "t_utf8_err" t_utf8_err,
926+ testProperty "t_utf8_err'" t_utf8_err'
927+ ]
928+ ],
929+
930+ testGroup "instances" [
931+ testProperty "s_Eq" s_Eq,
932+ testProperty "sf_Eq" sf_Eq,
933+ testProperty "t_Eq" t_Eq,
934+ testProperty "tl_Eq" tl_Eq,
935+ testProperty "s_Ord" s_Ord,
936+ testProperty "sf_Ord" sf_Ord,
937+ testProperty "t_Ord" t_Ord,
938+ testProperty "tl_Ord" tl_Ord,
939+ testProperty "t_Read" t_Read,
940+ testProperty "tl_Read" tl_Read,
941+ testProperty "t_Show" t_Show,
942+ testProperty "tl_Show" tl_Show,
943+ testProperty "t_mappend" t_mappend,
944+ testProperty "tl_mappend" tl_mappend,
945+ testProperty "t_mconcat" t_mconcat,
946+ testProperty "tl_mconcat" tl_mconcat,
947+ testProperty "t_mempty" t_mempty,
948+ testProperty "tl_mempty" tl_mempty,
949+ testProperty "t_IsString" t_IsString,
950+ testProperty "tl_IsString" tl_IsString
951+ ],
952+
953+ testGroup "basics" [
954+ testProperty "s_cons" s_cons,
955+ testProperty "s_cons_s" s_cons_s,
956+ testProperty "sf_cons" sf_cons,
957+ testProperty "t_cons" t_cons,
958+ testProperty "tl_cons" tl_cons,
959+ testProperty "s_snoc" s_snoc,
960+ testProperty "t_snoc" t_snoc,
961+ testProperty "tl_snoc" tl_snoc,
962+ testProperty "s_append" s_append,
963+ testProperty "s_append_s" s_append_s,
964+ testProperty "sf_append" sf_append,
965+ testProperty "t_append" t_append,
966+ testProperty "s_uncons" s_uncons,
967+ testProperty "sf_uncons" sf_uncons,
968+ testProperty "t_uncons" t_uncons,
969+ testProperty "tl_uncons" tl_uncons,
970+ testProperty "s_head" s_head,
971+ testProperty "sf_head" sf_head,
972+ testProperty "t_head" t_head,
973+ testProperty "tl_head" tl_head,
974+ testProperty "s_last" s_last,
975+ testProperty "sf_last" sf_last,
976+ testProperty "t_last" t_last,
977+ testProperty "tl_last" tl_last,
978+ testProperty "s_tail" s_tail,
979+ testProperty "s_tail_s" s_tail_s,
980+ testProperty "sf_tail" sf_tail,
981+ testProperty "t_tail" t_tail,
982+ testProperty "tl_tail" tl_tail,
983+ testProperty "s_init" s_init,
984+ testProperty "s_init_s" s_init_s,
985+ testProperty "sf_init" sf_init,
986+ testProperty "t_init" t_init,
987+ testProperty "tl_init" tl_init,
988+ testProperty "s_null" s_null,
989+ testProperty "sf_null" sf_null,
990+ testProperty "t_null" t_null,
991+ testProperty "tl_null" tl_null,
992+ testProperty "s_length" s_length,
993+ testProperty "sf_length" sf_length,
994+ testProperty "sl_length" sl_length,
995+ testProperty "t_length" t_length,
996+ testProperty "tl_length" tl_length,
997+ testProperty "t_compareLength" t_compareLength,
998+ testProperty "tl_compareLength" tl_compareLength
999+ ],
1000+
1001+ testGroup "transformations" [
1002+ testProperty "s_map" s_map,
1003+ testProperty "s_map_s" s_map_s,
1004+ testProperty "sf_map" sf_map,
1005+ testProperty "t_map" t_map,
1006+ testProperty "tl_map" tl_map,
1007+ testProperty "s_intercalate" s_intercalate,
1008+ testProperty "t_intercalate" t_intercalate,
1009+ testProperty "tl_intercalate" tl_intercalate,
1010+ testProperty "s_intersperse" s_intersperse,
1011+ testProperty "s_intersperse_s" s_intersperse_s,
1012+ testProperty "sf_intersperse" sf_intersperse,
1013+ testProperty "t_intersperse" t_intersperse,
1014+ testProperty "tl_intersperse" tl_intersperse,
1015+ testProperty "t_transpose" t_transpose,
1016+ testProperty "tl_transpose" tl_transpose,
1017+ testProperty "t_reverse" t_reverse,
1018+ testProperty "tl_reverse" tl_reverse,
1019+ testProperty "t_reverse_short" t_reverse_short,
1020+ testProperty "t_replace" t_replace,
1021+ testProperty "tl_replace" tl_replace,
1022+
1023+ testGroup "case conversion" [
1024+ testProperty "s_toCaseFold_length" s_toCaseFold_length,
1025+ testProperty "sf_toCaseFold_length" sf_toCaseFold_length,
1026+ testProperty "t_toCaseFold_length" t_toCaseFold_length,
1027+ testProperty "tl_toCaseFold_length" tl_toCaseFold_length,
1028+ testProperty "t_toLower_length" t_toLower_length,
1029+ testProperty "t_toLower_lower" t_toLower_lower,
1030+ testProperty "tl_toLower_lower" tl_toLower_lower,
1031+ testProperty "t_toUpper_length" t_toUpper_length,
1032+ testProperty "t_toUpper_upper" t_toUpper_upper,
1033+ testProperty "tl_toUpper_upper" tl_toUpper_upper
1034+ ],
1035+
1036+ testGroup "justification" [
1037+ testProperty "s_justifyLeft" s_justifyLeft,
1038+ testProperty "s_justifyLeft_s" s_justifyLeft_s,
1039+ testProperty "sf_justifyLeft" sf_justifyLeft,
1040+ testProperty "t_justifyLeft" t_justifyLeft,
1041+ testProperty "tl_justifyLeft" tl_justifyLeft,
1042+ testProperty "t_justifyRight" t_justifyRight,
1043+ testProperty "tl_justifyRight" tl_justifyRight,
1044+ testProperty "t_center" t_center,
1045+ testProperty "tl_center" tl_center
1046+ ]
1047+ ],
1048+
1049+ testGroup "folds" [
1050+ testProperty "sf_foldl" sf_foldl,
1051+ testProperty "t_foldl" t_foldl,
1052+ testProperty "tl_foldl" tl_foldl,
1053+ testProperty "sf_foldl'" sf_foldl',
1054+ testProperty "t_foldl'" t_foldl',
1055+ testProperty "tl_foldl'" tl_foldl',
1056+ testProperty "sf_foldl1" sf_foldl1,
1057+ testProperty "t_foldl1" t_foldl1,
1058+ testProperty "tl_foldl1" tl_foldl1,
1059+ testProperty "t_foldl1'" t_foldl1',
1060+ testProperty "sf_foldl1'" sf_foldl1',
1061+ testProperty "tl_foldl1'" tl_foldl1',
1062+ testProperty "sf_foldr" sf_foldr,
1063+ testProperty "t_foldr" t_foldr,
1064+ testProperty "tl_foldr" tl_foldr,
1065+ testProperty "sf_foldr1" sf_foldr1,
1066+ testProperty "t_foldr1" t_foldr1,
1067+ testProperty "tl_foldr1" tl_foldr1,
1068+
1069+ testGroup "special" [
1070+ testProperty "s_concat_s" s_concat_s,
1071+ testProperty "sf_concat" sf_concat,
1072+ testProperty "t_concat" t_concat,
1073+ testProperty "tl_concat" tl_concat,
1074+ testProperty "sf_concatMap" sf_concatMap,
1075+ testProperty "t_concatMap" t_concatMap,
1076+ testProperty "tl_concatMap" tl_concatMap,
1077+ testProperty "sf_any" sf_any,
1078+ testProperty "t_any" t_any,
1079+ testProperty "tl_any" tl_any,
1080+ testProperty "sf_all" sf_all,
1081+ testProperty "t_all" t_all,
1082+ testProperty "tl_all" tl_all,
1083+ testProperty "sf_maximum" sf_maximum,
1084+ testProperty "t_maximum" t_maximum,
1085+ testProperty "tl_maximum" tl_maximum,
1086+ testProperty "sf_minimum" sf_minimum,
1087+ testProperty "t_minimum" t_minimum,
1088+ testProperty "tl_minimum" tl_minimum
1089+ ]
1090+ ],
1091+
1092+ testGroup "construction" [
1093+ testGroup "scans" [
1094+ testProperty "sf_scanl" sf_scanl,
1095+ testProperty "t_scanl" t_scanl,
1096+ testProperty "tl_scanl" tl_scanl,
1097+ testProperty "t_scanl1" t_scanl1,
1098+ testProperty "tl_scanl1" tl_scanl1,
1099+ testProperty "t_scanr" t_scanr,
1100+ testProperty "tl_scanr" tl_scanr,
1101+ testProperty "t_scanr1" t_scanr1,
1102+ testProperty "tl_scanr1" tl_scanr1
1103+ ],
1104+
1105+ testGroup "mapAccum" [
1106+ testProperty "t_mapAccumL" t_mapAccumL,
1107+ testProperty "tl_mapAccumL" tl_mapAccumL,
1108+ testProperty "t_mapAccumR" t_mapAccumR,
1109+ testProperty "tl_mapAccumR" tl_mapAccumR
1110+ ],
1111+
1112+ testGroup "unfolds" [
1113+ testProperty "tl_repeat" tl_repeat,
1114+ testProperty "s_replicate" s_replicate,
1115+ testProperty "t_replicate" t_replicate,
1116+ testProperty "tl_replicate" tl_replicate,
1117+ testProperty "tl_cycle" tl_cycle,
1118+ testProperty "tl_iterate" tl_iterate,
1119+ testProperty "t_unfoldr" t_unfoldr,
1120+ testProperty "tl_unfoldr" tl_unfoldr,
1121+ testProperty "t_unfoldrN" t_unfoldrN,
1122+ testProperty "tl_unfoldrN" tl_unfoldrN
1123+ ]
1124+ ],
1125+
1126+ testGroup "substrings" [
1127+ testGroup "breaking" [
1128+ testProperty "s_take" s_take,
1129+ testProperty "s_take_s" s_take_s,
1130+ testProperty "sf_take" sf_take,
1131+ testProperty "t_take" t_take,
1132+ testProperty "t_takeEnd" t_takeEnd,
1133+ testProperty "tl_take" tl_take,
1134+ testProperty "tl_takeEnd" tl_takeEnd,
1135+ testProperty "s_drop" s_drop,
1136+ testProperty "s_drop_s" s_drop_s,
1137+ testProperty "sf_drop" sf_drop,
1138+ testProperty "t_drop" t_drop,
1139+ testProperty "t_dropEnd" t_dropEnd,
1140+ testProperty "tl_drop" tl_drop,
1141+ testProperty "tl_dropEnd" tl_dropEnd,
1142+ testProperty "s_take_drop" s_take_drop,
1143+ testProperty "s_take_drop_s" s_take_drop_s,
1144+ testProperty "s_takeWhile" s_takeWhile,
1145+ testProperty "s_takeWhile_s" s_takeWhile_s,
1146+ testProperty "sf_takeWhile" sf_takeWhile,
1147+ testProperty "t_takeWhile" t_takeWhile,
1148+ testProperty "tl_takeWhile" tl_takeWhile,
1149+ testProperty "t_takeWhileEnd" t_takeWhileEnd,
1150+ testProperty "tl_takeWhileEnd" tl_takeWhileEnd,
1151+ testProperty "sf_dropWhile" sf_dropWhile,
1152+ testProperty "s_dropWhile" s_dropWhile,
1153+ testProperty "s_dropWhile_s" s_dropWhile_s,
1154+ testProperty "t_dropWhile" t_dropWhile,
1155+ testProperty "tl_dropWhile" tl_dropWhile,
1156+ testProperty "t_dropWhileEnd" t_dropWhileEnd,
1157+ testProperty "tl_dropWhileEnd" tl_dropWhileEnd,
1158+ testProperty "t_dropAround" t_dropAround,
1159+ testProperty "tl_dropAround" tl_dropAround,
1160+ testProperty "t_stripStart" t_stripStart,
1161+ testProperty "tl_stripStart" tl_stripStart,
1162+ testProperty "t_stripEnd" t_stripEnd,
1163+ testProperty "tl_stripEnd" tl_stripEnd,
1164+ testProperty "t_strip" t_strip,
1165+ testProperty "tl_strip" tl_strip,
1166+ testProperty "t_splitAt" t_splitAt,
1167+ testProperty "tl_splitAt" tl_splitAt,
1168+ testProperty "t_span" t_span,
1169+ testProperty "tl_span" tl_span,
1170+ testProperty "t_breakOn_id" t_breakOn_id,
1171+ testProperty "tl_breakOn_id" tl_breakOn_id,
1172+ testProperty "t_breakOn_start" t_breakOn_start,
1173+ testProperty "tl_breakOn_start" tl_breakOn_start,
1174+ testProperty "t_breakOnEnd_end" t_breakOnEnd_end,
1175+ testProperty "tl_breakOnEnd_end" tl_breakOnEnd_end,
1176+ testProperty "t_break" t_break,
1177+ testProperty "tl_break" tl_break,
1178+ testProperty "t_group" t_group,
1179+ testProperty "tl_group" tl_group,
1180+ testProperty "t_groupBy" t_groupBy,
1181+ testProperty "tl_groupBy" tl_groupBy,
1182+ testProperty "t_inits" t_inits,
1183+ testProperty "tl_inits" tl_inits,
1184+ testProperty "t_tails" t_tails,
1185+ testProperty "tl_tails" tl_tails
1186+ ],
1187+
1188+ testGroup "breaking many" [
1189+ testProperty "t_findAppendId" t_findAppendId,
1190+ testProperty "tl_findAppendId" tl_findAppendId,
1191+ testProperty "t_findContains" t_findContains,
1192+ testProperty "tl_findContains" tl_findContains,
1193+ testProperty "sl_filterCount" sl_filterCount,
1194+ testProperty "t_findCount" t_findCount,
1195+ testProperty "tl_findCount" tl_findCount,
1196+ testProperty "t_splitOn_split" t_splitOn_split,
1197+ testProperty "tl_splitOn_split" tl_splitOn_split,
1198+ testProperty "t_splitOn_i" t_splitOn_i,
1199+ testProperty "tl_splitOn_i" tl_splitOn_i,
1200+ testProperty "t_split" t_split,
1201+ testProperty "t_split_count" t_split_count,
1202+ testProperty "t_split_splitOn" t_split_splitOn,
1203+ testProperty "tl_split" tl_split,
1204+ testProperty "t_chunksOf_same_lengths" t_chunksOf_same_lengths,
1205+ testProperty "t_chunksOf_length" t_chunksOf_length,
1206+ testProperty "tl_chunksOf" tl_chunksOf
1207+ ],
1208+
1209+ testGroup "lines and words" [
1210+ testProperty "t_lines" t_lines,
1211+ testProperty "tl_lines" tl_lines,
1212+ --testProperty "t_lines'" t_lines',
1213+ testProperty "t_words" t_words,
1214+ testProperty "tl_words" tl_words,
1215+ testProperty "t_unlines" t_unlines,
1216+ testProperty "tl_unlines" tl_unlines,
1217+ testProperty "t_unwords" t_unwords,
1218+ testProperty "tl_unwords" tl_unwords
1219+ ]
1220+ ],
1221+
1222+ testGroup "predicates" [
1223+ testProperty "s_isPrefixOf" s_isPrefixOf,
1224+ testProperty "sf_isPrefixOf" sf_isPrefixOf,
1225+ testProperty "t_isPrefixOf" t_isPrefixOf,
1226+ testProperty "tl_isPrefixOf" tl_isPrefixOf,
1227+ testProperty "t_isSuffixOf" t_isSuffixOf,
1228+ testProperty "tl_isSuffixOf" tl_isSuffixOf,
1229+ testProperty "t_isInfixOf" t_isInfixOf,
1230+ testProperty "tl_isInfixOf" tl_isInfixOf,
1231+
1232+ testGroup "view" [
1233+ testProperty "t_stripPrefix" t_stripPrefix,
1234+ testProperty "tl_stripPrefix" tl_stripPrefix,
1235+ testProperty "t_stripSuffix" t_stripSuffix,
1236+ testProperty "tl_stripSuffix" tl_stripSuffix,
1237+ testProperty "t_commonPrefixes" t_commonPrefixes,
1238+ testProperty "tl_commonPrefixes" tl_commonPrefixes
1239+ ]
1240+ ],
1241+
1242+ testGroup "searching" [
1243+ testProperty "sf_elem" sf_elem,
1244+ testProperty "sf_filter" sf_filter,
1245+ testProperty "t_filter" t_filter,
1246+ testProperty "tl_filter" tl_filter,
1247+ testProperty "sf_findBy" sf_findBy,
1248+ testProperty "t_find" t_find,
1249+ testProperty "tl_find" tl_find,
1250+ testProperty "t_partition" t_partition,
1251+ testProperty "tl_partition" tl_partition
1252+ ],
1253+
1254+ testGroup "indexing" [
1255+ testProperty "sf_index" sf_index,
1256+ testProperty "t_index" t_index,
1257+ testProperty "tl_index" tl_index,
1258+ testProperty "t_findIndex" t_findIndex,
1259+ testProperty "t_count" t_count,
1260+ testProperty "tl_count" tl_count,
1261+ testProperty "t_indices" t_indices,
1262+ testProperty "tl_indices" tl_indices,
1263+ testProperty "t_indices_occurs" t_indices_occurs
1264+ ],
1265+
1266+ testGroup "zips" [
1267+ testProperty "t_zip" t_zip,
1268+ testProperty "tl_zip" tl_zip,
1269+ testProperty "sf_zipWith" sf_zipWith,
1270+ testProperty "t_zipWith" t_zipWith,
1271+ testProperty "tl_zipWith" tl_zipWith
1272+ ],
1273+
1274+ testGroup "regressions" [
1275+ testProperty "s_filter_eq" s_filter_eq
1276+ ],
1277+
1278+ testGroup "shifts" [
1279+ testProperty "shiftL_Int" shiftL_Int,
1280+ testProperty "shiftL_Word16" shiftL_Word16,
1281+ testProperty "shiftL_Word32" shiftL_Word32,
1282+ testProperty "shiftR_Int" shiftR_Int,
1283+ testProperty "shiftR_Word16" shiftR_Word16,
1284+ testProperty "shiftR_Word32" shiftR_Word32
1285+ ],
1286+
1287+ testGroup "builder" [
1288+ testProperty "tb_associative" tb_associative,
1289+ testGroup "decimal" [
1290+ testProperty "tb_decimal_int" tb_decimal_int,
1291+ testProperty "tb_decimal_int8" tb_decimal_int8,
1292+ testProperty "tb_decimal_int16" tb_decimal_int16,
1293+ testProperty "tb_decimal_int32" tb_decimal_int32,
1294+ testProperty "tb_decimal_int64" tb_decimal_int64,
1295+ testProperty "tb_decimal_integer" tb_decimal_integer,
1296+ testProperty "tb_decimal_integer_big" tb_decimal_integer_big,
1297+ testProperty "tb_decimal_word" tb_decimal_word,
1298+ testProperty "tb_decimal_word8" tb_decimal_word8,
1299+ testProperty "tb_decimal_word16" tb_decimal_word16,
1300+ testProperty "tb_decimal_word32" tb_decimal_word32,
1301+ testProperty "tb_decimal_word64" tb_decimal_word64,
1302+ testProperty "tb_decimal_big_int" tb_decimal_big_int,
1303+ testProperty "tb_decimal_big_word" tb_decimal_big_word,
1304+ testProperty "tb_decimal_big_int64" tb_decimal_big_int64,
1305+ testProperty "tb_decimal_big_word64" tb_decimal_big_word64
1306+ ],
1307+ testGroup "hexadecimal" [
1308+ testProperty "tb_hexadecimal_int" tb_hexadecimal_int,
1309+ testProperty "tb_hexadecimal_int8" tb_hexadecimal_int8,
1310+ testProperty "tb_hexadecimal_int16" tb_hexadecimal_int16,
1311+ testProperty "tb_hexadecimal_int32" tb_hexadecimal_int32,
1312+ testProperty "tb_hexadecimal_int64" tb_hexadecimal_int64,
1313+ testProperty "tb_hexadecimal_integer" tb_hexadecimal_integer,
1314+ testProperty "tb_hexadecimal_word" tb_hexadecimal_word,
1315+ testProperty "tb_hexadecimal_word8" tb_hexadecimal_word8,
1316+ testProperty "tb_hexadecimal_word16" tb_hexadecimal_word16,
1317+ testProperty "tb_hexadecimal_word32" tb_hexadecimal_word32,
1318+ testProperty "tb_hexadecimal_word64" tb_hexadecimal_word64
1319+ ],
1320+ testGroup "realfloat" [
1321+ testProperty "tb_realfloat_double" tb_realfloat_double,
1322+ testProperty "tb_realfloat_float" tb_realfloat_float,
1323+ testProperty "tb_formatRealFloat_float" tb_formatRealFloat_float,
1324+ testProperty "tb_formatRealFloat_double" tb_formatRealFloat_double
1325+ ],
1326+ testProperty "tb_fromText" tb_fromText,
1327+ testProperty "tb_singleton" tb_singleton
1328+ ],
1329+
1330+ testGroup "read" [
1331+ testProperty "t_decimal" t_decimal,
1332+ testProperty "tl_decimal" tl_decimal,
1333+ testProperty "t_hexadecimal" t_hexadecimal,
1334+ testProperty "tl_hexadecimal" tl_hexadecimal,
1335+ testProperty "t_double" t_double,
1336+ testProperty "tl_double" tl_double,
1337+ testProperty "t_rational" t_rational,
1338+ testProperty "tl_rational" tl_rational
1339+ ],
1340+
1341+ {-
1342+ testGroup "input-output" [
1343+ testProperty "t_write_read" t_write_read,
1344+ testProperty "tl_write_read" tl_write_read,
1345+ testProperty "t_write_read_line" t_write_read_line,
1346+ testProperty "tl_write_read_line" tl_write_read_line
1347+ -- These tests are subject to I/O race conditions when run under
1348+ -- test-framework-quickcheck2.
1349+ -- testProperty "t_put_get" t_put_get
1350+ -- testProperty "tl_put_get" tl_put_get
1351+ ],
1352+ -}
1353+
1354+ testGroup "lowlevel" [
1355+ testProperty "t_dropWord16" t_dropWord16,
1356+ testProperty "t_takeWord16" t_takeWord16,
1357+ testProperty "t_take_drop_16" t_take_drop_16,
1358+ testProperty "t_use_from" t_use_from,
1359+ testProperty "t_copy" t_copy
1360+ ],
1361+
1362+ testGroup "mul" Mul.tests
1363+ ]
tests/Tests/Properties/Mul.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+
3+module Tests.Properties.Mul (tests) where
4+
5+import Control.Applicative ((<$>), pure)
6+import Control.Exception as E (SomeException, catch, evaluate)
7+import Data.Int (Int32, Int64)
8+import Data.Text.Internal (mul, mul32, mul64)
9+import System.IO.Unsafe (unsafePerformIO)
10+import Test.Framework (Test)
11+import Test.Framework.Providers.QuickCheck2 (testProperty)
12+import Test.QuickCheck hiding ((.&.))
13+
14+mulRef :: (Integral a, Bounded a) => a -> a -> Maybe a
15+mulRef a b
16+ | ab < bot || ab > top = Nothing
17+ | otherwise = Just (fromIntegral ab)
18+ where ab = fromIntegral a * fromIntegral b
19+ top = fromIntegral (maxBound `asTypeOf` a) :: Integer
20+ bot = fromIntegral (minBound `asTypeOf` a) :: Integer
21+
22+eval :: (a -> b -> c) -> a -> b -> Maybe c
23+eval f a b = unsafePerformIO $
24+ (Just <$> evaluate (f a b)) `E.catch` (\(_::SomeException) -> pure Nothing)
25+
26+t_mul32 :: Int32 -> Int32 -> Property
27+t_mul32 a b = mulRef a b === eval mul32 a b
28+
29+t_mul64 :: Int64 -> Int64 -> Property
30+t_mul64 a b = mulRef a b === eval mul64 a b
31+
32+t_mul :: Int -> Int -> Property
33+t_mul a b = mulRef a b === eval mul a b
34+
35+tests :: [Test]
36+tests = [
37+ testProperty "t_mul" t_mul
38+ , testProperty "t_mul32" t_mul32
39+ , testProperty "t_mul64" t_mul64
40+ ]
tests/Tests/QuickCheckUtils.hsnew file+360
@@ -0,0 +1,360 @@
1+-- | This module provides quickcheck utilities, e.g. arbitrary and show
2+-- instances, and comparison functions, so we can focus on the actual properties
3+-- in the 'Tests.Properties' module.
4+--
5+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
6+{-# OPTIONS_GHC -fno-warn-orphans #-}
7+module Tests.QuickCheckUtils
8+ (
9+ genUnicode
10+ , unsquare
11+ , smallArbitrary
12+
13+ , BigBounded(..)
14+ , BigInt(..)
15+ , NotEmpty(..)
16+
17+ , Small(..)
18+ , small
19+
20+ , Precision(..)
21+ , precision
22+
23+ , integralRandomR
24+
25+ , DecodeErr(..)
26+ , genDecodeErr
27+
28+ , Stringy(..)
29+ , eq
30+ , eqP
31+
32+ , Encoding(..)
33+
34+ , write_read
35+ ) where
36+
37+import Control.Applicative ((<$>))
38+import Control.Arrow (first, (***))
39+import Control.DeepSeq (NFData (..), deepseq)
40+import Control.Exception (bracket)
41+import Data.String (IsString, fromString)
42+import Data.Text.Foreign (I16)
43+import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
44+import Data.Word (Word8, Word16)
45+import Debug.Trace (trace)
46+import System.Random (Random(..), RandomGen)
47+import Test.QuickCheck hiding (Fixed(..), Small (..), (.&.))
48+import Test.QuickCheck.Monadic (assert, monadicIO, run)
49+import Test.QuickCheck.Unicode (string)
50+import Tests.Utils
51+import qualified Data.ByteString as B
52+import qualified Data.Text as T
53+import qualified Data.Text.Encoding.Error as T
54+import qualified Data.Text.Internal.Fusion as TF
55+import qualified Data.Text.Internal.Fusion.Common as TF
56+import qualified Data.Text.Internal.Lazy as TL
57+import qualified Data.Text.Internal.Lazy.Fusion as TLF
58+import qualified Data.Text.Lazy as TL
59+import qualified System.IO as IO
60+
61+#if !MIN_VERSION_base(4,4,0)
62+import Data.Int (Int64)
63+import Data.Word (Word, Word64)
64+#endif
65+
66+genUnicode :: IsString a => Gen a
67+genUnicode = fromString <$> string
68+
69+instance Random I16 where
70+ randomR = integralRandomR
71+ random = randomR (minBound,maxBound)
72+
73+instance Arbitrary I16 where
74+ arbitrary = arbitrarySizedIntegral
75+ shrink = shrinkIntegral
76+
77+instance Arbitrary B.ByteString where
78+ arbitrary = B.pack `fmap` arbitrary
79+ shrink = map B.pack . shrink . B.unpack
80+
81+#if !MIN_VERSION_base(4,4,0)
82+instance Random Int64 where
83+ randomR = integralRandomR
84+ random = randomR (minBound,maxBound)
85+
86+instance Random Word where
87+ randomR = integralRandomR
88+ random = randomR (minBound,maxBound)
89+
90+instance Random Word8 where
91+ randomR = integralRandomR
92+ random = randomR (minBound,maxBound)
93+
94+instance Random Word64 where
95+ randomR = integralRandomR
96+ random = randomR (minBound,maxBound)
97+#endif
98+
99+-- For tests that have O(n^2) running times or input sizes, resize
100+-- their inputs to the square root of the originals.
101+unsquare :: (Arbitrary a, Show a, Testable b) => (a -> b) -> Property
102+unsquare = forAll smallArbitrary
103+
104+smallArbitrary :: (Arbitrary a, Show a) => Gen a
105+smallArbitrary = sized $ \n -> resize (smallish n) arbitrary
106+ where smallish = round . (sqrt :: Double -> Double) . fromIntegral . abs
107+
108+instance Arbitrary T.Text where
109+ arbitrary = T.pack `fmap` arbitrary
110+ shrink = map T.pack . shrink . T.unpack
111+
112+instance Arbitrary TL.Text where
113+ arbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary
114+ shrink = map TL.pack . shrink . TL.unpack
115+
116+newtype BigInt = Big Integer
117+ deriving (Eq, Show)
118+
119+instance Arbitrary BigInt where
120+ arbitrary = choose (1::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e)
121+ shrink (Big a) = [Big (a `div` 2^(l-e)) | e <- shrink l]
122+ where l = truncate (log (fromIntegral a) / log 2 :: Double) :: Integer
123+
124+newtype BigBounded a = BigBounded a
125+ deriving (Eq, Show)
126+
127+instance (Bounded a, Random a, Arbitrary a) => Arbitrary (BigBounded a) where
128+ arbitrary = BigBounded <$> choose (minBound, maxBound)
129+
130+newtype NotEmpty a = NotEmpty { notEmpty :: a }
131+ deriving (Eq, Ord)
132+
133+instance Show a => Show (NotEmpty a) where
134+ show (NotEmpty a) = show a
135+
136+instance Functor NotEmpty where
137+ fmap f (NotEmpty a) = NotEmpty (f a)
138+
139+instance Arbitrary a => Arbitrary (NotEmpty [a]) where
140+ arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
141+ shrink = shrinkNotEmpty null
142+
143+instance Arbitrary (NotEmpty T.Text) where
144+ arbitrary = (fmap T.pack) `fmap` arbitrary
145+ shrink = shrinkNotEmpty T.null
146+
147+instance Arbitrary (NotEmpty TL.Text) where
148+ arbitrary = (fmap TL.pack) `fmap` arbitrary
149+ shrink = shrinkNotEmpty TL.null
150+
151+instance Arbitrary (NotEmpty B.ByteString) where
152+ arbitrary = (fmap B.pack) `fmap` arbitrary
153+ shrink = shrinkNotEmpty B.null
154+
155+shrinkNotEmpty :: Arbitrary a => (a -> Bool) -> NotEmpty a -> [NotEmpty a]
156+shrinkNotEmpty isNull (NotEmpty xs) =
157+ [ NotEmpty xs' | xs' <- shrink xs, not (isNull xs') ]
158+
159+data Small = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7
160+ | S8 | S9 | S10 | S11 | S12 | S13 | S14 | S15
161+ | S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23
162+ | S24 | S25 | S26 | S27 | S28 | S29 | S30 | S31
163+ deriving (Eq, Ord, Enum, Bounded)
164+
165+small :: Integral a => Small -> a
166+small = fromIntegral . fromEnum
167+
168+intf :: (Int -> Int -> Int) -> Small -> Small -> Small
169+intf f a b = toEnum ((fromEnum a `f` fromEnum b) `mod` 32)
170+
171+instance Show Small where
172+ show = show . fromEnum
173+
174+instance Read Small where
175+ readsPrec n = map (first toEnum) . readsPrec n
176+
177+instance Num Small where
178+ fromInteger = toEnum . fromIntegral
179+ signum _ = 1
180+ abs = id
181+ (+) = intf (+)
182+ (-) = intf (-)
183+ (*) = intf (*)
184+
185+instance Real Small where
186+ toRational = toRational . fromEnum
187+
188+instance Integral Small where
189+ toInteger = toInteger . fromEnum
190+ quotRem a b = (toEnum x, toEnum y)
191+ where (x, y) = fromEnum a `quotRem` fromEnum b
192+
193+instance Random Small where
194+ randomR = integralRandomR
195+ random = randomR (minBound,maxBound)
196+
197+instance Arbitrary Small where
198+ arbitrary = choose (minBound, maxBound)
199+ shrink = shrinkIntegral
200+
201+integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
202+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
203+ fromIntegral b :: Integer) g of
204+ (x,h) -> (fromIntegral x, h)
205+
206+data DecodeErr = Lenient | Ignore | Strict | Replace
207+ deriving (Show, Eq)
208+
209+genDecodeErr :: DecodeErr -> Gen T.OnDecodeError
210+genDecodeErr Lenient = return T.lenientDecode
211+genDecodeErr Ignore = return T.ignore
212+genDecodeErr Strict = return T.strictDecode
213+genDecodeErr Replace = arbitrary
214+
215+instance Arbitrary DecodeErr where
216+ arbitrary = elements [Lenient, Ignore, Strict, Replace]
217+
218+class Stringy s where
219+ packS :: String -> s
220+ unpackS :: s -> String
221+ splitAtS :: Int -> s -> (s,s)
222+ packSChunkSize :: Int -> String -> s
223+ packSChunkSize _ = packS
224+
225+instance Stringy String where
226+ packS = id
227+ unpackS = id
228+ splitAtS = splitAt
229+
230+instance Stringy (TF.Stream Char) where
231+ packS = TF.streamList
232+ unpackS = TF.unstreamList
233+ splitAtS n s = (TF.take n s, TF.drop n s)
234+
235+instance Stringy T.Text where
236+ packS = T.pack
237+ unpackS = T.unpack
238+ splitAtS = T.splitAt
239+
240+instance Stringy TL.Text where
241+ packSChunkSize k = TLF.unstreamChunks k . TF.streamList
242+ packS = TL.pack
243+ unpackS = TL.unpack
244+ splitAtS = ((TL.lazyInvariant *** TL.lazyInvariant) .) .
245+ TL.splitAt . fromIntegral
246+
247+-- Do two functions give the same answer?
248+eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
249+eq a b s = a s =^= b s
250+
251+-- What about with the RHS packed?
252+eqP :: (Eq a, Show a, Stringy s) =>
253+ (String -> a) -> (s -> a) -> String -> Word8 -> Bool
254+eqP f g s w = eql "orig" (f s) (g t) &&
255+ eql "mini" (f s) (g mini) &&
256+ eql "head" (f sa) (g ta) &&
257+ eql "tail" (f sb) (g tb)
258+ where t = packS s
259+ mini = packSChunkSize 10 s
260+ (sa,sb) = splitAt m s
261+ (ta,tb) = splitAtS m t
262+ l = length s
263+ m | l == 0 = n
264+ | otherwise = n `mod` l
265+ n = fromIntegral w
266+ eql d a b
267+ | a =^= b = True
268+ | otherwise = trace (d ++ ": " ++ show a ++ " /= " ++ show b) False
269+
270+instance Arbitrary FPFormat where
271+ arbitrary = elements [Exponent, Fixed, Generic]
272+
273+newtype Precision a = Precision (Maybe Int)
274+ deriving (Eq, Show)
275+
276+precision :: a -> Precision a -> Maybe Int
277+precision _ (Precision prec) = prec
278+
279+arbitraryPrecision :: Int -> Gen (Precision a)
280+arbitraryPrecision maxDigits = Precision <$> do
281+ n <- choose (-1,maxDigits)
282+ return $ if n == -1
283+ then Nothing
284+ else Just n
285+
286+instance Arbitrary (Precision Float) where
287+ arbitrary = arbitraryPrecision 11
288+ shrink = map Precision . shrink . precision undefined
289+
290+instance Arbitrary (Precision Double) where
291+ arbitrary = arbitraryPrecision 22
292+ shrink = map Precision . shrink . precision undefined
293+
294+-- Work around lack of Show instance for TextEncoding.
295+data Encoding = E String IO.TextEncoding
296+
297+instance Show Encoding where show (E n _) = "utf" ++ n
298+
299+instance Arbitrary Encoding where
300+ arbitrary = oneof . map return $
301+ [ E "8" IO.utf8, E "8_bom" IO.utf8_bom, E "16" IO.utf16
302+ , E "16le" IO.utf16le, E "16be" IO.utf16be, E "32" IO.utf32
303+ , E "32le" IO.utf32le, E "32be" IO.utf32be
304+ ]
305+
306+windowsNewlineMode :: IO.NewlineMode
307+windowsNewlineMode = IO.NewlineMode
308+ { IO.inputNL = IO.CRLF, IO.outputNL = IO.CRLF
309+ }
310+
311+instance Arbitrary IO.NewlineMode where
312+ arbitrary = oneof . map return $
313+ [ IO.noNewlineTranslation, IO.universalNewlineMode, IO.nativeNewlineMode
314+ , windowsNewlineMode
315+ ]
316+
317+instance Arbitrary IO.BufferMode where
318+ arbitrary = oneof [ return IO.NoBuffering,
319+ return IO.LineBuffering,
320+ return (IO.BlockBuffering Nothing),
321+ (IO.BlockBuffering . Just . (+1) . fromIntegral) `fmap`
322+ (arbitrary :: Gen Word16) ]
323+
324+-- This test harness is complex! What property are we checking?
325+--
326+-- Reading after writing a multi-line file should give the same
327+-- results as were written.
328+--
329+-- What do we vary while checking this property?
330+-- * The lines themselves, scrubbed to contain neither CR nor LF. (By
331+-- working with a list of lines, we ensure that the data will
332+-- sometimes contain line endings.)
333+-- * Encoding.
334+-- * Newline translation mode.
335+-- * Buffering.
336+write_read :: (NFData a, Eq a)
337+ => ([b] -> a)
338+ -> ((Char -> Bool) -> a -> b)
339+ -> (IO.Handle -> a -> IO ())
340+ -> (IO.Handle -> IO a)
341+ -> Encoding
342+ -> IO.NewlineMode
343+ -> IO.BufferMode
344+ -> [a]
345+ -> Property
346+write_read unline filt writer reader (E _ _) nl buf ts =
347+ monadicIO $ assert . (==t) =<< run act
348+ where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
349+ act = withTempFile $ \path h -> do
350+ -- hSetEncoding h enc
351+ IO.hSetNewlineMode h nl
352+ IO.hSetBuffering h buf
353+ () <- writer h t
354+ IO.hClose h
355+ bracket (IO.openFile path IO.ReadMode) IO.hClose $ \h' -> do
356+ -- hSetEncoding h' enc
357+ IO.hSetNewlineMode h' nl
358+ IO.hSetBuffering h' buf
359+ r <- reader h'
360+ r `deepseq` return r
tests/Regressions.hs → tests/Tests/Regressions.hsrenamed+42−11
@@ -1,29 +1,39 @@
1+-- | Regression tests for specific bugs.
2+--
13{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
2−
3−-- Regression tests for specific bugs.
4+module Tests.Regressions
5+ (
6+ tests
7+ ) where
48
59import Control.Exception (SomeException, handle)
610import System.IO
11+import Test.HUnit (assertBool, assertEqual, assertFailure)
712import qualified Data.ByteString as B
13+import Data.ByteString.Char8 ()
814import qualified Data.ByteString.Lazy as LB
915import qualified Data.Text as T
16+import qualified Data.Text.Encoding as TE
1017import qualified Data.Text.IO as T
1118import qualified Data.Text.Lazy as LT
1219import qualified Data.Text.Lazy.Encoding as LE
20+import qualified Data.Text.Unsafe as T
1321import qualified Test.Framework as F
1422import qualified Test.Framework.Providers.HUnit as F
15−import Test.HUnit (assertFailure)
16−import TestUtils (withTempFile)
23+
24+import Tests.Utils (withTempFile)
1725
1826-- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring
1927-- caused either a segfault or attempt to allocate a negative number
2028-- of bytes.
29+lazy_encode_crash :: IO ()
2130lazy_encode_crash = withTempFile $ \ _ h ->
2231 LB.hPut h . LE.encodeUtf8 . LT.pack . replicate 100000 $ 'a'
2332
2433-- Reported by Pieter Laeremans: attempting to read an incorrectly
2534-- encoded file can result in a crash in the RTS (i.e. not merely an
2635-- exception).
36+hGetContents_crash :: IO ()
2737hGetContents_crash = withTempFile $ \ path h -> do
2838 B.hPut h (B.pack [0x78, 0xc4 ,0x0a]) >> hClose h
2939 h' <- openFile path ReadMode
@@ -34,6 +44,7 @@ hGetContents_crash = withTempFile $ \ path h -> do
3444-- Reported by Ian Lynagh: attempting to allocate a sufficiently large
3545-- string (via either Array.new or Text.replicate) could result in an
3646-- integer overflow.
47+replicate_crash :: IO ()
3748replicate_crash = handle (\(_::SomeException) -> return ()) $
3849 T.replicate (2^power) "0123456789abcdef" `seq`
3950 assertFailure "T.replicate should crash"
@@ -41,11 +52,31 @@ replicate_crash = handle (\(_::SomeException) -> return ()) $
4152 power | maxBound == (2147483647::Int) = 28
4253 | otherwise = 60 :: Int
4354
44−tests :: F.Test
45−tests = F.testGroup "crashers" [
46− F.testCase "hGetContents_crash" hGetContents_crash
47− , F.testCase "lazy_encode_crash" lazy_encode_crash
48− , F.testCase "replicate_crash" replicate_crash
49− ]
55+-- Reported by John Millikin: a UTF-8 decode error handler could
56+-- return a bogus substitution character, which we would write without
57+-- checking.
58+utf8_decode_unsafe :: IO ()
59+utf8_decode_unsafe = do
60+ let t = TE.decodeUtf8With (\_ _ -> Just '\xdc00') "\x80"
61+ assertBool "broken error recovery shouldn't break us" (t == "\xfffd")
5062
51−main = F.defaultMain [tests]
63+-- Reported by Eric Seidel: we mishandled mapping Chars that fit in a
64+-- single Word16 to Chars that require two.
65+mapAccumL_resize :: IO ()
66+mapAccumL_resize = do
67+ let f a _ = (a, '\65536')
68+ count = 5
69+ val = T.mapAccumL f (0::Int) (T.replicate count "a")
70+ assertEqual "mapAccumL should correctly fill buffers for two-word results"
71+ (0, T.replicate count "\65536") val
72+ assertEqual "mapAccumL should correctly size buffers for two-word results"
73+ (count * 2) (T.lengthWord16 (snd val))
74+
75+tests :: F.Test
76+tests = F.testGroup "Regressions"
77+ [ F.testCase "hGetContents_crash" hGetContents_crash
78+ , F.testCase "lazy_encode_crash" lazy_encode_crash
79+ , F.testCase "mapAccumL_resize" mapAccumL_resize
80+ , F.testCase "replicate_crash" replicate_crash
81+ , F.testCase "utf8_decode_unsafe" utf8_decode_unsafe
82+ ]
tests/SlowFunctions.hs → tests/Tests/SlowFunctions.hsrenamed+1−2
@@ -1,6 +1,5 @@
11{-# LANGUAGE BangPatterns #-}
2−
3−module SlowFunctions
2+module Tests.SlowFunctions
43 (
54 indices
65 , splitOn
tests/Tests/Utils.hsnew file+52
@@ -0,0 +1,52 @@
1+-- | Miscellaneous testing utilities
2+--
3+{-# LANGUAGE ScopedTypeVariables #-}
4+module Tests.Utils
5+ (
6+ (=^=)
7+ , withRedirect
8+ , withTempFile
9+ ) where
10+
11+import Control.Exception (SomeException, bracket, bracket_, evaluate, try)
12+import Control.Monad (when)
13+import Debug.Trace (trace)
14+import GHC.IO.Handle.Internals (withHandle)
15+import System.Directory (removeFile)
16+import System.IO (Handle, hClose, hFlush, hIsOpen, hIsWritable, openTempFile)
17+import System.IO.Unsafe (unsafePerformIO)
18+
19+-- Ensure that two potentially bottom values (in the sense of crashing
20+-- for some inputs, not looping infinitely) either both crash, or both
21+-- give comparable results for some input.
22+(=^=) :: (Eq a, Show a) => a -> a -> Bool
23+i =^= j = unsafePerformIO $ do
24+ x <- try (evaluate i)
25+ y <- try (evaluate j)
26+ case (x,y) of
27+ (Left (_ :: SomeException), Left (_ :: SomeException))
28+ -> return True
29+ (Right a, Right b) -> return (a == b)
30+ e -> trace ("*** Divergence: " ++ show e) return False
31+infix 4 =^=
32+{-# NOINLINE (=^=) #-}
33+
34+withTempFile :: (FilePath -> Handle -> IO a) -> IO a
35+withTempFile = bracket (openTempFile "." "crashy.txt") cleanupTemp . uncurry
36+ where
37+ cleanupTemp (path,h) = do
38+ open <- hIsOpen h
39+ when open (hClose h)
40+ removeFile path
41+
42+withRedirect :: Handle -> Handle -> IO a -> IO a
43+withRedirect tmp h = bracket_ swap swap
44+ where
45+ whenM p a = p >>= (`when` a)
46+ swap = do
47+ whenM (hIsOpen tmp) $ whenM (hIsWritable tmp) $ hFlush tmp
48+ whenM (hIsOpen h) $ whenM (hIsWritable h) $ hFlush h
49+ withHandle "spam" tmp $ \tmph -> do
50+ hh <- withHandle "spam" h $ \hh ->
51+ return (tmph,hh)
52+ return (hh,())
tests/benchmarks/CaseMap.hsdeleted−21
@@ -1,21 +0,0 @@
1−import Control.Exception
2−import Control.Monad
3−import Data.Time.Clock
4−import Data.ByteString as B
5−import Data.Text.Encoding as T
6−import Data.Text as T
7−import System.Environment
8−
9−time act = do
10− start <- getCurrentTime
11− act
12− end <- getCurrentTime
13− let d = diffUTCTime end start
14− print d
15−
16−main = do
17− args <- getArgs
18− forM_ args $ \f -> do
19− t <- T.decodeUtf8 `fmap` B.readFile f
20− evaluate t
21− time $ evaluate (T.toUpper t)
tests/benchmarks/Cut.hsdeleted−60
@@ -1,60 +0,0 @@
1−import qualified Data.ByteString.Char8 as B
2−import qualified Data.ByteString.Lazy.Char8 as BL
3−import qualified Data.Text.IO as T
4−import qualified Data.Text as T
5−import qualified Data.Text.Encoding as T
6−import qualified Data.Text.Lazy.Encoding as TL
7−import qualified Data.Text.Lazy.IO as TL
8−import qualified Data.Text.Lazy as TL
9−import Data.Int (Int64)
10−import Numeric (readDec)
11−import System.Environment (getArgs)
12−
13−bytestring file s e = do
14− t <- B.readFile file
15− B.putStr (cut t)
16− where
17− cut = B.unlines . map (B.take (e - s) . B.drop s) . B.lines
18−
19−lazyBytestring file s e = do
20− t <- BL.readFile file
21− BL.putStr (cut (fromIntegral s) (fromIntegral e) t)
22− where
23− cut s e = BL.unlines . map (BL.take (e - s) . BL.drop s) . BL.lines
24−
25−lazyText file s e = do
26− t <- TL.readFile file
27− TL.putStr (cut (fromIntegral s) (fromIntegral e) t)
28− where
29− cut s e = TL.unlines . map (TL.take (e - s) . TL.drop s) . TL.lines
30−
31−text file s e = do
32− t <- T.readFile file
33− T.putStr (cut t)
34− where
35− cut = T.unlines . map (T.take (e - s) . T.drop s) . T.lines
36−
37−textBS file s e = do
38− bs <- B.readFile file
39− T.putStr . cut . T.decodeUtf8 $ bs
40− where
41− cut = T.unlines . map (T.take (e - s) . T.drop s) . T.lines
42−
43−lazyTextBS file s e = do
44− t <- BL.readFile file
45− TL.putStr (cut (fromIntegral s) (fromIntegral e) (TL.decodeUtf8 t))
46− where
47− cut s e = TL.unlines . map (TL.take (e - s) . TL.drop s) . TL.lines
48−
49−main = do
50− (name : ss : es : file : _) <- getArgs
51− let [(s',"")] = readDec ss
52− [(e,"")] = readDec es
53− s = s' - 1
54− case name of
55− "bs" -> bytestring file s e
56− "lbs" -> lazyBytestring file s e
57− "ltext" -> lazyText file s e
58− "text" -> text file s e
59− "ltextBS" -> lazyTextBS file s e
60− "textBS" -> textBS file s e
tests/benchmarks/DecodeUtf8.hsdeleted−107
@@ -1,107 +0,0 @@
1−import qualified Data.ByteString as B
2−import qualified Data.ByteString.Lazy as BL
3−import qualified Data.Text as T
4−import qualified Data.Text.IO as T
5−import qualified Data.Text.Encoding as T
6−import qualified Data.Text.Lazy as TL
7−import qualified Data.Text.Lazy.Encoding as TL
8−import qualified Data.Text.Lazy.IO as TL
9−import qualified Codec.Binary.UTF8.Generic as U8
10−import Control.DeepSeq
11−import System.Environment
12−import System.IO
13−
14−strict h = do
15− bs <- B.hGetContents h
16− rnf (T.decodeUtf8 bs) `seq` return ()
17−
18−strict_len h = do
19− bs <- B.hGetContents h
20− print . T.length . T.decodeUtf8 $ bs
21−
22−strict_init_len h = do
23− bs <- B.hGetContents h
24− print . T.length . T.init . T.decodeUtf8 $ bs
25−
26−strict_io h = do
27− hSetEncoding h utf8
28− t <- T.hGetContents h
29− rnf t `seq` return ()
30−
31−strict_len_io h = do
32− hSetEncoding h utf8
33− t <- T.hGetContents h
34− print (T.length t)
35−
36−lazy h = do
37− bs <- BL.hGetContents h
38− rnf (TL.decodeUtf8 bs) `seq` return ()
39−
40−lazy_len h = do
41− bs <- BL.hGetContents h
42− print . TL.length . TL.decodeUtf8 $ bs
43−
44−lazy_init_len h = do
45− bs <- BL.hGetContents h
46− print . TL.length . TL.init . TL.decodeUtf8 $ bs
47−
48−lazy_io h = do
49− hSetEncoding h utf8
50− t <- TL.hGetContents h
51− rnf t `seq` return ()
52−
53−lazy_len_io h = do
54− hSetEncoding h utf8
55− t <- TL.hGetContents h
56− print (TL.length t)
57−
58−string h = do
59− hSetEncoding h utf8
60− t <- hGetContents h
61− rnf t `seq` return ()
62−
63−string_len h = do
64− hSetEncoding h utf8
65− t <- hGetContents h
66− print (length t)
67−
68−lazy_string_utf8 h = do
69− bs <- BL.hGetContents h
70− let t = U8.toString bs
71− rnf t `seq` return ()
72−
73−lazy_string_utf8_len h = do
74− bs <- BL.hGetContents h
75− let t = U8.toString bs
76− print (length t)
77−
78−strict_string_utf8 h = do
79− bs <- B.hGetContents h
80− let t = U8.toString bs
81− rnf t `seq` return ()
82−
83−strict_string_utf8_len h = do
84− bs <- B.hGetContents h
85− let t = U8.toString bs
86− print (length t)
87−
88−main = do
89− [kind,name] <- getArgs
90− h <- openFile name ReadMode
91− case kind of
92− "strict" -> strict h
93− "strict_len" -> strict_len h
94− "strict_init_len" -> strict_init_len h
95− "strict_io" -> strict_io h
96− "strict_len_io" -> strict_len_io h
97− "lazy" -> lazy h
98− "lazy_len" -> lazy_len h
99− "lazy_init_len" -> lazy_init_len h
100− "lazy_io" -> lazy_io h
101− "lazy_len_io" -> lazy_len_io h
102− "string" -> string h
103− "string_len" -> string_len h
104− "lazy_string_utf8" -> lazy_string_utf8 h
105− "lazy_string_utf8_len" -> lazy_string_utf8_len h
106− "strict_string_utf8" -> strict_string_utf8 h
107− "strict_string_utf8_len" -> strict_string_utf8_len h
tests/benchmarks/EncodeUtf8.hsdeleted−55
@@ -1,55 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−import qualified Data.ByteString as B
3−import qualified Data.ByteString.Lazy as BL
4−import qualified Data.Text as T
5−import qualified Data.Text.IO as T
6−import qualified Data.Text.Encoding as T
7−import qualified Data.Text.Lazy as TL
8−import qualified Data.Text.Lazy.Encoding as TL
9−import qualified Data.Text.Lazy.IO as TL
10−import qualified Codec.Binary.UTF8.Generic as U8
11−import System.Environment
12−import System.IO
13−
14−strict_bytestring k s = do
15− let t = T.replicate k (T.pack s)
16− B.putStr (T.encodeUtf8 t)
17−
18−lazy_bytestring k s = do
19− let t = TL.replicate (fromIntegral k) (TL.pack s)
20− BL.putStr (TL.encodeUtf8 t)
21−
22−strict_io k s = do
23− let t = T.replicate k (T.pack s)
24− hSetEncoding stdout utf8
25− T.putStr t
26−
27−lazy_io k s = do
28− let t = TL.replicate (fromIntegral k) (TL.pack s)
29− hSetEncoding stdout utf8
30− TL.putStr t
31−
32−string k s = do
33− let t = concat $ replicate k s
34− hSetEncoding stdout utf8
35− putStr t
36−
37−lazy_string_utf8 k s = do
38− let t = concat $ replicate k s
39− BL.putStr (U8.fromString t)
40−
41−strict_string_utf8 k s = do
42− let t = concat $ replicate k s
43− B.putStr (U8.fromString t)
44−
45−main = do
46− [kind,str,kstr] <- getArgs
47− let k = read kstr * 1000000
48− case kind of
49− "strict" -> strict_bytestring k str
50− "lazy" -> lazy_bytestring k str
51− "strict_io" -> strict_io k str
52− "lazy_io" -> lazy_io k str
53− "string" -> string k str
54− "lazy_string_utf8" -> lazy_string_utf8 k str
55− "strict_string_utf8" -> strict_string_utf8 k str
tests/benchmarks/Equality.hsdeleted−31
@@ -1,31 +0,0 @@
1−import System.Environment
2−import qualified Data.ByteString.Char8 as B
3−import qualified Data.ByteString.Lazy.Char8 as BL
4−import qualified Data.Text as T
5−import qualified Data.Text.Encoding as T
6−import qualified Data.Text.Lazy as TL
7−import qualified Data.Text.Lazy.Encoding as TL
8−
9−func :: (Eq a) => [a] -> IO ()
10−func ls =
11− print . sum . map (\needle -> length . filter (==needle) $ ls) $ take 100 ls
12−
13−bytestring haystack = func =<< B.lines `fmap` B.readFile haystack
14−
15−lazyBytestring haystack = func =<< BL.lines `fmap` BL.readFile haystack
16−
17−text haystack = func =<< (T.lines . T.decodeUtf8) `fmap` B.readFile haystack
18−
19−lazyText haystack = func =<<
20− (TL.lines . TL.decodeUtf8) `fmap` BL.readFile haystack
21−
22−string haystack = func =<< lines `fmap` readFile haystack
23−
24−main = do
25− args <- getArgs
26− case args of
27− ["bs",h] -> bytestring h
28− ["lazybs",h] -> lazyBytestring h
29− ["text",h] -> text h
30− ["lazytext",h] -> lazyText h
31− ["string",h] -> string h
tests/benchmarks/FileIndices.hsdeleted−25
@@ -1,25 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−import System.Environment (getArgs)
4−import qualified Data.Text.Lazy.IO as T
5−import qualified Data.Text.Lazy as T
6−import qualified Data.Text.Lazy.Encoding as T
7−import qualified Data.ByteString.Lazy.Char8 as B
8−import qualified Data.ByteString.Char8 as BS
9−import qualified Data.ByteString.Lazy.Search as B
10−
11−text :: FilePath -> String -> IO ()
12−text file pat = T.readFile file >>= print . T.count (T.pack pat)
13−
14−textBS :: FilePath -> String -> IO ()
15−textBS file pat = B.readFile file >>= print . T.count (T.pack pat) . T.decodeUtf8
16−
17−bytestring :: FilePath -> String -> IO ()
18−bytestring file pat = B.readFile file >>= print . length . B.indices (BS.pack pat)
19−
20−main = do
21− (name : file : pat : _) <- getArgs
22− case name of
23− "bs" -> bytestring file pat
24− "text" -> text file pat
25− "textBS" -> textBS file pat
tests/benchmarks/FileRead.hsdeleted−57
@@ -1,57 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−import System.Environment (getArgs)
4−import qualified Data.Text.IO as T
5−import qualified Data.Text as T
6−import qualified Data.Text.Encoding as T
7−import qualified Data.Text.Lazy.IO as TL
8−import qualified Data.Text.Lazy as TL
9−import qualified Data.Text.Lazy.Encoding as TL
10−import qualified Data.ByteString.Char8 as B
11−import qualified Data.ByteString.Lazy.Char8 as BL
12−import System.IO
13−
14−string :: Handle -> IO ()
15−string h = hGetContents h >>= print . length
16−
17−ltext :: Handle -> IO ()
18−ltext h = do
19− t <- {-# SCC "TL.hGetContents" #-} TL.hGetContents h
20− print (TL.length t)
21−
22−ltextBS :: Handle -> IO ()
23−ltextBS h = do
24− bs <- {-# SCC "B.hGetContents" #-} BL.hGetContents h
25− print . TL.length . TL.decodeUtf8 $ bs
26−
27−text :: Handle -> IO ()
28−text h = do
29− t <- {-# SCC "T.hGetContents" #-} T.hGetContents h
30− print (T.length t)
31−
32−textBS :: Handle -> IO ()
33−textBS h = do
34− bs <- {-# SCC "B.hGetContents" #-} B.hGetContents h
35− print . T.length . T.decodeUtf8 $ bs
36−
37−lbytestring :: Handle -> IO ()
38−lbytestring h = do
39− bs <- {-# SCC "BL.hGetContents" #-} BL.hGetContents h
40− print (BL.length bs)
41−
42−bytestring :: Handle -> IO ()
43−bytestring h = do
44− bs <- {-# SCC "B.hGetContents" #-} B.hGetContents h
45− print (B.length bs)
46−
47−main = do
48− (name : file : _) <- getArgs
49− h <- openFile file ReadMode
50− case name of
51− "bs" -> bytestring h
52− "lbs" -> lbytestring h
53− "ltext" -> ltext h
54− "ltextBS" -> ltextBS h
55− "string" -> string h
56− "text" -> text h
57− "textBS" -> textBS h
tests/benchmarks/FoldLines.hsdeleted−47
@@ -1,47 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−import System.Environment
4−import System.IO
5−import qualified Data.Text as T
6−import qualified Data.Text.IO as T
7−import qualified Data.ByteString as S
8−
9−-- Text
10−foldLinesT :: (a -> T.Text -> a) -> a -> Handle -> IO a
11−foldLinesT f z0 h = go z0
12− where
13− go !z = do
14− eof <- hIsEOF h
15− if eof
16− then return z
17− else do
18− l <- T.hGetLine h
19− let z' = f z l in go z'
20−{-# INLINE foldLinesT #-}
21−
22−testT :: Handle -> IO Int
23−testT = foldLinesT (\n _ -> n + 1) 0
24−
25−--ByteString
26−foldLinesB :: (a -> S.ByteString -> a) -> a -> Handle -> IO a
27−foldLinesB f z0 h = go z0
28− where
29− go !z = do
30− eof <- hIsEOF h
31− if eof
32− then return z
33− else do
34− l <- S.hGetLine h
35− let z' = f z l in go z'
36−{-# INLINE foldLinesB #-}
37−
38−testB :: Handle -> IO Int
39−testB = foldLinesB (\n _ -> n + 1) 0
40−
41−main = do
42− (name : file : _) <- getArgs
43− h <- openFile file ReadMode
44− hSetBuffering h (BlockBuffering (Just 16384))
45− case name of
46− "bs" -> testB h
47− "text" -> testT h
tests/benchmarks/HtmlCombinator.hsdeleted−24
@@ -1,24 +0,0 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2−import Data.Monoid (mappend, mconcat)
3−import Prelude hiding (putStr)
4−import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)
5−import Data.Text.Lazy.IO (putStr)
6−
7−import qualified Data.Text as T
8−
9−main :: IO ()
10−main = do
11− putStr "Content-Type: text/html\n\n<table>"
12− putStr . toLazyText $ mconcat (replicate 20000 makeRow)
13− putStr "</table>"
14−
15−makeRow :: Builder
16−makeRow = mconcat (map makeCol [1..50])
17−
18−makeCol :: Int -> Builder
19−makeCol 1 = fromText "<tr><td>1</td>"
20−makeCol 50 = fromText "<td>50</td></tr>"
21−makeCol i = fromText "<td>" `mappend` (textInt i `mappend` fromText "</td>")
22−
23−textInt :: Int -> Builder
24−textInt = fromText . T.pack . show
tests/benchmarks/Makefiledeleted−18
@@ -1,18 +0,0 @@
1−CC := $(shell icu-config --cc)
2−CFLAGS := -g $(shell icu-config --cflags)
3−CPPFLAGS := $(shell icu-config --cppflags)
4−LDFLAGS := $(CFLAGS) $(shell icu-config --ldflags --ldflags-icuio)
5−ghc := ghc
6−
7−all := FileRead FileRead_prof Replace Replace_prof fileread_c
8−
9−all: $(all)
10−
11−%: %.hs
12− $(ghc) -O --make -o $@ $^
13−
14−%_prof: %.hs
15− $(ghc) -prof -auto-all -O --make -o $@ $^
16−
17−clean:
18− -rm -f *.hi *.o $(all)
tests/benchmarks/Ordering.hsdeleted−42
@@ -1,42 +0,0 @@
1−import System.Environment
2−import qualified Data.ByteString.Char8 as B
3−import qualified Data.ByteString.Lazy.Char8 as BL
4−import qualified Data.Text as T
5−import qualified Data.Text.Encoding as T
6−import qualified Data.Text.Lazy as TL
7−import qualified Data.Text.Lazy.Encoding as TL
8−
9−every :: Int -> [a] -> [a]
10−every k = go k
11− where go n (x:xs)
12− | n < k = go (n+1) xs
13− | otherwise = x : go 1 xs
14− go _ _ = []
15−
16−func :: (Ord a) => [a] -> IO ()
17−func ls = print . sum . map f $ every 1000 ls
18− where f needle = length . filter ((==GT) . compare needle) $ ls
19−
20−-- Test a comparison that could be fused: compare (toLower a) (toLower b)
21−func1 ls = print . sum . map f $ every 1000 ls
22− where f needle = length . filter ((==GT) . compare (T.toLower needle) . T.toLower) $ ls
23−
24−bytestring haystack = func =<< B.lines `fmap` B.readFile haystack
25−
26−lazyBytestring haystack = func =<< BL.lines `fmap` BL.readFile haystack
27−
28−text haystack = func =<< (T.lines . T.decodeUtf8) `fmap` B.readFile haystack
29−
30−lazyText haystack = func =<<
31− (TL.lines . TL.decodeUtf8) `fmap` BL.readFile haystack
32−
33−string haystack = func =<< lines `fmap` readFile haystack
34−
35−main = do
36− args <- getArgs
37− case args of
38− ["bs",h] -> bytestring h
39− ["lazybs",h] -> lazyBytestring h
40− ["text",h] -> text h
41− ["lazytext",h] -> lazyText h
42− ["string",h] -> string h
tests/benchmarks/ReadNumbers.hsdeleted−48
@@ -1,48 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−
3−import Data.List (foldl')
4−import System.Environment (getArgs)
5−import qualified Data.ByteString.Char8 as B
6−import qualified Data.ByteString.Lazy.Char8 as BL
7−import qualified Data.ByteString.Lex.Double as B
8−import qualified Data.ByteString.Lex.Lazy.Double as BL
9−import qualified Data.Text as T
10−import qualified Data.Text.Encoding as T
11−import qualified Data.Text.Lazy as TL
12−import qualified Data.Text.Lazy.Encoding as TL
13−import qualified Data.Text.Lazy.Read as TL
14−import qualified Data.Text.Read as T
15−
16−readem :: (Ord a, Num a) =>
17− IO [t] -> (t -> Either String (a,t)) -> IO ()
18−readem act reader = print . foldl' go 1000000 =<< act
19− where go z t = case reader t of
20− Left err -> error err
21− Right (n,_) -> min n z
22−
23−bytey :: (Ord a, Num a) =>
24− IO [t] -> (t -> Maybe (a,t)) -> IO ()
25−bytey act reader = print . foldl' go 1000000 =<< act
26− where go z t = case reader t of
27− Nothing -> error "barf"
28− Just (n,_) -> min n z
29−
30−main = do
31− args <- getArgs
32− let strict = (T.lines . T.decodeUtf8) `fmap` B.getContents
33− lazy = (TL.lines . TL.decodeUtf8) `fmap` BL.getContents
34− bs = B.lines `fmap` B.getContents
35− lbs = BL.lines `fmap` BL.getContents
36− case args of
37− ["dec"] -> readem strict (T.signed T.decimal :: T.Reader Int)
38− ["hex"] -> readem strict (T.signed T.hexadecimal :: T.Reader Int)
39− ["double"] -> readem strict (T.double :: T.Reader Double)
40− ["rational"] -> readem strict (T.rational :: T.Reader Double)
41− ["ldec"] -> readem lazy (TL.signed TL.decimal :: TL.Reader Int)
42− ["lhex"] -> readem lazy (TL.signed TL.hexadecimal :: TL.Reader Int)
43− ["ldouble"] -> readem lazy (TL.double :: TL.Reader Double)
44− ["lrational"] -> readem lazy (TL.rational :: TL.Reader Double)
45− ["bdec"] -> bytey bs B.readInt
46− ["bdouble"] -> bytey bs B.readDouble
47− ["bldec"] -> bytey lbs BL.readInt
48− ["bldouble"] -> bytey lbs BL.readDouble
tests/benchmarks/Replace.hsdeleted−23
@@ -1,23 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module Main (main) where
3−
4−import System.Environment (getArgs)
5−import qualified Data.Text.Lazy as LT
6−import qualified Data.Text.Lazy.IO as LT
7−import qualified Data.ByteString.Lazy.Search as LB
8−import qualified Data.ByteString.Lazy.Char8 as LB
9−import qualified Data.ByteString.Char8 as B
10−
11−lazyText file pat sub =
12− LT.readFile file >>= LT.putStr . LT.replace (LT.pack pat) (LT.pack sub)
13−
14−lazyBS file pat sub =
15− LB.readFile file >>= LB.putStr . LB.replace (B.pack pat) (LB.pack sub)
16−
17−main = do
18− (kind : file : pat : sub : _) <- getArgs
19− case kind of
20− "lazyText" -> lazyText file pat sub
21− "lazyTextNull" -> LT.readFile file >>= LT.putStr
22− "lazyBS" -> lazyBS file pat sub
23− "lazyBSNull" -> LB.readFile file >>= LB.putStr
tests/benchmarks/ReplaceTags.hsdeleted−91
@@ -1,91 +0,0 @@
1−-- Contributed by Ken Friis Larsen and Morten Ib Nielsen.
2−
3−{-# LANGUAGE BangPatterns #-}
4−module Main (main) where
5−
6−import System.Environment (getArgs)
7−import qualified Char
8−
9−import qualified Data.Text as T
10−import qualified Data.Text.IO as T
11−
12−import qualified Data.Text.Lazy as TL
13−import qualified Data.Text.Lazy.IO as TL
14−import qualified Data.ByteString.Lazy as BL
15−import qualified Data.Text.Lazy.Encoding as TLE
16−
17−
18−import qualified Data.ByteString.Char8 as BC
19−import qualified Data.ByteString as B
20−import qualified Data.Text.Encoding as TE
21−
22−replaceTagsM file tag sub =
23− BC.readFile file >>= BC.putStr . replaceTags tag sub . TE.encodeUtf8 . T.toLower . TE.decodeUtf8
24− where
25− replaceTags tag replacement str = B.concat $ reverse $ replaceTags' [] (BC.pack $ '<' : tag) '>' (BC.pack replacement) str
26− replaceTags' !res start end repl str =
27− let (pre, post) = BC.breakSubstring start str
28− in if BC.null post
29− then pre : res
30− else replaceTags' (repl : pre : res) start end repl $ BC.drop 1 $
31− BC.dropWhile (/= end) post
32−
33−splitB sep str = seplen `seq` splitter str
34− where
35− splitter str = h : if B.null t then [] else splitter (B.drop seplen t)
36− where (h,t) = B.breakSubstring sep str
37− seplen = B.length sep
38−
39−replaceTagsWrong file tagName sub = do
40− content <- BC.readFile file
41− let frags = map (BC.drop 1 . BC.dropWhile (/= '>'))
42− $ splitB (BC.pack $ '<' : tagName) (BC.map Char.toLower content)
43− BC.putStr $ BC.intercalate (BC.pack sub) frags
44−
45−replaceTagsK file tagName sub = do
46− raw <- BC.readFile file
47− let content = (TE.encodeUtf8 . T.toLower . TE.decodeUtf8) raw
48− let frags = map (BC.drop 1 . BC.dropWhile (/= '>'))
49− $ splitB (BC.pack $ '<' : tagName) content
50− BC.putStr $ BC.intercalate (BC.pack sub) frags
51−
52−replaceTagsO file tagName sub = do
53− raw <- BC.readFile file
54− let content = (TE.encodeUtf8 . T.toLower . TE.decodeUtf8) raw
55− let frags = splitB (BC.pack $ '<' : tagName) content
56− BC.putStr $ BC.intercalate (BC.pack sub) frags
57− where
58− splitB sep str = splitter str
59− where
60− splitter str = h : if BC.null t then [] else splitter (BC.drop 1 $ BC.dropWhile (/= '>') t)
61− where (h,t) = B.breakSubstring sep str
62−
63−
64−
65−replaceTagsT file tagName sub = do
66− raw <- B.readFile file
67− let content = TE.decodeUtf8 raw
68− let frags = map (T.drop 1 . T.dropWhile (/= '>'))
69− $ T.split (T.pack $ '<' : tagName) (T.toLower content)
70− T.putStr $ T.intercalate (T.pack sub) frags
71−
72−replaceTagsTL file tagName sub = do
73− raw <- BL.readFile file
74− let content = TLE.decodeUtf8 raw
75− let frags = map (TL.drop 1 . TL.dropWhile (/= '>'))
76− $ TL.split (TL.pack $ '<' : tagName) (TL.toLower content)
77− TL.putStr $ TL.intercalate (TL.pack sub) frags
78−
79−
80−main = do
81− (kind : file : tag : sub : _) <- getArgs
82− case kind of
83− "Text" -> replaceTagsT file tag sub
84− "TextLazy" -> replaceTagsTL file tag sub
85− "BytestringM" -> replaceTagsM file tag sub
86− "BytestringK" -> replaceTagsK file tag sub
87− "BytestringO" -> replaceTagsO file tag sub
88− "TextNull" -> T.readFile file >>= T.putStr
89− "ByteNull" -> B.readFile file >>= B.putStr
90− "EncodeNull" -> B.readFile file >>= T.putStr . T.toLower . TE.decodeUtf8
91−
tests/benchmarks/StripBrackets.hsdeleted−21
@@ -1,21 +0,0 @@
1−-- From Petr Prokhorenkov.
2−
3−import Data.Text as T
4−import Data.Text.IO as T
5−
6−stripBrackets :: T.Text -> T.Text
7−stripBrackets text = snd $ T.mapAccumL f 0 text where
8− f depth c = let
9− depth' = depth + d' c
10− c' | depth > 0 || depth' > 0 = ' '
11− | otherwise = c
12− in
13− (depth', c')
14−
15− d' '{' = 1
16− d' '[' = 1
17− d' '}' = -1
18− d' ']' = -1
19− d' _ = 0
20−
21−main = T.interact stripBrackets
tests/benchmarks/casemap.pydeleted−15
@@ -1,15 +0,0 @@
1−#!/usr/bin/env python
2−
3−import sys, time
4−
5−def timeit(f):
6− start = time.time()
7− f()
8− end = time.time()
9− print end - start
10−
11−for f in sys.argv[1:]:
12− s = open(f).read()
13− u = s.decode('utf8')
14− timeit(lambda: s.upper())
15− timeit(lambda: u.upper())
tests/benchmarks/fileread.pydeleted−41
@@ -1,41 +0,0 @@
1−#!/usr/bin/env python
2−
3−import sys
4−
5−def string(name):
6− print len(open(name).read())
7−
8−def lazystring(name):
9− fp = open(name)
10− n = 0
11− d = True
12− bs = 128 * 1024
13− read = fp.read
14− while d:
15− d = len(read(bs))
16− n += d
17− print n
18−
19−def lazytext(name):
20− fp = open(name)
21− n = 0
22− d = True
23− bs = 128 * 1024
24− read = fp.read
25− while d:
26− s = read(bs)
27− d = len(s.decode('utf-8', 'replace'))
28− n += d
29− print n
30−
31−def text(name):
32− print len(open(name).read().decode('utf-8', 'replace'))
33−
34−if sys.argv[1] == 'bs':
35− string(sys.argv[2])
36−if sys.argv[1] == 'lbs':
37− lazystring(sys.argv[2])
38−elif sys.argv[1] == 'lazytext':
39− lazytext(sys.argv[2])
40−elif sys.argv[1] == 'text':
41− text(sys.argv[2])
tests/benchmarks/fileread_c.cdeleted−96
@@ -1,96 +0,0 @@
1−#include <unicode/ustdio.h>
2−#include <stdio.h>
3−#include <stdlib.h>
4−#include <string.h>
5−
6−void lazystring(const char *name)
7−{
8− FILE *ufp = fopen(name, "r");
9− const size_t bufsize = sizeof(char) * 32 * 1024;
10− char *str = malloc(bufsize);
11− long len = 0;
12− int32_t n;
13−
14− do {
15− n = fread(str, sizeof(char), bufsize, ufp);
16− len += n;
17− } while (n > 0);
18−
19− printf("%ld\n", len);
20−}
21−
22−void lazytext(const char *name)
23−{
24− UFILE *ufp = u_fopen(name, "r", NULL, "UTF-8");
25− const size_t bufsize = sizeof(UChar) * 32 * 1024;
26− UChar *str = malloc(bufsize);
27− long len = 0;
28− int32_t n;
29−
30− do {
31− n = u_file_read(str, bufsize, ufp);
32− len += n;
33− } while (n > 0);
34−
35− printf("%ld\n", len);
36−}
37−
38−void text(const char *name)
39−{
40− UFILE *ufp = u_fopen(name, "r", NULL, "UTF-8");
41− FILE *fp = u_fgetfile(ufp);
42− UChar *str;
43− long fsize;
44− int32_t n;
45−
46− fseek(fp, 0, SEEK_END);
47− fsize = ftell(fp);
48− u_frewind(ufp);
49−
50− str = malloc(sizeof(*str) * fsize);
51−
52− n = u_file_read(str, fsize, ufp);
53−
54− printf("%d\n", n);
55−}
56−
57−void string(const char *name)
58−{
59− FILE *fp = fopen(name, "r");
60− char *str;
61− long fsize;
62− int32_t n;
63−
64− fseek(fp, 0, SEEK_END);
65− fsize = ftell(fp);
66− fseek(fp, 0, SEEK_SET);
67−
68− str = malloc(sizeof(*str) * fsize);
69−
70− n = fread(str, sizeof(char), fsize, fp);
71−
72− printf("%d\n", n);
73−}
74−
75−int main(int argc, char **argv)
76−{
77− if (argc != 3) {
78− fprintf(stderr, "Usage: %s handler filename\n", argv[0]);
79− exit(1);
80− }
81−
82− if (strcmp(argv[1], "lazystring") == 0)
83− lazystring(argv[2]);
84− else if (strcmp(argv[1], "lazytext") == 0)
85− lazytext(argv[2]);
86− else if (strcmp(argv[1], "string") == 0)
87− string(argv[2]);
88− else if (strcmp(argv[1], "text") == 0)
89− text(argv[2]);
90− else {
91− fprintf(stderr, "no matching handler\n");
92− return 1;
93− }
94−
95− return 0;
96−}
tests/cabal.confignew file+6
@@ -0,0 +1,6 @@
1+-- These flags help to speed up building the test suite.
2+
3+documentation: False
4+executable-stripping: False
5+flags: developer
6+library-profiling: False
tests/literal-rule-test.shnew file+29
@@ -0,0 +1,29 @@
1+#!/bin/bash -e
2+
3+failed=0
4+
5+function check_firings() {
6+ rule=$1
7+ expected=$2
8+ build="ghc -O -ddump-rule-firings LiteralRuleTest.hs"
9+ build="$build -i.. -I../include"
10+ touch LiteralRuleTest.hs
11+ echo -n "Want to see $expected firings of rule $rule... " >&2
12+ firings=$($build 2>&1 | grep "Rule fired: $rule\$" | wc -l)
13+ rm -f LiteralRuleTest.{o.hi}
14+
15+ if [ $firings != $expected ]; then
16+ echo "failed, saw $firings" >&2
17+ failed=1
18+ else
19+ echo "pass" >&2
20+ fi
21+}
22+
23+check_firings "TEXT literal" 8
24+check_firings "TEXT literal UTF8" 7
25+check_firings "TEXT empty literal" 4
26+# This is broken at the moment. "TEXT literal" rule fires instead.
27+#check_firings "TEXT singleton literal" 5
28+
29+exit $failed
tests/cover-stdio.sh → tests/scripts/cover-stdio.shrenamed+6−1
@@ -1,6 +1,11 @@
11#!/bin/bash
22
3−exe=./stdio-hpc
3+if [[ $# < 1 ]]; then
4+ echo "Usage: $0 <exe>"
5+ exit 1
6+fi
7+
8+exe=$1
49
510rm -f $exe.tix
611
tests/text-tests.cabalnew file+143
@@ -0,0 +1,143 @@
1+name: text-tests
2+version: 0.0.0.0
3+synopsis: Functional tests for the text package
4+description: Functional tests for the text package
5+homepage: https://github.com/bos/text
6+license: BSD2
7+license-file: ../LICENSE
8+author: Jasper Van der Jeugt <jaspervdj@gmail.com>,
9+ Bryan O'Sullivan <bos@serpentine.com>,
10+ Tom Harper <rtomharper@googlemail.com>,
11+ Duncan Coutts <duncan@haskell.org>
12+maintainer: Bryan O'Sullivan <bos@serpentine.com>
13+category: Text
14+build-type: Simple
15+
16+cabal-version: >=1.8
17+
18+flag hpc
19+ description: Enable HPC to generate coverage reports
20+ default: False
21+ manual: True
22+
23+executable text-tests
24+ main-is: Tests.hs
25+
26+ other-modules:
27+ Tests.IO
28+ Tests.Properties
29+ Tests.Properties.Mul
30+ Tests.QuickCheckUtils
31+ Tests.Regressions
32+ Tests.SlowFunctions
33+ Tests.Utils
34+
35+ ghc-options:
36+ -Wall -threaded -O0 -rtsopts
37+
38+ if flag(hpc)
39+ ghc-options:
40+ -fhpc
41+
42+ cpp-options:
43+ -DTEST_SUITE
44+ -DASSERTS
45+ -DHAVE_DEEPSEQ
46+
47+ build-depends:
48+ HUnit >= 1.2,
49+ QuickCheck >= 2.7,
50+ base == 4.*,
51+ bytestring,
52+ deepseq,
53+ directory,
54+ quickcheck-unicode,
55+ random,
56+ test-framework >= 0.4,
57+ test-framework-hunit >= 0.2,
58+ test-framework-quickcheck2 >= 0.2,
59+ text-tests
60+
61+executable text-tests-stdio
62+ main-is: Tests/IO.hs
63+
64+ ghc-options:
65+ -Wall -threaded -rtsopts
66+
67+ -- Optional HPC support
68+ if flag(hpc)
69+ ghc-options:
70+ -fhpc
71+
72+ build-depends:
73+ text-tests,
74+ base >= 4 && < 5
75+
76+library
77+ hs-source-dirs: ..
78+ c-sources: ../cbits/cbits.c
79+ include-dirs: ../include
80+ ghc-options: -Wall
81+ exposed-modules:
82+ Data.Text
83+ Data.Text.Array
84+ Data.Text.Encoding
85+ Data.Text.Encoding.Error
86+ Data.Text.Internal.Encoding.Fusion
87+ Data.Text.Internal.Encoding.Fusion.Common
88+ Data.Text.Internal.Encoding.Utf16
89+ Data.Text.Internal.Encoding.Utf32
90+ Data.Text.Internal.Encoding.Utf8
91+ Data.Text.Foreign
92+ Data.Text.Internal.Fusion
93+ Data.Text.Internal.Fusion.CaseMapping
94+ Data.Text.Internal.Fusion.Common
95+ Data.Text.Internal.Fusion.Size
96+ Data.Text.Internal.Fusion.Types
97+ Data.Text.IO
98+ Data.Text.Internal.IO
99+ Data.Text.Internal
100+ Data.Text.Lazy
101+ Data.Text.Lazy.Builder
102+ Data.Text.Internal.Builder.Functions
103+ Data.Text.Lazy.Builder.Int
104+ Data.Text.Internal.Builder.Int.Digits
105+ Data.Text.Internal.Builder
106+ Data.Text.Lazy.Builder.RealFloat
107+ Data.Text.Internal.Builder.RealFloat.Functions
108+ Data.Text.Lazy.Encoding
109+ Data.Text.Internal.Lazy.Encoding.Fusion
110+ Data.Text.Internal.Lazy.Fusion
111+ Data.Text.Lazy.IO
112+ Data.Text.Internal.Lazy
113+ Data.Text.Lazy.Read
114+ Data.Text.Internal.Lazy.Search
115+ Data.Text.Internal.Private
116+ Data.Text.Read
117+ Data.Text.Show
118+ Data.Text.Internal.Read
119+ Data.Text.Internal.Search
120+ Data.Text.Unsafe
121+ Data.Text.Internal.Unsafe
122+ Data.Text.Internal.Unsafe.Char
123+ Data.Text.Internal.Unsafe.Shift
124+ Data.Text.Internal.Functions
125+
126+ if flag(hpc)
127+ ghc-options:
128+ -fhpc
129+
130+ cpp-options:
131+ -DTEST_SUITE
132+ -DHAVE_DEEPSEQ
133+ -DASSERTS
134+ -DINTEGER_GMP
135+
136+ build-depends:
137+ array,
138+ base == 4.*,
139+ binary,
140+ bytestring,
141+ deepseq,
142+ ghc-prim,
143+ integer-gmp
text.cabal+137−70
@@ -1,9 +1,9 @@
11name: text
2−version: 0.11.0.6
3−homepage: http://bitbucket.org/bos/text
4−bug-reports: http://bitbucket.org/bos/text/issues
2+version: 1.2.2.1
3+homepage: https://github.com/bos/text
4+bug-reports: https://github.com/bos/text/issues
55synopsis: An efficient packed Unicode text type.
6−description:
6+description:
77 .
88 An efficient packed, immutable Unicode text type (both strict and
99 lazy), with a powerful loop fusion optimization framework.
@@ -30,53 +30,59 @@ description:
3030 non-standard encodings, text breaking, and locales), see
3131 the @text-icu@ package:
3232 <http://hackage.haskell.org/package/text-icu>
33− .
34−license: BSD3
33+
34+license: BSD2
3535license-file: LICENSE
3636author: Bryan O'Sullivan <bos@serpentine.com>
3737maintainer: Bryan O'Sullivan <bos@serpentine.com>
38− Tom Harper <rtomharper@googlemail.com>
39− Duncan Coutts <duncan@haskell.org>
40−copyright: 2008-2009 Tom Harper, 2009-2010 Bryan O'Sullivan
38+copyright: 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper
4139category: Data, Text
4240build-type: Simple
43−cabal-version: >= 1.6
41+cabal-version: >= 1.8
4442extra-source-files:
45− README.markdown
4643 -- scripts/CaseFolding.txt
4744 -- scripts/SpecialCasing.txt
48− scripts/ApiCompare.hs
49− scripts/Arsec.hs
50− scripts/CaseFolding.hs
51− scripts/CaseMapping.hs
52− scripts/SpecialCasing.hs
53− tests/Benchmarks.hs
45+ README.markdown
46+ benchmarks/Setup.hs
47+ benchmarks/cbits/*.c
48+ benchmarks/haskell/*.hs
49+ benchmarks/haskell/Benchmarks/*.hs
50+ benchmarks/haskell/Benchmarks/Programs/*.hs
51+ benchmarks/python/*.py
52+ benchmarks/ruby/*.rb
53+ benchmarks/text-benchmarks.cabal
54+ changelog.md
55+ include/*.h
56+ scripts/*.hs
57+ tests-and-benchmarks.markdown
58+ tests/*.hs
59+ tests/.ghci
5460 tests/Makefile
55− tests/Properties.hs
56− tests/QuickCheckUtils.hs
57− tests/SlowFunctions.hs
58− tests/StdioCoverage.hs
59− tests/TestUtils.hs
60− tests/benchmarks/Cut.hs
61− tests/benchmarks/DecodeUtf8.hs
62− tests/benchmarks/EncodeUtf8.hs
63− tests/benchmarks/Equality.hs
64− tests/benchmarks/FileIndices.hs
65− tests/benchmarks/FileRead.hs
66− tests/benchmarks/FoldLines.hs
67− tests/benchmarks/HtmlCombinator.hs
68− tests/benchmarks/Makefile
69− tests/benchmarks/Replace.hs
70− tests/benchmarks/ReplaceTags.hs
71− tests/benchmarks/fileread.py
72− tests/benchmarks/fileread_c.c
73− tests/cover-stdio.sh
61+ tests/Tests/*.hs
62+ tests/Tests/Properties/*.hs
63+ tests/cabal.config
64+ tests/scripts/*.sh
65+ tests/text-tests.cabal
66+
67+flag bytestring-builder
68+ description: Depend on the bytestring-builder package for backwards compatibility.
69+ default: False
70+ manual: False
7471
7572flag developer
7673 description: operate in developer mode
7774 default: False
75+ manual: True
76+
77+flag integer-simple
78+ description: Use the simple integer library instead of GMP
79+ default: False
80+ manual: False
7881
7982library
83+ c-sources: cbits/cbits.c
84+ include-dirs: include
85+
8086 exposed-modules:
8187 Data.Text
8288 Data.Text.Array
@@ -85,57 +91,118 @@ library
8591 Data.Text.Foreign
8692 Data.Text.IO
8793 Data.Text.Internal
94+ Data.Text.Internal.Builder
95+ Data.Text.Internal.Builder.Functions
96+ Data.Text.Internal.Builder.Int.Digits
97+ Data.Text.Internal.Builder.RealFloat.Functions
98+ Data.Text.Internal.Encoding.Fusion
99+ Data.Text.Internal.Encoding.Fusion.Common
100+ Data.Text.Internal.Encoding.Utf16
101+ Data.Text.Internal.Encoding.Utf32
102+ Data.Text.Internal.Encoding.Utf8
103+ Data.Text.Internal.Functions
104+ Data.Text.Internal.Fusion
105+ Data.Text.Internal.Fusion.CaseMapping
106+ Data.Text.Internal.Fusion.Common
107+ Data.Text.Internal.Fusion.Size
108+ Data.Text.Internal.Fusion.Types
109+ Data.Text.Internal.IO
110+ Data.Text.Internal.Lazy
111+ Data.Text.Internal.Lazy.Encoding.Fusion
112+ Data.Text.Internal.Lazy.Fusion
113+ Data.Text.Internal.Lazy.Search
114+ Data.Text.Internal.Private
115+ Data.Text.Internal.Read
116+ Data.Text.Internal.Search
117+ Data.Text.Internal.Unsafe
118+ Data.Text.Internal.Unsafe.Char
119+ Data.Text.Internal.Unsafe.Shift
88120 Data.Text.Lazy
89121 Data.Text.Lazy.Builder
122+ Data.Text.Lazy.Builder.Int
123+ Data.Text.Lazy.Builder.RealFloat
90124 Data.Text.Lazy.Encoding
91125 Data.Text.Lazy.IO
92126 Data.Text.Lazy.Internal
93127 Data.Text.Lazy.Read
94128 Data.Text.Read
95− other-modules:
96− Data.Text.Encoding.Fusion
97− Data.Text.Encoding.Fusion.Common
98− Data.Text.Encoding.Utf16
99− Data.Text.Encoding.Utf32
100− Data.Text.Encoding.Utf8
101− Data.Text.Fusion
102− Data.Text.Fusion.CaseMapping
103− Data.Text.Fusion.Common
104− Data.Text.Fusion.Internal
105− Data.Text.Fusion.Size
106− Data.Text.IO.Internal
107− Data.Text.Lazy.Encoding.Fusion
108− Data.Text.Lazy.Fusion
109− Data.Text.Lazy.Search
110− Data.Text.Search
111129 Data.Text.Unsafe
112− Data.Text.UnsafeChar
113− Data.Text.UnsafeShift
114− Data.Text.Util
130+
131+ other-modules:
132+ Data.Text.Show
115133
116134 build-depends:
117− base < 5,
118− bytestring >= 0.9 && < 1.0
119− if impl(ghc >= 6.10)
120− build-depends:
121− ghc-prim, base >= 4, deepseq >= 1.1.0.0
122− cpp-options: -DHAVE_DEEPSEQ
135+ array >= 0.3,
136+ base >= 4.2 && < 5,
137+ binary,
138+ deepseq >= 1.1.0.0,
139+ ghc-prim >= 0.2
140+
141+ if flag(bytestring-builder)
142+ build-depends: bytestring >= 0.9 && < 0.10.4,
143+ bytestring-builder >= 0.10.4
123144 else
124− build-depends: extensible-exceptions
125− extensions: PatternSignatures
145+ build-depends: bytestring >= 0.10.4
126146
127− ghc-options: -Wall -funbox-strict-fields -O2
128− if impl(ghc >= 6.8)
129− ghc-options: -fwarn-tabs
147+ cpp-options: -DHAVE_DEEPSEQ
148+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
130149 if flag(developer)
131150 ghc-prof-options: -auto-all
132151 ghc-options: -Werror
133152 cpp-options: -DASSERTS
134153
135−source-repository head
136− type: mercurial
137− location: http://bitbucket.org/bos/text
154+ if flag(integer-simple)
155+ cpp-options: -DINTEGER_SIMPLE
156+ build-depends: integer-simple >= 0.1 && < 0.5
157+ else
158+ cpp-options: -DINTEGER_GMP
159+ build-depends: integer-gmp >= 0.2
160+
161+test-suite tests
162+ type: exitcode-stdio-1.0
163+ hs-source-dirs: tests .
164+ main-is: Tests.hs
165+ c-sources: cbits/cbits.c
166+ include-dirs: include
167+
168+ ghc-options:
169+ -Wall -threaded -O0 -rtsopts
170+
171+ cpp-options:
172+ -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE
173+
174+ build-depends:
175+ HUnit >= 1.2,
176+ QuickCheck >= 2.7,
177+ array,
178+ base,
179+ binary,
180+ deepseq,
181+ directory,
182+ ghc-prim,
183+ quickcheck-unicode,
184+ random,
185+ test-framework >= 0.4,
186+ test-framework-hunit >= 0.2,
187+ test-framework-quickcheck2 >= 0.2
188+
189+ if flag(bytestring-builder)
190+ build-depends: bytestring >= 0.9 && < 0.10.4,
191+ bytestring-builder >= 0.10.4
192+ else
193+ build-depends: bytestring >= 0.10.4
194+
195+ if flag(integer-simple)
196+ cpp-options: -DINTEGER_SIMPLE
197+ build-depends: integer-simple >= 0.1 && < 0.5
198+ else
199+ cpp-options: -DINTEGER_GMP
200+ build-depends: integer-gmp >= 0.2
138201
139202source-repository head
140203 type: git
141− location: http://github.com/bos/text
204+ location: https://github.com/bos/text
205+
206+source-repository head
207+ type: mercurial
208+ location: https://bitbucket.org/bos/text