on master help sign in
.gitignorenew file+3
since splitsnapshots
unifiedsplit
@@ -0,0 +1,3 @@
1+dist
2+cabal-dev
3+cabal.sandbox.config
.hgignore+10−3
@@ -1,7 +1,14 @@
1−^dist$
1+^(?:dist|benchmarks/dist|tests/coverage|tests/dist)$
2−^tests/benchmarks/.*\.txt$
2+^benchmarks/.*\.txt$
3+^tests/text-testdata.tar.bz2$
3^tests/(?:\.hpc|bm|qc|qc-hpc|stdio-hpc|text/test)$
4^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)$
5~$
6~$
7+
6syntax: glob
8syntax: glob
7.\#*
9.\#*
10+cabal-dev
11+cabal.sandbox.config
12+\.cabal-sandbox
13+scripts/CaseFolding.txt
14+scripts/SpecialCasing.txt
.hgtags+53−2
@@ -11,5 +11,56 @@ b4fdbef1c1027a70b95c1a81747d968890acc3f6 0.3
11de7cb0cb2a72606126c357b860bb0dbf7f145ad2 0.9.0.1
11de7cb0cb2a72606126c357b860bb0dbf7f145ad2 0.9.0.1
12f2c9b1c019e3277926378d7b5a604f1c995f0202 0.7
12f2c9b1c019e3277926378d7b5a604f1c995f0202 0.7
13f3d625f2d0730cb6adf8506a1f37762178c9aea6 0.10.0.0
13f3d625f2d0730cb6adf8506a1f37762178c9aea6 0.10.0.0
14−99ea36957b1d47145d70f2ee8b13f1ddfd09245c 10.0.0.1
14+99ea36957b1d47145d70f2ee8b13f1ddfd09245c 0.10.0.1
15+1b7889216e78b00d69b32c48782111bcd935978d 0.10.0.2
15−75157eaec6eb38574ad5c347e75c48dcb7262dee 11.0.0.0
16+75157eaec6eb38574ad5c347e75c48dcb7262dee 0.11.0.0
17+0d7bc7bd77ec5a8f6d064de59d459e5eaf906b0f 0.11.0.1
18+a9d582a75dea9a4417883019d5110a35e4c07265 0.11.0.2
19+36b2a3aa661892ea25101199220383ba6d579abb 0.11.0.3
20+06e407bcdc9a3905abf9551062ecc6f92abcdde5 0.11.0.4
21+94bcf16e812f6fb49b87598673e17270f48c2bf1 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+403−181
@@ -1,15 +1,20 @@
1−{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
1+{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# 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
3
9
4-- |
10-- |
5-- Module : Data.Text
11-- Module : Data.Text
6−-- Copyright : (c) 2008, 2009 Tom Harper,
7−-- (c) 2009, 2010 Bryan O'Sullivan,
12+-- Copyright : (c) 2009, 2010, 2011, 2012 Bryan O'Sullivan,
8−-- (c) 2009 Duncan Coutts
13+-- (c) 2009 Duncan Coutts,
14+-- (c) 2008, 2009 Tom Harper
9--
15--
10-- License : BSD-style
16-- License : BSD-style
11−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
17+-- Maintainer : bos@serpentine.com
12−-- duncan@haskell.org
13-- Stability : experimental
18-- Stability : experimental
14-- Portability : GHC
19-- Portability : GHC
15--
20--
@@ -27,8 +32,8 @@
27--
32--
28-- To use an extended and very rich family of functions for working
33-- To use an extended and very rich family of functions for working
29-- with Unicode text (including normalization, regular expressions,
34-- with Unicode text (including normalization, regular expressions,
30−-- non-standard encodings, text breaking, and locales), see the
35+-- non-standard encodings, text breaking, and locales), see
31−-- @text-icu@ package: <http://hackage.haskell.org/package/text-icu>
36+-- <http://hackage.haskell.org/package/text-icu the text-icu package >.
32
37
33module Data.Text
38module Data.Text
34 (
39 (
@@ -76,6 +81,7 @@ module Data.Text
76 , toCaseFold
81 , toCaseFold
77 , toLower
82 , toLower
78 , toUpper
83 , toUpper
84+ , toTitle
79
85
80 -- ** Justification
86 -- ** Justification
81 , justifyLeft
87 , justifyLeft
@@ -119,8 +125,11 @@ module Data.Text
119
125
120 -- ** Breaking strings
126 -- ** Breaking strings
121 , take
127 , take
128+ , takeEnd
122 , drop
129 , drop
130+ , dropEnd
123 , takeWhile
131 , takeWhile
132+ , takeWhileEnd
124 , dropWhile
133 , dropWhile
125 , dropWhileEnd
134 , dropWhileEnd
126 , dropAround
135 , dropAround
@@ -158,6 +167,7 @@ module Data.Text
158 -- ** View patterns
167 -- ** View patterns
159 , stripPrefix
168 , stripPrefix
160 , stripSuffix
169 , stripSuffix
170+ , commonPrefixes
161
171
162 -- * Searching
172 -- * Searching
163 , filter
173 , filter
@@ -166,92 +176,110 @@ module Data.Text
166 , partition
176 , partition
167
177
168 -- , findSubstring
178 -- , findSubstring
169−
179+
170 -- * Indexing
180 -- * Indexing
171 -- $index
181 -- $index
172 , index
182 , index
173 , findIndex
183 , findIndex
174 , count
184 , count
175
185
176− -- * Zipping and unzipping
186+ -- * Zipping
177 , zip
187 , zip
178 , zipWith
188 , zipWith
179
189
180 -- -* Ordered text
190 -- -* Ordered text
181 -- , sort
191 -- , sort
192+
193+ -- * Low level operations
194+ , copy
195+ , unpackCString#
182 ) where
196 ) where
183
197
184import Prelude (Char, Bool(..), Int, Maybe(..), String,
198import Prelude (Char, Bool(..), Int, Maybe(..), String,
185 Eq(..), Ord(..), Ordering(..), (++),
199 Eq(..), Ord(..), Ordering(..), (++),
186− Read(..), Show(..),
200+ Read(..),
187− (&&), (||), (+), (-), (.), ($), ($!), (>>), (*),
201+ (&&), (||), (+), (-), (.), ($), ($!), (>>),
188− div, maxBound, not, return, otherwise)
202+ not, return, otherwise, quot)
189#if defined(HAVE_DEEPSEQ)
203#if defined(HAVE_DEEPSEQ)
190−import Control.DeepSeq (NFData)
204+import Control.DeepSeq (NFData(rnf))
191#endif
205#endif
192#if defined(ASSERTS)
206#if defined(ASSERTS)
193import Control.Exception (assert)
207import Control.Exception (assert)
194#endif
208#endif
195import Data.Char (isSpace)
209import Data.Char (isSpace)
196−import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf))
210+import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf), constrIndex,
197−#if __GLASGOW_HASKELL__ >= 612
211+ Constr, mkConstr, DataType, mkDataType, Fixity(Prefix))
198−import Data.Data (mkNoRepType)
199−#else
200−import Data.Data (mkNorepType)
201−#endif
202import Control.Monad (foldM)
212import Control.Monad (foldM)
213+import Control.Monad.ST (ST)
203import qualified Data.Text.Array as A
214import qualified Data.Text.Array as A
204import qualified Data.List as L
215import qualified Data.List as L
216+import Data.Binary (Binary(get, put))
205import Data.Monoid (Monoid(..))
217import Data.Monoid (Monoid(..))
218+#if MIN_VERSION_base(4,9,0)
219+import Data.Semigroup (Semigroup(..))
220+#endif
206import Data.String (IsString(..))
221import Data.String (IsString(..))
207−import qualified Data.Text.Fusion as S
222+import qualified Data.Text.Internal.Fusion as S
208−import qualified Data.Text.Fusion.Common as S
223+import qualified Data.Text.Internal.Fusion.Common as S
224+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
209−import Data.Text.Fusion (stream, reverseStream, unstream)
225+import Data.Text.Internal.Fusion (stream, reverseStream, unstream)
210−import Data.Text.Internal (Text(..), empty, firstf, safe, text, textP)
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#)
211import qualified Prelude as P
229import qualified Prelude as P
212import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter,
230import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter,
213− unsafeHead, unsafeTail)
231+ reverseIter_, unsafeHead, unsafeTail)
214−import Data.Text.UnsafeChar (unsafeChr)
232+import Data.Text.Internal.Unsafe.Char (unsafeChr)
215−import qualified Data.Text.Util as U
233+import qualified Data.Text.Internal.Functions as F
216−import qualified Data.Text.Encoding.Utf16 as U16
234+import qualified Data.Text.Internal.Encoding.Utf16 as U16
217−import Data.Text.Search (indices)
235+import Data.Text.Internal.Search (indices)
218#if defined(__HADDOCK__)
236#if defined(__HADDOCK__)
219import Data.ByteString (ByteString)
237import Data.ByteString (ByteString)
220import qualified Data.Text.Lazy as L
238import qualified Data.Text.Lazy as L
221import Data.Int (Int64)
239import Data.Int (Int64)
222#endif
240#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
223
248
224-- $strict
249-- $strict
225--
250--
226-- This package provides both strict and lazy 'Text' types. The
251-- This package provides both strict and lazy 'Text' types. The
227−-- strict type is provided by the 'Data.Text' package, while the lazy
252+-- strict type is provided by the "Data.Text" module, while the lazy
228−-- type is provided by the 'Data.Text.Lazy' package. Internally, the
253+-- type is provided by the "Data.Text.Lazy" module. Internally, the
229-- lazy @Text@ type consists of a list of strict chunks.
254-- lazy @Text@ type consists of a list of strict chunks.
230--
255--
231-- The strict 'Text' type requires that an entire string fit into
256-- The strict 'Text' type requires that an entire string fit into
232−-- memory at once. The lazy @Text@ type is capable of streaming
257+-- memory at once. The lazy 'Data.Text.Lazy.Text' type is capable of
233−-- strings that are larger than memory using a small memory footprint.
258+-- streaming strings that are larger than memory using a small memory
234−-- In many cases, the overhead of chunked streaming makes the lazy
259+-- footprint. In many cases, the overhead of chunked streaming makes
235−-- @Text@ type slower than its strict counterpart, but this is not
260+-- the lazy 'Data.Text.Lazy.Text' type slower than its strict
236−-- always the case. Sometimes, the time complexity of a function in
261+-- counterpart, but this is not always the case. Sometimes, the time
237−-- one module may be different from the other, due to their differing
262+-- complexity of a function in one module may be different from the
238−-- internal structures.
263+-- other, due to their differing internal structures.
239--
264--
240-- Each module provides an almost identical API, with the main
265-- Each module provides an almost identical API, with the main
241-- difference being that the strict module uses 'Int' values for
266-- difference being that the strict module uses 'Int' values for
242−-- lengths and counts, while the lazy module uses 'Int64' lengths.
267+-- lengths and counts, while the lazy module uses 'Data.Int.Int64'
268+-- lengths.
243
269
244-- $replacement
270-- $replacement
245--
271--
246-- A 'Text' value is a sequence of Unicode scalar values, as defined
272-- A 'Text' value is a sequence of Unicode scalar values, as defined
273+-- in
247−-- in &#xa7;3.9, definition D76 of the Unicode 5.2 standard:
274+-- <http://www.unicode.org/versions/Unicode5.2.0/ch03.pdf#page=35 §3.9, definition D76 of the Unicode 5.2 standard >.
248−-- <http://www.unicode.org/versions/Unicode5.2.0/ch03.pdf#page=35>. As
249−-- such, a 'Text' cannot contain values in the range U+D800 to U+DFFF
275+-- As such, a 'Text' cannot contain values in the range U+D800 to
250−-- inclusive. Haskell implementations admit all Unicode code points
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 >)
251−-- (&#xa7;3.4, definition D10) as 'Char' values, including code points
279+-- as 'Char' values, including code points from this invalid range.
252−-- from this invalid range. This means that there are some 'Char'
280+-- This means that there are some 'Char' values that are not valid
253−-- values that are not valid Unicode scalar values, and the functions
281+-- Unicode scalar values, and the functions in this module must handle
254−-- in this module must handle those cases.
282+-- those cases.
255--
283--
256-- Within this module, many functions construct a 'Text' from one or
284-- Within this module, many functions construct a 'Text' from one or
257-- more 'Char' values. Those functions will substitute 'Char' values
285-- more 'Char' values. Those functions will substitute 'Char' values
@@ -265,8 +293,8 @@ import Data.Int (Int64)
265-- range U+D800 through U+DFFF are used by UTF-16 to denote surrogate
293-- range U+D800 through U+DFFF are used by UTF-16 to denote surrogate
266-- code points, and so cannot be represented. The functions replace
294-- code points, and so cannot be represented. The functions replace
267-- invalid scalar values, instead of dropping them, as a security
295-- invalid scalar values, instead of dropping them, as a security
268−-- measure. For details, see Unicode Technical Report 36, &#xa7;3.5:
296+-- measure. For details, see
269−-- <http://unicode.org/reports/tr36/#Deletion_of_Noncharacters>)
297+-- <http://unicode.org/reports/tr36/#Deletion_of_Noncharacters Unicode Technical Report 36, §3.5 >.)
270
298
271-- $fusion
299-- $fusion
272--
300--
@@ -284,11 +312,11 @@ import Data.Int (Int64)
284-- > countChars = T.length . T.toUpper . E.decodeUtf8
312-- > countChars = T.length . T.toUpper . E.decodeUtf8
285--
313--
286-- From the type signatures involved, this looks like it should
314-- From the type signatures involved, this looks like it should
287−-- allocate one 'ByteString' value, and two 'Text' values. However,
315+-- allocate one 'Data.ByteString.ByteString' value, and two 'Text'
288−-- when a module is compiled with optimisation enabled under GHC, the
316+-- values. However, when a module is compiled with optimisation
289−-- two intermediate 'Text' values will be optimised away, and the
317+-- enabled under GHC, the two intermediate 'Text' values will be
290−-- function will be compiled down to a single loop over the source
318+-- optimised away, and the function will be compiled down to a single
291−-- 'ByteString'.
319+-- loop over the source 'Data.ByteString.ByteString'.
292--
320--
293-- Functions that can be fused by the compiler are documented with the
321-- Functions that can be fused by the compiler are documented with the
294-- phrase \"Subject to fusion\".
322-- phrase \"Subject to fusion\".
@@ -302,46 +330,83 @@ instance Eq Text where
302instance Ord Text where
330instance Ord Text where
303 compare = compareText
331 compare = compareText
304
332
305−instance Show Text where
306− showsPrec p ps r = showsPrec p (unpack ps) r
307−
308instance Read Text where
333instance Read Text where
309 readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
334 readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
310
335
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+
311instance Monoid Text where
344instance Monoid Text where
312 mempty = empty
345 mempty = empty
346+#if MIN_VERSION_base(4,9,0)
347+ mappend = (<>) -- future-proof definition
348+#else
313 mappend = append
349 mappend = append
350+#endif
314 mconcat = concat
351 mconcat = concat
315
352
316instance IsString Text where
353instance IsString Text where
317 fromString = pack
354 fromString = pack
318
355
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+
319#if defined(HAVE_DEEPSEQ)
363#if defined(HAVE_DEEPSEQ)
320−instance NFData Text
364+instance NFData Text where rnf !_ = ()
321#endif
365#endif
322
366
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+
323−-- This instance preserves data abstraction at the cost of inefficiency.
375+-- | This instance preserves data abstraction at the cost of inefficiency.
324-- We omit reflection services for the sake of data abstraction.
376-- We omit reflection services for the sake of data abstraction.
325−--
326−-- This instance was created by copying the behavior of Data.Set and
327−-- Data.Map. If you feel a mistake has been made, please feel free to
328−-- submit improvements.
329--
377--
330−-- Original discussion is archived here:
378+-- This instance was created by copying the updated behavior of
331−
379+-- @"Data.Set".@'Data.Set.Set' and @"Data.Map".@'Data.Map.Map'. If you
332−-- "could we get a Data instance for Data.Text.Text?"
380+-- feel a mistake has been made, please feel free to submit
381+-- improvements.
382+--
383+-- The original discussion is archived here:
333−-- http://groups.google.com/group/haskell-cafe/browse_thread/thread/b5bbb1b28a7e525d/0639d46852575b93
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, ... >
334
389
335instance Data Text where
390instance Data Text where
336 gfoldl f z txt = z pack `f` (unpack txt)
391 gfoldl f z txt = z pack `f` (unpack txt)
337− toConstr _ = P.error "Data.Text.Text.toConstr"
392+ toConstr _ = packConstr
393+ gunfold k z c = case constrIndex c of
394+ 1 -> k (z pack)
338− gunfold _ _ = P.error "Data.Text.Text.gunfold"
395+ _ -> P.error "gunfold"
339−#if __GLASGOW_HASKELL__ >= 612
396+ dataTypeOf _ = textDataType
340− dataTypeOf _ = mkNoRepType "Data.Text.Text"
397+
341−#else
398+#if MIN_VERSION_base(4,7,0)
342− dataTypeOf _ = mkNorepType "Data.Text.Text"
399+-- | Only defined for @base-4.7.0.0@ and later
400+instance PrintfArg Text where
401+ formatArg txt = formatString $ unpack txt
343#endif
402#endif
344
403
404+packConstr :: Constr
405+packConstr = mkConstr textDataType "pack" [] Prefix
406+
407+textDataType :: DataType
408+textDataType = mkDataType "Data.Text.Text" [packConstr]
409+
345-- | /O(n)/ Compare two 'Text' values lexicographically.
410-- | /O(n)/ Compare two 'Text' values lexicographically.
346compareText :: Text -> Text -> Ordering
411compareText :: Text -> Text -> Ordering
347compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
412compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
@@ -362,20 +427,9 @@ compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
362-- | /O(n)/ Convert a 'String' into a 'Text'. Subject to
427-- | /O(n)/ Convert a 'String' into a 'Text'. Subject to
363-- fusion. Performs replacement on invalid scalar values.
428-- fusion. Performs replacement on invalid scalar values.
364pack :: String -> Text
429pack :: String -> Text
365−pack = unstream . S.streamList . L.map safe
430+pack = unstream . S.map safe . S.streamList
366{-# INLINE [1] pack #-}
431{-# INLINE [1] pack #-}
367
432
368−-- | /O(n)/ Convert a Text into a String. Subject to fusion.
369−unpack :: Text -> String
370−unpack = S.unstreamList . stream
371−{-# INLINE [1] unpack #-}
372−
373−-- | /O(1)/ Convert a character into a Text. Subject to fusion.
374−-- Performs replacement on invalid scalar values.
375−singleton :: Char -> Text
376−singleton = unstream . S.singleton . safe
377−{-# INLINE [1] singleton #-}
378−
379-- -----------------------------------------------------------------------------
433-- -----------------------------------------------------------------------------
380-- * Basic functions
434-- * Basic functions
381
435
@@ -387,6 +441,8 @@ cons :: Char -> Text -> Text
387cons c t = unstream (S.cons (safe c) (stream t))
441cons c t = unstream (S.cons (safe c) (stream t))
388{-# INLINE cons #-}
442{-# INLINE cons #-}
389
443
444+infixr 5 `cons`
445+
390-- | /O(n)/ Adds a character to the end of a 'Text'. This copies the
446-- | /O(n)/ Adds a character to the end of a 'Text'. This copies the
391-- entire array in the process, unless fused. Subject to fusion.
447-- entire array in the process, unless fused. Subject to fusion.
392-- Performs replacement on invalid scalar values.
448-- Performs replacement on invalid scalar values.
@@ -404,12 +460,13 @@ append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2)
404 | otherwise = overflowError "append"
460 | otherwise = overflowError "append"
405 where
461 where
406 len = len1+len2
462 len = len1+len2
463+ x :: ST s (A.MArray s)
407 x = do
464 x = do
408 arr <- A.new len
465 arr <- A.new len
409 A.copyI arr 0 arr1 off1 len1
466 A.copyI arr 0 arr1 off1 len1
410 A.copyI arr len1 arr2 off2 len
467 A.copyI arr len1 arr2 off2 len
411 return arr
468 return arr
412−{-# INLINE append #-}
469+{-# NOINLINE append #-}
413
470
414{-# RULES
471{-# RULES
415"TEXT append -> fused" [~1] forall t1 t2.
472"TEXT append -> fused" [~1] forall t1 t2.
@@ -429,8 +486,8 @@ head t = S.head (stream t)
429uncons :: Text -> Maybe (Char, Text)
486uncons :: Text -> Maybe (Char, Text)
430uncons t@(Text arr off len)
487uncons t@(Text arr off len)
431 | len <= 0 = Nothing
488 | len <= 0 = Nothing
489+ | otherwise = Just $ let !(Iter c d) = iter t 0
432− | otherwise = Just (c, textP arr (off+d) (len-d))
490+ in (c, text arr (off+d) (len-d))
433− where Iter c d = iter t 0
434{-# INLINE [1] uncons #-}
491{-# INLINE [1] uncons #-}
435
492
436-- | Lifted from Control.Arrow and specialized.
493-- | Lifted from Control.Arrow and specialized.
@@ -460,7 +517,7 @@ last (Text arr off len)
460tail :: Text -> Text
517tail :: Text -> Text
461tail t@(Text arr off len)
518tail t@(Text arr off len)
462 | len <= 0 = emptyError "tail"
519 | len <= 0 = emptyError "tail"
463− | otherwise = textP arr (off+d) (len-d)
520+ | otherwise = text arr (off+d) (len-d)
464 where d = iter_ t 0
521 where d = iter_ t 0
465{-# INLINE [1] tail #-}
522{-# INLINE [1] tail #-}
466
523
@@ -475,8 +532,8 @@ tail t@(Text arr off len)
475-- be non-empty. Subject to fusion.
532-- be non-empty. Subject to fusion.
476init :: Text -> Text
533init :: Text -> Text
477init (Text arr off len) | len <= 0 = emptyError "init"
534init (Text arr off len) | len <= 0 = emptyError "init"
478− | n >= 0xDC00 && n <= 0xDFFF = textP arr off (len-2)
535+ | n >= 0xDC00 && n <= 0xDFFF = text arr off (len-2)
479− | otherwise = textP arr off (len-1)
536+ | otherwise = text arr off (len-1)
480 where
537 where
481 n = A.unsafeIndex arr (off+len-1)
538 n = A.unsafeIndex arr (off+len-1)
482{-# INLINE [1] init #-}
539{-# INLINE [1] init #-}
@@ -515,7 +572,9 @@ isSingleton = S.isSingleton . stream
515-- Subject to fusion.
572-- Subject to fusion.
516length :: Text -> Int
573length :: Text -> Int
517length t = S.length (stream t)
574length t = S.length (stream t)
518−{-# 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.
519
578
520-- | /O(n)/ Compare the count of characters in a 'Text' to a number.
579-- | /O(n)/ Compare the count of characters in a 'Text' to a number.
521-- Subject to fusion.
580-- Subject to fusion.
@@ -534,32 +593,32 @@ compareLength t n = S.compareLengthI (stream t) n
534
593
535{-# RULES
594{-# RULES
536"TEXT ==N/length -> compareLength/==EQ" [~1] forall t n.
595"TEXT ==N/length -> compareLength/==EQ" [~1] forall t n.
537− (==) (length t) n = compareLength t n == EQ
596+ eqInt (length t) n = compareLength t n == EQ
538 #-}
597 #-}
539
598
540{-# RULES
599{-# RULES
541"TEXT /=N/length -> compareLength//=EQ" [~1] forall t n.
600"TEXT /=N/length -> compareLength//=EQ" [~1] forall t n.
542− (/=) (length t) n = compareLength t n /= EQ
601+ neInt (length t) n = compareLength t n /= EQ
543 #-}
602 #-}
544
603
545{-# RULES
604{-# RULES
546"TEXT <N/length -> compareLength/==LT" [~1] forall t n.
605"TEXT <N/length -> compareLength/==LT" [~1] forall t n.
547− (<) (length t) n = compareLength t n == LT
606+ ltInt (length t) n = compareLength t n == LT
548 #-}
607 #-}
549
608
550{-# RULES
609{-# RULES
551"TEXT <=N/length -> compareLength//=GT" [~1] forall t n.
610"TEXT <=N/length -> compareLength//=GT" [~1] forall t n.
552− (<=) (length t) n = compareLength t n /= GT
611+ leInt (length t) n = compareLength t n /= GT
553 #-}
612 #-}
554
613
555{-# RULES
614{-# RULES
556"TEXT >N/length -> compareLength/==GT" [~1] forall t n.
615"TEXT >N/length -> compareLength/==GT" [~1] forall t n.
557− (>) (length t) n = compareLength t n == GT
616+ gtInt (length t) n = compareLength t n == GT
558 #-}
617 #-}
559
618
560{-# RULES
619{-# RULES
561"TEXT >=N/length -> compareLength//=LT" [~1] forall t n.
620"TEXT >=N/length -> compareLength//=LT" [~1] forall t n.
562− (>=) (length t) n = compareLength t n /= LT
621+ geInt (length t) n = compareLength t n /= LT
563 #-}
622 #-}
564
623
565-- -----------------------------------------------------------------------------
624-- -----------------------------------------------------------------------------
@@ -575,7 +634,7 @@ map f t = unstream (S.map (safe . f) (stream t))
575-- 'Text's and concatenates the list after interspersing the first
634-- 'Text's and concatenates the list after interspersing the first
576-- argument between each element of the list.
635-- argument between each element of the list.
577intercalate :: Text -> [Text] -> Text
636intercalate :: Text -> [Text] -> Text
578−intercalate t = concat . (U.intersperse t)
637+intercalate t = concat . (F.intersperse t)
579{-# INLINE intercalate #-}
638{-# INLINE intercalate #-}
580
639
581-- | /O(n)/ The 'intersperse' function takes a character and places it
640-- | /O(n)/ The 'intersperse' function takes a character and places it
@@ -590,16 +649,59 @@ reverse :: Text -> Text
590reverse t = S.reverse (stream t)
649reverse t = S.reverse (stream t)
591{-# INLINE reverse #-}
650{-# INLINE reverse #-}
592
651
593−-- | /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"
594--
672--
595-- In (unlikely) bad cases, this function's time complexity degrades
673-- In (unlikely) bad cases, this function's time complexity degrades
596-- towards /O(n*m)/.
674-- towards /O(n*m)/.
597−replace :: Text -- ^ Text to search for
675+replace :: Text
598− -> Text -- ^ Replacement text
676+ -- ^ @needle@ to search for. If this string is empty, an
677+ -- error will occur.
599− -> Text -- ^ Input text
678+ -> Text
679+ -- ^ @replacement@ to replace @needle@ with.
600 -> Text
680 -> Text
601−replace s d = intercalate d . splitOn s
681+ -- ^ @haystack@ in which to search.
602−{-# INLINE replace #-}
682+ -> Text
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
603
705
604-- ----------------------------------------------------------------------------
706-- ----------------------------------------------------------------------------
605-- ** Case conversions (folds)
707-- ** Case conversions (folds)
@@ -618,13 +720,13 @@ replace s d = intercalate d . splitOn s
618-- /Note/: In some languages, case conversion is a locale- and
720-- /Note/: In some languages, case conversion is a locale- and
619-- context-dependent operation. The case conversion functions in this
721-- context-dependent operation. The case conversion functions in this
620-- module are /not/ locale sensitive. Programs that require locale
722-- module are /not/ locale sensitive. Programs that require locale
621−-- sensitivity should use appropriate versions of the case mapping
723+-- sensitivity should use appropriate versions of the
622−-- functions from the @text-icu@ package:
623−-- <http://hackage.haskell.org/package/text-icu>
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 >.
624
725
625−-- | /O(n)/ Convert a string to folded case. This function is mainly
726+-- | /O(n)/ Convert a string to folded case. Subject to fusion.
727+--
626−-- useful for performing caseless (also known as case insensitive)
728+-- This function is mainly useful for performing caseless (also known
627−-- string comparisons.
729+-- as case insensitive) string comparisons.
628--
730--
629-- A string @x@ is a caseless match for a string @y@ if and only if:
731-- A string @x@ is a caseless match for a string @y@ if and only if:
630--
732--
@@ -639,25 +741,51 @@ replace s d = intercalate d . splitOn s
639-- instead of itself.
741-- instead of itself.
640toCaseFold :: Text -> Text
742toCaseFold :: Text -> Text
641toCaseFold t = unstream (S.toCaseFold (stream t))
743toCaseFold t = unstream (S.toCaseFold (stream t))
642−{-# INLINE [0] toCaseFold #-}
744+{-# INLINE toCaseFold #-}
643
745
644-- | /O(n)/ Convert a string to lower case, using simple case
746-- | /O(n)/ Convert a string to lower case, using simple case
747+-- conversion. Subject to fusion.
748+--
645−-- conversion. The result string may be longer than the input string.
749+-- The result string may be longer than the input string. For
646−-- For instance, \"&#x130;\" (Latin capital letter I with dot above,
750+-- instance, \"&#x130;\" (Latin capital letter I with dot above,
647−-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069) followed
751+-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
648−-- by \" &#x307;\" (combining dot above, U+0307).
752+-- followed by \" &#x307;\" (combining dot above, U+0307).
649toLower :: Text -> Text
753toLower :: Text -> Text
650toLower t = unstream (S.toLower (stream t))
754toLower t = unstream (S.toLower (stream t))
651{-# INLINE toLower #-}
755{-# INLINE toLower #-}
652
756
653-- | /O(n)/ Convert a string to upper case, using simple case
757-- | /O(n)/ Convert a string to upper case, using simple case
758+-- conversion. Subject to fusion.
759+--
654−-- conversion. The result string may be longer than the input string.
760+-- The result string may be longer than the input string. For
655−-- For instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
761+-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
656-- two-letter sequence \"SS\".
762-- two-letter sequence \"SS\".
657toUpper :: Text -> Text
763toUpper :: Text -> Text
658toUpper t = unstream (S.toUpper (stream t))
764toUpper t = unstream (S.toUpper (stream t))
659{-# INLINE toUpper #-}
765{-# INLINE toUpper #-}
660
766
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+
661-- | /O(n)/ Left-justify a string to the given length, using the
789-- | /O(n)/ Left-justify a string to the given length, using the
662-- specified fill character on the right. Subject to fusion.
790-- specified fill character on the right. Subject to fusion.
663-- Performs replacement on invalid scalar values.
791-- Performs replacement on invalid scalar values.
@@ -708,7 +836,7 @@ center k c t
708 | otherwise = replicateChar l c `append` t `append` replicateChar r c
836 | otherwise = replicateChar l c `append` t `append` replicateChar r c
709 where len = length t
837 where len = length t
710 d = k - len
838 d = k - len
711− r = d `div` 2
839+ r = d `quot` 2
712 l = d - r
840 l = d - r
713{-# INLINE center #-}
841{-# INLINE center #-}
714
842
@@ -755,7 +883,7 @@ foldr f z t = S.foldr f z (stream t)
755{-# INLINE foldr #-}
883{-# INLINE foldr #-}
756
884
757-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
885-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
758−-- 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
759-- fusion.
887-- fusion.
760foldr1 :: (Char -> Char -> Char) -> Text -> Char
888foldr1 :: (Char -> Char -> Char) -> Text -> Char
761foldr1 f t = S.foldr1 f (stream t)
889foldr1 f t = S.foldr1 f (stream t)
@@ -773,6 +901,7 @@ concat ts = case ts' of
773 where
901 where
774 ts' = L.filter (not . null) ts
902 ts' = L.filter (not . null) ts
775 len = sumP "concat" $ L.map lengthWord16 ts'
903 len = sumP "concat" $ L.map lengthWord16 ts'
904+ go :: ST s (A.MArray s)
776 go = do
905 go = do
777 arr <- A.new len
906 arr <- A.new len
778 let step i (Text a o l) =
907 let step i (Text a o l) =
@@ -786,13 +915,13 @@ concatMap f = concat . foldr ((:) . f) []
786{-# INLINE concatMap #-}
915{-# INLINE concatMap #-}
787
916
788-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
917-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
789−-- 'Text' @t@ satisifes the predicate @p@. Subject to fusion.
918+-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
790any :: (Char -> Bool) -> Text -> Bool
919any :: (Char -> Bool) -> Text -> Bool
791any p t = S.any p (stream t)
920any p t = S.any p (stream t)
792{-# INLINE any #-}
921{-# INLINE any #-}
793
922
794-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
923-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
795−-- 'Text' @t@ satisify the predicate @p@. Subject to fusion.
924+-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
796all :: (Char -> Bool) -> Text -> Bool
925all :: (Char -> Bool) -> Text -> Bool
797all p t = S.all p (stream t)
926all p t = S.all p (stream t)
798{-# INLINE all #-}
927{-# INLINE all #-}
@@ -880,13 +1009,13 @@ mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
880-- @t@ repeated @n@ times.
1009-- @t@ repeated @n@ times.
881replicate :: Int -> Text -> Text
1010replicate :: Int -> Text -> Text
882replicate n t@(Text a o l)
1011replicate n t@(Text a o l)
883− | n <= 0 || l <= 0 = empty
1012+ | n <= 0 || l <= 0 = empty
884− | n == 1 = t
1013+ | n == 1 = t
885− | isSingleton t = replicateChar n (unsafeHead t)
1014+ | isSingleton t = replicateChar n (unsafeHead t)
886− | n <= maxBound `div` l = Text (A.run x) 0 len
1015+ | otherwise = Text (A.run x) 0 len
887− | otherwise = overflowError "replicate"
888 where
1016 where
889− len = l * n
1017+ len = l `mul` n
1018+ x :: ST s (A.MArray s)
890 x = do
1019 x = do
891 arr <- A.new len
1020 arr <- A.new len
892 let loop !d !i | i >= n = return arr
1021 let loop !d !i | i >= n = return arr
@@ -937,14 +1066,16 @@ take :: Int -> Text -> Text
937take n t@(Text arr off len)
1066take n t@(Text arr off len)
938 | n <= 0 = empty
1067 | n <= 0 = empty
939 | n >= len = t
1068 | n >= len = t
940− | otherwise = Text arr off (loop 0 0)
1069+ | otherwise = text arr off (iterN n t)
941− where
942− loop !i !cnt
943− | i >= len || cnt >= n = i
944− | otherwise = loop (i+d) (cnt+1)
945− where d = iter_ t i
946{-# INLINE [1] take #-}
1070{-# INLINE [1] take #-}
947
1071
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+
948{-# RULES
1079{-# RULES
949"TEXT take -> fused" [~1] forall n t.
1080"TEXT take -> fused" [~1] forall n t.
950 take n t = unstream (S.take n (stream t))
1081 take n t = unstream (S.take n (stream t))
@@ -952,6 +1083,27 @@ take n t@(Text arr off len)
952 unstream (S.take n (stream t)) = take n t
1083 unstream (S.take n (stream t)) = take n t
953 #-}
1084 #-}
954
1085
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+
955-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
1107-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
956-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
1108-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
957-- is greater than the length of the 'Text'. Subject to fusion.
1109-- is greater than the length of the 'Text'. Subject to fusion.
@@ -959,11 +1111,8 @@ drop :: Int -> Text -> Text
959drop n t@(Text arr off len)
1111drop n t@(Text arr off len)
960 | n <= 0 = t
1112 | n <= 0 = t
961 | n >= len = empty
1113 | n >= len = empty
962− | otherwise = loop 0 0
1114+ | otherwise = text arr (off+i) (len-i)
963− where loop !i !cnt
964− | i >= len || cnt >= n = Text arr (off+i) (len-i)
965− | otherwise = loop (i+d) (cnt+1)
966− where d = iter_ t i
1115+ where i = iterN n t
967{-# INLINE [1] drop #-}
1116{-# INLINE [1] drop #-}
968
1117
969{-# RULES
1118{-# RULES
@@ -973,6 +1122,18 @@ drop n t@(Text arr off len)
973 unstream (S.drop n (stream t)) = drop n t
1122 unstream (S.drop n (stream t)) = drop n t
974 #-}
1123 #-}
975
1124
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+
976-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
1137-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
977-- returns the longest prefix (possibly empty) of elements that
1138-- returns the longest prefix (possibly empty) of elements that
978-- satisfy @p@. Subject to fusion.
1139-- satisfy @p@. Subject to fusion.
@@ -980,7 +1141,7 @@ takeWhile :: (Char -> Bool) -> Text -> Text
980takeWhile p t@(Text arr off len) = loop 0
1141takeWhile p t@(Text arr off len) = loop 0
981 where loop !i | i >= len = t
1142 where loop !i | i >= len = t
982 | p c = loop (i+d)
1143 | p c = loop (i+d)
983− | otherwise = textP arr off i
1144+ | otherwise = text arr off i
984 where Iter c d = iter t i
1145 where Iter c d = iter t i
985{-# INLINE [1] takeWhile #-}
1146{-# INLINE [1] takeWhile #-}
986
1147
@@ -991,6 +1152,27 @@ takeWhile p t@(Text arr off len) = loop 0
991 unstream (S.takeWhile p (stream t)) = takeWhile p t
1152 unstream (S.takeWhile p (stream t)) = takeWhile p t
992 #-}
1153 #-}
993
1154
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+
994-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
1176-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
995-- 'takeWhile' @p@ @t@. Subject to fusion.
1177-- 'takeWhile' @p@ @t@. Subject to fusion.
996dropWhile :: (Char -> Bool) -> Text -> Text
1178dropWhile :: (Char -> Bool) -> Text -> Text
@@ -1009,8 +1191,9 @@ dropWhile p t@(Text arr off len) = loop 0 0
1009 #-}
1191 #-}
1010
1192
1011-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
1193-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
1012−-- dropping characters that fail the predicate @p@ from the end of
1194+-- dropping characters that satisfy the predicate @p@ from the end of
1013-- @t@. Subject to fusion.
1195-- @t@. Subject to fusion.
1196+--
1014-- Examples:
1197-- Examples:
1015--
1198--
1016-- > dropWhileEnd (=='.') "foo..." == "foo"
1199-- > dropWhileEnd (=='.') "foo..." == "foo"
@@ -1030,7 +1213,7 @@ dropWhileEnd p t@(Text arr off len) = loop (len-1) len
1030 #-}
1213 #-}
1031
1214
1032-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
1215-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
1033−-- dropping characters that fail the predicate @p@ from both the
1216+-- dropping characters that satisfy the predicate @p@ from both the
1034-- beginning and end of @t@. Subject to fusion.
1217-- beginning and end of @t@. Subject to fusion.
1035dropAround :: (Char -> Bool) -> Text -> Text
1218dropAround :: (Char -> Bool) -> Text -> Text
1036dropAround p = dropWhile p . dropWhileEnd p
1219dropAround p = dropWhile p . dropWhileEnd p
@@ -1065,24 +1248,16 @@ splitAt :: Int -> Text -> (Text, Text)
1065splitAt n t@(Text arr off len)
1248splitAt n t@(Text arr off len)
1066 | n <= 0 = (empty, t)
1249 | n <= 0 = (empty, t)
1067 | n >= len = (t, empty)
1250 | n >= len = (t, empty)
1068− | otherwise = (Text arr off k, Text arr (off+k) (len-k))
1251+ | otherwise = let k = iterN n t
1069− where k = loop 0 0
1252+ in (text arr off k, text arr (off+k) (len-k))
1070− loop !i !cnt
1071− | i >= len || cnt >= n = i
1072− | otherwise = loop (i+d) (cnt+1)
1073− where d = iter_ t i
1074−{-# INLINE splitAt #-}
1075
1253
1076-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
1254-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
1077-- a pair whose first element is the longest prefix (possibly empty)
1255-- a pair whose first element is the longest prefix (possibly empty)
1078-- of @t@ of elements that satisfy @p@, and whose second is the
1256-- of @t@ of elements that satisfy @p@, and whose second is the
1079-- remainder of the list.
1257-- remainder of the list.
1080span :: (Char -> Bool) -> Text -> (Text, Text)
1258span :: (Char -> Bool) -> Text -> (Text, Text)
1081−span p t@(Text arr off len) = (textP arr off k, textP arr (off+k) (len-k))
1259+span p t = case span_ p t of
1082− where k = loop 0
1260+ (# hd,tl #) -> (hd,tl)
1083− loop !i | i >= len || not (p c) = i
1084− | otherwise = loop (i+d)
1085− where Iter c d = iter t i
1086{-# INLINE span #-}
1261{-# INLINE span #-}
1087
1262
1088-- | /O(n)/ 'break' is like 'span', but the prefix returned is
1263-- | /O(n)/ 'break' is like 'span', but the prefix returned is
@@ -1109,7 +1284,7 @@ findAIndexOrEnd q t@(Text _arr _off len) = go 0
1109 where go !i | i >= len || q c = i
1284 where go !i | i >= len || q c = i
1110 | otherwise = go (i+d)
1285 | otherwise = go (i+d)
1111 where Iter c d = iter t i
1286 where Iter c d = iter t i
1112−
1287+
1113-- | /O(n)/ Group characters in a string by equality.
1288-- | /O(n)/ Group characters in a string by equality.
1114group :: Text -> [Text]
1289group :: Text -> [Text]
1115group = groupBy (==)
1290group = groupBy (==)
@@ -1133,31 +1308,38 @@ tails t | null t = [empty]
1133-- copies to create substrings; they just construct new 'Text's that
1308-- copies to create substrings; they just construct new 'Text's that
1134-- are slices of the original.
1309-- are slices of the original.
1135
1310
1136−-- | /O(m+n)/ Break a 'Text' into pieces separated by the first
1311+-- | /O(m+n)/ Break a 'Text' into pieces separated by the first 'Text'
1137−-- 'Text' argument, consuming the delimiter. An empty delimiter is
1312+-- argument (which cannot be empty), consuming the delimiter. An empty
1138−-- invalid, and will cause an error to be raised.
1313+-- delimiter is invalid, and will cause an error to be raised.
1139--
1314--
1140-- Examples:
1315-- Examples:
1141--
1316--
1142-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1317-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1143-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1318-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1144-- > splitOn "x" "x" == ["",""]
1319-- > splitOn "x" "x" == ["",""]
1145−--
1320+--
1146-- and
1321-- and
1147--
1322--
1148-- > intercalate s . splitOn s == id
1323-- > intercalate s . splitOn s == id
1149-- > splitOn (singleton c) == split (==c)
1324-- > splitOn (singleton c) == split (==c)
1150--
1325--
1326+-- (Note: the string @s@ to split on above cannot be empty.)
1327+--
1151-- In (unlikely) bad cases, this function's time complexity degrades
1328-- In (unlikely) bad cases, this function's time complexity degrades
1152-- towards /O(n*m)/.
1329-- towards /O(n*m)/.
1153−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]
1154splitOn pat@(Text _ _ l) src@(Text arr off len)
1336splitOn pat@(Text _ _ l) src@(Text arr off len)
1155 | l <= 0 = emptyError "splitOn"
1337 | l <= 0 = emptyError "splitOn"
1156 | isSingleton pat = split (== unsafeHead pat) src
1338 | isSingleton pat = split (== unsafeHead pat) src
1157 | otherwise = go 0 (indices pat src)
1339 | otherwise = go 0 (indices pat src)
1158 where
1340 where
1159− go !s (x:xs) = textP arr (s+off) (x-s) : go (x+l) xs
1341+ go !s (x:xs) = text arr (s+off) (x-s) : go (x+l) xs
1160− go s _ = [textP arr (s+off) (len-s)]
1342+ go s _ = [text arr (s+off) (len-s)]
1161{-# INLINE [1] splitOn #-}
1343{-# INLINE [1] splitOn #-}
1162
1344
1163{-# RULES
1345{-# RULES
@@ -1177,7 +1359,7 @@ split _ t@(Text _off _arr 0) = [t]
1177split p t = loop t
1359split p t = loop t
1178 where loop s | null s' = [l]
1360 where loop s | null s' = [l]
1179 | otherwise = l : loop (unsafeTail s')
1361 | otherwise = l : loop (unsafeTail s')
1180− where (l, s') = break p s
1362+ where (# l, s' #) = span_ (not . p) s
1181{-# INLINE split #-}
1363{-# INLINE split #-}
1182
1364
1183-- | /O(n)/ Splits a 'Text' into components of length @k@. The last
1365-- | /O(n)/ Splits a 'Text' into components of length @k@. The last
@@ -1249,7 +1431,7 @@ breakOn pat src@(Text arr off len)
1249 | null pat = emptyError "breakOn"
1431 | null pat = emptyError "breakOn"
1250 | otherwise = case indices pat src of
1432 | otherwise = case indices pat src of
1251 [] -> (src, empty)
1433 [] -> (src, empty)
1252− (x:_) -> (textP arr off x, textP arr (off+x) (len-x))
1434+ (x:_) -> (text arr off x, text arr (off+x) (len-x))
1253{-# INLINE breakOn #-}
1435{-# INLINE breakOn #-}
1254
1436
1255-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
1437-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
@@ -1274,9 +1456,9 @@ breakOnEnd pat src = (reverse b, reverse a)
1274--
1456--
1275-- Examples:
1457-- Examples:
1276--
1458--
1277−-- > find "::" ""
1459+-- > breakOnAll "::" ""
1278-- > ==> []
1460-- > ==> []
1279−-- > find "/" "a/b/c/"
1461+-- > breakOnAll "/" "a/b/c/"
1280-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
1462-- > ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
1281--
1463--
1282-- In (unlikely) bad cases, this function's time complexity degrades
1464-- In (unlikely) bad cases, this function's time complexity degrades
@@ -1291,7 +1473,7 @@ breakOnAll pat src@(Text arr off slen)
1291 | otherwise = L.map step (indices pat src)
1473 | otherwise = L.map step (indices pat src)
1292 where
1474 where
1293 step x = (chunk 0 x, chunk x (slen-x))
1475 step x = (chunk 0 x, chunk x (slen-x))
1294− chunk !n !l = textP arr (n+off) l
1476+ chunk !n !l = text arr (n+off) l
1295{-# INLINE breakOnAll #-}
1477{-# INLINE breakOnAll #-}
1296
1478
1297-------------------------------------------------------------------------------
1479-------------------------------------------------------------------------------
@@ -1311,7 +1493,7 @@ breakOnAll pat src@(Text arr off slen)
1311-- For example, suppose you have a string that you want to split on
1493-- For example, suppose you have a string that you want to split on
1312-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of
1494-- the substring @\"::\"@, such as @\"foo::bar::quux\"@. Instead of
1313-- searching for the index of @\"::\"@ and taking the substrings
1495-- searching for the index of @\"::\"@ and taking the substrings
1314−-- before and after that index, you would instead use @find \"::\"@.
1496+-- before and after that index, you would instead use @breakOnAll \"::\"@.
1315
1497
1316-- | /O(n)/ 'Text' index (subscript) operator, starting from 0.
1498-- | /O(n)/ 'Text' index (subscript) operator, starting from 0.
1317index :: Text -> Int -> Char
1499index :: Text -> Int -> Char
@@ -1358,7 +1540,7 @@ countChar c t = S.countChar c (stream t)
1358-- equivalent to a pair of 'unpack' operations.
1540-- equivalent to a pair of 'unpack' operations.
1359zip :: Text -> Text -> [(Char,Char)]
1541zip :: Text -> Text -> [(Char,Char)]
1360zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1542zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1361−{-# INLINE [0] zip #-}
1543+{-# INLINE zip #-}
1362
1544
1363-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1545-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1364-- given as the first argument, instead of a tupling function.
1546-- given as the first argument, instead of a tupling function.
@@ -1366,7 +1548,7 @@ zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1366zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
1548zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
1367zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
1549zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
1368 where g a b = safe (f a b)
1550 where g a b = safe (f a b)
1369−{-# INLINE [0] zipWith #-}
1551+{-# INLINE zipWith #-}
1370
1552
1371-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's
1553-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's
1372-- representing white space.
1554-- representing white space.
@@ -1392,7 +1574,7 @@ lines ps | null ps = []
1392 | otherwise = h : if null t
1574 | otherwise = h : if null t
1393 then []
1575 then []
1394 else lines (unsafeTail t)
1576 else lines (unsafeTail t)
1395− where (h,t) = span (/= '\n') ps
1577+ where (# h,t #) = span_ (/= '\n') ps
1396{-# INLINE lines #-}
1578{-# INLINE lines #-}
1397
1579
1398{-
1580{-
@@ -1438,8 +1620,6 @@ isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
1438{-# RULES
1620{-# RULES
1439"TEXT isPrefixOf -> fused" [~1] forall s t.
1621"TEXT isPrefixOf -> fused" [~1] forall s t.
1440 isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1622 isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1441−"TEXT isPrefixOf -> unfused" [1] forall s t.
1442− S.isPrefixOf (stream s) (stream t) = isPrefixOf s t
1443 #-}
1623 #-}
1444
1624
1445-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns
1625-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns
@@ -1473,12 +1653,13 @@ isInfixOf needle haystack
1473-------------------------------------------------------------------------------
1653-------------------------------------------------------------------------------
1474-- * View patterns
1654-- * View patterns
1475
1655
1476−-- | /O(n)/ Returns the suffix of the second string if its prefix
1656+-- | /O(n)/ Return the suffix of the second string if its prefix
1477−-- matches the first.
1657+-- matches the entire first string.
1478--
1658--
1479-- Examples:
1659-- Examples:
1480--
1660--
1481-- > stripPrefix "foo" "foobar" == Just "bar"
1661-- > stripPrefix "foo" "foobar" == Just "bar"
1662+-- > stripPrefix "" "baz" == Just "baz"
1482-- > stripPrefix "foo" "quux" == Nothing
1663-- > stripPrefix "foo" "quux" == Nothing
1483--
1664--
1484-- This is particularly useful with the @ViewPatterns@ extension to
1665-- This is particularly useful with the @ViewPatterns@ extension to
@@ -1489,18 +1670,42 @@ isInfixOf needle haystack
1489-- >
1670-- >
1490-- > fnordLength :: Text -> Int
1671-- > fnordLength :: Text -> Int
1491-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1672-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1492−-- > fnordLength _ = -1
1673+-- > fnordLength _ = -1
1493stripPrefix :: Text -> Text -> Maybe Text
1674stripPrefix :: Text -> Text -> Maybe Text
1494stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1675stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1495− | p `isPrefixOf` t = Just $! textP arr (off+plen) (len-plen)
1676+ | p `isPrefixOf` t = Just $! text arr (off+plen) (len-plen)
1496 | otherwise = Nothing
1677 | otherwise = Nothing
1497
1678
1679+-- | /O(n)/ Find the longest non-empty common prefix of two strings
1680+-- and return it, along with the suffixes of each string at which they
1681+-- no longer match.
1682+--
1683+-- If the strings do not have a common prefix or either one is empty,
1684+-- this function returns 'Nothing'.
1685+--
1686+-- Examples:
1687+--
1688+-- > commonPrefixes "foobar" "fooquux" == Just ("foo","bar","quux")
1689+-- > commonPrefixes "veeble" "fetzer" == Nothing
1690+-- > commonPrefixes "" "baz" == Nothing
1691+commonPrefixes :: Text -> Text -> Maybe (Text,Text,Text)
1692+commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
1693+ where
1694+ go !i !j | i < len0 && j < len1 && a == b = go (i+d0) (j+d1)
1695+ | i > 0 = Just (Text arr0 off0 i,
1696+ text arr0 (off0+i) (len0-i),
1697+ text arr1 (off1+j) (len1-j))
1698+ | otherwise = Nothing
1699+ where Iter a d0 = iter t0 i
1700+ Iter b d1 = iter t1 j
1701+
1498−-- | /O(n)/ Returns the prefix of the second string if its suffix
1702+-- | /O(n)/ Return the prefix of the second string if its suffix
1499−-- matches the first.
1703+-- matches the entire first string.
1500--
1704--
1501-- Examples:
1705-- Examples:
1502--
1706--
1503-- > stripSuffix "bar" "foobar" == Just "foo"
1707-- > stripSuffix "bar" "foobar" == Just "foo"
1708+-- > stripSuffix "" "baz" == Just "baz"
1504-- > stripSuffix "foo" "quux" == Nothing
1709-- > stripSuffix "foo" "quux" == Nothing
1505--
1710--
1506-- This is particularly useful with the @ViewPatterns@ extension to
1711-- This is particularly useful with the @ViewPatterns@ extension to
@@ -1511,10 +1716,10 @@ stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1511-- >
1716-- >
1512-- > quuxLength :: Text -> Int
1717-- > quuxLength :: Text -> Int
1513-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1718-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1514−-- > quuxLength _ = -1
1719+-- > quuxLength _ = -1
1515stripSuffix :: Text -> Text -> Maybe Text
1720stripSuffix :: Text -> Text -> Maybe Text
1516stripSuffix p@(Text _arr _off plen) t@(Text arr off len)
1721stripSuffix p@(Text _arr _off plen) t@(Text arr off len)
1517− | p `isSuffixOf` t = Just $! textP arr off (len-plen)
1722+ | p `isSuffixOf` t = Just $! text arr off (len-plen)
1518 | otherwise = Nothing
1723 | otherwise = Nothing
1519
1724
1520-- | Add a list of non-negative numbers. Errors out on overflow.
1725-- | Add a list of non-negative numbers. Errors out on overflow.
@@ -1531,3 +1736,20 @@ emptyError fun = P.error $ "Data.Text." ++ fun ++ ": empty input"
1531
1736
1532overflowError :: String -> a
1737overflowError :: String -> a
1533overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
1738overflowError 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,
1+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, Rank2Types,
2− UnboxedTuples #-}
2+ RecordWildCards, UnboxedTuples, UnliftedFFITypes #-}
3{-# OPTIONS_GHC -fno-warn-unused-matches #-}
3{-# OPTIONS_GHC -fno-warn-unused-matches #-}
4-- |
4-- |
5-- Module : Data.Text.Array
5-- Module : Data.Text.Array
6−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
6+-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
7--
7--
8-- License : BSD-style
8-- License : BSD-style
9−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
9+-- Maintainer : bos@serpentine.com
10−-- duncan@haskell.org
11-- Stability : experimental
10-- Stability : experimental
12-- Portability : portable
11-- Portability : portable
13--
12--
@@ -21,13 +20,13 @@
21-- > import qualified Data.Text.Array as A
20-- > import qualified Data.Text.Array as A
22--
21--
23-- The names in this module resemble those in the 'Data.Array' family
22-- 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
25-- naming.
24-- naming.
26module Data.Text.Array
25module Data.Text.Array
27 (
26 (
28 -- * Types
27 -- * Types
29− Array
28+ Array(Array, aBA)
30− , MArray
29+ , MArray(MArray, maBA)
31
30
32 -- * Functions
31 -- * Functions
33 , copyM
32 , copyM
@@ -60,14 +59,24 @@ if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.Text.Array." ++ (_func_) ++ "
60#if defined(ASSERTS)
59#if defined(ASSERTS)
61import Control.Exception (assert)
60import Control.Exception (assert)
62#endif
61#endif
62+#if __GLASGOW_HASKELL__ >= 702
63+import Control.Monad.ST.Unsafe (unsafeIOToST)
64+#else
65+import Control.Monad.ST (unsafeIOToST)
66+#endif
63import Data.Bits ((.&.), xor)
67import 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
65import GHC.Base (ByteArray#, MutableByteArray#, Int(..),
75import GHC.Base (ByteArray#, MutableByteArray#, Int(..),
66− indexWord16Array#, indexWordArray#, newByteArray#,
76+ indexWord16Array#, newByteArray#,
67− readWord16Array#, readWordArray#, unsafeCoerce#,
68− writeWord16Array#, writeWordArray#)
77+ unsafeFreezeByteArray#, writeWord16Array#)
69import GHC.ST (ST(..), runST)
78import GHC.ST (ST(..), runST)
70−import GHC.Word (Word16(..), Word(..))
79+import GHC.Word (Word16(..))
71import Prelude hiding (length, read)
80import Prelude hiding (length, read)
72
81
73-- | Immutable array type.
82-- | Immutable array type.
@@ -104,7 +113,7 @@ instance IArray (MArray s) where
104-- | Create an uninitialized mutable array.
113-- | Create an uninitialized mutable array.
105new :: forall s. Int -> ST s (MArray s)
114new :: forall s. Int -> ST s (MArray s)
106new n
115new n
107− | n < 0 || n .&. highBit /= 0 = error $ "Data.Text.Array.new: size overflow"
116+ | n < 0 || n .&. highBit /= 0 = array_size_error
108 | otherwise = ST $ \s1# ->
117 | otherwise = ST $ \s1# ->
109 case newByteArray# len# s1# of
118 case newByteArray# len# s1# of
110 (# s2#, marr# #) -> (# s2#, MArray marr#
119 (# s2#, marr# #) -> (# s2#, MArray marr#
@@ -116,10 +125,14 @@ new n
116 highBit = maxBound `xor` (maxBound `shiftR` 1)
125 highBit = maxBound `xor` (maxBound `shiftR` 1)
117{-# INLINE new #-}
126{-# INLINE new #-}
118
127
128+array_size_error :: a
129+array_size_error = error "Data.Text.Array.new: size overflow"
130+
119-- | Freeze a mutable array. Do not mutate the 'MArray' afterwards!
131-- | Freeze a mutable array. Do not mutate the 'MArray' afterwards!
120unsafeFreeze :: MArray s -> ST s Array
132unsafeFreeze :: MArray s -> ST s Array
121−unsafeFreeze MArray{..} = ST $ \s# ->
133+unsafeFreeze MArray{..} = ST $ \s1# ->
122− (# s#, Array (unsafeCoerce# maBA)
134+ case unsafeFreezeByteArray# maBA s1# of
135+ (# s2#, ba# #) -> (# s2#, Array ba#
123#if defined(ASSERTS)
136#if defined(ASSERTS)
124 maLen
137 maLen
125#endif
138#endif
@@ -140,23 +153,6 @@ unsafeIndex Array{..} i@(I# i#) =
140 case indexWord16Array# aBA i# of r# -> (W16# r#)
153 case indexWord16Array# aBA i# of r# -> (W16# r#)
141{-# INLINE unsafeIndex #-}
154{-# INLINE unsafeIndex #-}
142
155
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−
160-- | Unchecked write of a mutable array. May return garbage or crash
156-- | Unchecked write of a mutable array. May return garbage or crash
161-- on an out-of-bounds access.
157-- on an out-of-bounds access.
162unsafeWrite :: MArray s -> Int -> Word16 -> ST s ()
158unsafeWrite :: MArray s -> Int -> Word16 -> ST s ()
@@ -166,24 +162,6 @@ unsafeWrite MArray{..} i@(I# i#) (W16# e#) = ST $ \s1# ->
166 s2# -> (# s2#, () #)
162 s2# -> (# s2#, () #)
167{-# INLINE unsafeWrite #-}
163{-# INLINE unsafeWrite #-}
168
164
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−
187-- | Convert an immutable array to a list.
165-- | Convert an immutable array to a list.
188toList :: Array -> Int -> Int -> [Word16]
166toList :: Array -> Int -> Int -> [Word16]
189toList ary off len = loop 0
167toList ary off len = loop 0
@@ -206,15 +184,7 @@ run2 k = runST (do
206 (marr,b) <- k
184 (marr,b) <- k
207 arr <- unsafeFreeze marr
185 arr <- unsafeFreeze marr
208 return (arr,b))
186 return (arr,b))
209−
187+{-# INLINE run2 #-}
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
218
188
219-- | Copy some elements of a mutable array.
189-- | Copy some elements of a mutable array.
220copyM :: MArray s -- ^ Destination
190copyM :: MArray s -- ^ Destination
@@ -223,49 +193,33 @@ copyM :: MArray s -- ^ Destination
223 -> Int -- ^ Source offset
193 -> Int -- ^ Source offset
224 -> Int -- ^ Count
194 -> Int -- ^ Count
225 -> ST s ()
195 -> ST s ()
226−copyM dest didx src sidx count =
196+copyM dest didx src sidx count
197+ | count <= 0 = return ()
198+ | otherwise =
227#if defined(ASSERTS)
199#if defined(ASSERTS)
228 assert (sidx + count <= length src) .
200 assert (sidx + count <= length src) .
229− assert (didx + count <= length dest) $
201+ assert (didx + count <= length dest) .
230#endif
202#endif
231− if srem == 0 && drem == 0
203+ unsafeIOToST $ memcpyM (maBA dest) (fromIntegral didx)
232− then fast_loop 0
204+ (maBA src) (fromIntegral sidx)
233− else slow_loop 0
205+ (fromIntegral count)
234− where
206+{-# INLINE copyM #-}
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)
247
207
248-- | Copy some elements of an immutable array.
208-- | Copy some elements of an immutable array.
249copyI :: MArray s -- ^ Destination
209copyI :: MArray s -- ^ Destination
250 -> Int -- ^ Destination offset
210 -> Int -- ^ Destination offset
251 -> Array -- ^ Source
211 -> Array -- ^ Source
252 -> Int -- ^ Source offset
212 -> Int -- ^ Source offset
253− -> Int -- ^ First offset in source /not/ to
213+ -> Int -- ^ First offset in destination /not/ to
254 -- copy (i.e. /not/ length)
214 -- copy (i.e. /not/ length)
255 -> ST s ()
215 -> ST s ()
256copyI dest i0 src j0 top
216copyI 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 ()
217+ | i0 >= top = return ()
267− | otherwise = do unsafeWrite dest i (src `unsafeIndex` j)
218+ | otherwise = unsafeIOToST $
268− slow (i+1) (j+1)
219+ memcpyI (maBA dest) (fromIntegral i0)
220+ (aBA src) (fromIntegral j0)
221+ (fromIntegral (top-i0))
222+{-# INLINE copyI #-}
269
223
270-- | Compare portions of two arrays for equality. No bounds checking
224-- | Compare portions of two arrays for equality. No bounds checking
271-- is performed.
225-- is performed.
@@ -275,22 +229,18 @@ equal :: Array -- ^ First
275 -> Int -- ^ Offset into second
229 -> Int -- ^ Offset into second
276 -> Int -- ^ Count
230 -> Int -- ^ Count
277 -> Bool
231 -> Bool
278−equal arrA offA arrB offB count
232+equal arrA offA arrB offB count = inlinePerformIO $ do
279− | wordAligned offA && wordAligned offB = fast 0
233+ i <- memcmp (aBA arrA) (fromIntegral offA)
280− | otherwise = slow 0
234+ (aBA arrB) (fromIntegral offB) (fromIntegral count)
281− where
235+ return $! i == 0
282− countWords = count `div` wordFactor
236+{-# INLINE equal #-}
283− fast !i
237+
284− | i >= countWords = slow (i * wordFactor)
238+foreign import ccall unsafe "_hs_text_memcpy" memcpyI
285− | a /= b = False
239+ :: MutableByteArray# s -> CSize -> ByteArray# -> CSize -> CSize -> IO ()
286− | otherwise = fast (i+1)
240+
287− where a = unsafeIndexWord arrA (offAW+i)
241+foreign import ccall unsafe "_hs_text_memcmp" memcmp
288− b = unsafeIndexWord arrB (offBW+i)
242+ :: ByteArray# -> CSize -> ByteArray# -> CSize -> CSize -> IO CInt
289− offAW = offA `div` wordFactor
243+
290− offBW = offB `div` wordFactor
244+foreign import ccall unsafe "_hs_text_memcpy" memcpyM
291− slow !i
245+ :: MutableByteArray# s -> CSize -> MutableByteArray# s -> CSize -> CSize
292− | i >= count = True
246+ -> IO ()
293− | a /= b = False
294− | otherwise = slow (i+1)
295− where a = unsafeIndex arrA (offA+i)
296− b = unsafeIndex arrB (offB+i)
Data/Text/Encoding.hs+328−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
2-- |
6-- |
3-- Module : Data.Text.Encoding
7-- Module : Data.Text.Encoding
4−-- Copyright : (c) 2008, 2009 Tom Harper,
5−-- (c) 2009, 2010 Bryan O'Sullivan,
8+-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,
6−-- (c) 2009 Duncan Coutts
9+-- (c) 2009 Duncan Coutts,
10+-- (c) 2008, 2009 Tom Harper
7--
11--
8-- License : BSD-style
12-- License : BSD-style
9−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
13+-- Maintainer : bos@serpentine.com
10−-- duncan@haskell.org
11-- Stability : experimental
14-- Stability : experimental
12-- Portability : portable
15-- Portability : portable
13--
16--
@@ -22,12 +25,16 @@ module Data.Text.Encoding
22 -- * Decoding ByteStrings to Text
25 -- * Decoding ByteStrings to Text
23 -- $strict
26 -- $strict
24 decodeASCII
27 decodeASCII
28+ , decodeLatin1
25 , decodeUtf8
29 , decodeUtf8
26 , decodeUtf16LE
30 , decodeUtf16LE
27 , decodeUtf16BE
31 , decodeUtf16BE
28 , decodeUtf32LE
32 , decodeUtf32LE
29 , decodeUtf32BE
33 , decodeUtf32BE
30
34
35+ -- ** Catchable failure
36+ , decodeUtf8'
37+
31 -- ** Controllable error handling
38 -- ** Controllable error handling
32 , decodeUtf8With
39 , decodeUtf8With
33 , decodeUtf16LEWith
40 , decodeUtf16LEWith
@@ -35,32 +42,59 @@ module Data.Text.Encoding
35 , decodeUtf32LEWith
42 , decodeUtf32LEWith
36 , decodeUtf32BEWith
43 , decodeUtf32BEWith
37
44
45+ -- ** Stream oriented decoding
46+ -- $stream
47+ , streamDecodeUtf8
48+ , streamDecodeUtf8With
49+ , Decoding(..)
50+
38 -- * Encoding Text to ByteStrings
51 -- * Encoding Text to ByteStrings
39 , encodeUtf8
52 , encodeUtf8
40 , encodeUtf16LE
53 , encodeUtf16LE
41 , encodeUtf16BE
54 , encodeUtf16BE
42 , encodeUtf32LE
55 , encodeUtf32LE
43 , encodeUtf32BE
56 , encodeUtf32BE
57+
58+ -- * Encoding Text using ByteString Builders
59+ , encodeUtf8Builder
60+ , encodeUtf8BuilderEscaped
44 ) where
61 ) where
45
62
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+
69+import Control.Exception (evaluate, try)
70+import Control.Monad.ST (runST)
46import Data.Bits ((.&.))
71import Data.Bits ((.&.))
47import Data.ByteString as B
72import Data.ByteString as B
48−import Data.ByteString.Internal as B
73+import Data.ByteString.Internal as B hiding (c2w)
49−import Data.ByteString.Unsafe as B
50−import Data.Text.Encoding.Error (OnDecodeError, strictDecode)
74+import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
51−import Data.Text.Internal (Text(..), textP)
75+import Data.Text.Internal (Text(..), safe, text)
52−import Data.Text.UnsafeChar (ord, unsafeWrite)
76+import Data.Text.Internal.Private (runText)
77+import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
53−import Data.Text.UnsafeShift (shiftL, shiftR)
78+import Data.Text.Internal.Unsafe.Shift (shiftR)
54−import Data.Word (Word8)
79+import Data.Text.Show ()
80+import Data.Text.Unsafe (unsafeDupablePerformIO)
81+import Data.Word (Word8, Word32)
82+import Foreign.C.Types (CSize(..))
55import Foreign.ForeignPtr (withForeignPtr)
83import Foreign.ForeignPtr (withForeignPtr)
56−import Foreign.Ptr (plusPtr)
84+import Foreign.Marshal.Utils (with)
85+import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
57−import Foreign.Storable (poke)
86+import Foreign.Storable (Storable, peek, poke)
58−import System.IO.Unsafe (unsafePerformIO)
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
59import qualified Data.Text.Array as A
92import qualified Data.Text.Array as A
60−import qualified Data.Text.Encoding.Fusion as E
93+import qualified Data.Text.Internal.Encoding.Fusion as E
61−import qualified Data.Text.Encoding.Utf16 as U16
94+import qualified Data.Text.Internal.Encoding.Utf16 as U16
62−import qualified Data.Text.Encoding.Utf8 as U8
95+import qualified Data.Text.Internal.Fusion as F
63−import qualified Data.Text.Fusion as F
96+
97+#include "text_cbits.h"
64
98
65-- $strict
99-- $strict
66--
100--
@@ -75,100 +109,283 @@ import qualified Data.Text.Fusion as F
75-- 'decodeUtf8With' allows the programmer to determine what to do on a
109-- 'decodeUtf8With' allows the programmer to determine what to do on a
76-- decoding error.
110-- decoding error.
77
111
78−-- | Decode a 'ByteString' containing 7-bit ASCII encoded text.
112+-- | /Deprecated/. Decode a 'ByteString' containing 7-bit ASCII
113+-- encoded text.
79decodeASCII :: ByteString -> Text
114decodeASCII :: ByteString -> Text
80−decodeASCII bs = F.unstream (E.streamASCII bs)
115+decodeASCII = decodeUtf8
81−{-# INLINE decodeASCII #-}
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
82
129
83-- | Decode a 'ByteString' containing UTF-8 encoded text.
130-- | Decode a 'ByteString' containing UTF-8 encoded text.
84decodeUtf8With :: OnDecodeError -> ByteString -> Text
131decodeUtf8With :: OnDecodeError -> ByteString -> Text
85−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
86 where
154 where
87− a = A.run2 (A.new len >>= outer 0 0)
155+ desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
88− len = B.length bs
156+{- INLINE[0] decodeUtf8With #-}
89− outer n0 m0 arr = go n0 m0
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)
90 where
245 where
91− go !n !m = do
246+ decodeChunkToBuffer :: A.MArray s -> IO Decoding
92− let x1 = idx m
247+ decodeChunkToBuffer dest = withForeignPtr fp $ \ptr ->
93− x2 = idx (m + 1)
248+ with (0::CSize) $ \destOffPtr ->
94− x3 = idx (m + 2)
249+ with codepoint0 $ \codepointPtr ->
95− x4 = idx (m + 3)
250+ with state0 $ \statePtr ->
96− idx = B.unsafeIndex bs
251+ with nullPtr $ \curPtrPtr ->
97− case undefined of
252+ let end = ptr `plusPtr` (off + len)
98− _| m >= len -> return (arr,n)
253+ loop curPtr = do
99− | U8.validate1 x1 -> do
254+ poke curPtrPtr curPtr
100− A.unsafeWrite arr n (fromIntegral x1)
255+ curPtr' <- c_decode_utf8_with_state (A.maBA dest) destOffPtr
101− go (n+1) (m+1)
256+ curPtrPtr end codepointPtr statePtr
102− | m+1 < len && U8.validate2 x1 x2 -> do
257+ state <- peek statePtr
103− w <- unsafeWrite arr n (U8.chr2 x1 x2)
258+ case state of
104− go (n+w) (m+2)
259+ UTF8_REJECT -> do
105− | m+2 < len && U8.validate3 x1 x2 x3 -> do
260+ -- We encountered an encoding error
106− w <- unsafeWrite arr n (U8.chr3 x1 x2 x3)
261+ x <- peek curPtr'
107− go (n+w) (m+3)
262+ poke statePtr 0
108− | m+3 < len && U8.validate4 x1 x2 x3 x4 -> do
109− w <- unsafeWrite arr n (U8.chr4 x1 x2 x3 x4)
110− go (n+w) (m+4)
111− | otherwise -> case onErr desc (Just x1) of
263+ case onErr desc (Just x) of
112− Nothing -> go n (m+1)
264+ Nothing -> loop $ curPtr' `plusPtr` 1
113− Just c -> do
265+ Just c -> do
114− w <- unsafeWrite arr n c
266+ destOff <- peek destOffPtr
115− go (n+w) (m+1)
267+ w <- unsafeSTToIO $
116− desc = "Data.Text.Encoding.decodeUtf8: Invalid UTF-8 stream"
268+ unsafeWrite dest (fromIntegral destOff) (safe c)
117−{-# INLINE[0] decodeUtf8With #-}
269+ poke destOffPtr (destOff + fromIntegral w)
270+ loop $ curPtr' `plusPtr` 1
118
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+
119−-- | Decode a 'ByteString' containing UTF-8 encoded text.
289+-- | Decode a 'ByteString' containing UTF-8 encoded text that is known
290+-- to be valid.
120--
291--
121-- If the input contains any invalid UTF-8 data, an exception will be
292-- If the input contains any invalid UTF-8 data, an exception will be
293+-- thrown that cannot be caught in pure code. For more control over
122−-- thrown. For more control over the handling of invalid data, use
294+-- the handling of invalid data, use 'decodeUtf8'' or
123-- 'decodeUtf8With'.
295-- 'decodeUtf8With'.
124decodeUtf8 :: ByteString -> Text
296decodeUtf8 :: ByteString -> Text
125decodeUtf8 = decodeUtf8With strictDecode
297decodeUtf8 = decodeUtf8With strictDecode
126{-# INLINE[0] decodeUtf8 #-}
298{-# INLINE[0] decodeUtf8 #-}
127−
128{-# RULES "STREAM stream/decodeUtf8 fusion" [1]
299{-# RULES "STREAM stream/decodeUtf8 fusion" [1]
129 forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-}
300 forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-}
130
301
302+-- | Decode a 'ByteString' containing UTF-8 encoded text.
303+--
304+-- If the input contains any invalid UTF-8 data, the relevant
305+-- exception will be returned, otherwise the decoded text.
306+decodeUtf8' :: ByteString -> Either UnicodeException Text
307+decodeUtf8' = unsafeDupablePerformIO . try . evaluate . decodeUtf8With strictDecode
308+{-# INLINE decodeUtf8' #-}
309+
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+
131-- | Encode text using UTF-8 encoding.
371-- | Encode text using UTF-8 encoding.
132encodeUtf8 :: Text -> ByteString
372encodeUtf8 :: Text -> ByteString
133−encodeUtf8 (Text arr off len) = unsafePerformIO $ do
373+encodeUtf8 (Text arr off len)
134− let size0 = min len 4
374+ | len == 0 = B.empty
135− mallocByteString size0 >>= start size0 off 0
375+ | otherwise = unsafeDupablePerformIO $ do
136− where
376+ fp <- mallocByteString (len*4)
137− start size n0 m0 fp = withForeignPtr fp $ loop n0 m0
377+ withForeignPtr fp $ \ptr ->
138− where
378+ with ptr $ \destPtr -> do
139− loop n1 m1 ptr = go n1 m1
379+ c_encode_utf8 destPtr (A.aBA arr) (fromIntegral off) (fromIntegral len)
140− where
380+ newDest <- peek destPtr
141− go !n !m
381+ let utf8len = newDest `minusPtr` ptr
142− | n-off == len = return $! PS fp 0 m
382+ if utf8len >= len `shiftR` 1
143− | size-m < 4 = {-# SCC "encodeUtf8/resize" #-} do
383+ then return (PS fp 0 utf8len)
144− let newSize = size `shiftL` 1
384+ else do
145− fp' <- mallocByteString newSize
385+ fp' <- mallocByteString utf8len
386+ withForeignPtr fp' $ \ptr' -> do
146− withForeignPtr fp' $ \ptr' -> memcpy ptr' ptr (fromIntegral m)
387+ memcpy ptr' ptr (fromIntegral utf8len)
147− start newSize n m fp'
388+ return (PS fp' 0 utf8len)
148− | otherwise = do
149− let poke8 k v = poke (ptr `plusPtr` k) (fromIntegral v :: Word8)
150− w = A.unsafeIndex arr n
151− case undefined of
152− _| w <= 0x7F -> do
153− poke8 m w
154− go (n+1) (m+1)
155− | w <= 0x7FF -> do
156− poke8 m $ (w `shiftR` 6) + 0xC0
157− poke8 (m+1) $ (w .&. 0x3f) + 0x80
158− go (n+1) (m+2)
159− | 0xD800 <= w && w <= 0xDBFF -> do
160− let c = ord $ U16.chr2 w (A.unsafeIndex arr (n+1))
161− poke8 m $ (c `shiftR` 18) + 0xF0
162− poke8 (m+1) $ ((c `shiftR` 12) .&. 0x3F) + 0x80
163− poke8 (m+2) $ ((c `shiftR` 6) .&. 0x3F) + 0x80
164− poke8 (m+3) $ (c .&. 0x3F) + 0x80
165− go (n+2) (m+4)
166− | otherwise -> do
167− poke8 m $ (w `shiftR` 12) + 0xE0
168− poke8 (m+1) $ ((w `shiftR` 6) .&. 0x3F) + 0x80
169− poke8 (m+2) $ (w .&. 0x3F) + 0x80
170− go (n+1) (m+3)
171−{- INLINE encodeUtf8 #-}
172
389
173-- | Decode text from little endian UTF-16 encoding.
390-- | Decode text from little endian UTF-16 encoding.
174decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
391decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
@@ -245,3 +462,18 @@ encodeUtf32LE txt = E.unstream (E.restreamUtf32LE (F.stream txt))
245encodeUtf32BE :: Text -> ByteString
462encodeUtf32BE :: Text -> ByteString
246encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt))
463encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt))
247{-# INLINE encodeUtf32BE #-}
464{-# 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+17−8
@@ -1,11 +1,15 @@
1{-# LANGUAGE CPP, DeriveDataTypeable #-}
1{-# LANGUAGE CPP, DeriveDataTypeable #-}
2+#if __GLASGOW_HASKELL__ >= 704
3+{-# LANGUAGE Safe #-}
4+#elif __GLASGOW_HASKELL__ >= 702
5+{-# LANGUAGE Trustworthy #-}
6+#endif
2-- |
7-- |
3-- Module : Data.Text.Encoding.Error
8-- Module : Data.Text.Encoding.Error
4-- Copyright : (c) Bryan O'Sullivan 2009
9-- Copyright : (c) Bryan O'Sullivan 2009
5--
10--
6-- License : BSD-style
11-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
12+-- Maintainer : bos@serpentine.com
8−-- duncan@haskell.org
9-- Stability : experimental
13-- Stability : experimental
10-- Portability : GHC
14-- Portability : GHC
11--
15--
@@ -35,11 +39,8 @@ module Data.Text.Encoding.Error
35 , replace
39 , replace
36 ) where
40 ) where
37
41
38−#if __GLASGOW_HASKELL__ >= 610
42+import Control.DeepSeq (NFData (..))
39import Control.Exception (Exception, throw)
43import Control.Exception (Exception, throw)
40−#else
41−import Control.Exception.Extensible (Exception, throw)
42−#endif
43import Data.Typeable (Typeable)
44import Data.Typeable (Typeable)
44import Data.Word (Word8)
45import Data.Word (Word8)
45import Numeric (showHex)
46import Numeric (showHex)
@@ -67,6 +68,7 @@ type OnError a b = String -> Maybe a -> Maybe b
67type OnDecodeError = OnError Word8 Char
68type OnDecodeError = OnError Word8 Char
68
69
69-- | A handler for an encoding error.
70-- | A handler for an encoding error.
71+{-# DEPRECATED OnEncodeError "This exception is never used in practice, and will be removed." #-}
70type OnEncodeError = OnError Char Word8
72type OnEncodeError = OnError Char Word8
71
73
72-- | An exception type for representing Unicode encoding errors.
74-- | An exception type for representing Unicode encoding errors.
@@ -77,7 +79,9 @@ data UnicodeException =
77 | EncodeError String (Maybe Char)
79 | EncodeError String (Maybe Char)
78 -- ^ Tried to encode a character that could not be represented
80 -- ^ Tried to encode a character that could not be represented
79 -- under the given encoding, or ran out of input in mid-encode.
81 -- under the given encoding, or ran out of input in mid-encode.
80− deriving (Typeable)
82+ deriving (Eq, Typeable)
83+
84+{-# DEPRECATED EncodeError "This constructor is never used, and will be removed." #-}
81
85
82showUnicodeException :: UnicodeException -> String
86showUnicodeException :: UnicodeException -> String
83showUnicodeException (DecodeError desc (Just w))
87showUnicodeException (DecodeError desc (Just w))
@@ -88,12 +92,16 @@ showUnicodeException (EncodeError desc (Just c))
88 = "Cannot encode character '\\x" ++ showHex (fromEnum c) ("': " ++ desc)
92 = "Cannot encode character '\\x" ++ showHex (fromEnum c) ("': " ++ desc)
89showUnicodeException (EncodeError desc Nothing)
93showUnicodeException (EncodeError desc Nothing)
90 = "Cannot encode input: " ++ desc
94 = "Cannot encode input: " ++ desc
91−
95+
92instance Show UnicodeException where
96instance Show UnicodeException where
93 show = showUnicodeException
97 show = showUnicodeException
94
98
95instance Exception UnicodeException
99instance Exception UnicodeException
96
100
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+
97-- | Throw a 'UnicodeException' if decoding fails.
105-- | Throw a 'UnicodeException' if decoding fails.
98strictDecode :: OnDecodeError
106strictDecode :: OnDecodeError
99strictDecode desc c = throw (DecodeError desc c)
107strictDecode desc c = throw (DecodeError desc c)
@@ -104,6 +112,7 @@ lenientDecode :: OnDecodeError
104lenientDecode _ _ = Just '\xfffd'
112lenientDecode _ _ = Just '\xfffd'
105
113
106-- | Throw a 'UnicodeException' if encoding fails.
114-- | Throw a 'UnicodeException' if encoding fails.
115+{-# DEPRECATED strictEncode "This function always throws an exception, and will be removed." #-}
107strictEncode :: OnEncodeError
116strictEncode :: OnEncodeError
108strictEncode desc c = throw (EncodeError desc c)
117strictEncode desc c = throw (EncodeError desc c)
109
118
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 @@
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
5--
5--
6-- License : BSD-style
6-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
7+-- Maintainer : bos@serpentine.com
8−-- duncan@haskell.org
9-- Stability : experimental
8-- Stability : experimental
10-- Portability : GHC
9-- Portability : GHC
11--
10--
@@ -21,6 +20,9 @@ module Data.Text.Foreign
21 , fromPtr
20 , fromPtr
22 , useAsPtr
21 , useAsPtr
23 , asForeignPtr
22 , asForeignPtr
23+ -- ** Encoding as UTF-8
24+ , peekCStringLen
25+ , withCStringLen
24 -- * Unsafe conversion code
26 -- * Unsafe conversion code
25 , lengthWord16
27 , lengthWord16
26 , unsafeCopyToPtr
28 , unsafeCopyToPtr
@@ -33,15 +35,22 @@ module Data.Text.Foreign
33#if defined(ASSERTS)
35#if defined(ASSERTS)
34import Control.Exception (assert)
36import Control.Exception (assert)
35#endif
37#endif
38+#if __GLASGOW_HASKELL__ >= 702
39+import Control.Monad.ST.Unsafe (unsafeIOToST)
40+#else
36import Control.Monad.ST (unsafeIOToST)
41import Control.Monad.ST (unsafeIOToST)
42+#endif
43+import Data.ByteString.Unsafe (unsafePackCStringLen, unsafeUseAsCStringLen)
44+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
37import Data.Text.Internal (Text(..), empty)
45import Data.Text.Internal (Text(..), empty)
38import Data.Text.Unsafe (lengthWord16)
46import Data.Text.Unsafe (lengthWord16)
39−import qualified Data.Text.Array as A
40import Data.Word (Word16)
47import Data.Word (Word16)
48+import Foreign.C.String (CStringLen)
49+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray, withForeignPtr)
41import Foreign.Marshal.Alloc (allocaBytes)
50import Foreign.Marshal.Alloc (allocaBytes)
42import Foreign.Ptr (Ptr, castPtr, plusPtr)
51import Foreign.Ptr (Ptr, castPtr, plusPtr)
43−import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray, withForeignPtr)
44import Foreign.Storable (peek, poke)
52import Foreign.Storable (peek, poke)
53+import qualified Data.Text.Array as A
45
54
46-- $interop
55-- $interop
47--
56--
@@ -144,3 +153,21 @@ asForeignPtr t@(Text _arr _off len) = do
144 fp <- mallocForeignPtrArray len
153 fp <- mallocForeignPtrArray len
145 withForeignPtr fp $ unsafeCopyToPtr t
154 withForeignPtr fp $ unsafeCopyToPtr t
146 return (fp, I16 len)
155 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 @@
1{-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-}
1{-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
2-- |
5-- |
3-- Module : Data.Text.IO
6-- Module : Data.Text.IO
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
7-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
@@ -16,7 +19,7 @@
16module Data.Text.IO
19module Data.Text.IO
17 (
20 (
18 -- * Performance
21 -- * Performance
19− -- $performance
22+ -- $performance
20
23
21 -- * Locale support
24 -- * Locale support
22 -- $locale
25 -- $locale
@@ -26,6 +29,7 @@ module Data.Text.IO
26 , appendFile
29 , appendFile
27 -- * Operations on handles
30 -- * Operations on handles
28 , hGetContents
31 , hGetContents
32+ , hGetChunk
29 , hGetLine
33 , hGetLine
30 , hPutStr
34 , hPutStr
31 , hPutStrLn
35 , hPutStrLn
@@ -38,21 +42,17 @@ module Data.Text.IO
38 ) where
42 ) where
39
43
40import Data.Text (Text)
44import Data.Text (Text)
41−import Prelude hiding (appendFile, catch, getContents, getLine, interact,
45+import Prelude hiding (appendFile, getContents, getLine, interact,
42 putStr, putStrLn, readFile, writeFile)
46 putStr, putStrLn, readFile, writeFile)
43import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,
47import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,
44 withFile)
48 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
50import Control.Monad (liftM2, when)
50import Control.Monad (liftM2, when)
51import Data.IORef (readIORef, writeIORef)
51import Data.IORef (readIORef, writeIORef)
52import qualified Data.Text as T
52import qualified Data.Text as T
53−import Data.Text.Fusion (stream)
53+import Data.Text.Internal.Fusion (stream)
54−import Data.Text.Fusion.Internal (Step(..), Stream(..))
54+import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
55−import Data.Text.IO.Internal (hGetLineWith, readChunk)
55+import Data.Text.Internal.IO (hGetLineWith, readChunk)
56import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,
56import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer,
57 RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer,
57 RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer,
58 writeCharBuf)
58 writeCharBuf)
@@ -64,7 +64,6 @@ import GHC.IO.Handle.Types (BufferList(..), BufferMode(..), Handle__(..),
64 HandleType(..), Newline(..))
64 HandleType(..), Newline(..))
65import System.IO (hGetBuffering, hFileSize, hSetBuffering, hTell)
65import System.IO (hGetBuffering, hFileSize, hSetBuffering, hTell)
66import System.IO.Error (isEOFError)
66import System.IO.Error (isEOFError)
67−#endif
68
67
69-- $performance
68-- $performance
70-- #performance#
69-- #performance#
@@ -97,6 +96,30 @@ writeFile p = withFile p WriteMode . flip hPutStr
97appendFile :: FilePath -> Text -> IO ()
96appendFile :: FilePath -> Text -> IO ()
98appendFile p = withFile p AppendMode . flip hPutStr
97appendFile p = withFile p AppendMode . flip hPutStr
99
98
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+
100-- | Read the remaining contents of a 'Handle' as a string. The
123-- | Read the remaining contents of a 'Handle' as a string. The
101-- 'Handle' is closed once the contents have been read, or if an
124-- 'Handle' is closed once the contents have been read, or if an
102-- exception is thrown.
125-- exception is thrown.
@@ -109,31 +132,21 @@ appendFile p = withFile p AppendMode . flip hPutStr
109-- result to construct its result. For files more than a half of
132-- result to construct its result. For files more than a half of
110-- available RAM in size, this may result in memory exhaustion.
133-- available RAM in size, this may result in memory exhaustion.
111hGetContents :: Handle -> IO Text
134hGetContents :: Handle -> IO Text
112−#if __GLASGOW_HASKELL__ <= 610
113−hGetContents = fmap decodeUtf8 . B.hGetContents
114−#else
115hGetContents h = do
135hGetContents h = do
116 chooseGoodBuffering h
136 chooseGoodBuffering h
117 wantReadableHandle "hGetContents" h readAll
137 wantReadableHandle "hGetContents" h readAll
118 where
138 where
119 readAll hh@Handle__{..} = do
139 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
128 buf <- readIORef haCharBuffer
141 buf <- readIORef haCharBuffer
129− t <- readChunk hh buf `catch` catchError
142+ t <- readChunk hh buf `E.catch` catchError "hGetContents" h hh
130 if T.null t
143 if T.null t
131 then return [t]
144 then return [t]
132 else (t:) `fmap` readChunks
145 else (t:) `fmap` readChunks
133 ts <- readChunks
146 ts <- readChunks
134 (hh', _) <- hClose_help hh
147 (hh', _) <- hClose_help hh
135 return (hh'{haType=ClosedHandle}, T.concat ts)
148 return (hh'{haType=ClosedHandle}, T.concat ts)
136−
149+
137-- | Use a more efficient buffer size if we're reading in
150-- | Use a more efficient buffer size if we're reading in
138-- block-buffered mode with the default buffer size. When we can
151-- block-buffered mode with the default buffer size. When we can
139-- determine the size of the handle we're reading, set the buffer size
152-- determine the size of the handle we're reading, set the buffer size
@@ -144,30 +157,22 @@ chooseGoodBuffering h = do
144 bufMode <- hGetBuffering h
157 bufMode <- hGetBuffering h
145 case bufMode of
158 case bufMode of
146 BlockBuffering Nothing -> do
159 BlockBuffering Nothing -> do
147− d <- catch (liftM2 (-) (hFileSize h) (hTell h)) $ \(e::IOException) ->
160+ d <- E.catch (liftM2 (-) (hFileSize h) (hTell h)) $ \(e::IOException) ->
148 if ioe_type e == InappropriateType
161 if ioe_type e == InappropriateType
149 then return 16384 -- faster than the 2KB default
162 then return 16384 -- faster than the 2KB default
150− else throw e
163+ else E.throwIO e
151 when (d > 0) . hSetBuffering h . BlockBuffering . Just . fromIntegral $ d
164 when (d > 0) . hSetBuffering h . BlockBuffering . Just . fromIntegral $ d
152 _ -> return ()
165 _ -> return ()
153−#endif
154
166
155-- | Read a single line from a handle.
167-- | Read a single line from a handle.
156hGetLine :: Handle -> IO Text
168hGetLine :: Handle -> IO Text
157−#if __GLASGOW_HASKELL__ <= 610
158−hGetLine = fmap decodeUtf8 . B.hGetLine
159−#else
160hGetLine = hGetLineWith T.concat
169hGetLine = hGetLineWith T.concat
161−#endif
162
170
163-- | Write a string to a handle.
171-- | Write a string to a handle.
164hPutStr :: Handle -> Text -> IO ()
172hPutStr :: Handle -> Text -> IO ()
165−#if __GLASGOW_HASKELL__ <= 610
166−hPutStr h = B.hPutStr h . encodeUtf8
167−#else
168-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
173-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
169hPutStr h t = do
174hPutStr h t = do
170− (buffer_mode, nl) <-
175+ (buffer_mode, nl) <-
171 wantWritableHandle "hPutStr" h $ \h_ -> do
176 wantWritableHandle "hPutStr" h $ \h_ -> do
172 bmode <- getSpareBuffer h_
177 bmode <- getSpareBuffer h_
173 return (bmode, haOutputNL h_)
178 return (bmode, haOutputNL h_)
@@ -249,7 +254,7 @@ writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
249
254
250-- This function is completely lifted from GHC.IO.Handle.Text.
255-- This function is completely lifted from GHC.IO.Handle.Text.
251getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
256getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
252−getSpareBuffer Handle__{haCharBuffer=ref,
257+getSpareBuffer Handle__{haCharBuffer=ref,
253 haBuffers=spare_ref,
258 haBuffers=spare_ref,
254 haBufferMode=mode}
259 haBufferMode=mode}
255 = do
260 = do
@@ -270,11 +275,10 @@ getSpareBuffer Handle__{haCharBuffer=ref,
270-- This function is completely lifted from GHC.IO.Handle.Text.
275-- This function is completely lifted from GHC.IO.Handle.Text.
271commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
276commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
272 -> IO CharBuffer
277 -> IO CharBuffer
273−commitBuffer hdl !raw !sz !count flush release =
278+commitBuffer hdl !raw !sz !count flush release =
274 wantWritableHandle "commitAndReleaseBuffer" hdl $
279 wantWritableHandle "commitAndReleaseBuffer" hdl $
275 commitBuffer' raw sz count flush release
280 commitBuffer' raw sz count flush release
276{-# INLINE commitBuffer #-}
281{-# INLINE commitBuffer #-}
277−#endif
278
282
279-- | Write a string to a handle, followed by a newline.
283-- | Write a string to a handle, followed by a newline.
280hPutStrLn :: Handle -> Text -> IO ()
284hPutStrLn :: Handle -> Text -> IO ()
Data/Text/Internal.hs+109−19
@@ -1,4 +1,5 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}
2+{-# OPTIONS_HADDOCK not-home #-}
2
3
3-- |
4-- |
4-- Module : Data.Text.Internal
5-- Module : Data.Text.Internal
@@ -7,17 +8,26 @@
7-- (c) 2009 Duncan Coutts
8-- (c) 2009 Duncan Coutts
8--
9--
9-- License : BSD-style
10-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11+-- Maintainer : bos@serpentine.com
11−-- duncan@haskell.org
12-- Stability : experimental
12-- Stability : experimental
13-- Portability : GHC
13-- Portability : GHC
14--
14--
15−-- Semi-public internals. Most users should not need to use this
15+-- A module containing private 'Text' internals. This exposes the
16−-- module.
16+-- 'Text' representation and low level construction functions.
17+-- Modules which extend the 'Text' system may need to use this module.
18+--
19+-- You should not use this module unless you are determined to monkey
20+-- with the internals, as the functions here do just about nothing to
21+-- preserve data invariants. You have been warned!
22+
23+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
24+#include "MachDeps.h"
25+#endif
17
26
18module Data.Text.Internal
27module Data.Text.Internal
19 (
28 (
20 -- * Types
29 -- * Types
30+ -- $internals
21 Text(..)
31 Text(..)
22 -- * Construction
32 -- * Construction
23 , text
33 , text
@@ -26,8 +36,13 @@ module Data.Text.Internal
26 , safe
36 , safe
27 -- * Code that must be here for accessibility
37 -- * Code that must be here for accessibility
28 , empty
38 , empty
39+ , empty_
29 -- * Utilities
40 -- * Utilities
30 , firstf
41 , firstf
42+ -- * Checked multiplication
43+ , mul
44+ , mul32
45+ , mul64
31 -- * Debugging
46 -- * Debugging
32 , showText
47 , showText
33 ) where
48 ) where
@@ -35,21 +50,22 @@ module Data.Text.Internal
35#if defined(ASSERTS)
50#if defined(ASSERTS)
36import Control.Exception (assert)
51import Control.Exception (assert)
37#endif
52#endif
38−import Data.Bits ((.&.))
53+import Data.Bits
39−import qualified Data.Text.Array as A
54+import Data.Int (Int32, Int64)
40−import Data.Text.UnsafeChar (ord)
55+import Data.Text.Internal.Unsafe.Char (ord)
41import Data.Typeable (Typeable)
56import Data.Typeable (Typeable)
57+import qualified Data.Text.Array as A
42
58
43-- | A space efficient, packed, unboxed Unicode text type.
59-- | A space efficient, packed, unboxed Unicode text type.
44data Text = Text
60data Text = Text
45− {-# UNPACK #-} !A.Array -- payload
61+ {-# UNPACK #-} !A.Array -- payload (Word16 elements)
46− {-# UNPACK #-} !Int -- offset
62+ {-# UNPACK #-} !Int -- offset (units of Word16, not Char)
47− {-# UNPACK #-} !Int -- length
63+ {-# UNPACK #-} !Int -- length (units of Word16, not Char)
48 deriving (Typeable)
64 deriving (Typeable)
49
65
50-- | Smart constructor.
66-- | Smart constructor.
51−text :: A.Array -> Int -> Int -> Text
67+text_ :: A.Array -> Int -> Int -> Text
52−text arr off len =
68+text_ arr off len =
53#if defined(ASSERTS)
69#if defined(ASSERTS)
54 let c = A.unsafeIndex arr off
70 let c = A.unsafeIndex arr off
55 alen = A.length arr
71 alen = A.length arr
@@ -59,19 +75,28 @@ text arr off len =
59 assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $
75 assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $
60#endif
76#endif
61 Text arr off len
77 Text arr off len
62−{-# INLINE text #-}
78+{-# INLINE text_ #-}
63
79
64-- | /O(1)/ The empty 'Text'.
80-- | /O(1)/ The empty 'Text'.
65empty :: Text
81empty :: Text
66empty = Text A.empty 0 0
82empty = Text A.empty 0 0
67{-# INLINE [1] empty #-}
83{-# INLINE [1] empty #-}
68
84
85+-- | A non-inlined version of 'empty'.
86+empty_ :: Text
87+empty_ = Text A.empty 0 0
88+{-# NOINLINE empty_ #-}
89+
69-- | Construct a 'Text' without invisibly pinning its byte array in
90-- | Construct a 'Text' without invisibly pinning its byte array in
70-- memory if its length has dwindled to zero.
91-- 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+
71textP :: A.Array -> Int -> Int -> Text
97textP :: A.Array -> Int -> Int -> Text
72−textP arr off len | len == 0 = empty
98+{-# DEPRECATED textP "Use text instead" #-}
73− | otherwise = text arr off len
99+textP = text
74−{-# INLINE textP #-}
75
100
76-- | A useful 'show'-like function for debugging purposes.
101-- | A useful 'show'-like function for debugging purposes.
77showText :: Text -> String
102showText :: Text -> String
@@ -85,14 +110,79 @@ showText (Text arr off len) =
85-- scalar values, but are unfortunately admitted as valid 'Char'
110-- scalar values, but are unfortunately admitted as valid 'Char'
86-- values by Haskell. They cannot be represented in a 'Text'. This
111-- values by Haskell. They cannot be represented in a 'Text'. This
87-- function remaps those code points to the Unicode replacement
112-- function remaps those code points to the Unicode replacement
88−-- character \"&#xfffd;\", and leaves other code points unchanged.
113+-- character (U+FFFD, \'&#xfffd;\'), and leaves other code points
114+-- unchanged.
89safe :: Char -> Char
115safe :: Char -> Char
90safe c
116safe c
91 | ord c .&. 0x1ff800 /= 0xd800 = c
117 | ord c .&. 0x1ff800 /= 0xd800 = c
92 | otherwise = '\xfffd'
118 | otherwise = '\xfffd'
93−{-# INLINE safe #-}
119+{-# INLINE [0] safe #-}
94
120
95-- | Apply a function to the first element of an optional pair.
121-- | Apply a function to the first element of an optional pair.
96firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
122firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
97firstf f (Just (a, b)) = Just (f a, b)
123firstf f (Just (a, b)) = Just (f a, b)
98firstf _ Nothing = Nothing
124firstf _ 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 @@
1{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
1{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.Encoding.Fusion
4+-- Module : Data.Text.Internal.Encoding.Fusion
5-- Copyright : (c) Tom Harper 2008-2009,
5-- Copyright : (c) Tom Harper 2008-2009,
6-- (c) Bryan O'Sullivan 2009,
6-- (c) Bryan O'Sullivan 2009,
7-- (c) Duncan Coutts 2009
7-- (c) Duncan Coutts 2009
8--
8--
9-- License : BSD-style
9-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10+-- Maintainer : bos@serpentine.com
11−-- duncan@haskell.org
12-- Stability : experimental
11-- Stability : experimental
13-- Portability : portable
12-- Portability : portable
14--
13--
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+--
15-- Fusible 'Stream'-oriented functions for converting between 'Text'
18-- Fusible 'Stream'-oriented functions for converting between 'Text'
16-- and several common encodings.
19-- and several common encodings.
17
20
18−module Data.Text.Encoding.Fusion
21+module Data.Text.Internal.Encoding.Fusion
19 (
22 (
20 -- * Streaming
23 -- * Streaming
21 streamASCII
24 streamASCII
@@ -28,28 +31,28 @@ module Data.Text.Encoding.Fusion
28 -- * Unstreaming
31 -- * Unstreaming
29 , unstream
32 , unstream
30
33
31− , module Data.Text.Encoding.Fusion.Common
34+ , module Data.Text.Internal.Encoding.Fusion.Common
32 ) where
35 ) where
33
36
34#if defined(ASSERTS)
37#if defined(ASSERTS)
35import Control.Exception (assert)
38import Control.Exception (assert)
36#endif
39#endif
37import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy)
40import Data.ByteString.Internal (ByteString(..), mallocByteString, memcpy)
38−import Data.Text.Fusion (Step(..), Stream(..))
41+import Data.Text.Internal.Fusion (Step(..), Stream(..))
39−import Data.Text.Fusion.Size
42+import Data.Text.Internal.Fusion.Size
40import Data.Text.Encoding.Error
43import Data.Text.Encoding.Error
41−import Data.Text.Encoding.Fusion.Common
44+import Data.Text.Internal.Encoding.Fusion.Common
42−import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32)
45+import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
43−import Data.Text.UnsafeShift (shiftL, shiftR)
46+import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
44import Data.Word (Word8, Word16, Word32)
47import Data.Word (Word8, Word16, Word32)
45import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
48import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
46import Foreign.Storable (pokeByteOff)
49import Foreign.Storable (pokeByteOff)
47−import System.IO.Unsafe (unsafePerformIO)
48import qualified Data.ByteString as B
50import qualified Data.ByteString as B
49import qualified Data.ByteString.Unsafe as B
51import qualified Data.ByteString.Unsafe as B
50−import qualified Data.Text.Encoding.Utf8 as U8
52+import qualified Data.Text.Internal.Encoding.Utf8 as U8
51−import qualified Data.Text.Encoding.Utf16 as U16
53+import qualified Data.Text.Internal.Encoding.Utf16 as U16
52−import qualified Data.Text.Encoding.Utf32 as U32
54+import qualified Data.Text.Internal.Encoding.Utf32 as U32
55+import Data.Text.Unsafe (unsafeDupablePerformIO)
53
56
54streamASCII :: ByteString -> Stream Char
57streamASCII :: ByteString -> Stream Char
55streamASCII bs = Stream next 0 (maxSize l)
58streamASCII bs = Stream next 0 (maxSize l)
@@ -61,6 +64,7 @@ streamASCII bs = Stream next 0 (maxSize l)
61 | otherwise = Yield (unsafeChr8 x1) (i+1)
64 | otherwise = Yield (unsafeChr8 x1) (i+1)
62 where
65 where
63 x1 = B.unsafeIndex bs i
66 x1 = B.unsafeIndex bs i
67+{-# DEPRECATED streamASCII "Do not use this function" #-}
64{-# INLINE [0] streamASCII #-}
68{-# INLINE [0] streamASCII #-}
65
69
66-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8
70-- | /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))
162
166
163-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
167-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
164unstream :: Stream Word8 -> ByteString
168unstream :: Stream Word8 -> ByteString
165−unstream (Stream next s0 len) = unsafePerformIO $ do
169+unstream (Stream next s0 len) = unsafeDupablePerformIO $ do
166 let mlen = upperBound 4 len
170 let mlen = upperBound 4 len
167 mallocByteString mlen >>= loop mlen 0 s0
171 mallocByteString mlen >>= loop mlen 0 s0
168 where
172 where
@@ -200,5 +204,5 @@ decodeError func kind onErr mb i =
200 case onErr desc mb of
204 case onErr desc mb of
201 Nothing -> Skip i
205 Nothing -> Skip i
202 Just c -> Yield c i
206 Just c -> Yield c i
203− where desc = "Data.Text.Encoding.Fusion." ++ func ++ ": Invalid " ++
207+ where desc = "Data.Text.Internal.Encoding.Fusion." ++ func ++ ": Invalid " ++
204 kind ++ " stream"
208 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 #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.Encoding.Utf16
4+-- Module : Data.Text.Internal.Encoding.Utf16
5-- Copyright : (c) 2008, 2009 Tom Harper,
5-- Copyright : (c) 2008, 2009 Tom Harper,
6-- (c) 2009 Bryan O'Sullivan,
6-- (c) 2009 Bryan O'Sullivan,
7-- (c) 2009 Duncan Coutts
7-- (c) 2009 Duncan Coutts
8--
8--
9-- License : BSD-style
9-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10+-- Maintainer : bos@serpentine.com
11−-- duncan@haskell.org
12-- Stability : experimental
11-- Stability : experimental
13-- Portability : GHC
12-- Portability : GHC
14--
13--
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+--
15-- Basic UTF-16 validation and character manipulation.
18-- Basic UTF-16 validation and character manipulation.
16−module Data.Text.Encoding.Utf16
19+module Data.Text.Internal.Encoding.Utf16
17 (
20 (
18 chr2
21 chr2
19 , validate1
22 , validate1
Data/Text/Encoding/Utf32.hs → Data/Text/Internal/Encoding/Utf32.hsrenamed+7−4
@@ -1,17 +1,20 @@
1-- |
1-- |
2−-- Module : Data.Text.Encoding.Utf32
2+-- Module : Data.Text.Internal.Encoding.Utf32
3-- Copyright : (c) 2008, 2009 Tom Harper,
3-- Copyright : (c) 2008, 2009 Tom Harper,
4-- (c) 2009, 2010 Bryan O'Sullivan,
4-- (c) 2009, 2010 Bryan O'Sullivan,
5-- (c) 2009 Duncan Coutts
5-- (c) 2009 Duncan Coutts
6--
6--
7-- License : BSD-style
7-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
9-- Stability : experimental
11-- Portability : portable
10-- Portability : portable
12--
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+--
13-- Basic UTF-32 validation.
16-- Basic UTF-32 validation.
14−module Data.Text.Encoding.Utf32
17+module Data.Text.Internal.Encoding.Utf32
15 (
18 (
16 validate
19 validate
17 ) where
20 ) 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 #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.Encoding.Utf8
4+-- Module : Data.Text.Internal.Encoding.Utf8
5-- Copyright : (c) 2008, 2009 Tom Harper,
5-- Copyright : (c) 2008, 2009 Tom Harper,
6-- (c) 2009, 2010 Bryan O'Sullivan,
6-- (c) 2009, 2010 Bryan O'Sullivan,
7-- (c) 2009 Duncan Coutts
7-- (c) 2009 Duncan Coutts
8--
8--
9-- License : BSD-style
9-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10+-- Maintainer : bos@serpentine.com
11−-- duncan@haskell.org
12-- Stability : experimental
11-- Stability : experimental
13-- Portability : GHC
12-- Portability : GHC
14--
13--
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+--
15-- Basic UTF-8 validation and character manipulation.
18-- Basic UTF-8 validation and character manipulation.
16−module Data.Text.Encoding.Utf8
19+module Data.Text.Internal.Encoding.Utf8
17 (
20 (
18 -- Decomposition
21 -- Decomposition
19 ord2
22 ord2
@@ -30,12 +33,16 @@ module Data.Text.Encoding.Utf8
30 , validate4
33 , validate4
31 ) where
34 ) where
32
35
36+#if defined(TEST_SUITE)
37+# undef ASSERTS
38+#endif
39+
33#if defined(ASSERTS)
40#if defined(ASSERTS)
34import Control.Exception (assert)
41import Control.Exception (assert)
35#endif
42#endif
36import Data.Bits ((.&.))
43import Data.Bits ((.&.))
37−import Data.Text.UnsafeChar (ord)
44+import Data.Text.Internal.Unsafe.Char (ord)
38−import Data.Text.UnsafeShift (shiftR)
45+import Data.Text.Internal.Unsafe.Shift (shiftR)
39import GHC.Exts
46import GHC.Exts
40import GHC.Word (Word8(..))
47import GHC.Word (Word8(..))
41
48
@@ -146,7 +153,7 @@ validate3 x1 x2 x3 = validate3_1 || validate3_2 || validate3_3 || validate3_4
146validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
153validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
147{-# INLINE validate4 #-}
154{-# INLINE validate4 #-}
148validate4 x1 x2 x3 x4 = validate4_1 || validate4_2 || validate4_3
155validate4 x1 x2 x3 x4 = validate4_1 || validate4_2 || validate4_3
149− where
156+ where
150 validate4_1 = x1 == 0xF0 &&
157 validate4_1 = x1 == 0xF0 &&
151 between x2 0x90 0xBF &&
158 between x2 0x90 0xBF &&
152 between x3 0x80 0xBF &&
159 between x3 0x80 0xBF &&
Data/Text/Util.hs → Data/Text/Internal/Functions.hsrenamed+6−2
@@ -1,7 +1,7 @@
1{-# LANGUAGE CPP, DeriveDataTypeable #-}
1{-# LANGUAGE CPP, DeriveDataTypeable #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.Util
4+-- Module : Data.Text.Internal.Functions
5-- Copyright : 2010 Bryan O'Sullivan
5-- Copyright : 2010 Bryan O'Sullivan
6--
6--
7-- License : BSD-style
7-- License : BSD-style
@@ -9,9 +9,13 @@
9-- Stability : experimental
9-- Stability : experimental
10-- Portability : GHC
10-- Portability : GHC
11--
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+--
12-- Useful functions.
16-- Useful functions.
13
17
14−module Data.Text.Util
18+module Data.Text.Internal.Functions
15 (
19 (
16 intersperse
20 intersperse
17 ) where
21 ) where
Data/Text/Fusion.hs → Data/Text/Internal/Fusion.hsrenamed+58−45
@@ -1,20 +1,23 @@
1{-# LANGUAGE BangPatterns, MagicHash #-}
1{-# LANGUAGE BangPatterns, MagicHash #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.Fusion
4+-- Module : Data.Text.Internal.Fusion
5-- Copyright : (c) Tom Harper 2008-2009,
5-- Copyright : (c) Tom Harper 2008-2009,
6-- (c) Bryan O'Sullivan 2009-2010,
6-- (c) Bryan O'Sullivan 2009-2010,
7-- (c) Duncan Coutts 2009
7-- (c) Duncan Coutts 2009
8--
8--
9-- License : BSD-style
9-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10+-- Maintainer : bos@serpentine.com
11−-- duncan@haskell.org
12-- Stability : experimental
11-- Stability : experimental
13-- Portability : GHC
12-- Portability : GHC
14--
13--
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+--
15-- Text manipulation functions represented as fusible operations over
18-- Text manipulation functions represented as fusible operations over
16-- streams.
19-- streams.
17−module Data.Text.Fusion
20+module Data.Text.Internal.Fusion
18 (
21 (
19 -- * Types
22 -- * Types
20 Stream(..)
23 Stream(..)
@@ -51,21 +54,21 @@ import Prelude (Bool(..), Char, Maybe(..), Monad(..), Int,
51 fromIntegral, otherwise)
54 fromIntegral, otherwise)
52import Data.Bits ((.&.))
55import Data.Bits ((.&.))
53import Data.Text.Internal (Text(..))
56import Data.Text.Internal (Text(..))
57+import Data.Text.Internal.Private (runText)
54−import Data.Text.UnsafeChar (ord, unsafeChr, unsafeWrite)
58+import Data.Text.Internal.Unsafe.Char (ord, unsafeChr, unsafeWrite)
55−import Data.Text.UnsafeShift (shiftL, shiftR)
59+import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
56import qualified Data.Text.Array as A
60import qualified Data.Text.Array as A
57−import qualified Data.Text.Fusion.Common as S
61+import qualified Data.Text.Internal.Fusion.Common as S
58−import Data.Text.Fusion.Internal
62+import Data.Text.Internal.Fusion.Types
59−import Data.Text.Fusion.Size
63+import Data.Text.Internal.Fusion.Size
60import qualified Data.Text.Internal as I
64import qualified Data.Text.Internal as I
61−import qualified Data.Text.Encoding.Utf16 as U16
65+import qualified Data.Text.Internal.Encoding.Utf16 as U16
62−import qualified Prelude as P
63
66
64default(Int)
67default(Int)
65
68
66-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
69-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
67stream :: Text -> Stream Char
70stream :: 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)
69 where
72 where
70 !end = off+len
73 !end = off+len
71 next !i
74 next !i
@@ -80,7 +83,7 @@ stream (Text arr off len) = Stream next off (maxSize len)
80-- | /O(n)/ Convert a 'Text' into a 'Stream Char', but iterate
83-- | /O(n)/ Convert a 'Text' into a 'Stream Char', but iterate
81-- backwards.
84-- backwards.
82reverseStream :: Text -> Stream Char
85reverseStream :: 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)
84 where
87 where
85 {-# INLINE next #-}
88 {-# INLINE next #-}
86 next !i
89 next !i
@@ -94,26 +97,36 @@ reverseStream (Text arr off len) = Stream next (off+len-1) (maxSize len)
94
97
95-- | /O(n)/ Convert a 'Stream Char' into a 'Text'.
98-- | /O(n)/ Convert a 'Stream Char' into a 'Text'.
96unstream :: Stream Char -> Text
99unstream :: Stream Char -> Text
97−unstream (Stream next0 s0 len) = I.textP (P.fst a) 0 (P.snd a)
100+unstream (Stream next0 s0 len) = runText $ \done -> do
98− where
101+ -- Before encoding each char we perform a buffer realloc check assuming
99− a = A.run2 (A.new mlen >>= \arr -> outer arr mlen s0 0)
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.
100− where mlen = upperBound 4 len
105+ let mlen = upperBound 4 len + 1
106+ arr0 <- A.new mlen
101− outer arr top = loop
107+ let outer !arr !maxi = encode
102− where
108+ where
103− loop !s !i =
109+ -- keep the common case loop as small as possible
110+ encode !si !di =
104− case next0 s of
111+ case next0 si of
105− Done -> return (arr, i)
112+ Done -> done arr di
106− Skip s' -> loop s' i
113+ Skip si' -> encode si' di
107− Yield x s'
114+ Yield c si'
108− | j >= top -> {-# SCC "unstream/resize" #-} do
115+ -- simply check for the worst case
109− let top' = (top + 1) `shiftL` 1
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
110− arr' <- A.new top'
125+ arr' <- A.new newlen
111− A.copyM arr' 0 arr 0 top
126+ A.copyM arr' 0 arr 0 di
112− outer arr' top' s i
127+ outer arr' (newlen - 1) si di
113− | otherwise -> do d <- unsafeWrite arr i x
128+
114− loop s' (i+d)
129+ outer arr0 (mlen - 1) s0 0
115− where j | ord x < 0x10000 = i
116− | otherwise = i + 1
117{-# INLINE [0] unstream #-}
130{-# INLINE [0] unstream #-}
118{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
131{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
119
132
@@ -129,7 +142,7 @@ length = S.lengthI
129reverse :: Stream Char -> Text
142reverse :: Stream Char -> Text
130reverse (Stream next s len0)
143reverse (Stream next s len0)
131 | isEmpty len0 = I.empty
144 | isEmpty len0 = I.empty
132− | otherwise = I.textP arr off' len'
145+ | otherwise = I.text arr off' len'
133 where
146 where
134 len0' = upperBound 4 (larger len0 4)
147 len0' = upperBound 4 (larger len0 4)
135 (arr, (off', len')) = A.run2 (A.new len0' >>= loop s (len0'-1) len0')
148 (arr, (off', len')) = A.run2 (A.new len0' >>= loop s (len0'-1) len0')
@@ -163,15 +176,15 @@ reverse (Stream next s len0)
163-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
176-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
164-- the input and result reversed.
177-- the input and result reversed.
165reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
178reverseScanr :: (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
167 where
180 where
168 {-# INLINE next #-}
181 {-# INLINE next #-}
169− next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s)
182+ next (Scan1 z s) = Yield z (Scan2 z s)
170− next (S2 :*: z :*: s) = case next0 s of
183+ next (Scan2 z s) = case next0 s of
171− Yield x s' -> let !x' = f x z
184+ Yield x s' -> let !x' = f x z
172− in Yield x' (S2 :*: x' :*: s')
185+ in Yield x' (Scan2 x' s')
173− Skip s' -> Skip (S2 :*: z :*: s')
186+ Skip s' -> Skip (Scan2 z s')
174− Done -> Done
187+ Done -> Done
175{-# INLINE reverseScanr #-}
188{-# INLINE reverseScanr #-}
176
189
177-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
190-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
@@ -207,7 +220,7 @@ countChar = S.countCharI
207-- function to each element of a 'Text', passing an accumulating
220-- function to each element of a 'Text', passing an accumulating
208-- parameter from left to right, and returns a final 'Text'.
221-- parameter from left to right, and returns a final 'Text'.
209mapAccumL :: (a -> Char -> (a,Char)) -> a -> Stream Char -> (a, Text)
222mapAccumL :: (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)
211 where
224 where
212 (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0)
225 (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0)
213 where mlen = upperBound 4 len
226 where mlen = upperBound 4 len
@@ -223,9 +236,9 @@ mapAccumL f z0 (Stream next0 s0 len) = (nz,I.textP na 0 nl)
223 arr' <- A.new top'
236 arr' <- A.new top'
224 A.copyM arr' 0 arr 0 top
237 A.copyM arr' 0 arr 0 top
225 outer arr' top' z s i
238 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
228 loop z' s' (i+d)
240 loop z' s' (i+d)
241+ where (z',c) = f z x
229− where j | ord x < 0x10000 = i
242+ j | ord c < 0x10000 = i
230 | otherwise = i + 1
243 | otherwise = i + 1
231{-# INLINE [0] mapAccumL #-}
244{-# INLINE [0] mapAccumL #-}
Data/Text/Fusion/CaseMapping.hs → Data/Text/Internal/Fusion/CaseMapping.hsrenamed+392−6
@@ -1,12 +1,17 @@
1{-# LANGUAGE Rank2Types #-}
1{-# LANGUAGE Rank2Types #-}
2-- AUTOMATICALLY GENERATED - DO NOT EDIT
2-- AUTOMATICALLY GENERATED - DO NOT EDIT
3−-- Generated by scripts/SpecialCasing.hs
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+
4−module Data.Text.Fusion.CaseMapping where
9+module Data.Text.Internal.Fusion.CaseMapping where
5import Data.Char
10import Data.Char
6−import Data.Text.Fusion.Internal
11+import Data.Text.Internal.Fusion.Types
7
12
8upperMapping :: forall s. Char -> s -> Step (CC s) Char
13upperMapping :: forall s. Char -> s -> Step (CC s) Char
9−{-# INLINE upperMapping #-}
14+{-# NOINLINE upperMapping #-}
10-- LATIN SMALL LETTER SHARP S
15-- LATIN SMALL LETTER SHARP S
11upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')
16upperMapping '\x00df' s = Yield '\x0053' (CC s '\x0053' '\x0000')
12-- LATIN SMALL LIGATURE FF
17-- LATIN SMALL LIGATURE FF
@@ -213,12 +218,111 @@ upperMapping '\x1fc7' s = Yield '\x0397' (CC s '\x0342' '\x0399')
213upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')
218upperMapping '\x1ff7' s = Yield '\x03a9' (CC s '\x0342' '\x0399')
214upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')
219upperMapping c s = Yield (toUpper c) (CC s '\0' '\0')
215lowerMapping :: forall s. Char -> s -> Step (CC s) Char
220lowerMapping :: forall s. Char -> s -> Step (CC s) Char
216−{-# INLINE lowerMapping #-}
221+{-# NOINLINE lowerMapping #-}
217-- LATIN CAPITAL LETTER I WITH DOT ABOVE
222-- LATIN CAPITAL LETTER I WITH DOT ABOVE
218lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
223lowerMapping '\x0130' s = Yield '\x0069' (CC s '\x0307' '\x0000')
219lowerMapping c s = Yield (toLower c) (CC s '\0' '\0')
224lowerMapping 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')
220foldMapping :: forall s. Char -> s -> Step (CC s) Char
324foldMapping :: forall s. Char -> s -> Step (CC s) Char
221−{-# INLINE foldMapping #-}
325+{-# NOINLINE foldMapping #-}
222-- MICRO SIGN
326-- MICRO SIGN
223foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')
327foldMapping '\x00b5' s = Yield '\x03bc' (CC s '\x0000' '\x0000')
224-- LATIN SMALL LETTER SHARP S
328-- LATIN SMALL LETTER SHARP S
@@ -255,6 +359,18 @@ foldMapping '\x03f1' s = Yield '\x03c1' (CC s '\x0000' '\x0000')
255foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')
359foldMapping '\x03f5' s = Yield '\x03b5' (CC s '\x0000' '\x0000')
256-- ARMENIAN SMALL LIGATURE ECH YIWN
360-- ARMENIAN SMALL LIGATURE ECH YIWN
257foldMapping '\x0587' s = Yield '\x0565' (CC s '\x0582' '\x0000')
361foldMapping '\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')
258-- LATIN SMALL LETTER H WITH LINE BELOW
374-- LATIN SMALL LETTER H WITH LINE BELOW
259foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')
375foldMapping '\x1e96' s = Yield '\x0068' (CC s '\x0331' '\x0000')
260-- LATIN SMALL LETTER T WITH DIAERESIS
376-- LATIN SMALL LETTER T WITH DIAERESIS
@@ -429,6 +545,174 @@ foldMapping '\x1ff6' s = Yield '\x03c9' (CC s '\x0342' '\x0000')
429foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')
545foldMapping '\x1ff7' s = Yield '\x03c9' (CC s '\x0342' '\x03b9')
430-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
546-- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
431foldMapping '\x1ffc' s = Yield '\x03c9' (CC s '\x03b9' '\x0000')
547foldMapping '\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')
432-- LATIN SMALL LIGATURE FF
716-- LATIN SMALL LIGATURE FF
433foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')
717foldMapping '\xfb00' s = Yield '\x0066' (CC s '\x0066' '\x0000')
434-- LATIN SMALL LIGATURE FI
718-- LATIN SMALL LIGATURE FI
@@ -453,4 +737,106 @@ foldMapping '\xfb15' s = Yield '\x0574' (CC s '\x056b' '\x0000')
453foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')
737foldMapping '\xfb16' s = Yield '\x057e' (CC s '\x0576' '\x0000')
454-- ARMENIAN SMALL LIGATURE MEN XEH
738-- ARMENIAN SMALL LIGATURE MEN XEH
455foldMapping '\xfb17' s = Yield '\x0574' (CC s '\x056d' '\x0000')
739foldMapping '\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')
456foldMapping c s = Yield (toLower c) (CC s '\0' '\0')
842foldMapping 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 #-}
2-- |
2-- |
3−-- Module : Data.Text.Fusion.Common
3+-- Module : Data.Text.Internal.Fusion.Common
4−-- Copyright : (c) Bryan O'Sullivan 2009
4+-- Copyright : (c) Bryan O'Sullivan 2009, 2012
5--
5--
6-- License : BSD-style
6-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
7+-- Maintainer : bos@serpentine.com
8−-- duncan@haskell.org
9-- Stability : experimental
8-- Stability : experimental
10-- Portability : GHC
9-- Portability : GHC
11--
10--
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+--
12-- Common stream fusion functionality for text.
15-- Common stream fusion functionality for text.
13
16
14−module Data.Text.Fusion.Common
17+module Data.Text.Internal.Fusion.Common
15 (
18 (
16 -- * Creation and elimination
19 -- * Creation and elimination
17 singleton
20 singleton
18 , streamList
21 , streamList
19 , unstreamList
22 , unstreamList
23+ , streamCString#
20
24
21 -- * Basic interface
25 -- * Basic interface
22 , cons
26 , cons
@@ -41,6 +45,7 @@ module Data.Text.Fusion.Common
41 -- $case
45 -- $case
42 , toCaseFold
46 , toCaseFold
43 , toLower
47 , toLower
48+ , toTitle
44 , toUpper
49 , toUpper
45
50
46 -- ** Justification
51 -- ** Justification
@@ -66,9 +71,6 @@ module Data.Text.Fusion.Common
66 -- ** Scans
71 -- ** Scans
67 , scanl
72 , scanl
68
73
69− -- ** Accumulating maps
70− -- , mapAccumL
71−
72 -- ** Generation and unfolding
74 -- ** Generation and unfolding
73 , replicateCharI
75 , replicateCharI
74 , replicateI
76 , replicateI
@@ -104,16 +106,21 @@ import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),
104 (&&), fromIntegral, otherwise)
106 (&&), fromIntegral, otherwise)
105import qualified Data.List as L
107import qualified Data.List as L
106import qualified Prelude as P
108import qualified Prelude as P
109+import Data.Bits (shiftL)
110+import Data.Char (isLetter)
107import Data.Int (Int64)
111import Data.Int (Int64)
108−import Data.Text.Fusion.Internal
112+import Data.Text.Internal.Fusion.Types
109−import Data.Text.Fusion.CaseMapping (foldMapping, lowerMapping, upperMapping)
113+import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping,
114+ upperMapping)
110−import Data.Text.Fusion.Size
115+import Data.Text.Internal.Fusion.Size
116+import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)
117+import GHC.Types (Char(..), Int(..))
111
118
112singleton :: Char -> Stream Char
119singleton :: Char -> Stream Char
113singleton c = Stream next False 1
120singleton c = Stream next False 1
114 where next False = Yield c True
121 where next False = Yield c True
115 next True = Done
122 next True = Done
116−{-# INLINE singleton #-}
123+{-# INLINE [0] singleton #-}
117
124
118streamList :: [a] -> Stream a
125streamList :: [a] -> Stream a
119{-# INLINE [0] streamList #-}
126{-# INLINE [0] streamList #-}
@@ -131,6 +138,35 @@ unstreamList (Stream next s0 _len) = unfold s0
131
138
132{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}
139{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}
133
140
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+
134-- ----------------------------------------------------------------------------
170-- ----------------------------------------------------------------------------
135-- * Basic stream functions
171-- * Basic stream functions
136
172
@@ -139,7 +175,7 @@ data C s = C0 !s
139
175
140-- | /O(n)/ Adds a character to the front of a Stream Char.
176-- | /O(n)/ Adds a character to the front of a Stream Char.
141cons :: Char -> Stream Char -> Stream Char
177cons :: 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)
143 where
179 where
144 next (C1 s) = Yield w (C0 s)
180 next (C1 s) = Yield w (C0 s)
145 next (C0 s) = case next0 s of
181 next (C0 s) = case next0 s of
@@ -148,6 +184,9 @@ cons w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
148 Yield x s' -> Yield x (C0 s')
184 Yield x s' -> Yield x (C0 s')
149{-# INLINE [0] cons #-}
185{-# INLINE [0] cons #-}
150
186
187+data Snoc a = N
188+ | J !a
189+
151-- | /O(n)/ Adds a character to the end of a stream.
190-- | /O(n)/ Adds a character to the end of a stream.
152snoc :: Stream Char -> Char -> Stream Char
191snoc :: Stream Char -> Char -> Stream Char
153snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)
192snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)
@@ -185,9 +224,13 @@ head (Stream next s0 _len) = loop_head s0
185 loop_head !s = case next s of
224 loop_head !s = case next s of
186 Yield x _ -> x
225 Yield x _ -> x
187 Skip s' -> loop_head s'
226 Skip s' -> loop_head s'
188− Done -> streamError "head" "Empty stream"
227+ Done -> head_empty
189{-# INLINE [0] head #-}
228{-# INLINE [0] head #-}
190
229
230+head_empty :: a
231+head_empty = streamError "head" "Empty stream"
232+{-# NOINLINE head_empty #-}
233+
191-- | /O(1)/ Returns the first character and remainder of a 'Stream
234-- | /O(1)/ Returns the first character and remainder of a 'Stream
192-- Char', or 'Nothing' if empty. Subject to array fusion.
235-- Char', or 'Nothing' if empty. Subject to array fusion.
193uncons :: Stream Char -> Maybe (Char, Stream Char)
236uncons :: Stream Char -> Maybe (Char, Stream Char)
@@ -272,12 +315,13 @@ lengthI (Stream next s0 _len) = loop_length 0 s0
272--
315--
273-- This function gives the same answer as comparing against the result
316-- This function gives the same answer as comparing against the result
274-- of 'lengthI', but can short circuit if the count of characters is
317-- of 'lengthI', but can short circuit if the count of characters is
318+-- greater than the number or if the stream can't possibly be as long
275−-- greater than the number, and hence be more efficient.
319+-- as the number supplied, and hence be more efficient.
276compareLengthI :: Integral a => Stream Char -> a -> Ordering
320compareLengthI :: Integral a => Stream Char -> a -> Ordering
277−compareLengthI (Stream next s0 len) n =
321+compareLengthI (Stream next s0 len) n =
278− case exactly len of
322+ case compareSize len (fromIntegral n) of
323+ Just o -> o
279 Nothing -> loop_cmp 0 s0
324 Nothing -> loop_cmp 0 s0
280− Just i -> compare (fromIntegral i) n
281 where
325 where
282 loop_cmp !z s = case next s of
326 loop_cmp !z s = case next s of
283 Done -> compare z n
327 Done -> compare z n
@@ -395,17 +439,54 @@ toLower :: Stream Char -> Stream Char
395toLower = caseConvert lowerMapping
439toLower = caseConvert lowerMapping
396{-# INLINE [0] toLower #-}
440{-# INLINE [0] toLower #-}
397
441
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+
398justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char
479justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char
399justifyLeftI k c (Stream next0 s0 len) =
480justifyLeftI 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)
401 where
482 where
402− next (s :*: S1 :*: n) =
483+ next (Just1 n s) =
403 case next0 s of
484 case next0 s of
404− Done -> next (s :*: S2 :*: n)
485+ Done -> next (Just2 n s)
405− Skip s' -> Skip (s' :*: S1 :*: n)
486+ Skip s' -> Skip (Just1 n s')
406− Yield x s' -> Yield x (s' :*: S1 :*: n+1)
487+ Yield x s' -> Yield x (Just1 (n+1) s')
407− next (s :*: S2 :*: n)
488+ next (Just2 n s)
408− | n < k = Yield c (s :*: S2 :*: n+1)
489+ | n < k = Yield c (Just2 (n+1) s)
409 | otherwise = Done
490 | otherwise = Done
410 {-# INLINE next #-}
491 {-# INLINE next #-}
411{-# INLINE [0] justifyLeftI #-}
492{-# INLINE [0] justifyLeftI #-}
@@ -512,7 +593,7 @@ concatMap f = foldr (append . f) empty
512{-# INLINE [0] concatMap #-}
593{-# INLINE [0] concatMap #-}
513
594
514-- | /O(n)/ any @p @xs determines if any character in the stream
595-- | /O(n)/ any @p @xs determines if any character in the stream
515−-- @xs@ satisifes the predicate @p@.
596+-- @xs@ satisfies the predicate @p@.
516any :: (Char -> Bool) -> Stream Char -> Bool
597any :: (Char -> Bool) -> Stream Char -> Bool
517any p (Stream next0 s0 _len) = loop_any s0
598any p (Stream next0 s0 _len) = loop_any s0
518 where
599 where
@@ -524,7 +605,7 @@ any p (Stream next0 s0 _len) = loop_any s0
524{-# INLINE [0] any #-}
605{-# INLINE [0] any #-}
525
606
526-- | /O(n)/ all @p @xs determines if all characters in the 'Text'
607-- | /O(n)/ all @p @xs determines if all characters in the 'Text'
527−-- @xs@ satisify the predicate @p@.
608+-- @xs@ satisfy the predicate @p@.
528all :: (Char -> Bool) -> Stream Char -> Bool
609all :: (Char -> Bool) -> Stream Char -> Bool
529all p (Stream next0 s0 _len) = loop_all s0
610all p (Stream next0 s0 _len) = loop_all s0
530 where
611 where
@@ -573,50 +654,27 @@ minimum (Stream next0 s0 _len) = loop0_minimum s0
573-- * Building streams
654-- * Building streams
574
655
575scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
656scanl :: (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
577 where
658 where
578 {-# INLINE next #-}
659 {-# INLINE next #-}
579− next (S1 :*: z :*: s) = Yield z (S2 :*: z :*: s)
660+ next (Scan1 z s) = Yield z (Scan2 z s)
580− next (S2 :*: z :*: s) = case next0 s of
661+ next (Scan2 z s) = case next0 s of
581− Yield x s' -> let !x' = f z x
662+ Yield x s' -> let !x' = f z x
582− in Yield x' (S2 :*: x' :*: s')
663+ in Yield x' (Scan2 x' s')
583− Skip s' -> Skip (S2 :*: z :*: s')
664+ Skip s' -> Skip (Scan2 z s')
584− Done -> Done
665+ Done -> Done
585{-# INLINE [0] scanl #-}
666{-# INLINE [0] scanl #-}
586
667
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−
610-- -----------------------------------------------------------------------------
668-- -----------------------------------------------------------------------------
611-- ** Generating and unfolding streams
669-- ** Generating and unfolding streams
612
670
613replicateCharI :: Integral a => a -> Char -> Stream Char
671replicateCharI :: Integral a => a -> Char -> Stream Char
614−replicateCharI n c
672+replicateCharI !n !c
615 | n < 0 = empty
673 | n < 0 = empty
616 | otherwise = Stream next 0 (fromIntegral n) -- HINT maybe too low
674 | otherwise = Stream next 0 (fromIntegral n) -- HINT maybe too low
617 where
675 where
618− next i | i >= n = Done
676+ next !i | i >= n = Done
619− | otherwise = Yield c (i + 1)
677+ | otherwise = Yield c (i + 1)
620{-# INLINE [0] replicateCharI #-}
678{-# INLINE [0] replicateCharI #-}
621
679
622data RI s = RI !s {-# UNPACK #-} !Int64
680data RI s = RI !s {-# UNPACK #-} !Int64
@@ -681,24 +739,27 @@ take n0 (Stream next0 s0 len) =
681 Yield x s' -> Yield x ((n-1) :*: s')
739 Yield x s' -> Yield x ((n-1) :*: s')
682{-# INLINE [0] take #-}
740{-# INLINE [0] take #-}
683
741
742+data Drop a s = NS !s
743+ | JS !a !s
744+
684-- | /O(n)/ drop n, applied to a stream, returns the suffix of the
745-- | /O(n)/ drop n, applied to a stream, returns the suffix of the
685-- stream after the first @n@ characters, or the empty stream if @n@
746-- stream after the first @n@ characters, or the empty stream if @n@
686-- is greater than the length of the stream.
747-- is greater than the length of the stream.
687drop :: Integral a => a -> Stream Char -> Stream Char
748drop :: Integral a => a -> Stream Char -> Stream Char
688drop n0 (Stream next0 s0 len) =
749drop 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))
690 where
751 where
691 {-# INLINE next #-}
752 {-# INLINE next #-}
692− next (J n :*: s)
753+ next (JS n s)
693− | n <= 0 = Skip (N :*: s)
754+ | n <= 0 = Skip (NS s)
694 | otherwise = case next0 s of
755 | otherwise = case next0 s of
695 Done -> Done
756 Done -> Done
696− Skip s' -> Skip (J n :*: s')
757+ Skip s' -> Skip (JS n s')
697− Yield _ s' -> Skip (J (n-1) :*: s')
758+ Yield _ s' -> Skip (JS (n-1) s')
698− next (N :*: s) = case next0 s of
759+ next (NS s) = case next0 s of
699 Done -> Done
760 Done -> Done
700− Skip s' -> Skip (N :*: s')
761+ Skip s' -> Skip (NS s')
701− Yield x s' -> Yield x (N :*: s')
762+ Yield x s' -> Yield x (NS s')
702{-# INLINE [0] drop #-}
763{-# INLINE [0] drop #-}
703
764
704-- | takeWhile, applied to a predicate @p@ and a stream, returns the
765-- | 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
716
777
717-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
778-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
718dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
779dropWhile :: (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
720 where
781 where
721 {-# INLINE next #-}
782 {-# INLINE next #-}
722− next (S1 :*: s) = case next0 s of
783+ next (L s) = case next0 s of
723 Done -> Done
784 Done -> Done
724− Skip s' -> Skip (S1 :*: s')
785+ Skip s' -> Skip (L s')
725− Yield x s' | p x -> Skip (S1 :*: s')
786+ Yield x s' | p x -> Skip (L s')
726− | otherwise -> Yield x (S2 :*: s')
787+ | otherwise -> Yield x (R s')
727− next (S2 :*: s) = case next0 s of
788+ next (R s) = case next0 s of
728 Done -> Done
789 Done -> Done
729− Skip s' -> Skip (S2 :*: s')
790+ Skip s' -> Skip (R s')
730− Yield x s' -> Yield x (S2 :*: s')
791+ Yield x s' -> Yield x (R s')
731{-# INLINE [0] dropWhile #-}
792{-# INLINE [0] dropWhile #-}
732
793
733-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns
794-- | /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)
743 loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
804 loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
744 loop (next1 s1') (next2 s2')
805 loop (next1 s1') (next2 s2')
745{-# INLINE [0] isPrefixOf #-}
806{-# INLINE [0] isPrefixOf #-}
746−{-# SPECIALISE isPrefixOf :: Stream Char -> Stream Char -> Bool #-}
747
807
748-- ----------------------------------------------------------------------------
808-- ----------------------------------------------------------------------------
749-- * Searching
809-- * Searching
@@ -835,21 +895,25 @@ findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0
835-------------------------------------------------------------------------------
895-------------------------------------------------------------------------------
836-- * Zipping
896-- * Zipping
837
897
898+-- | Strict triple.
899+data Zip a b m = Z1 !a !b
900+ | Z2 !a !b !m
901+
838-- | zipWith generalises 'zip' by zipping with the function given as
902-- | zipWith generalises 'zip' by zipping with the function given as
839-- the first argument, instead of a tupling function.
903-- the first argument, instead of a tupling function.
840zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b
904zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b
841zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) =
905zipWith 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)
843 where
907 where
844− next (sa :*: sb :*: N) = case next0 sa of
908+ next (Z1 sa sb) = case next0 sa of
845− Done -> Done
909+ Done -> Done
846− Skip sa' -> Skip (sa' :*: sb :*: N)
910+ Skip sa' -> Skip (Z1 sa' sb)
847− Yield a sa' -> Skip (sa' :*: sb :*: J a)
911+ Yield a sa' -> Skip (Z2 sa' sb a)
848−
912+
849− next (sa' :*: sb :*: J a) = case next1 sb of
913+ next (Z2 sa' sb a) = case next1 sb of
850− Done -> Done
914+ Done -> Done
851− Skip sb' -> Skip (sa' :*: sb' :*: J a)
915+ Skip sb' -> Skip (Z2 sa' sb' a)
852− Yield b sb' -> Yield (f a b) (sa' :*: sb' :*: N)
916+ Yield b sb' -> Yield (f a b) (Z1 sa' sb')
853{-# INLINE [0] zipWith #-}
917{-# INLINE [0] zipWith #-}
854
918
855-- | /O(n)/ The 'countCharI' function returns the number of times the
919-- | /O(n)/ The 'countCharI' function returns the number of times the
@@ -865,7 +929,7 @@ countCharI a (Stream next s0 _len) = loop 0 s0
865{-# INLINE [0] countCharI #-}
929{-# INLINE [0] countCharI #-}
866
930
867streamError :: String -> String -> a
931streamError :: 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
869
933
870emptyError :: String -> a
934emptyError :: String -> a
871emptyError func = internalError func "Empty input"
935emptyError 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+25−24
@@ -1,53 +1,56 @@
1{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
1{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
2-- |
2-- |
3−-- Module : Data.Text.Fusion.Internal
3+-- Module : Data.Text.Internal.Fusion.Types
4-- Copyright : (c) Tom Harper 2008-2009,
4-- Copyright : (c) Tom Harper 2008-2009,
5-- (c) Bryan O'Sullivan 2009,
5-- (c) Bryan O'Sullivan 2009,
6−-- (c) Duncan Coutts 2009
6+-- (c) Duncan Coutts 2009,
7+-- (c) Jasper Van der Jeugt 2011
7--
8--
8-- License : BSD-style
9-- License : BSD-style
9−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10+-- Maintainer : bos@serpentine.com
10−-- duncan@haskell.org
11-- Stability : experimental
11-- Stability : experimental
12-- Portability : GHC
12-- Portability : GHC
13--
13--
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+--
14-- Core stream fusion functionality for text.
18-- Core stream fusion functionality for text.
15
19
16−module Data.Text.Fusion.Internal
20+module Data.Text.Internal.Fusion.Types
17 (
21 (
18 CC(..)
22 CC(..)
19− , M(..)
20− , M8
21 , PairS(..)
23 , PairS(..)
22− , S(..)
24+ , Scan(..)
25+ , RS(..)
23 , Step(..)
26 , Step(..)
24 , Stream(..)
27 , Stream(..)
25− , Switch(..)
26 , empty
28 , empty
27 ) where
29 ) where
28
30
29−import Data.Text.Fusion.Size
31+import Data.Text.Internal.Fusion.Size
30import Data.Word (Word8)
32import Data.Word (Word8)
31
33
32-- | Specialised tuple for case conversion.
34-- | Specialised tuple for case conversion.
33data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
35data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
34
36
35−-- | Specialised, strict Maybe-like type.
36−data M a = N
37− | J !a
38−
39−type M8 = M Word8
40−
41−-- Restreaming state.
37+-- | Restreaming state.
38+data RS s
39+ = RS0 !s
40+ | RS1 !s {-# UNPACK #-} !Word8
41+ | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
42−data S s = S !s {-# UNPACK #-} !M8 {-# UNPACK #-} !M8 {-# UNPACK #-} !M8
42+ | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
43
43
44−infixl 2 :*:
44+-- | Strict pair.
45data PairS a b = !a :*: !b
45data PairS a b = !a :*: !b
46 -- deriving (Eq, Ord, Show)
46 -- deriving (Eq, Ord, Show)
47+infixl 2 :*:
47
48
48−-- | Allow a function over a stream to switch between two states.
49+-- | An intermediate result in a scan.
49−data Switch = S1 | S2
50+data Scan s = Scan1 {-# UNPACK #-} !Char !s
51+ | Scan2 {-# UNPACK #-} !Char !s
50
52
53+-- | Intermediate result in a processing pipeline.
51data Step s a = Done
54data Step s a = Done
52 | Skip !s
55 | Skip !s
53 | Yield !a !s
56 | Yield !a !s
@@ -81,7 +84,7 @@ data Stream a =
81 forall s. Stream
84 forall s. Stream
82 (s -> Step s a) -- stepper function
85 (s -> Step s a) -- stepper function
83 !s -- current state
86 !s -- current state
84− {-# UNPACK #-} !Size -- size hint
87+ !Size -- size hint
85
88
86-- | /O(n)/ Determines if two streams are equal.
89-- | /O(n)/ Determines if two streams are equal.
87eq :: (Eq a) => Stream a -> Stream a -> Bool
90eq :: (Eq a) => Stream a -> Stream a -> Bool
@@ -96,7 +99,6 @@ eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
96 loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
99 loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
97 loop (next1 s1') (next2 s2')
100 loop (next1 s1') (next2 s2')
98{-# INLINE [0] eq #-}
101{-# INLINE [0] eq #-}
99−{-# SPECIALISE eq :: Stream Char -> Stream Char -> Bool #-}
100
102
101cmp :: (Ord a) => Stream a -> Stream a -> Ordering
103cmp :: (Ord a) => Stream a -> Stream a -> Ordering
102cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
104cmp (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)
112 EQ -> loop (next1 s1') (next2 s2')
114 EQ -> loop (next1 s1') (next2 s2')
113 other -> other
115 other -> other
114{-# INLINE [0] cmp #-}
116{-# INLINE [0] cmp #-}
115−{-# SPECIALISE cmp :: Stream Char -> Stream Char -> Ordering #-}
116
117
117-- | The empty stream.
118-- | The empty stream.
118empty :: Stream a
119empty :: Stream a
Data/Text/IO/Internal.hs → Data/Text/Internal/IO.hsrenamed+13−12
@@ -1,6 +1,6 @@
1{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
1{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
2-- |
2-- |
3−-- Module : Data.Text.IO.Internal
3+-- Module : Data.Text.Internal.IO
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
5-- (c) 2009 Simon Marlow
5-- (c) 2009 Simon Marlow
6-- License : BSD-style
6-- License : BSD-style
@@ -8,22 +8,24 @@
8-- Stability : experimental
8-- Stability : experimental
9-- Portability : GHC
9-- Portability : GHC
10--
10--
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+--
11-- Low-level support for text I\/O.
15-- Low-level support for text I\/O.
12
16
13−module Data.Text.IO.Internal
17+module Data.Text.Internal.IO
14 (
18 (
15−#if __GLASGOW_HASKELL__ >= 612
16 hGetLineWith
19 hGetLineWith
17 , readChunk
20 , readChunk
18−#endif
19 ) where
21 ) where
20
22
21−#if __GLASGOW_HASKELL__ >= 612
23+import qualified Control.Exception as E
22import Data.IORef (readIORef, writeIORef)
24import Data.IORef (readIORef, writeIORef)
23import Data.Text (Text)
25import Data.Text (Text)
24−import Data.Text.Fusion (unstream)
26+import Data.Text.Internal.Fusion (unstream)
25−import Data.Text.Fusion.Internal (Step(..), Stream(..))
27+import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
26−import Data.Text.Fusion.Size (exactSize, maxSize)
28+import Data.Text.Internal.Fusion.Size (exactSize, maxSize)
27import Data.Text.Unsafe (inlinePerformIO)
29import Data.Text.Unsafe (inlinePerformIO)
28import Foreign.Storable (peekElemOff)
30import Foreign.Storable (peekElemOff)
29import GHC.IO.Buffer (Buffer(..), CharBuffer, RawCharBuffer, bufferAdjustL,
31import GHC.IO.Buffer (Buffer(..), CharBuffer, RawCharBuffer, bufferAdjustL,
@@ -82,9 +84,9 @@ hGetLineLoop hh@Handle__{..} = go where
82-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
84-- This function is lifted almost verbatim from GHC.IO.Handle.Text.
83maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
85maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
84maybeFillReadBuffer handle_ buf
86maybeFillReadBuffer handle_ buf
85− = catch (Just `fmap` getSomeCharacters handle_ buf) $ \e ->
87+ = E.catch (Just `fmap` getSomeCharacters handle_ buf) $ \e ->
86− if isEOFError e
88+ if isEOFError e
87− then return Nothing
89+ then return Nothing
88 else ioError e
90 else ioError e
89
91
90unpack :: RawCharBuffer -> Int -> Int -> IO Text
92unpack :: RawCharBuffer -> Int -> Int -> IO Text
@@ -162,4 +164,3 @@ readChunk hh@Handle__{..} buf = do
162
164
163sizeError :: String -> a
165sizeError :: String -> a
164sizeError loc = error $ "Data.Text.IO." ++ loc ++ ": bad internal buffer size"
166sizeError 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 @@
5-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
5-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
6--
6--
7-- License : BSD-style
7-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
9-- Stability : experimental
11-- Portability : portable
10-- Portability : portable
12--
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+--
13-- Fusible 'Stream'-oriented functions for converting between lazy
16-- Fusible 'Stream'-oriented functions for converting between lazy
14-- 'Text' and several common encodings.
17-- 'Text' and several common encodings.
15
18
16−module Data.Text.Lazy.Encoding.Fusion
19+module Data.Text.Internal.Lazy.Encoding.Fusion
17 (
20 (
18 -- * Streaming
21 -- * Streaming
19 -- streamASCII
22 -- streamASCII
@@ -26,23 +29,23 @@ module Data.Text.Lazy.Encoding.Fusion
26 -- * Unstreaming
29 -- * Unstreaming
27 , unstream
30 , unstream
28
31
29− , module Data.Text.Encoding.Fusion.Common
32+ , module Data.Text.Internal.Encoding.Fusion.Common
30 ) where
33 ) where
31
34
32import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize)
35import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize)
33import qualified Data.ByteString as B
36import qualified Data.ByteString as B
34import qualified Data.ByteString.Unsafe as B
37import qualified Data.ByteString.Unsafe as B
35−import Data.Text.Encoding.Fusion.Common
38+import Data.Text.Internal.Encoding.Fusion.Common
36import Data.Text.Encoding.Error
39import Data.Text.Encoding.Error
37−import Data.Text.Fusion (Step(..), Stream(..))
40+import Data.Text.Internal.Fusion (Step(..), Stream(..))
38−import Data.Text.Fusion.Size
41+import Data.Text.Internal.Fusion.Size
39−import Data.Text.UnsafeChar (unsafeChr, unsafeChr8, unsafeChr32)
42+import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
40−import Data.Text.UnsafeShift (shiftL)
43+import Data.Text.Internal.Unsafe.Shift (shiftL)
41import Data.Word (Word8, Word16, Word32)
44import Data.Word (Word8, Word16, Word32)
42−import qualified Data.Text.Encoding.Utf8 as U8
45+import qualified Data.Text.Internal.Encoding.Utf8 as U8
43−import qualified Data.Text.Encoding.Utf16 as U16
46+import qualified Data.Text.Internal.Encoding.Utf16 as U16
44−import qualified Data.Text.Encoding.Utf32 as U32
47+import qualified Data.Text.Internal.Encoding.Utf32 as U32
45−import System.IO.Unsafe (unsafePerformIO)
48+import Data.Text.Unsafe (unsafeDupablePerformIO)
46import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
49import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
47import Foreign.Storable (pokeByteOff)
50import Foreign.Storable (pokeByteOff)
48import Data.ByteString.Internal (mallocByteString, memcpy)
51import Data.ByteString.Internal (mallocByteString, memcpy)
@@ -272,7 +275,7 @@ streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
272-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.
275-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.
273unstreamChunks :: Int -> Stream Word8 -> ByteString
276unstreamChunks :: Int -> Stream Word8 -> ByteString
274unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
277unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
275− where chunk s1 len1 = unsafePerformIO $ do
278+ where chunk s1 len1 = unsafeDupablePerformIO $ do
276 let len = max 4 (min len1 chunkSize)
279 let len = max 4 (min len1 chunkSize)
277 mallocByteString len >>= loop len 0 s1
280 mallocByteString len >>= loop len 0 s1
278 where
281 where
Data/Text/Lazy/Fusion.hs → Data/Text/Internal/Lazy/Fusion.hsrenamed+38−31
@@ -4,14 +4,17 @@
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
5--
5--
6-- License : BSD-style
6-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
7+-- Maintainer : bos@serpentine.com
8−-- duncan@haskell.org
9-- Stability : experimental
8-- Stability : experimental
10-- Portability : GHC
9-- Portability : GHC
11--
10--
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+--
12-- Core stream fusion functionality for text.
15-- Core stream fusion functionality for text.
13
16
14−module Data.Text.Lazy.Fusion
17+module Data.Text.Internal.Lazy.Fusion
15 (
18 (
16 stream
19 stream
17 , unstream
20 , unstream
@@ -23,14 +26,15 @@ module Data.Text.Lazy.Fusion
23 ) where
26 ) where
24
27
25import Prelude hiding (length)
28import Prelude hiding (length)
26−import qualified Data.Text.Fusion.Common as S
29+import qualified Data.Text.Internal.Fusion.Common as S
30+import Control.Monad.ST (runST)
27−import Data.Text.Fusion.Internal
31+import Data.Text.Internal.Fusion.Types
28−import Data.Text.Fusion.Size (isEmpty, unknownSize)
32+import Data.Text.Internal.Fusion.Size (isEmpty, unknownSize)
29−import Data.Text.Lazy.Internal
33+import Data.Text.Internal.Lazy
30import qualified Data.Text.Internal as I
34import qualified Data.Text.Internal as I
31import qualified Data.Text.Array as A
35import qualified Data.Text.Array as A
32−import Data.Text.UnsafeChar (unsafeWrite)
36+import Data.Text.Internal.Unsafe.Char (unsafeWrite)
33−import Data.Text.UnsafeShift (shiftL)
37+import Data.Text.Internal.Unsafe.Shift (shiftL)
34import Data.Text.Unsafe (Iter(..), iter)
38import Data.Text.Unsafe (Iter(..), iter)
35import Data.Int (Int64)
39import Data.Int (Int64)
36
40
@@ -50,33 +54,36 @@ stream text = Stream next (text :*: 0) unknownSize
50-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given
54-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given
51-- chunk size.
55-- chunk size.
52unstreamChunks :: Int -> Stream Char -> Text
56unstreamChunks :: Int -> Stream Char -> Text
53−unstreamChunks chunkSize (Stream next s0 len0)
57+unstreamChunks !chunkSize (Stream next s0 len0)
54 | isEmpty len0 = Empty
58 | isEmpty len0 = Empty
55 | otherwise = outer s0
59 | otherwise = outer s0
56 where
60 where
57− outer s = {-# SCC "unstreamChunks/outer" #-}
61+ outer so = {-# SCC "unstreamChunks/outer" #-}
58− case next s of
62+ case next so of
59 Done -> Empty
63 Done -> Empty
60 Skip s' -> outer s'
64 Skip s' -> outer s'
61− Yield x s' -> I.Text arr 0 len `chunk` outer s''
65+ Yield x s' -> runST $ do
62− where (arr,(s'',len)) = A.run2 fill
63− fill = do a <- A.new unknownLength
66+ a <- A.new unknownLength
64− unsafeWrite a 0 x >>= inner a unknownLength s'
67+ unsafeWrite a 0 x >>= inner a unknownLength s'
65− unknownLength = 4
68+ where unknownLength = 4
69+ where
66− inner marr len s !i
70+ inner marr !len s !i
67− | i + 1 >= chunkSize = return (marr, (s,i))
71+ | i + 1 >= chunkSize = finish marr i s
68− | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
72+ | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
69− let newLen = min (len `shiftL` 1) chunkSize
73+ let newLen = min (len `shiftL` 1) chunkSize
70− marr' <- A.new newLen
74+ marr' <- A.new newLen
71− A.copyM marr' 0 marr 0 len
75+ A.copyM marr' 0 marr 0 len
72− inner marr' newLen s i
76+ inner marr' newLen s i
73− | otherwise =
77+ | otherwise =
74− {-# SCC "unstreamChunks/inner" #-}
78+ {-# SCC "unstreamChunks/inner" #-}
75− case next s of
79+ case next s of
76− Done -> return (marr,(s,i))
80+ Done -> finish marr i s
77− Skip s' -> inner marr len s' i
81+ Skip s' -> inner marr len s' i
78− Yield x s' -> do d <- unsafeWrite marr i x
82+ Yield x s' -> do d <- unsafeWrite marr i x
79− inner marr len s' (i+d)
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')
80{-# INLINE [0] unstreamChunks #-}
87{-# INLINE [0] unstreamChunks #-}
81
88
82-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using
89-- | /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 @@
5-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
5-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
6--
6--
7-- License : BSD-style
7-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
9-- Stability : experimental
11-- Portability : GHC
10-- Portability : GHC
12--
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+--
13-- Fast substring search for lazy 'Text', based on work by Boyer,
16-- Fast substring search for lazy 'Text', based on work by Boyer,
14-- Moore, Horspool, Sunday, and Lundh. Adapted from the strict
17-- Moore, Horspool, Sunday, and Lundh. Adapted from the strict
15-- implementation.
18-- implementation.
16
19
17−module Data.Text.Lazy.Search
20+module Data.Text.Internal.Lazy.Search
18 (
21 (
19 indices
22 indices
20 ) where
23 ) where
@@ -23,10 +26,10 @@ import qualified Data.Text.Array as A
23import Data.Int (Int64)
26import Data.Int (Int64)
24import Data.Word (Word16, Word64)
27import Data.Word (Word16, Word64)
25import qualified Data.Text.Internal as T
28import qualified Data.Text.Internal as T
26−import Data.Text.Fusion.Internal (PairS(..))
29+import Data.Text.Internal.Fusion.Types (PairS(..))
27−import Data.Text.Lazy.Internal (Text(..), foldlChunks)
30+import Data.Text.Internal.Lazy (Text(..), foldlChunks)
28import Data.Bits ((.|.), (.&.))
31import Data.Bits ((.|.), (.&.))
29−import Data.Text.UnsafeShift (shiftL)
32+import Data.Text.Internal.Unsafe.Shift (shiftL)
30
33
31-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
34-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
32-- @needle@ within @haystack@.
35-- @needle@ within @haystack@.
@@ -77,10 +80,11 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
77 go !(g::Int64) !i !msk !skp
80 go !(g::Int64) !i !msk !skp
78 | i >= xlast = case xs of
81 | i >= xlast = case xs of
79 Empty -> (msk .|. swizzle z) :*: skp
82 Empty -> (msk .|. swizzle z) :*: skp
80− Chunk y ys -> buildTable y ys g 0 msk skp
83+ Chunk y ys -> buildTable y ys g 0 msk' skp'
81− | otherwise = go (g+1) (i+1) (msk .|. swizzle c) skp'
84+ | otherwise = go (g+1) (i+1) msk' skp'
82 where c = A.unsafeIndex xarr (xoff+i)
85 where c = A.unsafeIndex xarr (xoff+i)
86+ msk' = msk .|. swizzle c
83− skp' | c == z = nlen - fromIntegral g - 2
87+ skp' | c == z = nlen - g - 2
84 | otherwise = skp
88 | otherwise = skp
85 xlast = xlen - 1
89 xlast = xlen - 1
86 -- | Check whether an attempt to index into the haystack at the
90 -- | 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 @@
1{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
1{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.Search
4+-- Module : Data.Text.Internal.Search
5-- Copyright : (c) Bryan O'Sullivan 2009
5-- Copyright : (c) Bryan O'Sullivan 2009
6--
6--
7-- License : BSD-style
7-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
9-- Stability : experimental
11-- Portability : GHC
10-- Portability : GHC
12--
11--
@@ -14,7 +13,7 @@
14-- Horspool, Sunday, and Lundh.
13-- Horspool, Sunday, and Lundh.
15--
14--
16-- References:
15-- References:
17−--
16+--
18-- * R. S. Boyer, J. S. Moore: A Fast String Searching Algorithm.
17-- * R. S. Boyer, J. S. Moore: A Fast String Searching Algorithm.
19-- Communications of the ACM, 20, 10, 762-772 (1977)
18-- Communications of the ACM, 20, 10, 762-772 (1977)
20--
19--
@@ -27,7 +26,7 @@
27-- * F. Lundh: The Fast Search Algorithm.
26-- * F. Lundh: The Fast Search Algorithm.
28-- <http://effbot.org/zone/stringlib.htm> (2006)
27-- <http://effbot.org/zone/stringlib.htm> (2006)
29
28
30−module Data.Text.Search
29+module Data.Text.Internal.Search
31 (
30 (
32 indices
31 indices
33 ) where
32 ) where
@@ -35,13 +34,15 @@ module Data.Text.Search
35import qualified Data.Text.Array as A
34import qualified Data.Text.Array as A
36import Data.Word (Word64)
35import Data.Word (Word64)
37import Data.Text.Internal (Text(..))
36import Data.Text.Internal (Text(..))
38−import Data.Text.Fusion.Internal (PairS(..))
39import Data.Bits ((.|.), (.&.))
37import Data.Bits ((.|.), (.&.))
40−import Data.Text.UnsafeShift (shiftL)
38+import Data.Text.Internal.Unsafe.Shift (shiftL)
39+
40+data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
41
41
42-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
42-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
43-- @needle@ within @haystack@. The offsets returned represent
43-- @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.
45--
46--
46-- In (unlikely) bad cases, this algorithm's complexity degrades
47-- In (unlikely) bad cases, this algorithm's complexity degrades
47-- towards /O(n*m)/.
48-- towards /O(n*m)/.
@@ -60,9 +61,8 @@ indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
60 hindex k = A.unsafeIndex harr (hoff+k)
61 hindex k = A.unsafeIndex harr (hoff+k)
61 hindex' k | k == hlen = 0
62 hindex' k | k == hlen = 0
62 | otherwise = A.unsafeIndex harr (hoff+k)
63 | otherwise = A.unsafeIndex harr (hoff+k)
63− (mask :: Word64) :*: skip = buildTable 0 0 (nlen-2)
64 buildTable !i !msk !skp
64 buildTable !i !msk !skp
65− | i >= nlast = (msk .|. swizzle z) :*: skp
65+ | i >= nlast = (msk .|. swizzle z) :* skp
66 | otherwise = buildTable (i+1) (msk .|. swizzle c) skp'
66 | otherwise = buildTable (i+1) (msk .|. swizzle c) skp'
67 where c = nindex i
67 where c = nindex i
68 skp' | c == z = nlen - i - 2
68 skp' | c == z = nlen - i - 2
@@ -80,7 +80,8 @@ indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
80 delta | nextInPattern = nlen + 1
80 delta | nextInPattern = nlen + 1
81 | c == z = skip + 1
81 | c == z = skip + 1
82 | otherwise = 1
82 | 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)
84 scanOne c = loop 0
85 scanOne c = loop 0
85 where loop !i | i >= hlen = []
86 where loop !i | i >= hlen = []
86 | hindex i == c = i : loop (i+1)
87 | 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 @@
1{-# LANGUAGE CPP, MagicHash #-}
1{-# LANGUAGE CPP, MagicHash #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.UnsafeChar
4+-- Module : Data.Text.Internal.Unsafe.Char
5-- Copyright : (c) 2008, 2009 Tom Harper,
5-- Copyright : (c) 2008, 2009 Tom Harper,
6-- (c) 2009, 2010 Bryan O'Sullivan,
6-- (c) 2009, 2010 Bryan O'Sullivan,
7-- (c) 2009 Duncan Coutts
7-- (c) 2009 Duncan Coutts
8--
8--
9-- License : BSD-style
9-- License : BSD-style
10−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10+-- Maintainer : bos@serpentine.com
11−-- duncan@haskell.org
12-- Stability : experimental
11-- Stability : experimental
13-- Portability : GHC
12-- Portability : GHC
14--
13--
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+--
15-- Fast character manipulation functions.
18-- Fast character manipulation functions.
16−module Data.Text.UnsafeChar
19+module Data.Text.Internal.Unsafe.Char
17 (
20 (
18 ord
21 ord
19 , unsafeChr
22 , unsafeChr
@@ -28,7 +31,7 @@ import Control.Exception (assert)
28#endif
31#endif
29import Control.Monad.ST (ST)
32import Control.Monad.ST (ST)
30import Data.Bits ((.&.))
33import Data.Bits ((.&.))
31−import Data.Text.UnsafeShift (shiftR)
34+import Data.Text.Internal.Unsafe.Shift (shiftR)
32import GHC.Exts (Char(..), Int(..), chr#, ord#, word2Int#)
35import GHC.Exts (Char(..), Int(..), chr#, ord#, word2Int#)
33import GHC.Word (Word8(..), Word16(..), Word32(..))
36import GHC.Word (Word8(..), Word16(..), Word32(..))
34import qualified Data.Text.Array as A
37import qualified Data.Text.Array as A
Data/Text/UnsafeShift.hs → Data/Text/Internal/Unsafe/Shift.hsrenamed+7−4
@@ -1,18 +1,21 @@
1{-# LANGUAGE MagicHash #-}
1{-# LANGUAGE MagicHash #-}
2
2
3-- |
3-- |
4−-- Module : Data.Text.UnsafeShift
4+-- Module : Data.Text.Internal.Unsafe.Shift
5-- Copyright : (c) Bryan O'Sullivan 2009
5-- Copyright : (c) Bryan O'Sullivan 2009
6--
6--
7-- License : BSD-style
7-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
8+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
9-- Stability : experimental
11-- Portability : GHC
10-- Portability : GHC
12--
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+--
13-- Fast, unchecked bit shifting functions.
16-- Fast, unchecked bit shifting functions.
14
17
15−module Data.Text.UnsafeShift
18+module Data.Text.Internal.Unsafe.Shift
16 (
19 (
17 UnsafeShift(..)
20 UnsafeShift(..)
18 ) where
21 ) where
Data/Text/Lazy.hs+321−75
@@ -1,12 +1,18 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# 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+
3-- |
10-- |
4-- Module : Data.Text.Lazy
11-- Module : Data.Text.Lazy
5−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
12+-- Copyright : (c) 2009, 2010, 2012 Bryan O'Sullivan
6--
13--
7-- License : BSD-style
14-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
15+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
16-- Stability : experimental
11-- Portability : GHC
17-- Portability : GHC
12--
18--
@@ -83,6 +89,7 @@ module Data.Text.Lazy
83 , toCaseFold
89 , toCaseFold
84 , toLower
90 , toLower
85 , toUpper
91 , toUpper
92+ , toTitle
86
93
87 -- ** Justification
94 -- ** Justification
88 , justifyLeft
95 , justifyLeft
@@ -118,7 +125,10 @@ module Data.Text.Lazy
118 , mapAccumR
125 , mapAccumR
119
126
120 -- ** Generation and unfolding
127 -- ** Generation and unfolding
128+ , repeat
121 , replicate
129 , replicate
130+ , cycle
131+ , iterate
122 , unfoldr
132 , unfoldr
123 , unfoldrN
133 , unfoldrN
124
134
@@ -126,8 +136,11 @@ module Data.Text.Lazy
126
136
127 -- ** Breaking strings
137 -- ** Breaking strings
128 , take
138 , take
139+ , takeEnd
129 , drop
140 , drop
141+ , dropEnd
130 , takeWhile
142 , takeWhile
143+ , takeWhileEnd
131 , dropWhile
144 , dropWhile
132 , dropWhileEnd
145 , dropWhileEnd
133 , dropAround
146 , dropAround
@@ -165,6 +178,7 @@ module Data.Text.Lazy
165 -- ** View patterns
178 -- ** View patterns
166 , stripPrefix
179 , stripPrefix
167 , stripSuffix
180 , stripSuffix
181+ , commonPrefixes
168
182
169 -- * Searching
183 -- * Searching
170 , filter
184 , filter
@@ -173,7 +187,7 @@ module Data.Text.Lazy
173 , partition
187 , partition
174
188
175 -- , findSubstring
189 -- , findSubstring
176−
190+
177 -- * Indexing
191 -- * Indexing
178 , index
192 , index
179 , count
193 , count
@@ -189,7 +203,7 @@ module Data.Text.Lazy
189import Prelude (Char, Bool(..), Maybe(..), String,
203import Prelude (Char, Bool(..), Maybe(..), String,
190 Eq(..), Ord(..), Ordering(..), Read(..), Show(..),
204 Eq(..), Ord(..), Ordering(..), Read(..), Show(..),
191 (&&), (||), (+), (-), (.), ($), (++),
205 (&&), (||), (+), (-), (.), ($), (++),
192− div, error, flip, fromIntegral, not, otherwise)
206+ error, flip, fmap, fromIntegral, not, otherwise, quot)
193import qualified Prelude as P
207import qualified Prelude as P
194#if defined(HAVE_DEEPSEQ)
208#if defined(HAVE_DEEPSEQ)
195import Control.DeepSeq (NFData(..))
209import Control.DeepSeq (NFData(..))
@@ -197,25 +211,39 @@ import Control.DeepSeq (NFData(..))
197import Data.Int (Int64)
211import Data.Int (Int64)
198import qualified Data.List as L
212import qualified Data.List as L
199import Data.Char (isSpace)
213import Data.Char (isSpace)
200−import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf))
214+import Data.Data (Data(gfoldl, toConstr, gunfold, dataTypeOf), constrIndex,
201−#if __GLASGOW_HASKELL__ >= 612
215+ Constr, mkConstr, DataType, mkDataType, Fixity(Prefix))
202−import Data.Data (mkNoRepType)
216+import Data.Binary (Binary(get, put))
203−#else
204−import Data.Data (mkNorepType)
205−#endif
206import Data.Monoid (Monoid(..))
217import Data.Monoid (Monoid(..))
218+#if MIN_VERSION_base(4,9,0)
219+import Data.Semigroup (Semigroup(..))
220+#endif
207import Data.String (IsString(..))
221import Data.String (IsString(..))
208import qualified Data.Text as T
222import qualified Data.Text as T
209import qualified Data.Text.Internal as T
223import qualified Data.Text.Internal as T
210−import qualified Data.Text.Fusion.Common as S
224+import qualified Data.Text.Internal.Fusion.Common as S
211import qualified Data.Text.Unsafe as T
225import qualified Data.Text.Unsafe as T
212−import qualified Data.Text.Lazy.Fusion as S
226+import qualified Data.Text.Internal.Lazy.Fusion as S
213−import Data.Text.Fusion.Internal (PairS(..))
227+import Data.Text.Internal.Fusion.Types (PairS(..))
214−import Data.Text.Lazy.Fusion (stream, unstream)
228+import Data.Text.Internal.Lazy.Fusion (stream, unstream)
215−import Data.Text.Lazy.Internal (Text(..), chunk, empty, foldlChunks, foldrChunks)
229+import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldlChunks,
230+ foldrChunks, smallChunkSize)
216−import Data.Text.Internal (firstf, safe, textP)
231+import Data.Text.Internal (firstf, safe, text)
232+import Data.Text.Lazy.Encoding (decodeUtf8', encodeUtf8)
217−import qualified Data.Text.Util as U
233+import qualified Data.Text.Internal.Functions as F
218−import Data.Text.Lazy.Search (indices)
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
219
247
220-- $fusion
248-- $fusion
221--
249--
@@ -313,30 +341,72 @@ instance Show Text where
313instance Read Text where
341instance Read Text where
314 readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
342 readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
315
343
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+
316instance Monoid Text where
352instance Monoid Text where
317 mempty = empty
353 mempty = empty
354+#if MIN_VERSION_base(4,9,0)
355+ mappend = (<>) -- future-proof definition
356+#else
318 mappend = append
357 mappend = append
358+#endif
319 mconcat = concat
359 mconcat = concat
320
360
321instance IsString Text where
361instance IsString Text where
322 fromString = pack
362 fromString = pack
323
363
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+
324#if defined(HAVE_DEEPSEQ)
371#if defined(HAVE_DEEPSEQ)
325instance NFData Text where
372instance NFData Text where
326 rnf Empty = ()
373 rnf Empty = ()
327 rnf (Chunk _ ts) = rnf ts
374 rnf (Chunk _ ts) = rnf ts
328#endif
375#endif
329
376
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'
330instance Data Text where
390instance Data Text where
331 gfoldl f z txt = z pack `f` (unpack txt)
391 gfoldl f z txt = z pack `f` (unpack txt)
332− toConstr _ = error "Data.Text.Lazy.Text.toConstr"
392+ toConstr _ = packConstr
393+ gunfold k z c = case constrIndex c of
394+ 1 -> k (z pack)
333− gunfold _ _ = error "Data.Text.Lazy.Text.gunfold"
395+ _ -> error "Data.Text.Lazy.Text.gunfold"
334−#if __GLASGOW_HASKELL__ >= 612
396+ dataTypeOf _ = textDataType
335− dataTypeOf _ = mkNoRepType "Data.Text.Lazy.Text"
397+
336−#else
398+#if MIN_VERSION_base(4,7,0)
337− dataTypeOf _ = mkNorepType "Data.Text.Lazy.Text"
399+-- | Only defined for @base-4.7.0.0@ and later
400+instance PrintfArg Text where
401+ formatArg txt = formatString $ unpack txt
338#endif
402#endif
339
403
404+packConstr :: Constr
405+packConstr = mkConstr textDataType "pack" [] Prefix
406+
407+textDataType :: DataType
408+textDataType = mkDataType "Data.Text.Lazy.Text" [packConstr]
409+
340-- | /O(n)/ Convert a 'String' into a 'Text'.
410-- | /O(n)/ Convert a 'String' into a 'Text'.
341--
411--
342-- Subject to fusion. Performs replacement on invalid scalar values.
412-- Subject to fusion. Performs replacement on invalid scalar values.
@@ -350,6 +420,27 @@ unpack :: Text -> String
350unpack t = S.unstreamList (stream t)
420unpack t = S.unstreamList (stream t)
351{-# INLINE [1] unpack #-}
421{-# INLINE [1] unpack #-}
352
422
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+
353-- | /O(1)/ Convert a character into a Text. Subject to fusion.
444-- | /O(1)/ Convert a character into a Text. Subject to fusion.
354-- Performs replacement on invalid scalar values.
445-- Performs replacement on invalid scalar values.
355singleton :: Char -> Text
446singleton :: Char -> Text
@@ -391,6 +482,8 @@ cons :: Char -> Text -> Text
391cons c t = Chunk (T.singleton c) t
482cons c t = Chunk (T.singleton c) t
392{-# INLINE [1] cons #-}
483{-# INLINE [1] cons #-}
393
484
485+infixr 5 `cons`
486+
394{-# RULES
487{-# RULES
395"LAZY TEXT cons -> fused" [~1] forall c t.
488"LAZY TEXT cons -> fused" [~1] forall c t.
396 cons c t = unstream (S.cons c (stream t))
489 cons c t = unstream (S.cons c (stream t))
@@ -452,7 +545,7 @@ tail Empty = emptyError "tail"
452 unstream (S.tail (stream t)) = tail t
545 unstream (S.tail (stream t)) = tail t
453 #-}
546 #-}
454
547
455−-- | /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
456-- be non-empty. Subject to fusion.
549-- be non-empty. Subject to fusion.
457init :: Text -> Text
550init :: Text -> Text
458init (Chunk t0 ts0) = go t0 ts0
551init (Chunk t0 ts0) = go t0 ts0
@@ -488,7 +581,7 @@ isSingleton :: Text -> Bool
488isSingleton = S.isSingleton . stream
581isSingleton = S.isSingleton . stream
489{-# INLINE isSingleton #-}
582{-# INLINE isSingleton #-}
490
583
491−-- | /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
492-- non-empty. Subject to fusion.
585-- non-empty. Subject to fusion.
493last :: Text -> Char
586last :: Text -> Char
494last Empty = emptyError "last"
587last Empty = emptyError "last"
@@ -543,7 +636,7 @@ map f t = unstream (S.map (safe . f) (stream t))
543-- 'Text's and concatenates the list after interspersing the first
636-- 'Text's and concatenates the list after interspersing the first
544-- argument between each element of the list.
637-- argument between each element of the list.
545intercalate :: Text -> [Text] -> Text
638intercalate :: Text -> [Text] -> Text
546−intercalate t = concat . (U.intersperse t)
639+intercalate t = concat . (F.intersperse t)
547{-# INLINE intercalate #-}
640{-# INLINE intercalate #-}
548
641
549-- | /O(n)/ The 'intersperse' function takes a character and places it
642-- | /O(n)/ The 'intersperse' function takes a character and places it
@@ -603,7 +696,7 @@ center k c t
603 | otherwise = replicateChar l c `append` t `append` replicateChar r c
696 | otherwise = replicateChar l c `append` t `append` replicateChar r c
604 where len = length t
697 where len = length t
605 d = k - len
698 d = k - len
606− r = d `div` 2
699+ r = d `quot` 2
607 l = d - r
700 l = d - r
608{-# INLINE center #-}
701{-# INLINE center #-}
609
702
@@ -622,13 +715,36 @@ reverse = rev Empty
622 where rev a Empty = a
715 where rev a Empty = a
623 rev a (Chunk t ts) = rev (Chunk (T.reverse t) a) ts
716 rev a (Chunk t ts) = rev (Chunk (T.reverse t) a) ts
624
717
625−-- | /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"
626--
738--
627-- In (unlikely) bad cases, this function's time complexity degrades
739-- In (unlikely) bad cases, this function's time complexity degrades
628-- towards /O(n*m)/.
740-- towards /O(n*m)/.
629−replace :: Text -- ^ Text to search for
741+replace :: Text
630− -> Text -- ^ Replacement text
742+ -- ^ @needle@ to search for. If this string is empty, an
743+ -- error will occur.
744+ -> Text
745+ -- ^ @replacement@ to replace @needle@ with.
631− -> Text -- ^ Input text
746+ -> Text
747+ -- ^ @haystack@ in which to search.
632 -> Text
748 -> Text
633replace s d = intercalate d . splitOn s
749replace s d = intercalate d . splitOn s
634{-# INLINE replace #-}
750{-# INLINE replace #-}
@@ -645,9 +761,10 @@ replace s d = intercalate d . splitOn s
645-- functions may map one input character to two or three output
761-- functions may map one input character to two or three output
646-- characters.
762-- characters.
647
763
648−-- | /O(n)/ Convert a string to folded case. This function is mainly
764+-- | /O(n)/ Convert a string to folded case. Subject to fusion.
765+--
649−-- useful for performing caseless (or case insensitive) string
766+-- This function is mainly useful for performing caseless (or case
650−-- comparisons.
767+-- insensitive) string comparisons.
651--
768--
652-- A string @x@ is a caseless match for a string @y@ if and only if:
769-- A string @x@ is a caseless match for a string @y@ if and only if:
653--
770--
@@ -664,22 +781,49 @@ toCaseFold t = unstream (S.toCaseFold (stream t))
664{-# INLINE [0] toCaseFold #-}
781{-# INLINE [0] toCaseFold #-}
665
782
666-- | /O(n)/ Convert a string to lower case, using simple case
783-- | /O(n)/ Convert a string to lower case, using simple case
784+-- conversion. Subject to fusion.
785+--
667−-- conversion. The result string may be longer than the input string.
786+-- The result string may be longer than the input string. For
668−-- For instance, the Latin capital letter I with dot above (U+0130)
787+-- instance, the Latin capital letter I with dot above (U+0130) maps
669−-- maps to the sequence Latin small letter i (U+0069) followed by
788+-- to the sequence Latin small letter i (U+0069) followed by combining
670−-- combining dot above (U+0307).
789+-- dot above (U+0307).
671toLower :: Text -> Text
790toLower :: Text -> Text
672toLower t = unstream (S.toLower (stream t))
791toLower t = unstream (S.toLower (stream t))
673{-# INLINE toLower #-}
792{-# INLINE toLower #-}
674
793
675-- | /O(n)/ Convert a string to upper case, using simple case
794-- | /O(n)/ Convert a string to upper case, using simple case
795+-- conversion. Subject to fusion.
796+--
676−-- conversion. The result string may be longer than the input string.
797+-- The result string may be longer than the input string. For
677−-- For instance, the German eszett (U+00DF) maps to the two-letter
798+-- instance, the German eszett (U+00DF) maps to the two-letter
678-- sequence SS.
799-- sequence SS.
679toUpper :: Text -> Text
800toUpper :: Text -> Text
680toUpper t = unstream (S.toUpper (stream t))
801toUpper t = unstream (S.toUpper (stream t))
681{-# INLINE toUpper #-}
802{-# INLINE toUpper #-}
682
803
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+
683-- | /O(n)/ 'foldl', applied to a binary operator, a starting value
827-- | /O(n)/ 'foldl', applied to a binary operator, a starting value
684-- (typically the left-identity of the operator), and a 'Text',
828-- (typically the left-identity of the operator), and a 'Text',
685-- reduces the 'Text' using the binary operator, from left to right.
829-- reduces the 'Text' using the binary operator, from left to right.
@@ -714,7 +858,7 @@ foldr f z t = S.foldr f z (stream t)
714{-# INLINE foldr #-}
858{-# INLINE foldr #-}
715
859
716-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
860-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
717−-- 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
718-- fusion.
862-- fusion.
719foldr1 :: (Char -> Char -> Char) -> Text -> Char
863foldr1 :: (Char -> Char -> Char) -> Text -> Char
720foldr1 f t = S.foldr1 f (stream t)
864foldr1 f t = S.foldr1 f (stream t)
@@ -737,13 +881,13 @@ concatMap f = concat . foldr ((:) . f) []
737{-# INLINE concatMap #-}
881{-# INLINE concatMap #-}
738
882
739-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
883-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
740−-- 'Text' @t@ satisifes the predicate @p@. Subject to fusion.
884+-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
741any :: (Char -> Bool) -> Text -> Bool
885any :: (Char -> Bool) -> Text -> Bool
742any p t = S.any p (stream t)
886any p t = S.any p (stream t)
743{-# INLINE any #-}
887{-# INLINE any #-}
744
888
745-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
889-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
746−-- 'Text' @t@ satisify the predicate @p@. Subject to fusion.
890+-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
747all :: (Char -> Bool) -> Text -> Bool
891all :: (Char -> Bool) -> Text -> Bool
748all p t = S.all p (stream t)
892all p t = S.all p (stream t)
749{-# INLINE all #-}
893{-# INLINE all #-}
@@ -826,6 +970,12 @@ mapAccumR f = go
826 go z Empty = (z, Empty)
970 go z Empty = (z, Empty)
827{-# INLINE mapAccumR #-}
971{-# INLINE mapAccumR #-}
828
972
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+
829-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'Text' consisting of the input
979-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'Text' consisting of the input
830-- @t@ repeated @n@ times.
980-- @t@ repeated @n@ times.
831replicate :: Int64 -> Text -> Text
981replicate :: Int64 -> Text -> Text
@@ -835,7 +985,22 @@ replicate n t
835 | otherwise = concat (rep 0)
985 | otherwise = concat (rep 0)
836 where rep !i | i >= n = []
986 where rep !i | i >= n = []
837 | otherwise = t : rep (i+1)
987 | otherwise = t : rep (i+1)
838−{-# 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
839
1004
840-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the
1005-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the
841-- value of every element. Subject to fusion.
1006-- value of every element. Subject to fusion.
@@ -890,6 +1055,22 @@ take i t0 = take' i t0
890 unstream (S.take n (stream t)) = take n t
1055 unstream (S.take n (stream t)) = take n t
891 #-}
1056 #-}
892
1057
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+
893-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
1074-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
894-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
1075-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
895-- is greater than the length of the 'Text'. Subject to fusion.
1076-- is greater than the length of the 'Text'. Subject to fusion.
@@ -899,7 +1080,7 @@ drop i t0
899 | otherwise = drop' i t0
1080 | otherwise = drop' i t0
900 where drop' 0 ts = ts
1081 where drop' 0 ts = ts
901 drop' _ Empty = Empty
1082 drop' _ Empty = Empty
902− drop' n (Chunk t ts)
1083+ drop' n (Chunk t ts)
903 | n < len = Chunk (T.drop (fromIntegral n) t) ts
1084 | n < len = Chunk (T.drop (fromIntegral n) t) ts
904 | otherwise = drop' (n - len) ts
1085 | otherwise = drop' (n - len) ts
905 where len = fromIntegral (T.length t)
1086 where len = fromIntegral (T.length t)
@@ -912,6 +1093,23 @@ drop i t0
912 unstream (S.drop n (stream t)) = drop n t
1093 unstream (S.drop n (stream t)) = drop n t
913 #-}
1094 #-}
914
1095
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+
915-- | /O(n)/ 'dropWords' @n@ returns the suffix with @n@ 'Word16'
1113-- | /O(n)/ 'dropWords' @n@ returns the suffix with @n@ 'Word16'
916-- values dropped, or the empty 'Text' if @n@ is greater than the
1114-- values dropped, or the empty 'Text' if @n@ is greater than the
917-- number of 'Word16' values present.
1115-- number of 'Word16' values present.
@@ -922,7 +1120,7 @@ dropWords i t0
922 where drop' 0 ts = ts
1120 where drop' 0 ts = ts
923 drop' _ Empty = Empty
1121 drop' _ Empty = Empty
924 drop' n (Chunk (T.Text arr off len) ts)
1122 drop' n (Chunk (T.Text arr off len) ts)
925− | n < len' = chunk (textP arr (off+n') (len-n')) ts
1123+ | n < len' = chunk (text arr (off+n') (len-n')) ts
926 | otherwise = drop' (n - len') ts
1124 | otherwise = drop' (n - len') ts
927 where len' = fromIntegral len
1125 where len' = fromIntegral len
928 n' = fromIntegral n
1126 n' = fromIntegral n
@@ -946,6 +1144,20 @@ takeWhile p t0 = takeWhile' t0
946"LAZY TEXT takeWhile -> unfused" [1] forall p t.
1144"LAZY TEXT takeWhile -> unfused" [1] forall p t.
947 unstream (S.takeWhile p (stream t)) = takeWhile p t
1145 unstream (S.takeWhile p (stream t)) = takeWhile p t
948 #-}
1146 #-}
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 #-}
949
1161
950-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
1162-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
951-- 'takeWhile' @p@ @t@. Subject to fusion.
1163-- 'takeWhile' @p@ @t@. Subject to fusion.
@@ -964,9 +1176,11 @@ dropWhile p t0 = dropWhile' t0
964"LAZY TEXT dropWhile -> unfused" [1] forall p t.
1176"LAZY TEXT dropWhile -> unfused" [1] forall p t.
965 unstream (S.dropWhile p (stream t)) = dropWhile p t
1177 unstream (S.dropWhile p (stream t)) = dropWhile p t
966 #-}
1178 #-}
1179+
967-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
1180-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
968−-- dropping characters that fail the predicate @p@ from the end of
1181+-- dropping characters that satisfy the predicate @p@ from the end of
969-- @t@.
1182-- @t@.
1183+--
970-- Examples:
1184-- Examples:
971--
1185--
972-- > dropWhileEnd (=='.') "foo..." == "foo"
1186-- > dropWhileEnd (=='.') "foo..." == "foo"
@@ -983,7 +1197,7 @@ dropWhileEnd p = go
983{-# INLINE dropWhileEnd #-}
1197{-# INLINE dropWhileEnd #-}
984
1198
985-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
1199-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
986−-- dropping characters that fail the predicate @p@ from both the
1200+-- dropping characters that satisfy the predicate @p@ from both the
987-- beginning and end of @t@. Subject to fusion.
1201-- beginning and end of @t@. Subject to fusion.
988dropAround :: (Char -> Bool) -> Text -> Text
1202dropAround :: (Char -> Bool) -> Text -> Text
989dropAround p = dropWhile p . dropWhileEnd p
1203dropAround p = dropWhile p . dropWhileEnd p
@@ -1033,8 +1247,8 @@ splitAtWord _ Empty = empty :*: empty
1033splitAtWord x (Chunk c@(T.Text arr off len) cs)
1247splitAtWord x (Chunk c@(T.Text arr off len) cs)
1034 | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
1248 | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
1035 in Chunk c h :*: t
1249 in Chunk c h :*: t
1036− | otherwise = chunk (textP arr off y) empty :*:
1250+ | otherwise = chunk (text arr off y) empty :*:
1037− chunk (textP arr (off+y) (len-y)) cs
1251+ chunk (text arr (off+y) (len-y)) cs
1038 where y = fromIntegral x
1252 where y = fromIntegral x
1039
1253
1040-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1254-- | /O(n+m)/ Find the first instance of @needle@ (which must be
@@ -1053,7 +1267,7 @@ splitAtWord x (Chunk c@(T.Text arr off len) cs)
1053-- > where (prefix, match) = breakOn needle haystack
1267-- > where (prefix, match) = breakOn needle haystack
1054--
1268--
1055-- If you need to break a string by a substring repeatedly (e.g. you
1269-- If you need to break a string by a substring repeatedly (e.g. you
1056−-- want to break on every instance of a substring), use 'find'
1270+-- want to break on every instance of a substring), use 'breakOnAll'
1057-- instead, as it has lower startup overhead.
1271-- instead, as it has lower startup overhead.
1058--
1272--
1059-- This function is strict in its first argument, and lazy in its
1273-- This function is strict in its first argument, and lazy in its
@@ -1178,28 +1392,34 @@ tails ts@(Chunk t ts')
1178-- copies to create substrings; they just construct new 'Text's that
1392-- copies to create substrings; they just construct new 'Text's that
1179-- are slices of the original.
1393-- are slices of the original.
1180
1394
1181−-- | /O(m+n)/ Break a 'Text' into pieces separated by the first
1395+-- | /O(m+n)/ Break a 'Text' into pieces separated by the first 'Text'
1182−-- 'Text' argument, consuming the delimiter. An empty delimiter is
1396+-- argument (which cannot be an empty string), consuming the
1183−-- invalid, and will cause an error to be raised.
1397+-- delimiter. An empty delimiter is invalid, and will cause an error
1398+-- to be raised.
1184--
1399--
1185-- Examples:
1400-- Examples:
1186--
1401--
1187-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1402-- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"]
1188-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1403-- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]
1189-- > splitOn "x" "x" == ["",""]
1404-- > splitOn "x" "x" == ["",""]
1190−--
1405+--
1191-- and
1406-- and
1192--
1407--
1193-- > intercalate s . splitOn s == id
1408-- > intercalate s . splitOn s == id
1194-- > splitOn (singleton c) == split (==c)
1409-- > splitOn (singleton c) == split (==c)
1195--
1410--
1411+-- (Note: the string @s@ to split on above cannot be empty.)
1412+--
1196-- This function is strict in its first argument, and lazy in its
1413-- This function is strict in its first argument, and lazy in its
1197-- second.
1414-- second.
1198--
1415--
1199-- In (unlikely) bad cases, this function's time complexity degrades
1416-- In (unlikely) bad cases, this function's time complexity degrades
1200-- towards /O(n*m)/.
1417-- towards /O(n*m)/.
1201−splitOn :: Text -- ^ Text to split on
1418+splitOn :: Text
1419+ -- ^ String to split on. If this string is empty, an error
1420+ -- will occur.
1421+ -> Text
1202− -> Text -- ^ Input text
1422+ -- ^ Input text.
1203 -> [Text]
1423 -> [Text]
1204splitOn pat src
1424splitOn pat src
1205 | null pat = emptyError "splitOn"
1425 | null pat = emptyError "splitOn"
@@ -1325,51 +1545,77 @@ isInfixOf needle haystack
1325-------------------------------------------------------------------------------
1545-------------------------------------------------------------------------------
1326-- * View patterns
1546-- * View patterns
1327
1547
1328−-- | /O(n)/ Returns the suffix of the second string if its prefix
1548+-- | /O(n)/ Return the suffix of the second string if its prefix
1329−-- matches the first.
1549+-- matches the entire first string.
1330--
1550--
1331-- Examples:
1551-- Examples:
1332--
1552--
1333-- > stripPrefix "foo" "foobar" == Just "bar"
1553-- > stripPrefix "foo" "foobar" == Just "bar"
1554+-- > stripPrefix "" "baz" == Just "baz"
1334-- > stripPrefix "foo" "quux" == Nothing
1555-- > stripPrefix "foo" "quux" == Nothing
1335--
1556--
1336-- This is particularly useful with the @ViewPatterns@ extension to
1557-- This is particularly useful with the @ViewPatterns@ extension to
1337-- GHC, as follows:
1558-- GHC, as follows:
1338--
1559--
1339-- > {-# LANGUAGE ViewPatterns #-}
1560-- > {-# LANGUAGE ViewPatterns #-}
1340−-- > import Data.Text as T
1561+-- > import Data.Text.Lazy as T
1341-- >
1562-- >
1342-- > fnordLength :: Text -> Int
1563-- > fnordLength :: Text -> Int
1343-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1564-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1344−-- > fnordLength _ = -1
1565+-- > fnordLength _ = -1
1345stripPrefix :: Text -> Text -> Maybe Text
1566stripPrefix :: Text -> Text -> Maybe Text
1346−-- Yes, this could be much more efficient.
1347stripPrefix p t
1567stripPrefix p t
1348− | p `isPrefixOf` t = Just (drop (length p) t)
1568+ | null p = Just t
1569+ | otherwise = case commonPrefixes p t of
1570+ Just (_,c,r) | null c -> Just r
1349− | otherwise = Nothing
1571+ _ -> Nothing
1350
1572
1573+-- | /O(n)/ Find the longest non-empty common prefix of two strings
1574+-- and return it, along with the suffixes of each string at which they
1575+-- no longer match.
1576+--
1577+-- If the strings do not have a common prefix or either one is empty,
1578+-- this function returns 'Nothing'.
1579+--
1580+-- Examples:
1581+--
1582+-- > commonPrefixes "foobar" "fooquux" == Just ("foo","bar","quux")
1583+-- > commonPrefixes "veeble" "fetzer" == Nothing
1584+-- > commonPrefixes "" "baz" == Nothing
1585+commonPrefixes :: Text -> Text -> Maybe (Text,Text,Text)
1586+commonPrefixes Empty _ = Nothing
1587+commonPrefixes _ Empty = Nothing
1588+commonPrefixes a0 b0 = Just (go a0 b0 [])
1589+ where
1590+ go t0@(Chunk x xs) t1@(Chunk y ys) ps
1591+ = case T.commonPrefixes x y of
1592+ Just (p,a,b)
1593+ | T.null a -> go xs (chunk b ys) (p:ps)
1594+ | T.null b -> go (chunk a xs) ys (p:ps)
1595+ | otherwise -> (fromChunks (L.reverse (p:ps)),chunk a xs, chunk b ys)
1596+ Nothing -> (fromChunks (L.reverse ps),t0,t1)
1597+ go t0 t1 ps = (fromChunks (L.reverse ps),t0,t1)
1598+
1351−-- | /O(n)/ Returns the prefix of the second string if its suffix
1599+-- | /O(n)/ Return the prefix of the second string if its suffix
1352−-- matches the first.
1600+-- matches the entire first string.
1353--
1601--
1354-- Examples:
1602-- Examples:
1355--
1603--
1356-- > stripSuffix "bar" "foobar" == Just "foo"
1604-- > stripSuffix "bar" "foobar" == Just "foo"
1605+-- > stripSuffix "" "baz" == Just "baz"
1357-- > stripSuffix "foo" "quux" == Nothing
1606-- > stripSuffix "foo" "quux" == Nothing
1358--
1607--
1359-- This is particularly useful with the @ViewPatterns@ extension to
1608-- This is particularly useful with the @ViewPatterns@ extension to
1360-- GHC, as follows:
1609-- GHC, as follows:
1361--
1610--
1362-- > {-# LANGUAGE ViewPatterns #-}
1611-- > {-# LANGUAGE ViewPatterns #-}
1363−-- > import Data.Text as T
1612+-- > import Data.Text.Lazy as T
1364-- >
1613-- >
1365-- > quuxLength :: Text -> Int
1614-- > quuxLength :: Text -> Int
1366-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1615-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1367−-- > quuxLength _ = -1
1616+-- > quuxLength _ = -1
1368stripSuffix :: Text -> Text -> Maybe Text
1617stripSuffix :: Text -> Text -> Maybe Text
1369−-- Yes, this could be much more efficient.
1370−stripSuffix p t
1618+stripSuffix p t = reverse `fmap` stripPrefix (reverse p) (reverse t)
1371− | p `isSuffixOf` t = Just (take (length t - length p) t)
1372− | otherwise = Nothing
1373
1619
1374-- | /O(n)/ 'filter', applied to a predicate and a 'Text',
1620-- | /O(n)/ 'filter', applied to a predicate and a 'Text',
1375-- returns a 'Text' containing those characters that satisfy the
1621-- returns a 'Text' containing those characters that satisfy the
Data/Text/Lazy/Builder.hs+19−261
@@ -1,11 +1,15 @@
1{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
1{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
2
5
3-----------------------------------------------------------------------------
6-----------------------------------------------------------------------------
4-- |
7-- |
5-- Module : Data.Text.Lazy.Builder
8-- Module : Data.Text.Lazy.Builder
9+-- Copyright : (c) 2013 Bryan O'Sullivan
6−-- Copyright : (c) 2010 Johan Tibell
10+-- (c) 2010 Johan Tibell
7−-- License : BSD3-style (see LICENSE)
11+-- License : BSD-style (see LICENSE)
8−--
12+--
9-- Maintainer : Johan Tibell <johan.tibell@gmail.com>
13-- Maintainer : Johan Tibell <johan.tibell@gmail.com>
10-- Stability : experimental
14-- Stability : experimental
11-- Portability : portable to Hugs and GHC
15-- Portability : portable to Hugs and GHC
@@ -15,7 +19,9 @@
15-- @fromLazyText@, which construct new builders, and 'mappend', which
19-- @fromLazyText@, which construct new builders, and 'mappend', which
16-- concatenates two builders.
20-- concatenates two builders.
17--
21--
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
19--
25--
20-- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c')
26-- > singleton 'a' `mappend` (singleton 'b' `mappend` singleton 'c')
21--
27--
@@ -23,8 +29,14 @@
23--
29--
24-- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c'
30-- > singleton 'a' `mappend` singleton 'b' `mappend` singleton 'c'
25--
31--
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'
27--
36--
37+-- since the '<>' from recent versions of 'Data.Monoid' associates
38+-- to the right.
39+
28-----------------------------------------------------------------------------
40-----------------------------------------------------------------------------
29
41
30module Data.Text.Lazy.Builder
42module Data.Text.Lazy.Builder
@@ -37,264 +49,10 @@ module Data.Text.Lazy.Builder
37 , singleton
49 , singleton
38 , fromText
50 , fromText
39 , fromLazyText
51 , fromLazyText
52+ , fromString
40
53
41 -- * Flushing the buffer state
54 -- * Flushing the buffer state
42 , flush
55 , flush
43 ) where
56 ) where
44
57
45−import Control.Monad.ST (ST, runST)
46−import Data.Bits ((.&.))
47−import Data.Monoid (Monoid(..))
48−import Data.Text.Internal (Text(..))
58+import Data.Text.Internal.Builder
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− #-}
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
2-- |
5-- |
3-- Module : Data.Text.Lazy.Encoding
6-- Module : Data.Text.Lazy.Encoding
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
7-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
5--
8--
6-- License : BSD-style
9-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
10+-- Maintainer : bos@serpentine.com
8−-- duncan@haskell.org
9-- Stability : experimental
11-- Stability : experimental
10-- Portability : portable
12-- Portability : portable
11--
13--
@@ -20,11 +22,16 @@ module Data.Text.Lazy.Encoding
20 -- * Decoding ByteStrings to Text
22 -- * Decoding ByteStrings to Text
21 -- $strict
23 -- $strict
22 decodeASCII
24 decodeASCII
25+ , decodeLatin1
23 , decodeUtf8
26 , decodeUtf8
24 , decodeUtf16LE
27 , decodeUtf16LE
25 , decodeUtf16BE
28 , decodeUtf16BE
26 , decodeUtf32LE
29 , decodeUtf32LE
27 , decodeUtf32BE
30 , decodeUtf32BE
31+
32+ -- ** Catchable failure
33+ , decodeUtf8'
34+
28 -- ** Controllable error handling
35 -- ** Controllable error handling
29 , decodeUtf8With
36 , decodeUtf8With
30 , decodeUtf16LEWith
37 , decodeUtf16LEWith
@@ -38,19 +45,29 @@ module Data.Text.Lazy.Encoding
38 , encodeUtf16BE
45 , encodeUtf16BE
39 , encodeUtf32LE
46 , encodeUtf32LE
40 , encodeUtf32BE
47 , encodeUtf32BE
48+
49+ -- * Encoding Text using ByteString Builders
50+ , encodeUtf8Builder
51+ , encodeUtf8BuilderEscaped
41 ) where
52 ) where
42
53
43−import Data.Bits ((.&.))
54+import Control.Exception (evaluate, try)
55+import Data.Monoid (Monoid(..))
44−import Data.Text.Encoding.Error (OnDecodeError, strictDecode)
56+import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
45−import Data.Text.Lazy.Internal (Text(..), chunk, empty, foldrChunks)
57+import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldrChunks)
58+import Data.Word (Word8)
46import qualified Data.ByteString as S
59import 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
47import qualified Data.ByteString.Lazy as B
63import qualified Data.ByteString.Lazy as B
48import qualified Data.ByteString.Lazy.Internal as B
64import qualified Data.ByteString.Lazy.Internal as B
49−import qualified Data.ByteString.Unsafe as S
65+import qualified Data.ByteString.Unsafe as B
50import qualified Data.Text as T
66import qualified Data.Text as T
51import qualified Data.Text.Encoding as TE
67import qualified Data.Text.Encoding as TE
52−import qualified Data.Text.Lazy.Encoding.Fusion as E
68+import qualified Data.Text.Internal.Lazy.Encoding.Fusion as E
53−import qualified Data.Text.Lazy.Fusion as F
69+import qualified Data.Text.Internal.Lazy.Fusion as F
70+import Data.Text.Unsafe (unsafeDupablePerformIO)
54
71
55-- $strict
72-- $strict
56--
73--
@@ -65,53 +82,39 @@ import qualified Data.Text.Lazy.Fusion as F
65-- 'decodeUtf8With' allows the programmer to determine what to do on a
82-- 'decodeUtf8With' allows the programmer to determine what to do on a
66-- decoding error.
83-- decoding error.
67
84
68−-- | Decode a 'ByteString' containing 7-bit ASCII encoded text.
85+-- | /Deprecated/. Decode a 'ByteString' containing 7-bit ASCII
86+-- encoded text.
69decodeASCII :: B.ByteString -> Text
87decodeASCII :: B.ByteString -> Text
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
70−decodeASCII bs = foldr (chunk . TE.decodeASCII) empty (B.toChunks bs)
93+decodeLatin1 = foldr (chunk . TE.decodeLatin1) empty . B.toChunks
71−{-# INLINE decodeASCII #-}
72
94
73-- | Decode a 'ByteString' containing UTF-8 encoded text.
95-- | Decode a 'ByteString' containing UTF-8 encoded text.
74decodeUtf8With :: OnDecodeError -> B.ByteString -> Text
96decodeUtf8With :: 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)
76 where
100 where
77− decode = TE.decodeUtf8With onErr
101+ go f0 _ (B.Chunk b bs) =
78− fast (B.Chunk p ps) | isComplete p = chunk (decode p) (fast ps)
102+ case f0 b of
79− | otherwise = chunk (decode h) (slow t ps)
103+ TE.Some t l f -> chunk t (go f l bs)
80− where (h,t) = S.splitAt pivot p
104+ go _ l _
81− pivot | at 1 = len-1
105+ | S.null l = empty
82− | at 2 = len-2
106+ | otherwise = case onErr desc (Just (B.unsafeHead l)) of
83− | otherwise = len-3
107+ Nothing -> empty
84− len = S.length p
108+ Just c -> Chunk (T.singleton c) Empty
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)
108 desc = "Data.Text.Lazy.Encoding.decodeUtf8With: Invalid UTF-8 stream"
109 desc = "Data.Text.Lazy.Encoding.decodeUtf8With: Invalid UTF-8 stream"
109−{-# INLINE[0] decodeUtf8With #-}
110+decodeUtf8With _ _ = empty
110
111
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.
112--
114--
113-- If the input contains any invalid UTF-8 data, an exception will be
115-- If the input contains any invalid UTF-8 data, an exception will be
116+-- thrown that cannot be caught in pure code. For more control over
114−-- thrown. For more control over the handling of invalid data, use
117+-- the handling of invalid data, use 'decodeUtf8'' or
115-- 'decodeUtf8With'.
118-- 'decodeUtf8With'.
116decodeUtf8 :: B.ByteString -> Text
119decodeUtf8 :: B.ByteString -> Text
117decodeUtf8 = decodeUtf8With strictDecode
120decodeUtf8 = decodeUtf8With strictDecode
@@ -121,9 +124,44 @@ decodeUtf8 = decodeUtf8With strictDecode
121{- RULES "LAZY STREAM stream/decodeUtf8' fusion" [1]
124{- RULES "LAZY STREAM stream/decodeUtf8' fusion" [1]
122 forall bs. F.stream (decodeUtf8' bs) = E.streamUtf8 strictDecode bs #-}
125 forall bs. F.stream (decodeUtf8' bs) = E.streamUtf8 strictDecode bs #-}
123
126
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+
124encodeUtf8 :: Text -> B.ByteString
144encodeUtf8 :: Text -> B.ByteString
125−encodeUtf8 (Chunk c cs) = B.Chunk (TE.encodeUtf8 c) (encodeUtf8 cs)
145+encodeUtf8 Empty = B.empty
126−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
127
165
128-- | Decode text from little endian UTF-16 encoding.
166-- | Decode text from little endian UTF-16 encoding.
129decodeUtf16LEWith :: OnDecodeError -> B.ByteString -> Text
167decodeUtf16LEWith :: OnDecodeError -> B.ByteString -> Text
Data/Text/Lazy/IO.hs+12−23
@@ -1,4 +1,7 @@
1{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
1{-# LANGUAGE BangPatterns, CPP, RecordWildCards #-}
2+#if __GLASGOW_HASKELL__ >= 702
3+{-# LANGUAGE Trustworthy #-}
4+#endif
2-- |
5-- |
3-- Module : Data.Text.Lazy.IO
6-- Module : Data.Text.Lazy.IO
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
7-- Copyright : (c) 2009, 2010 Bryan O'Sullivan,
@@ -16,7 +19,7 @@
16module Data.Text.Lazy.IO
19module Data.Text.Lazy.IO
17 (
20 (
18 -- * Performance
21 -- * Performance
19− -- $performance
22+ -- $performance
20
23
21 -- * Locale support
24 -- * Locale support
22 -- $locale
25 -- $locale
@@ -38,22 +41,17 @@ module Data.Text.Lazy.IO
38 ) where
41 ) where
39
42
40import Data.Text.Lazy (Text)
43import Data.Text.Lazy (Text)
41−import Prelude hiding (appendFile, getContents, getLine, interact, putStr,
44+import Prelude hiding (appendFile, getContents, getLine, interact,
42− putStrLn, readFile, writeFile)
45+ putStr, putStrLn, readFile, writeFile)
43import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,
46import System.IO (Handle, IOMode(..), hPutChar, openFile, stdin, stdout,
44 withFile)
47 withFile)
45import qualified Data.Text.IO as T
48import qualified Data.Text.IO as T
46import qualified Data.Text.Lazy as L
49import 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
53import Control.Monad (when)
51import Control.Monad (when)
54import Data.IORef (readIORef)
52import Data.IORef (readIORef)
55−import Data.Text.IO.Internal (hGetLineWith, readChunk)
53+import Data.Text.Internal.IO (hGetLineWith, readChunk)
56−import Data.Text.Lazy.Internal (chunk, empty)
54+import Data.Text.Internal.Lazy (chunk, empty)
57import GHC.IO.Buffer (isEmptyBuffer)
55import GHC.IO.Buffer (isEmptyBuffer)
58import GHC.IO.Exception (IOException(..), IOErrorType(..), ioException)
56import GHC.IO.Exception (IOException(..), IOErrorType(..), ioException)
59import GHC.IO.Handle.Internals (augmentIOError, hClose_help,
57import GHC.IO.Handle.Internals (augmentIOError, hClose_help,
@@ -62,7 +60,6 @@ import GHC.IO.Handle.Types (Handle__(..), HandleType(..))
62import System.IO (BufferMode(..), hGetBuffering, hSetBuffering)
60import System.IO (BufferMode(..), hGetBuffering, hSetBuffering)
63import System.IO.Error (isEOFError)
61import System.IO.Error (isEOFError)
64import System.IO.Unsafe (unsafeInterleaveIO)
62import System.IO.Unsafe (unsafeInterleaveIO)
65−#endif
66
63
67-- $performance
64-- $performance
68--
65--
@@ -96,9 +93,6 @@ appendFile p = withFile p AppendMode . flip hPutStr
96-- | Lazily read the remaining contents of a 'Handle'. The 'Handle'
93-- | Lazily read the remaining contents of a 'Handle'. The 'Handle'
97-- will be closed after the read completes, or on error.
94-- will be closed after the read completes, or on error.
98hGetContents :: Handle -> IO Text
95hGetContents :: Handle -> IO Text
99−#if __GLASGOW_HASKELL__ <= 610
100−hGetContents = fmap decodeUtf8 . L8.hGetContents
101−#else
102hGetContents h = do
96hGetContents h = do
103 chooseGoodBuffering h
97 chooseGoodBuffering h
104 wantReadableHandle "hGetContents" h $ \hh -> do
98 wantReadableHandle "hGetContents" h $ \hh -> do
@@ -119,7 +113,7 @@ lazyRead h = unsafeInterleaveIO $
119 case haType hh of
113 case haType hh of
120 ClosedHandle -> return (hh, L.empty)
114 ClosedHandle -> return (hh, L.empty)
121 SemiClosedHandle -> lazyReadBuffered h hh
115 SemiClosedHandle -> lazyReadBuffered h hh
122− _ -> ioException
116+ _ -> ioException
123 (IOError (Just h) IllegalOperation "hGetContents"
117 (IOError (Just h) IllegalOperation "hGetContents"
124 "illegal handle type" Nothing Nothing)
118 "illegal handle type" Nothing Nothing)
125
119
@@ -128,22 +122,17 @@ lazyReadBuffered h hh@Handle__{..} = do
128 buf <- readIORef haCharBuffer
122 buf <- readIORef haCharBuffer
129 (do t <- readChunk hh buf
123 (do t <- readChunk hh buf
130 ts <- lazyRead h
124 ts <- lazyRead h
131− return (hh, chunk t ts)) `catch` \e -> do
125+ return (hh, chunk t ts)) `E.catch` \e -> do
132 (hh', _) <- hClose_help hh
126 (hh', _) <- hClose_help hh
133 if isEOFError e
127 if isEOFError e
134 then return $ if isEmptyBuffer buf
128 then return $ if isEmptyBuffer buf
135 then (hh', empty)
129 then (hh', empty)
136 else (hh', L.singleton '\r')
130 else (hh', L.singleton '\r')
137− else throw (augmentIOError e "hGetContents" h)
131+ else E.throwIO (augmentIOError e "hGetContents" h)
138−#endif
139
132
140-- | Read a single line from a handle.
133-- | Read a single line from a handle.
141hGetLine :: Handle -> IO Text
134hGetLine :: Handle -> IO Text
142−#if __GLASGOW_HASKELL__ <= 610
143−hGetLine = fmap (decodeUtf8 . L8.fromChunks . (:[])) . S8.hGetLine
144−#else
145hGetLine = hGetLineWith L.fromChunks
135hGetLine = hGetLineWith L.fromChunks
146−#endif
147
136
148-- | Write a string to a handle.
137-- | Write a string to a handle.
149hPutStr :: Handle -> Text -> IO ()
138hPutStr :: Handle -> Text -> IO ()
Data/Text/Lazy/Internal.hs+9−103
@@ -1,114 +1,20 @@
1{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
1{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
2-- |
2-- |
3-- Module : Data.Text.Lazy.Internal
3-- Module : Data.Text.Lazy.Internal
4−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
4+-- Copyright : (c) 2013 Bryan O'Sullivan
5--
5--
6-- License : BSD-style
6-- License : BSD-style
7−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
7+-- Maintainer : bos@serpentine.com
8−-- duncan@haskell.org
9-- Stability : experimental
8-- Stability : experimental
10-- Portability : GHC
9-- Portability : GHC
11−--
10+--
12−-- A module containing semi-public 'Text' internals. This exposes the
11+-- This module has been renamed to 'Data.Text.Internal.Lazy'. This
13−-- 'Text' representation and low level construction functions.
12+-- name for the module will be removed in the next major release.
14−-- Modules which extend the 'Text' system may need to use this module.
13+
15−-- Regular users should not.
16module Data.Text.Lazy.Internal
14module Data.Text.Lazy.Internal
15+ {-# DEPRECATED "Use Data.Text.Internal.Lazy instead" #-}
17 (
16 (
18− Text(..)
17+ module Data.Text.Internal.Lazy
19− , chunk
20− , empty
21− , foldrChunks
22− , foldlChunks
23− -- * Data type invariant and abstraction functions
24−
25− -- $invariant
26− , strictInvariant
27− , lazyInvariant
28− , showStructure
29−
30− -- * Chunk allocation sizes
31− , defaultChunkSize
32− , smallChunkSize
33− , chunkOverhead
34 ) where
18 ) where
35
19
36−import Data.Text ()
20+import Data.Text.Internal.Lazy
37−import Data.Text.UnsafeShift (shiftL)
38−import Data.Typeable (Typeable)
39−import Foreign.Storable (sizeOf)
40−import qualified Data.Text.Internal as T
41−
42−data Text = Empty
43− | Chunk {-# UNPACK #-} !T.Text Text
44− deriving (Typeable)
45−
46−-- $invariant
47−--
48−-- The data type invariant for lazy 'Text': Every 'Text' is either 'Empty' or
49−-- consists of non-null 'T.Text's. All functions must preserve this,
50−-- and the QC properties must check this.
51−
52−-- | Check the invariant strictly.
53−strictInvariant :: Text -> Bool
54−strictInvariant Empty = True
55−strictInvariant x@(Chunk (T.Text _ _ len) cs)
56− | len > 0 = strictInvariant cs
57− | otherwise = error $ "Data.Text.Lazy: invariant violation: "
58− ++ showStructure x
59−
60−-- | Check the invariant lazily.
61−lazyInvariant :: Text -> Text
62−lazyInvariant Empty = Empty
63−lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)
64− | len > 0 = Chunk c (lazyInvariant cs)
65− | otherwise = error $ "Data.Text.Lazy: invariant violation: "
66− ++ showStructure x
67−
68−-- | Display the internal structure of a lazy 'Text'.
69−showStructure :: Text -> String
70−showStructure Empty = "Empty"
71−showStructure (Chunk t Empty) = "Chunk " ++ show t ++ " Empty"
72−showStructure (Chunk t ts) =
73− "Chunk " ++ show t ++ " (" ++ showStructure ts ++ ")"
74−
75−-- | Smart constructor for 'Chunk'. Guarantees the data type invariant.
76−chunk :: T.Text -> Text -> Text
77−{-# INLINE chunk #-}
78−chunk t@(T.Text _ _ len) ts | len == 0 = ts
79− | otherwise = Chunk t ts
80−
81−-- | Smart constructor for 'Empty'.
82−empty :: Text
83−{-# INLINE [0] empty #-}
84−empty = Empty
85−
86−-- | Consume the chunks of a lazy 'Text' with a natural right fold.
87−foldrChunks :: (T.Text -> a -> a) -> a -> Text -> a
88−foldrChunks f z = go
89− where go Empty = z
90− go (Chunk c cs) = f c (go cs)
91−{-# INLINE foldrChunks #-}
92−
93−-- | Consume the chunks of a lazy 'Text' with a strict, tail-recursive,
94−-- accumulating left fold.
95−foldlChunks :: (a -> T.Text -> a) -> a -> Text -> a
96−foldlChunks f z = go z
97− where go !a Empty = a
98− go !a (Chunk c cs) = go (f a c) cs
99−{-# INLINE foldlChunks #-}
100−
101−-- | Currently set to 16 KiB, less the memory management overhead.
102−defaultChunkSize :: Int
103−defaultChunkSize = 16384 - chunkOverhead
104−{-# INLINE defaultChunkSize #-}
105−
106−-- | Currently set to 128 bytes, less the memory management overhead.
107−smallChunkSize :: Int
108−smallChunkSize = 128 - chunkOverhead
109−{-# INLINE smallChunkSize #-}
110−
111−-- | The memory management overhead. Currently this is tuned for GHC only.
112−chunkOverhead :: Int
113−chunkOverhead = sizeOf (undefined :: Int) `shiftL` 1
114−{-# INLINE chunkOverhead #-}
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
2
7
3-- |
8-- |
4-- Module : Data.Text.Lazy.Read
9-- Module : Data.Text.Lazy.Read
5−-- Copyright : (c) 2010 Bryan O'Sullivan
10+-- Copyright : (c) 2010, 2011 Bryan O'Sullivan
6--
11--
7-- License : BSD-style
12-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
13+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
14-- Stability : experimental
11-- Portability : GHC
15-- Portability : GHC
12--
16--
@@ -22,13 +26,17 @@ module Data.Text.Lazy.Read
22 ) where
26 ) where
23
27
24import Control.Monad (liftM)
28import Control.Monad (liftM)
25−import Data.Char (isDigit, isHexDigit, ord)
29+import Data.Char (isDigit, isHexDigit)
30+import Data.Int (Int8, Int16, Int32, Int64)
26import Data.Ratio ((%))
31import Data.Ratio ((%))
32+import Data.Text.Internal.Read
27import Data.Text.Lazy as T
33import Data.Text.Lazy as T
34+import Data.Word (Word, Word8, Word16, Word32, Word64)
28
35
29-- | Read some text. If the read succeeds, return its value and the
36-- | Read some text. If the read succeeds, return its value and the
30-- remaining text, otherwise an error message.
37-- 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
32
40
33-- | Read a decimal integer. The input must begin with at least one
41-- | Read a decimal integer. The input must begin with at least one
34-- decimal digit, and is consumed until a non-digit or end of string
42-- 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)
43-- 'Integer' for your result type.
51-- 'Integer' for your result type.
44decimal :: Integral a => Reader a
52decimal :: Integral a => Reader a
45{-# SPECIALIZE decimal :: Reader Int #-}
53{-# SPECIALIZE decimal :: Reader Int #-}
54+{-# SPECIALIZE decimal :: Reader Int8 #-}
55+{-# SPECIALIZE decimal :: Reader Int16 #-}
56+{-# SPECIALIZE decimal :: Reader Int32 #-}
57+{-# SPECIALIZE decimal :: Reader Int64 #-}
46{-# SPECIALIZE decimal :: Reader Integer #-}
58{-# 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 #-}
47decimal txt
64decimal txt
48 | T.null h = Left "input does not start with a digit"
65 | T.null h = Left "input does not start with a digit"
49 | otherwise = Right (T.foldl' go 0 h, t)
66 | otherwise = Right (T.foldl' go 0 h, t)
@@ -71,23 +88,23 @@ hexadecimal txt
71 where (h,t) = T.splitAt 2 txt
88 where (h,t) = T.splitAt 2 txt
72
89
73hex :: Integral a => Reader a
90hex :: Integral a => Reader a
74−{-# SPECIALIZE hex :: Reader Int #-}
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 #-}
75−{-# SPECIALIZE hex :: Reader Integer #-}
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 #-}
76hex txt
102hex txt
77 | T.null h = Left "input does not start with a hexadecimal digit"
103 | T.null h = Left "input does not start with a hexadecimal digit"
78 | otherwise = Right (T.foldl' go 0 h, t)
104 | otherwise = Right (T.foldl' go 0 h, t)
79 where (h,t) = T.span isHexDigit txt
105 where (h,t) = T.span isHexDigit txt
80 go n d = (n * 16 + fromIntegral (hexDigitToInt d))
106 go n d = (n * 16 + fromIntegral (hexDigitToInt d))
81
107
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−
91-- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
108-- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
92-- apply it to the result of applying the given reader.
109-- apply it to the result of applying the given reader.
93signed :: Num a => Reader a -> Reader a
110signed :: Num a => Reader a -> Reader a
@@ -114,7 +131,7 @@ signed f = runP (signa (P f))
114--
131--
115-- >rational "3.foo" == Right (3.0, ".foo")
132-- >rational "3.foo" == Right (3.0, ".foo")
116-- >rational "3e" == Right (3.0, "e")
133-- >rational "3e" == Right (3.0, "e")
117−rational :: RealFloat a => Reader a
134+rational :: Fractional a => Reader a
118{-# SPECIALIZE rational :: Reader Double #-}
135{-# SPECIALIZE rational :: Reader Double #-}
119rational = floaty $ \real frac fracDenom -> fromRational $
136rational = floaty $ \real frac fracDenom -> fromRational $
120 real % 1 + frac % fracDenom
137 real % 1 + frac % fracDenom
@@ -138,37 +155,21 @@ double = floaty $ \real frac fracDenom ->
138
155
139signa :: Num a => Parser a -> Parser a
156signa :: Num a => Parser a -> Parser a
140{-# SPECIALIZE signa :: Parser Int -> Parser Int #-}
157{-# 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 #-}
141{-# SPECIALIZE signa :: Parser Integer -> Parser Integer #-}
162{-# SPECIALIZE signa :: Parser Integer -> Parser Integer #-}
142signa p = do
163signa p = do
143 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
164 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
144 if sign == '+' then p else negate `liftM` p
165 if sign == '+' then p else negate `liftM` p
145
166
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−
164char :: (Char -> Bool) -> Parser Char
167char :: (Char -> Bool) -> Parser Char
165char p = P $ \t -> case T.uncons t of
168char p = P $ \t -> case T.uncons t of
166 Just (c,t') | p c -> Right (c,t')
169 Just (c,t') | p c -> Right (c,t')
167 _ -> Left "character does not match"
170 _ -> Left "character does not match"
168
171
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
172{-# INLINE floaty #-}
173{-# INLINE floaty #-}
173floaty f = runP $ do
174floaty f = runP $ do
174 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
175 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
2
5
3-- |
6-- |
4-- Module : Data.Text.Read
7-- Module : Data.Text.Read
5−-- Copyright : (c) 2010 Bryan O'Sullivan
8+-- Copyright : (c) 2010, 2011 Bryan O'Sullivan
6--
9--
7-- License : BSD-style
10-- License : BSD-style
8−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
11+-- Maintainer : bos@serpentine.com
9−-- duncan@haskell.org
10-- Stability : experimental
12-- Stability : experimental
11-- Portability : GHC
13-- Portability : GHC
12--
14--
@@ -22,13 +24,18 @@ module Data.Text.Read
22 ) where
24 ) where
23
25
24import Control.Monad (liftM)
26import Control.Monad (liftM)
25−import Data.Char (isDigit, isHexDigit, ord)
27+import Data.Char (isDigit, isHexDigit)
28+import Data.Int (Int8, Int16, Int32, Int64)
26import Data.Ratio ((%))
29import Data.Ratio ((%))
27import Data.Text as T
30import 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)
28
34
29-- | Read some text. If the read succeeds, return its value and the
35-- | Read some text. If the read succeeds, return its value and the
30-- remaining text, otherwise an error message.
36-- 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
32
39
33-- | Read a decimal integer. The input must begin with at least one
40-- | Read a decimal integer. The input must begin with at least one
34-- decimal digit, and is consumed until a non-digit or end of string
41-- 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)
43-- 'Integer' for your result type.
50-- 'Integer' for your result type.
44decimal :: Integral a => Reader a
51decimal :: Integral a => Reader a
45{-# SPECIALIZE decimal :: Reader Int #-}
52{-# SPECIALIZE decimal :: Reader Int #-}
53+{-# SPECIALIZE decimal :: Reader Int8 #-}
54+{-# SPECIALIZE decimal :: Reader Int16 #-}
55+{-# SPECIALIZE decimal :: Reader Int32 #-}
56+{-# SPECIALIZE decimal :: Reader Int64 #-}
46{-# SPECIALIZE decimal :: Reader Integer #-}
57{-# 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 #-}
47decimal txt
63decimal txt
48 | T.null h = Left "input does not start with a digit"
64 | T.null h = Left "input does not start with a digit"
49 | otherwise = Right (T.foldl' go 0 h, t)
65 | otherwise = Right (T.foldl' go 0 h, t)
50− where (h,t) = T.span isDigit txt
66+ where (# h,t #) = span_ isDigit txt
51 go n d = (n * 10 + fromIntegral (digitToInt d))
67 go n d = (n * 10 + fromIntegral (digitToInt d))
52
68
53-- | Read a hexadecimal integer, consisting of an optional leading
69-- | Read a hexadecimal integer, consisting of an optional leading
@@ -64,7 +80,16 @@ decimal txt
64-- 'Integer' for your result type.
80-- 'Integer' for your result type.
65hexadecimal :: Integral a => Reader a
81hexadecimal :: Integral a => Reader a
66{-# SPECIALIZE hexadecimal :: Reader Int #-}
82{-# SPECIALIZE hexadecimal :: Reader Int #-}
83+{-# SPECIALIZE hexadecimal :: Reader Int8 #-}
84+{-# SPECIALIZE hexadecimal :: Reader Int16 #-}
85+{-# SPECIALIZE hexadecimal :: Reader Int32 #-}
86+{-# SPECIALIZE hexadecimal :: Reader Int64 #-}
67{-# SPECIALIZE hexadecimal :: Reader Integer #-}
87{-# 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 #-}
68hexadecimal txt
93hexadecimal txt
69 | h == "0x" || h == "0X" = hex t
94 | h == "0x" || h == "0X" = hex t
70 | otherwise = hex txt
95 | otherwise = hex txt
@@ -72,22 +97,22 @@ hexadecimal txt
72
97
73hex :: Integral a => Reader a
98hex :: Integral a => Reader a
74{-# SPECIALIZE hex :: Reader Int #-}
99{-# SPECIALIZE hex :: Reader Int #-}
100+{-# SPECIALIZE hex :: Reader Int8 #-}
101+{-# SPECIALIZE hex :: Reader Int16 #-}
102+{-# SPECIALIZE hex :: Reader Int32 #-}
103+{-# SPECIALIZE hex :: Reader Int64 #-}
75{-# SPECIALIZE hex :: Reader Integer #-}
104{-# 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 #-}
76hex txt
110hex txt
77 | T.null h = Left "input does not start with a hexadecimal digit"
111 | T.null h = Left "input does not start with a hexadecimal digit"
78 | otherwise = Right (T.foldl' go 0 h, t)
112 | otherwise = Right (T.foldl' go 0 h, t)
79− where (h,t) = T.span isHexDigit txt
113+ where (# h,t #) = span_ isHexDigit txt
80 go n d = (n * 16 + fromIntegral (hexDigitToInt d))
114 go n d = (n * 16 + fromIntegral (hexDigitToInt d))
81
115
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−
91-- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
116-- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
92-- apply it to the result of applying the given reader.
117-- apply it to the result of applying the given reader.
93signed :: Num a => Reader a -> Reader a
118signed :: Num a => Reader a -> Reader a
@@ -114,7 +139,7 @@ signed f = runP (signa (P f))
114--
139--
115-- >rational "3.foo" == Right (3.0, ".foo")
140-- >rational "3.foo" == Right (3.0, ".foo")
116-- >rational "3e" == Right (3.0, "e")
141-- >rational "3e" == Right (3.0, "e")
117−rational :: RealFloat a => Reader a
142+rational :: Fractional a => Reader a
118{-# SPECIALIZE rational :: Reader Double #-}
143{-# SPECIALIZE rational :: Reader Double #-}
119rational = floaty $ \real frac fracDenom -> fromRational $
144rational = floaty $ \real frac fracDenom -> fromRational $
120 real % 1 + frac % fracDenom
145 real % 1 + frac % fracDenom
@@ -138,37 +163,21 @@ double = floaty $ \real frac fracDenom ->
138
163
139signa :: Num a => Parser a -> Parser a
164signa :: Num a => Parser a -> Parser a
140{-# SPECIALIZE signa :: Parser Int -> Parser Int #-}
165{-# 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 #-}
141{-# SPECIALIZE signa :: Parser Integer -> Parser Integer #-}
170{-# SPECIALIZE signa :: Parser Integer -> Parser Integer #-}
142signa p = do
171signa p = do
143 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
172 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
144 if sign == '+' then p else negate `liftM` p
173 if sign == '+' then p else negate `liftM` p
145
174
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−
164char :: (Char -> Bool) -> Parser Char
175char :: (Char -> Bool) -> Parser Char
165char p = P $ \t -> case T.uncons t of
176char p = P $ \t -> case T.uncons t of
166 Just (c,t') | p c -> Right (c,t')
177 Just (c,t') | p c -> Right (c,t')
167 _ -> Left "character does not match"
178 _ -> Left "character does not match"
168
179
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
172{-# INLINE floaty #-}
181{-# INLINE floaty #-}
173floaty f = runP $ do
182floaty f = runP $ do
174 sign <- perhaps '+' $ char (\c -> c == '-' || c == '+')
183 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 @@
1{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
1{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
2-- |
2-- |
3-- Module : Data.Text.Unsafe
3-- Module : Data.Text.Unsafe
4−-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
4+-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
5-- License : BSD-style
5-- License : BSD-style
6−-- Maintainer : bos@serpentine.com, rtomharper@googlemail.com,
6+-- Maintainer : bos@serpentine.com
7−-- duncan@haskell.org
8-- Stability : experimental
7-- Stability : experimental
9-- Portability : portable
8-- Portability : portable
10--
9--
@@ -14,33 +13,28 @@ module Data.Text.Unsafe
14 (
13 (
15 inlineInterleaveST
14 inlineInterleaveST
16 , inlinePerformIO
15 , inlinePerformIO
16+ , unsafeDupablePerformIO
17 , Iter(..)
17 , Iter(..)
18 , iter
18 , iter
19 , iter_
19 , iter_
20 , reverseIter
20 , reverseIter
21+ , reverseIter_
21 , unsafeHead
22 , unsafeHead
22 , unsafeTail
23 , unsafeTail
23 , lengthWord16
24 , lengthWord16
24 , takeWord16
25 , takeWord16
25 , dropWord16
26 , dropWord16
26 ) where
27 ) where
27−
28+
28#if defined(ASSERTS)
29#if defined(ASSERTS)
29import Control.Exception (assert)
30import Control.Exception (assert)
30#endif
31#endif
31−import Data.Text.Encoding.Utf16 (chr2)
32+import Data.Text.Internal.Encoding.Utf16 (chr2)
32import Data.Text.Internal (Text(..))
33import Data.Text.Internal (Text(..))
33−import Data.Text.UnsafeChar (unsafeChr)
34+import Data.Text.Internal.Unsafe (inlineInterleaveST, inlinePerformIO)
34−import GHC.ST (ST(..))
35+import Data.Text.Internal.Unsafe.Char (unsafeChr)
35import qualified Data.Text.Array as A
36import qualified Data.Text.Array as A
36−#if defined(__GLASGOW_HASKELL__)
37−# if __GLASGOW_HASKELL__ >= 611
38−import GHC.IO (IO(IO))
37+import GHC.IO (unsafeDupablePerformIO)
39−# else
40−import GHC.IOBase (IO(IO))
41−# endif
42−import GHC.Base (realWorld#)
43−#endif
44
38
45-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
39-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
46-- omits the check for the empty case, so there is an obligation on
40-- omits the check for the empty case, so there is an obligation on
@@ -53,7 +47,7 @@ unsafeHead (Text arr off _len)
53 n = A.unsafeIndex arr (off+1)
47 n = A.unsafeIndex arr (off+1)
54{-# INLINE unsafeHead #-}
48{-# INLINE unsafeHead #-}
55
49
56−-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeHead'
50+-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeTail'
57-- omits the check for the empty case, so there is an obligation on
51-- omits the check for the empty case, so there is an obligation on
58-- the programmer to provide a proof that the 'Text' is non-empty.
52-- the programmer to provide a proof that the 'Text' is non-empty.
59unsafeTail :: Text -> Text
53unsafeTail :: Text -> Text
@@ -101,32 +95,15 @@ reverseIter (Text arr off _len) i
101 k = j - 1
95 k = j - 1
102{-# INLINE reverseIter #-}
96{-# INLINE reverseIter #-}
103
97
104−-- | Just like unsafePerformIO, but we inline it. Big performance gains as
98+-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
105−-- it exposes lots of things to further inlining. /Very unsafe/. In
99+-- returning the delta to add (i.e. a negative number) to give the
106−-- particular, you should do no memory allocation inside an
100+-- next offset to iterate at.
107−-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.
101+reverseIter_ :: Text -> Int -> Int
108−--
102+reverseIter_ (Text arr off _len) i
109−{-# INLINE inlinePerformIO #-}
103+ | m < 0xDC00 || m > 0xDFFF = -1
110−inlinePerformIO :: IO a -> a
104+ | otherwise = -2
111−#if defined(__GLASGOW_HASKELL__)
105+ where m = A.unsafeIndex arr (off+i)
112−inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
106+{-# INLINE reverseIter_ #-}
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 #-}
130
107
131-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This
108-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This
132-- is useful for sizing a target array appropriately before using
109-- is useful for sizing a target array appropriately before using
README.markdown+5−5
@@ -19,15 +19,15 @@ library to provide these facilities.
19# Get involved!
19# Get involved!
20
20
21Please report bugs via the
21Please report bugs via the
22−[bitbucket issue tracker](http://bitbucket.org/bos/text/issues).
22+[github issue tracker](https://github.com/bos/text/issues).
23
23
24−Master [Mercurial repository](http://bitbucket.org/bos/text):
24+Master [git repository](https://github.com/bos/text):
25
25
26−* `hg clone http://bitbucket.org/bos/text`
26+* `git clone git://github.com/bos/text.git`
27
27
28−There's also a [git mirror](http://github.com/bos/text):
28+There's also a [Mercurial mirror](https://bitbucket.org/bos/text):
29
29
30−* `git clone git://github.com/bos/text.git`
30+* `hg clone https://bitbucket.org/bos/text`
31
31
32(You can create and contribute changes using either Mercurial or git.)
32(You can create and contribute changes using either Mercurial or git.)
33
33
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 @@
1module Arsec
1module Arsec
2 (
2 (
3+ Comment
3− comment
4+ , comment
4 , semi
5 , semi
5 , showC
6 , showC
6 , unichar
7 , unichar
@@ -23,13 +24,7 @@ import Text.ParserCombinators.Parsec.Combinator hiding (optional)
23import Text.ParserCombinators.Parsec.Error
24import Text.ParserCombinators.Parsec.Error
24import Text.ParserCombinators.Parsec.Prim hiding ((<|>), many)
25import Text.ParserCombinators.Parsec.Prim hiding ((<|>), many)
25
26
26−instance Applicative (GenParser s a) where
27+type Comment = String
27− pure = return
28− (<*>) = ap
29−
30−instance Alternative (GenParser s a) where
31− empty = mzero
32− (<|>) = mplus
33
28
34unichar :: Parser Char
29unichar :: Parser Char
35unichar = chr . fst . head . readHex <$> many1 hexDigit
30unichar = chr . fst . head . readHex <$> many1 hexDigit
@@ -40,7 +35,7 @@ unichars = manyTill (unichar <* spaces) semi
40semi :: Parser ()
35semi :: Parser ()
41semi = char ';' *> spaces *> pure ()
36semi = char ';' *> spaces *> pure ()
42
37
43−comment :: Parser String
38+comment :: Parser Comment
44comment = (char '#' *> manyTill anyToken (char '\n')) <|> string "\n"
39comment = (char '#' *> manyTill anyToken (char '\n')) <|> string "\n"
45
40
46showC :: Char -> String
41showC :: Char -> String
scripts/CaseFolding.hs+11−7
@@ -4,7 +4,8 @@
4
4
5module CaseFolding
5module CaseFolding
6 (
6 (
7+ CaseFolding(..)
7− Fold(..)
8+ , Fold(..)
8 , parseCF
9 , parseCF
9 , mapCF
10 , mapCF
10 ) where
11 ) where
@@ -18,22 +19,25 @@ data Fold = Fold {
18 , name :: String
19 , name :: String
19 } deriving (Eq, Ord, Show)
20 } deriving (Eq, Ord, Show)
20
21
22+data CaseFolding = CF { cfComments :: [Comment], cfFolding :: [Fold] }
23+ deriving (Show)
24+
21−entries :: Parser [Fold]
25+entries :: Parser CaseFolding
22−entries = many comment *> many (entry <* many comment)
26+entries = CF <$> many comment <*> many (entry <* many comment)
23 where
27 where
24 entry = Fold <$> unichar <* semi
28 entry = Fold <$> unichar <* semi
25 <*> oneOf "CFST" <* semi
29 <*> oneOf "CFST" <* semi
26 <*> unichars
30 <*> unichars
27 <*> (string "# " *> manyTill anyToken (char '\n'))
31 <*> (string "# " *> manyTill anyToken (char '\n'))
28
32
29−parseCF :: FilePath -> IO (Either ParseError [Fold])
33+parseCF :: FilePath -> IO (Either ParseError CaseFolding)
30parseCF name = parse entries name <$> readFile name
34parseCF name = parse entries name <$> readFile name
31
35
32−mapCF :: [Fold] -> [String]
36+mapCF :: CaseFolding -> [String]
33−mapCF ms = typ ++ (map nice . filter p $ ms) ++ [last]
37+mapCF (CF _ ms) = typ ++ (map nice . filter p $ ms) ++ [last]
34 where
38 where
35 typ = ["foldMapping :: forall s. Char -> s -> Step (CC s) Char"
39 typ = ["foldMapping :: forall s. Char -> s -> Step (CC s) Char"
36− ,"{-# INLINE foldMapping #-}"]
40+ ,"{-# NOINLINE foldMapping #-}"]
37 last = "foldMapping c s = Yield (toLower c) (CC s '\\0' '\\0')"
41 last = "foldMapping c s = Yield (toLower c) (CC s '\\0' '\\0')"
38 nice c = "-- " ++ name c ++ "\n" ++
42 nice c = "-- " ++ name c ++ "\n" ++
39 "foldMapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
43 "foldMapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
scripts/CaseMapping.hs+11−5
@@ -8,7 +8,7 @@ import SpecialCasing
8main = do
8main = do
9 args <- getArgs
9 args <- getArgs
10 let oname = case args of
10 let oname = case args of
11− [] -> "../Data/Text/Fusion/CaseMapping.hs"
11+ [] -> "../Data/Text/Internal/Fusion/CaseMapping.hs"
12 [o] -> o
12 [o] -> o
13 psc <- parseSC "SpecialCasing.txt"
13 psc <- parseSC "SpecialCasing.txt"
14 pcf <- parseCF "CaseFolding.txt"
14 pcf <- parseCF "CaseFolding.txt"
@@ -19,14 +19,20 @@ main = do
19 Left err -> print err >> return undefined
19 Left err -> print err >> return undefined
20 Right ms -> return ms
20 Right ms -> return ms
21 h <- openFile oname WriteMode
21 h <- openFile oname WriteMode
22+ let comments = map ("--" ++) $
23+ take 2 (cfComments cfs) ++ take 2 (scComments scs)
24+ mapM_ (hPutStrLn h) $
22− mapM_ (hPutStrLn h) ["{-# LANGUAGE Rank2Types #-}"
25+ ["{-# LANGUAGE Rank2Types #-}"
23 ,"-- AUTOMATICALLY GENERATED - DO NOT EDIT"
26 ,"-- AUTOMATICALLY GENERATED - DO NOT EDIT"
24− ,"-- Generated by scripts/SpecialCasing.hs"
27+ ,"-- Generated by scripts/CaseMapping.hs"] ++
28+ comments ++
29+ [""
25− ,"module Data.Text.Fusion.CaseMapping where"
30+ ,"module Data.Text.Internal.Fusion.CaseMapping where"
26 ,"import Data.Char"
31 ,"import Data.Char"
27− ,"import Data.Text.Fusion.Internal"
32+ ,"import Data.Text.Internal.Fusion.Types"
28 ,""]
33 ,""]
29 mapM_ (hPutStrLn h) (mapSC "upper" upper toUpper scs)
34 mapM_ (hPutStrLn h) (mapSC "upper" upper toUpper scs)
30 mapM_ (hPutStrLn h) (mapSC "lower" lower toLower scs)
35 mapM_ (hPutStrLn h) (mapSC "lower" lower toLower scs)
36+ mapM_ (hPutStrLn h) (mapSC "title" title toTitle scs)
31 mapM_ (hPutStrLn h) (mapCF cfs)
37 mapM_ (hPutStrLn h) (mapCF cfs)
32 hClose h
38 hClose h
scripts/SpecialCasing.hs+13−7
@@ -4,13 +4,17 @@
4
4
5module SpecialCasing
5module SpecialCasing
6 (
6 (
7+ SpecialCasing(..)
7− Case(..)
8+ , Case(..)
8 , parseSC
9 , parseSC
9 , mapSC
10 , mapSC
10 ) where
11 ) where
11
12
12import Arsec
13import Arsec
13
14
15+data SpecialCasing = SC { scComments :: [Comment], scCasing :: [Case] }
16+ deriving (Show)
17+
14data Case = Case {
18data Case = Case {
15 code :: Char
19 code :: Char
16 , lower :: [Char]
20 , lower :: [Char]
@@ -20,8 +24,8 @@ data Case = Case {
20 , name :: String
24 , name :: String
21 } deriving (Eq, Ord, Show)
25 } deriving (Eq, Ord, Show)
22
26
23−entries :: Parser [Case]
27+entries :: Parser SpecialCasing
24−entries = many comment *> many (entry <* many comment)
28+entries = SC <$> many comment <*> many (entry <* many comment)
25 where
29 where
26 entry = Case <$> unichar <* semi
30 entry = Case <$> unichar <* semi
27 <*> unichars
31 <*> unichars
@@ -30,14 +34,16 @@ entries = many comment *> many (entry <* many comment)
30 <*> manyTill anyToken (string "# ")
34 <*> manyTill anyToken (string "# ")
31 <*> manyTill anyToken (char '\n')
35 <*> manyTill anyToken (char '\n')
32
36
33−parseSC :: FilePath -> IO (Either ParseError [Case])
37+parseSC :: FilePath -> IO (Either ParseError SpecialCasing)
34parseSC name = parse entries name <$> readFile name
38parseSC name = parse entries name <$> readFile name
35
39
36−mapSC :: String -> (Case -> String) -> (Char -> Char) -> [Case] -> [String]
40+mapSC :: String -> (Case -> String) -> (Char -> Char) -> SpecialCasing
41+ -> [String]
37−mapSC which access twiddle ms = typ ++ (map nice . filter p $ ms) ++ [last]
42+mapSC which access twiddle (SC _ ms) =
43+ typ ++ (map nice . filter p $ ms) ++ [last]
38 where
44 where
39 typ = [which ++ "Mapping :: forall s. Char -> s -> Step (CC s) Char"
45 typ = [which ++ "Mapping :: forall s. Char -> s -> Step (CC s) Char"
40− ,"{-# INLINE " ++ which ++ "Mapping #-}"]
46+ ,"{-# NOINLINE " ++ which ++ "Mapping #-}"]
41 last = which ++ "Mapping c s = Yield (to" ++ ucFirst which ++ " c) (CC s '\\0' '\\0')"
47 last = which ++ "Mapping c s = Yield (to" ++ ucFirst which ++ " c) (CC s '\\0' '\\0')"
42 nice c = "-- " ++ name c ++ "\n" ++
48 nice c = "-- " ++ name c ++ "\n" ++
43 which ++ "Mapping " ++ showC (code c) ++ " s = Yield " ++ x ++ " (CC s " ++ y ++ " " ++ z ++ ")"
49 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)
1+count = 1000
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,')
19
2
20−cabal := $(shell which cabal 2>/dev/null)
3+all: coverage literal-rule-test
21
4
22−all: bm qc coverage regressions
5+literal-rule-test:
6+ ./literal-rule-test.sh
23
7
24−lib: $(lib)
8+coverage: build coverage/hpc_index.html
25
9
26−$(lib): $(lib-srcs:%=../%)
10+build: text-test-data
27−ifeq ($(cabal),)
28− cd .. && runghc Setup configure --user --prefix=$(HOME)
29− cd .. && runghc Setup build
30−else
31− cd .. && cabal configure
11+ cabal configure -fhpc
32− cd .. && cabal build
12+ cabal build
33−endif
34
13
35−Properties.o Regressions.o qc qc-hpc: ghc-flags += $(ghc-test-flags)
14+text-test-data:
36−Properties.o: QuickCheckUtils.o SlowFunctions.o TestUtils.o
15+ hg clone https://bitbucket.org/bos/text-test-data
16+ $(MAKE) -C text-test-data
37
17
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 $@
39
22
40−qc: Properties.o QuickCheckUtils.o SlowFunctions.o TestUtils.o
23+coverage/text-tests-stdio.tix:
41− $(ghc) $(ghc-flags) -threaded -o $@ $^ $(lib)
24+ -mkdir -p coverage
25+ ./scripts/cover-stdio.sh ./dist/build/text-tests-stdio/text-tests-stdio
26+ mv text-tests-stdio.tix $@
42
27
43−sb: SearchBench.o SlowFunctions.o
28+coverage/coverage.tix: coverage/text-tests.tix coverage/text-tests-stdio.tix
44− $(ghc) $(ghc-flags) -threaded -o $@ $^ $(lib)
29+ hpc combine --output=$@ \
30+ --exclude=Main \
31+ coverage/text-tests.tix \
32+ coverage/text-tests-stdio.tix
45
33
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
34+coverage/hpc_index.html: coverage/coverage.tix
61− @rm -f qc-hpc.tix stdio-hpc.tix coverage.tix
35+ hpc markup --destdir=coverage coverage/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
95
36
96clean:
37clean:
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−1206
@@ -1,1206 +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−sf_elem p c = (L.elem c . L.filter p) `eqP` (S.elem c . S.filter p)
595−sf_filter q p = (L.filter p . L.filter q) `eqP`
596− (unpackS . S.filter p . S.filter q)
597−t_filter p = L.filter p `eqP` (unpackS . T.filter p)
598−tl_filter p = L.filter p `eqP` (unpackS . TL.filter p)
599−sf_findBy q p = (L.find p . L.filter q) `eqP` (S.findBy p . S.filter q)
600−t_find p = L.find p `eqP` T.find p
601−tl_find p = L.find p `eqP` TL.find p
602−t_partition p = L.partition p `eqP` (unpack2 . T.partition p)
603−tl_partition p = L.partition p `eqP` (unpack2 . TL.partition p)
604−
605−sf_index p s = forAll (choose (-l,l*2))
606− ((L.filter p s L.!!) `eq` S.index (S.filter p $ packS s))
607− where l = L.length s
608−t_index s = forAll (choose (-l,l*2)) ((s L.!!) `eq` T.index (packS s))
609− where l = L.length s
610−
611−tl_index s = forAll (choose (-l,l*2))
612− ((s L.!!) `eq` (TL.index (packS s) . fromIntegral))
613− where l = L.length s
614−
615−t_findIndex p = L.findIndex p `eqP` T.findIndex p
616−t_count (NotEmpty t) = (subtract 1 . L.length . T.splitOn t) `eq` T.count t
617−tl_count (NotEmpty t) = (subtract 1 . L.genericLength . TL.splitOn t) `eq`
618− TL.count t
619−t_zip s = L.zip s `eqP` T.zip (packS s)
620−tl_zip s = L.zip s `eqP` TL.zip (packS s)
621−sf_zipWith p c s = (L.zipWith c (L.filter p s) . L.filter p) `eqP`
622− (unpackS . S.zipWith c (S.filter p $ packS s) . S.filter p)
623−t_zipWith c s = L.zipWith c s `eqP` (unpackS . T.zipWith c (packS s))
624−tl_zipWith c s = L.zipWith c s `eqP` (unpackS . TL.zipWith c (packS s))
625−
626−t_indices (NotEmpty s) = Slow.indices s `eq` indices s
627−tl_indices (NotEmpty s) = lazyIndices s `eq` S.indices s
628− where lazyIndices ss t = map fromIntegral $ Slow.indices (conc ss) (conc t)
629− conc = T.concat . TL.toChunks
630−t_indices_occurs (NotEmpty t) ts = let s = T.intercalate t ts
631− in Slow.indices t s == indices t s
632−
633−-- Bit shifts.
634−shiftL w = forAll (choose (0,width-1)) $ \k -> Bits.shiftL w k == U.shiftL w k
635− where width = round (log (fromIntegral m) / log 2 :: Double)
636− (m,_) = (maxBound, m == w)
637−shiftR w = forAll (choose (0,width-1)) $ \k -> Bits.shiftR w k == U.shiftR w k
638− where width = round (log (fromIntegral m) / log 2 :: Double)
639− (m,_) = (maxBound, m == w)
640−
641−shiftL_Int = shiftL :: Int -> Property
642−shiftL_Word16 = shiftL :: Word16 -> Property
643−shiftL_Word32 = shiftL :: Word32 -> Property
644−shiftR_Int = shiftR :: Int -> Property
645−shiftR_Word16 = shiftR :: Word16 -> Property
646−shiftR_Word32 = shiftR :: Word32 -> Property
647−
648−-- Builder.
649−
650−t_builderSingleton = id `eqP`
651− (unpackS . TB.toLazyText . mconcat . map TB.singleton)
652−t_builderFromText = L.concat `eq` (unpackS . TB.toLazyText . mconcat .
653− map (TB.fromText . packS))
654−t_builderAssociative s1 s2 s3 =
655− TB.toLazyText (b1 `mappend` (b2 `mappend` b3)) ==
656− TB.toLazyText ((b1 `mappend` b2) `mappend` b3)
657− where b1 = TB.fromText (packS s1)
658− b2 = TB.fromText (packS s2)
659− b3 = TB.fromText (packS s3)
660−
661−-- Reading.
662−
663−t_decimal (n::Int) s =
664− T.signed T.decimal (T.pack (show n) `T.append` t) == Right (n,t)
665− where t = T.dropWhile isDigit s
666−tl_decimal (n::Int) s =
667− TL.signed TL.decimal (TL.pack (show n) `TL.append` t) == Right (n,t)
668− where t = TL.dropWhile isDigit s
669−t_hexadecimal (n::Positive Int) s ox =
670− T.hexadecimal (T.concat [p, T.pack (showHex n ""), t]) == Right (n,t)
671− where t = T.dropWhile isHexDigit s
672− p = if ox then "0x" else ""
673−tl_hexadecimal (n::Positive Int) s ox =
674− TL.hexadecimal (TL.concat [p, TL.pack (showHex n ""), t]) == Right (n,t)
675− where t = TL.dropWhile isHexDigit s
676− p = if ox then "0x" else ""
677−
678−isFloaty c = c `elem` "+-.0123456789eE"
679−
680−t_read_rational p tol (n::Double) s =
681− case p (T.pack (show n) `T.append` t) of
682− Left _err -> False
683− Right (n',t') -> t == t' && abs (n-n') <= tol
684− where t = T.dropWhile isFloaty s
685−
686−tl_read_rational p tol (n::Double) s =
687− case p (TL.pack (show n) `TL.append` t) of
688− Left _err -> False
689− Right (n',t') -> t == t' && abs (n-n') <= tol
690− where t = TL.dropWhile isFloaty s
691−
692−t_double = t_read_rational T.double 1e-13
693−tl_double = tl_read_rational TL.double 1e-13
694−t_rational = t_read_rational T.rational 1e-16
695−tl_rational = tl_read_rational TL.rational 1e-16
696−
697−-- Input and output.
698−
699−-- Work around lack of Show instance for TextEncoding.
700−data Encoding = E String TextEncoding
701−
702−instance Show Encoding where show (E n _) = "utf" ++ n
703−
704−instance Arbitrary Encoding where
705− arbitrary = oneof . map return $
706− [ E "8" utf8, E "8_bom" utf8_bom, E "16" utf16, E "16le" utf16le,
707− E "16be" utf16be, E "32" utf32, E "32le" utf32le, E "32be" utf32be ]
708−
709−windowsNewlineMode = NewlineMode { inputNL = CRLF, outputNL = CRLF }
710−
711−instance Show Newline where
712− show CRLF = "CRLF"
713− show LF = "LF"
714−
715−instance Show NewlineMode where
716− show (NewlineMode i o) = "NewlineMode { inputNL = " ++ show i ++
717− ", outputNL = " ++ show o ++ " }"
718−
719−instance Arbitrary NewlineMode where
720− arbitrary = oneof . map return $
721− [ noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
722− windowsNewlineMode ]
723−
724−instance Arbitrary BufferMode where
725− arbitrary = oneof [ return NoBuffering,
726− return LineBuffering,
727− return (BlockBuffering Nothing),
728− (BlockBuffering . Just . (+1) . fromIntegral) `fmap`
729− (arbitrary :: Gen Word16) ]
730−
731−-- This test harness is complex! What property are we checking?
732−--
733−-- Reading after writing a multi-line file should give the same
734−-- results as were written.
735−--
736−-- What do we vary while checking this property?
737−-- * The lines themselves, scrubbed to contain neither CR nor LF. (By
738−-- working with a list of lines, we ensure that the data will
739−-- sometimes contain line endings.)
740−-- * Encoding.
741−-- * Newline translation mode.
742−-- * Buffering.
743−write_read unline filt writer reader (E _ enc) nl buf ts =
744− monadicIO $ assert . (==t) =<< run act
745− where t = unline . map (filt (not . (`elem` "\r\n"))) $ ts
746− act = withTempFile $ \path h -> do
747− hSetEncoding h enc
748− hSetNewlineMode h nl
749− hSetBuffering h buf
750− () <- writer h t
751− hClose h
752− bracket (openFile path ReadMode) hClose $ \h' -> do
753− hSetEncoding h' enc
754− hSetNewlineMode h' nl
755− hSetBuffering h' buf
756− r <- reader h'
757− r `deepseq` return r
758−
759−t_put_get = write_read T.unlines T.filter put get
760− where put h = withRedirect h stdout . T.putStr
761− get h = withRedirect h stdin T.getContents
762−tl_put_get = write_read TL.unlines TL.filter put get
763− where put h = withRedirect h stdout . TL.putStr
764− get h = withRedirect h stdin TL.getContents
765−t_write_read = write_read T.unlines T.filter T.hPutStr T.hGetContents
766−tl_write_read = write_read TL.unlines TL.filter TL.hPutStr TL.hGetContents
767−
768−t_write_read_line e m b t = write_read head T.filter T.hPutStrLn
769− T.hGetLine e m b [t]
770−tl_write_read_line e m b t = write_read head TL.filter TL.hPutStrLn
771− TL.hGetLine e m b [t]
772−
773−-- Low-level.
774−
775−t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t
776−t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t
777−t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) == t
778− where n = small m
779−t_use_from t = monadicIO $ assert . (==t) =<< run (useAsPtr t fromPtr)
780−
781−-- Regression tests.
782−s_filter_eq s = S.filter p t == S.streamList (filter p s)
783− where p = (/= S.last t)
784− t = S.streamList s
785−
786−-- Make a stream appear shorter than it really is, to ensure that
787−-- functions that consume inaccurately sized streams behave
788−-- themselves.
789−shorten :: Int -> S.Stream a -> S.Stream a
790−shorten n t@(S.Stream arr off len)
791− | n > 0 = S.Stream arr off (smaller (exactSize n) len)
792− | otherwise = t
793−
794−main = defaultMain tests
795−
796−tests = [
797− testGroup "creation/elimination" [
798− testProperty "t_pack_unpack" t_pack_unpack,
799− testProperty "tl_pack_unpack" tl_pack_unpack,
800− testProperty "t_stream_unstream" t_stream_unstream,
801− testProperty "tl_stream_unstream" tl_stream_unstream,
802− testProperty "t_reverse_stream" t_reverse_stream,
803− testProperty "t_singleton" t_singleton,
804− testProperty "tl_singleton" tl_singleton,
805− testProperty "tl_unstreamChunks" tl_unstreamChunks,
806− testProperty "tl_chunk_unchunk" tl_chunk_unchunk,
807− testProperty "tl_from_to_strict" tl_from_to_strict
808− ],
809−
810− testGroup "transcoding" [
811− testProperty "t_ascii" t_ascii,
812− testProperty "tl_ascii" tl_ascii,
813− testProperty "t_utf8" t_utf8,
814− testProperty "tl_utf8" tl_utf8,
815− testProperty "t_utf16LE" t_utf16LE,
816− testProperty "tl_utf16LE" tl_utf16LE,
817− testProperty "t_utf16BE" t_utf16BE,
818− testProperty "tl_utf16BE" tl_utf16BE,
819− testProperty "t_utf32LE" t_utf32LE,
820− testProperty "tl_utf32LE" tl_utf32LE,
821− testProperty "t_utf32BE" t_utf32BE,
822− testProperty "tl_utf32BE" tl_utf32BE,
823− testGroup "errors" [
824− testProperty "t_utf8_err" t_utf8_err
825− ]
826− ],
827−
828− testGroup "instances" [
829− testProperty "s_Eq" s_Eq,
830− testProperty "sf_Eq" sf_Eq,
831− testProperty "t_Eq" t_Eq,
832− testProperty "tl_Eq" tl_Eq,
833− testProperty "s_Ord" s_Ord,
834− testProperty "sf_Ord" sf_Ord,
835− testProperty "t_Ord" t_Ord,
836− testProperty "tl_Ord" tl_Ord,
837− testProperty "t_Read" t_Read,
838− testProperty "tl_Read" tl_Read,
839− testProperty "t_Show" t_Show,
840− testProperty "tl_Show" tl_Show,
841− testProperty "t_mappend" t_mappend,
842− testProperty "tl_mappend" tl_mappend,
843− testProperty "t_mconcat" t_mconcat,
844− testProperty "tl_mconcat" tl_mconcat,
845− testProperty "t_mempty" t_mempty,
846− testProperty "tl_mempty" tl_mempty,
847− testProperty "t_IsString" t_IsString,
848− testProperty "tl_IsString" tl_IsString
849− ],
850−
851− testGroup "basics" [
852− testProperty "s_cons" s_cons,
853− testProperty "s_cons_s" s_cons_s,
854− testProperty "sf_cons" sf_cons,
855− testProperty "t_cons" t_cons,
856− testProperty "tl_cons" tl_cons,
857− testProperty "s_snoc" s_snoc,
858− testProperty "t_snoc" t_snoc,
859− testProperty "tl_snoc" tl_snoc,
860− testProperty "s_append" s_append,
861− testProperty "s_append_s" s_append_s,
862− testProperty "sf_append" sf_append,
863− testProperty "t_append" t_append,
864− testProperty "s_uncons" s_uncons,
865− testProperty "sf_uncons" sf_uncons,
866− testProperty "t_uncons" t_uncons,
867− testProperty "tl_uncons" tl_uncons,
868− testProperty "s_head" s_head,
869− testProperty "sf_head" sf_head,
870− testProperty "t_head" t_head,
871− testProperty "tl_head" tl_head,
872− testProperty "s_last" s_last,
873− testProperty "sf_last" sf_last,
874− testProperty "t_last" t_last,
875− testProperty "tl_last" tl_last,
876− testProperty "s_tail" s_tail,
877− testProperty "s_tail_s" s_tail_s,
878− testProperty "sf_tail" sf_tail,
879− testProperty "t_tail" t_tail,
880− testProperty "tl_tail" tl_tail,
881− testProperty "s_init" s_init,
882− testProperty "s_init_s" s_init_s,
883− testProperty "sf_init" sf_init,
884− testProperty "t_init" t_init,
885− testProperty "tl_init" tl_init,
886− testProperty "s_null" s_null,
887− testProperty "sf_null" sf_null,
888− testProperty "t_null" t_null,
889− testProperty "tl_null" tl_null,
890− testProperty "s_length" s_length,
891− testProperty "sf_length" sf_length,
892− testProperty "sl_length" sl_length,
893− testProperty "t_length" t_length,
894− testProperty "tl_length" tl_length,
895− testProperty "t_compareLength" t_compareLength,
896− testProperty "tl_compareLength" tl_compareLength
897− ],
898−
899− testGroup "transformations" [
900− testProperty "s_map" s_map,
901− testProperty "s_map_s" s_map_s,
902− testProperty "sf_map" sf_map,
903− testProperty "t_map" t_map,
904− testProperty "tl_map" tl_map,
905− testProperty "t_intercalate" t_intercalate,
906− testProperty "tl_intercalate" tl_intercalate,
907− testProperty "s_intersperse" s_intersperse,
908− testProperty "s_intersperse_s" s_intersperse_s,
909− testProperty "sf_intersperse" sf_intersperse,
910− testProperty "t_intersperse" t_intersperse,
911− testProperty "tl_intersperse" tl_intersperse,
912− testProperty "t_transpose" t_transpose,
913− testProperty "tl_transpose" tl_transpose,
914− testProperty "t_reverse" t_reverse,
915− testProperty "tl_reverse" tl_reverse,
916− testProperty "t_reverse_short" t_reverse_short,
917− testProperty "t_replace" t_replace,
918− testProperty "tl_replace" tl_replace,
919−
920− testGroup "case conversion" [
921− testProperty "s_toCaseFold_length" s_toCaseFold_length,
922− testProperty "sf_toCaseFold_length" sf_toCaseFold_length,
923− testProperty "t_toCaseFold_length" t_toCaseFold_length,
924− testProperty "tl_toCaseFold_length" tl_toCaseFold_length,
925− testProperty "t_toLower_length" t_toLower_length,
926− testProperty "t_toLower_lower" t_toLower_lower,
927− testProperty "tl_toLower_lower" tl_toLower_lower,
928− testProperty "t_toUpper_length" t_toUpper_length,
929− testProperty "t_toUpper_upper" t_toUpper_upper,
930− testProperty "tl_toUpper_upper" tl_toUpper_upper
931− ],
932−
933− testGroup "justification" [
934− testProperty "s_justifyLeft" s_justifyLeft,
935− testProperty "s_justifyLeft_s" s_justifyLeft_s,
936− testProperty "sf_justifyLeft" sf_justifyLeft,
937− testProperty "t_justifyLeft" t_justifyLeft,
938− testProperty "tl_justifyLeft" tl_justifyLeft,
939− testProperty "t_justifyRight" t_justifyRight,
940− testProperty "tl_justifyRight" tl_justifyRight,
941− testProperty "t_center" t_center,
942− testProperty "tl_center" tl_center
943− ]
944− ],
945−
946− testGroup "folds" [
947− testProperty "sf_foldl" sf_foldl,
948− testProperty "t_foldl" t_foldl,
949− testProperty "tl_foldl" tl_foldl,
950− testProperty "sf_foldl'" sf_foldl',
951− testProperty "t_foldl'" t_foldl',
952− testProperty "tl_foldl'" tl_foldl',
953− testProperty "sf_foldl1" sf_foldl1,
954− testProperty "t_foldl1" t_foldl1,
955− testProperty "tl_foldl1" tl_foldl1,
956− testProperty "t_foldl1'" t_foldl1',
957− testProperty "sf_foldl1'" sf_foldl1',
958− testProperty "tl_foldl1'" tl_foldl1',
959− testProperty "sf_foldr" sf_foldr,
960− testProperty "t_foldr" t_foldr,
961− testProperty "tl_foldr" tl_foldr,
962− testProperty "sf_foldr1" sf_foldr1,
963− testProperty "t_foldr1" t_foldr1,
964− testProperty "tl_foldr1" tl_foldr1,
965−
966− testGroup "special" [
967− testProperty "s_concat_s" s_concat_s,
968− testProperty "sf_concat" sf_concat,
969− testProperty "t_concat" t_concat,
970− testProperty "tl_concat" tl_concat,
971− testProperty "sf_concatMap" sf_concatMap,
972− testProperty "t_concatMap" t_concatMap,
973− testProperty "tl_concatMap" tl_concatMap,
974− testProperty "sf_any" sf_any,
975− testProperty "t_any" t_any,
976− testProperty "tl_any" tl_any,
977− testProperty "sf_all" sf_all,
978− testProperty "t_all" t_all,
979− testProperty "tl_all" tl_all,
980− testProperty "sf_maximum" sf_maximum,
981− testProperty "t_maximum" t_maximum,
982− testProperty "tl_maximum" tl_maximum,
983− testProperty "sf_minimum" sf_minimum,
984− testProperty "t_minimum" t_minimum,
985− testProperty "tl_minimum" tl_minimum
986− ]
987− ],
988−
989− testGroup "construction" [
990− testGroup "scans" [
991− testProperty "sf_scanl" sf_scanl,
992− testProperty "t_scanl" t_scanl,
993− testProperty "tl_scanl" tl_scanl,
994− testProperty "t_scanl1" t_scanl1,
995− testProperty "tl_scanl1" tl_scanl1,
996− testProperty "t_scanr" t_scanr,
997− testProperty "tl_scanr" tl_scanr,
998− testProperty "t_scanr1" t_scanr1,
999− testProperty "tl_scanr1" tl_scanr1
1000− ],
1001−
1002− testGroup "mapAccum" [
1003− testProperty "t_mapAccumL" t_mapAccumL,
1004− testProperty "tl_mapAccumL" tl_mapAccumL,
1005− testProperty "t_mapAccumR" t_mapAccumR,
1006− testProperty "tl_mapAccumR" tl_mapAccumR
1007− ],
1008−
1009− testGroup "unfolds" [
1010− testProperty "t_replicate" t_replicate,
1011− testProperty "tl_replicate" tl_replicate,
1012− testProperty "t_unfoldr" t_unfoldr,
1013− testProperty "tl_unfoldr" tl_unfoldr,
1014− testProperty "t_unfoldrN" t_unfoldrN,
1015− testProperty "tl_unfoldrN" tl_unfoldrN
1016− ]
1017− ],
1018−
1019− testGroup "substrings" [
1020− testGroup "breaking" [
1021− testProperty "s_take" s_take,
1022− testProperty "s_take_s" s_take_s,
1023− testProperty "sf_take" sf_take,
1024− testProperty "t_take" t_take,
1025− testProperty "tl_take" tl_take,
1026− testProperty "s_drop" s_drop,
1027− testProperty "s_drop_s" s_drop_s,
1028− testProperty "sf_drop" sf_drop,
1029− testProperty "t_drop" t_drop,
1030− testProperty "tl_drop" tl_drop,
1031− testProperty "s_take_drop" s_take_drop,
1032− testProperty "s_take_drop_s" s_take_drop_s,
1033− testProperty "s_takeWhile" s_takeWhile,
1034− testProperty "s_takeWhile_s" s_takeWhile_s,
1035− testProperty "sf_takeWhile" sf_takeWhile,
1036− testProperty "t_takeWhile" t_takeWhile,
1037− testProperty "tl_takeWhile" tl_takeWhile,
1038− testProperty "sf_dropWhile" sf_dropWhile,
1039− testProperty "s_dropWhile" s_dropWhile,
1040− testProperty "s_dropWhile_s" s_dropWhile_s,
1041− testProperty "t_dropWhile" t_dropWhile,
1042− testProperty "tl_dropWhile" tl_dropWhile,
1043− testProperty "t_dropWhileEnd" t_dropWhileEnd,
1044− testProperty "tl_dropWhileEnd" tl_dropWhileEnd,
1045− testProperty "t_dropAround" t_dropAround,
1046− testProperty "tl_dropAround" tl_dropAround,
1047− testProperty "t_stripStart" t_stripStart,
1048− testProperty "tl_stripStart" tl_stripStart,
1049− testProperty "t_stripEnd" t_stripEnd,
1050− testProperty "tl_stripEnd" tl_stripEnd,
1051− testProperty "t_strip" t_strip,
1052− testProperty "tl_strip" tl_strip,
1053− testProperty "t_splitAt" t_splitAt,
1054− testProperty "tl_splitAt" tl_splitAt,
1055− testProperty "t_span" t_span,
1056− testProperty "tl_span" tl_span,
1057− testProperty "t_breakOn_id" t_breakOn_id,
1058− testProperty "tl_breakOn_id" tl_breakOn_id,
1059− testProperty "t_breakOn_start" t_breakOn_start,
1060− testProperty "tl_breakOn_start" tl_breakOn_start,
1061− testProperty "t_breakOnEnd_end" t_breakOnEnd_end,
1062− testProperty "tl_breakOnEnd_end" tl_breakOnEnd_end,
1063− testProperty "t_break" t_break,
1064− testProperty "tl_break" tl_break,
1065− testProperty "t_group" t_group,
1066− testProperty "tl_group" tl_group,
1067− testProperty "t_groupBy" t_groupBy,
1068− testProperty "tl_groupBy" tl_groupBy,
1069− testProperty "t_inits" t_inits,
1070− testProperty "tl_inits" tl_inits,
1071− testProperty "t_tails" t_tails,
1072− testProperty "tl_tails" tl_tails
1073− ],
1074−
1075− testGroup "breaking many" [
1076− testProperty "t_findAppendId" t_findAppendId,
1077− testProperty "tl_findAppendId" tl_findAppendId,
1078− testProperty "t_findContains" t_findContains,
1079− testProperty "tl_findContains" tl_findContains,
1080− testProperty "sl_filterCount" sl_filterCount,
1081− testProperty "t_findCount" t_findCount,
1082− testProperty "tl_findCount" tl_findCount,
1083− testProperty "t_splitOn_split" t_splitOn_split,
1084− testProperty "tl_splitOn_split" tl_splitOn_split,
1085− testProperty "t_splitOn_i" t_splitOn_i,
1086− testProperty "tl_splitOn_i" tl_splitOn_i,
1087− testProperty "t_split" t_split,
1088− testProperty "t_split_count" t_split_count,
1089− testProperty "t_split_splitOn" t_split_splitOn,
1090− testProperty "tl_split" tl_split,
1091− testProperty "t_chunksOf_same_lengths" t_chunksOf_same_lengths,
1092− testProperty "t_chunksOf_length" t_chunksOf_length,
1093− testProperty "tl_chunksOf" tl_chunksOf
1094− ],
1095−
1096− testGroup "lines and words" [
1097− testProperty "t_lines" t_lines,
1098− testProperty "tl_lines" tl_lines,
1099− --testProperty "t_lines'" t_lines',
1100− testProperty "t_words" t_words,
1101− testProperty "tl_words" tl_words,
1102− testProperty "t_unlines" t_unlines,
1103− testProperty "tl_unlines" tl_unlines,
1104− testProperty "t_unwords" t_unwords,
1105− testProperty "tl_unwords" tl_unwords
1106− ]
1107− ],
1108−
1109− testGroup "predicates" [
1110− testProperty "s_isPrefixOf" s_isPrefixOf,
1111− testProperty "sf_isPrefixOf" sf_isPrefixOf,
1112− testProperty "t_isPrefixOf" t_isPrefixOf,
1113− testProperty "tl_isPrefixOf" tl_isPrefixOf,
1114− testProperty "t_isSuffixOf" t_isSuffixOf,
1115− testProperty "tl_isSuffixOf" tl_isSuffixOf,
1116− testProperty "t_isInfixOf" t_isInfixOf,
1117− testProperty "tl_isInfixOf" tl_isInfixOf,
1118−
1119− testGroup "view" [
1120− testProperty "t_stripPrefix" t_stripPrefix,
1121− testProperty "tl_stripPrefix" tl_stripPrefix,
1122− testProperty "t_stripSuffix" t_stripSuffix,
1123− testProperty "tl_stripSuffix" tl_stripSuffix
1124− ]
1125− ],
1126−
1127− testGroup "searching" [
1128− testProperty "sf_elem" sf_elem,
1129− testProperty "sf_filter" sf_filter,
1130− testProperty "t_filter" t_filter,
1131− testProperty "tl_filter" tl_filter,
1132− testProperty "sf_findBy" sf_findBy,
1133− testProperty "t_find" t_find,
1134− testProperty "tl_find" tl_find,
1135− testProperty "t_partition" t_partition,
1136− testProperty "tl_partition" tl_partition
1137− ],
1138−
1139− testGroup "indexing" [
1140− testProperty "sf_index" sf_index,
1141− testProperty "t_index" t_index,
1142− testProperty "tl_index" tl_index,
1143− testProperty "t_findIndex" t_findIndex,
1144− testProperty "t_count" t_count,
1145− testProperty "tl_count" tl_count,
1146− testProperty "t_indices" t_indices,
1147− testProperty "tl_indices" tl_indices,
1148− testProperty "t_indices_occurs" t_indices_occurs
1149− ],
1150−
1151− testGroup "zips" [
1152− testProperty "t_zip" t_zip,
1153− testProperty "tl_zip" tl_zip,
1154− testProperty "sf_zipWith" sf_zipWith,
1155− testProperty "t_zipWith" t_zipWith,
1156− testProperty "tl_zipWith" tl_zipWith
1157− ],
1158−
1159− testGroup "regressions" [
1160− testProperty "s_filter_eq" s_filter_eq
1161− ],
1162−
1163− testGroup "shifts" [
1164− testProperty "shiftL_Int" shiftL_Int,
1165− testProperty "shiftL_Word16" shiftL_Word16,
1166− testProperty "shiftL_Word32" shiftL_Word32,
1167− testProperty "shiftR_Int" shiftR_Int,
1168− testProperty "shiftR_Word16" shiftR_Word16,
1169− testProperty "shiftR_Word32" shiftR_Word32
1170− ],
1171−
1172− testGroup "builder" [
1173− testProperty "t_builderSingleton" t_builderSingleton,
1174− testProperty "t_builderFromText" t_builderFromText,
1175− testProperty "t_builderAssociative" t_builderAssociative
1176− ],
1177−
1178− testGroup "read" [
1179− testProperty "t_decimal" t_decimal,
1180− testProperty "tl_decimal" tl_decimal,
1181− testProperty "t_hexadecimal" t_hexadecimal,
1182− testProperty "tl_hexadecimal" tl_hexadecimal,
1183− testProperty "t_double" t_double,
1184− testProperty "tl_double" tl_double,
1185− testProperty "t_rational" t_rational,
1186− testProperty "tl_rational" tl_rational
1187− ],
1188−
1189− testGroup "input-output" [
1190− testProperty "t_write_read" t_write_read,
1191− testProperty "tl_write_read" tl_write_read,
1192− testProperty "t_write_read_line" t_write_read_line,
1193− testProperty "tl_write_read_line" tl_write_read_line
1194− -- These tests are subject to I/O race conditions when run under
1195− -- test-framework-quickcheck2.
1196− -- testProperty "t_put_get" t_put_get
1197− -- testProperty "tl_put_get" tl_put_get
1198− ],
1199−
1200− testGroup "lowlevel" [
1201− testProperty "t_dropWord16" t_dropWord16,
1202− testProperty "t_takeWord16" t_takeWord16,
1203− testProperty "t_take_drop_16" t_take_drop_16,
1204− testProperty "t_use_from" t_use_from
1205− ]
1206− ]
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)
1import qualified Data.Text as T
12import qualified Data.Text as T
2import qualified Data.Text.IO as T
13import qualified Data.Text.IO as T
3import qualified Data.Text.Lazy as TL
14import qualified Data.Text.Lazy as TL
4import qualified Data.Text.Lazy.IO as TL
15import qualified Data.Text.Lazy.IO as TL
5−import System.Environment (getArgs)
6−import System.Exit (exitFailure)
7−import System.IO (hPutStrLn, stderr)
8
16
17+main :: IO ()
9main = do
18main = do
10 args <- getArgs
19 args <- getArgs
11 case args of
20 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+--
1{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
3{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
2−
4+module Tests.Regressions
3−-- Regression tests for specific bugs.
5+ (
6+ tests
7+ ) where
4
8
5import Control.Exception (SomeException, handle)
9import Control.Exception (SomeException, handle)
6import System.IO
10import System.IO
11+import Test.HUnit (assertBool, assertEqual, assertFailure)
7import qualified Data.ByteString as B
12import qualified Data.ByteString as B
13+import Data.ByteString.Char8 ()
8import qualified Data.ByteString.Lazy as LB
14import qualified Data.ByteString.Lazy as LB
9import qualified Data.Text as T
15import qualified Data.Text as T
16+import qualified Data.Text.Encoding as TE
10import qualified Data.Text.IO as T
17import qualified Data.Text.IO as T
11import qualified Data.Text.Lazy as LT
18import qualified Data.Text.Lazy as LT
12import qualified Data.Text.Lazy.Encoding as LE
19import qualified Data.Text.Lazy.Encoding as LE
20+import qualified Data.Text.Unsafe as T
13import qualified Test.Framework as F
21import qualified Test.Framework as F
14import qualified Test.Framework.Providers.HUnit as F
22import qualified Test.Framework.Providers.HUnit as F
15−import Test.HUnit (assertFailure)
23+
16−import TestUtils (withTempFile)
24+import Tests.Utils (withTempFile)
17
25
18-- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring
26-- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring
19-- caused either a segfault or attempt to allocate a negative number
27-- caused either a segfault or attempt to allocate a negative number
20-- of bytes.
28-- of bytes.
29+lazy_encode_crash :: IO ()
21lazy_encode_crash = withTempFile $ \ _ h ->
30lazy_encode_crash = withTempFile $ \ _ h ->
22 LB.hPut h . LE.encodeUtf8 . LT.pack . replicate 100000 $ 'a'
31 LB.hPut h . LE.encodeUtf8 . LT.pack . replicate 100000 $ 'a'
23
32
24-- Reported by Pieter Laeremans: attempting to read an incorrectly
33-- Reported by Pieter Laeremans: attempting to read an incorrectly
25-- encoded file can result in a crash in the RTS (i.e. not merely an
34-- encoded file can result in a crash in the RTS (i.e. not merely an
26-- exception).
35-- exception).
36+hGetContents_crash :: IO ()
27hGetContents_crash = withTempFile $ \ path h -> do
37hGetContents_crash = withTempFile $ \ path h -> do
28 B.hPut h (B.pack [0x78, 0xc4 ,0x0a]) >> hClose h
38 B.hPut h (B.pack [0x78, 0xc4 ,0x0a]) >> hClose h
29 h' <- openFile path ReadMode
39 h' <- openFile path ReadMode
@@ -34,6 +44,7 @@ hGetContents_crash = withTempFile $ \ path h -> do
34-- Reported by Ian Lynagh: attempting to allocate a sufficiently large
44-- Reported by Ian Lynagh: attempting to allocate a sufficiently large
35-- string (via either Array.new or Text.replicate) could result in an
45-- string (via either Array.new or Text.replicate) could result in an
36-- integer overflow.
46-- integer overflow.
47+replicate_crash :: IO ()
37replicate_crash = handle (\(_::SomeException) -> return ()) $
48replicate_crash = handle (\(_::SomeException) -> return ()) $
38 T.replicate (2^power) "0123456789abcdef" `seq`
49 T.replicate (2^power) "0123456789abcdef" `seq`
39 assertFailure "T.replicate should crash"
50 assertFailure "T.replicate should crash"
@@ -41,11 +52,31 @@ replicate_crash = handle (\(_::SomeException) -> return ()) $
41 power | maxBound == (2147483647::Int) = 28
52 power | maxBound == (2147483647::Int) = 28
42 | otherwise = 60 :: Int
53 | otherwise = 60 :: Int
43
54
44−tests :: F.Test
55+-- Reported by John Millikin: a UTF-8 decode error handler could
45−tests = F.testGroup "crashers" [
56+-- return a bogus substitution character, which we would write without
46− F.testCase "hGetContents_crash" hGetContents_crash
57+-- checking.
47− , F.testCase "lazy_encode_crash" lazy_encode_crash
58+utf8_decode_unsafe :: IO ()
48− , F.testCase "replicate_crash" replicate_crash
59+utf8_decode_unsafe = do
49− ]
60+ let t = TE.decodeUtf8With (\_ _ -> Just '\xdc00') "\x80"
61+ assertBool "broken error recovery shouldn't break us" (t == "\xfffd")
50
62
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 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2−
3−module SlowFunctions
2+module Tests.SlowFunctions
4 (
3 (
5 indices
4 indices
6 , splitOn
5 , 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 @@
1#!/bin/bash
1#!/bin/bash
2
2
3+if [[ $# < 1 ]]; then
4+ echo "Usage: $0 <exe>"
5+ exit 1
6+fi
7+
3−exe=./stdio-hpc
8+exe=$1
4
9
5rm -f $exe.tix
10rm -f $exe.tix
6
11
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+141−76
@@ -1,9 +1,9 @@
1name: text
1name: text
2−version: 0.11.0.0
2+version: 1.2.2.1
3−homepage: http://bitbucket.org/bos/text
3+homepage: https://github.com/bos/text
4−bug-reports: http://bitbucket.org/bos/text/issues
4+bug-reports: https://github.com/bos/text/issues
5synopsis: An efficient packed Unicode text type.
5synopsis: An efficient packed Unicode text type.
6−description:
6+description:
7 .
7 .
8 An efficient packed, immutable Unicode text type (both strict and
8 An efficient packed, immutable Unicode text type (both strict and
9 lazy), with a powerful loop fusion optimization framework.
9 lazy), with a powerful loop fusion optimization framework.
@@ -30,114 +30,179 @@ description:
30 non-standard encodings, text breaking, and locales), see
30 non-standard encodings, text breaking, and locales), see
31 the @text-icu@ package:
31 the @text-icu@ package:
32 <http://hackage.haskell.org/package/text-icu>
32 <http://hackage.haskell.org/package/text-icu>
33− .
33+
34−license: BSD3
34+license: BSD2
35license-file: LICENSE
35license-file: LICENSE
36author: Bryan O'Sullivan <bos@serpentine.com>
36author: Bryan O'Sullivan <bos@serpentine.com>
37maintainer: Bryan O'Sullivan <bos@serpentine.com>
37maintainer: 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
41category: Data, Text
39category: Data, Text
42build-type: Simple
40build-type: Simple
43−cabal-version: >= 1.6
41+cabal-version: >= 1.8
44extra-source-files:
42extra-source-files:
45− README.markdown
46 -- scripts/CaseFolding.txt
43 -- scripts/CaseFolding.txt
47 -- scripts/SpecialCasing.txt
44 -- scripts/SpecialCasing.txt
48− scripts/ApiCompare.hs
45+ README.markdown
49− scripts/Arsec.hs
46+ benchmarks/Setup.hs
50− scripts/CaseFolding.hs
47+ benchmarks/cbits/*.c
51− scripts/CaseMapping.hs
48+ benchmarks/haskell/*.hs
52− scripts/SpecialCasing.hs
49+ benchmarks/haskell/Benchmarks/*.hs
53− tests/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
54 tests/Makefile
60 tests/Makefile
61+ tests/Tests/*.hs
55− tests/Properties.hs
62+ tests/Tests/Properties/*.hs
56− tests/QuickCheckUtils.hs
63+ tests/cabal.config
57− tests/SlowFunctions.hs
64+ tests/scripts/*.sh
58− tests/StdioCoverage.hs
65+ tests/text-tests.cabal
59− tests/TestUtils.hs
66+
60− tests/benchmarks/Cut.hs
67+flag bytestring-builder
61− tests/benchmarks/DecodeUtf8.hs
68+ description: Depend on the bytestring-builder package for backwards compatibility.
62− tests/benchmarks/EncodeUtf8.hs
69+ default: False
63− tests/benchmarks/Equality.hs
70+ manual: False
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
74
71
75flag developer
72flag developer
76 description: operate in developer mode
73 description: operate in developer mode
77 default: False
74 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
78
81
79library
82library
83+ c-sources: cbits/cbits.c
84+ include-dirs: include
85+
80 exposed-modules:
86 exposed-modules:
81 Data.Text
87 Data.Text
88+ Data.Text.Array
82 Data.Text.Encoding
89 Data.Text.Encoding
83 Data.Text.Encoding.Error
90 Data.Text.Encoding.Error
84 Data.Text.Foreign
91 Data.Text.Foreign
85 Data.Text.IO
92 Data.Text.IO
93+ 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
86 Data.Text.Lazy
120 Data.Text.Lazy
87 Data.Text.Lazy.Builder
121 Data.Text.Lazy.Builder
122+ Data.Text.Lazy.Builder.Int
123+ Data.Text.Lazy.Builder.RealFloat
88 Data.Text.Lazy.Encoding
124 Data.Text.Lazy.Encoding
89 Data.Text.Lazy.IO
125 Data.Text.Lazy.IO
126+ Data.Text.Lazy.Internal
90 Data.Text.Lazy.Read
127 Data.Text.Lazy.Read
91 Data.Text.Read
128 Data.Text.Read
92− other-modules:
93− Data.Text.Array
94− Data.Text.Encoding.Fusion
95− Data.Text.Encoding.Fusion.Common
96− Data.Text.Encoding.Utf16
97− Data.Text.Encoding.Utf32
98− Data.Text.Encoding.Utf8
99− Data.Text.Fusion
100− Data.Text.Fusion.CaseMapping
101− Data.Text.Fusion.Common
102− Data.Text.Fusion.Internal
103− Data.Text.Fusion.Size
104− Data.Text.IO.Internal
105− Data.Text.Internal
106− Data.Text.Lazy.Encoding.Fusion
107− Data.Text.Lazy.Fusion
108− Data.Text.Lazy.Internal
109− Data.Text.Lazy.Search
110− Data.Text.Search
111 Data.Text.Unsafe
129 Data.Text.Unsafe
112− Data.Text.UnsafeChar
130+
113− Data.Text.UnsafeShift
131+ other-modules:
114− Data.Text.Util
132+ Data.Text.Show
115
133
116 build-depends:
134 build-depends:
135+ array >= 0.3,
117− base < 5,
136+ base >= 4.2 && < 5,
118− bytestring >= 0.9 && < 1.0
137+ binary,
119− if impl(ghc >= 6.10)
138+ deepseq >= 1.1.0.0,
120− build-depends:
121− ghc-prim, base >= 4, deepseq >= 1.1.0.0
139+ ghc-prim >= 0.2
122− cpp-options: -DHAVE_DEEPSEQ
123− else
124− build-depends: extensible-exceptions
125− extensions: PatternSignatures
126
140
127− -- gather extensive profiling data for now
141+ if flag(bytestring-builder)
128− ghc-prof-options: -auto-all
142+ build-depends: bytestring >= 0.9 && < 0.10.4,
143+ bytestring-builder >= 0.10.4
144+ else
145+ build-depends: bytestring >= 0.10.4
129
146
147+ cpp-options: -DHAVE_DEEPSEQ
130− ghc-options: -Wall -funbox-strict-fields -O2
148+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
131− if impl(ghc >= 6.8)
132− ghc-options: -fwarn-tabs
133 if flag(developer)
149 if flag(developer)
150+ ghc-prof-options: -auto-all
134 ghc-options: -Werror
151 ghc-options: -Werror
135 cpp-options: -DASSERTS
152 cpp-options: -DASSERTS
136
153
137−source-repository head
154+ if flag(integer-simple)
138− type: mercurial
155+ cpp-options: -DINTEGER_SIMPLE
139− location: http://bitbucket.org/bos/text
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
140
201
141source-repository head
202source-repository head
142 type: git
203 type: git
143− 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