git.iko.soy/text
on master help sign in
Import of Tom Harper's Unicode 'text' package

--HG-- extra : convert_revision : c17a5dcdfe0634a341c4e62a1ccb62f45173510c

commitfd96b669df8a2b6197606cbd40cb1cc3b65890a1 authorDuncan Coutts <duncan@haskell.org> dateSun 18 Jan 2009, 16:11 (18 years ago)
11 files changed+1706
compare with master
unifiedsplit
Text.hs+477 Text/Fusion.hs+887 Text/Internal.hs+11 Text/UnsafeChar.hs+18 Text/Utf16.hs+24 Text/Utf32.hs+8 Text/Utf32/Fusion.hs+49 Text/Utf32/Internal.hs+8 Text/Utf8.hs+134 Text/Utf8/Fusion.hs+84 Text/Utf8/Internal.hs+6
Text.hsnew file+477
@@ -0,0 +1,477 @@
1+{-# OPTIONS_GHC -fglasgow-exts #-}
2+{-# LANGUAGE BangPatterns #-}
3+
4+module Text where
5+
6+import Prelude (Char,Bool,Int,Maybe,String,
7+ Eq,(==),
8+ Show,showsPrec,show,not,
9+ Read,readsPrec,read,
10+ (&&),(||),(+),(-),($),(<),(>),(<=),(>=),(.),(>>=),
11+ return,otherwise,seq,fromIntegral)
12+
13+import Char (isSpace)
14+import Control.Monad.ST(ST(..))
15+import Data.Array.Base(unsafeNewArray_,unsafeWrite,unsafeAt)
16+import Data.Array.ST(STUArray(..), runSTUArray)
17+import qualified Data.ByteString as B
18+import Data.ByteString(ByteString(..))
19+import qualified Data.List as L
20+import Data.Monoid(Monoid(..))
21+import Data.Word(Word16(..))
22+import System.IO hiding (readFile)
23+
24+import qualified Text.Fusion as S
25+import Text.Fusion (Stream(..),Step(..),Encoding(..),
26+ stream,unstream,stream_bs,unstream_bs,restream,
27+ errorEmptyList)
28+import Text.Internal(Text(..),empty)
29+import qualified Prelude as P
30+import Text.UnsafeChar(unsafeChr)
31+import qualified Text.Utf16 as U16
32+
33+instance Eq Text where
34+ t1 == t2 = (stream t1) `S.eq` (stream t2)
35+
36+instance Show Text where
37+ showsPrec p ps r = showsPrec p (unpack ps) r
38+
39+instance Read Text where
40+ readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
41+
42+instance Monoid Text where
43+ mempty = empty
44+ mappend = append
45+ mconcat = concat
46+
47+
48+
49+-- -----------------------------------------------------------------------------
50+-- * Conversion to/from 'Text'
51+
52+-- | /O(n)/ Convert a String into a Text.
53+--
54+-- This function is subject to array fusion, so calling other fusible
55+-- function(s) on a packed string will only cause one 'Text' to be written
56+-- out at the end of the pipeline, instead of one before and one after.
57+pack :: String -> Text
58+pack str = (unstream (stream_list str))
59+ where
60+ stream_list s0 = S.Stream next s0 (P.length s0) -- total guess
61+ where
62+ next [] = S.Done
63+ next (x:xs) = S.Yield x xs
64+{-# INLINE [1] pack #-}
65+-- TODO: Has to do validation! -- No, it doesn't, the
66+
67+-- | /O(n)/ Convert a Text into a String.
68+-- Subject to array fusion.
69+unpack :: Text -> String
70+unpack txt = (unstream_list (stream txt))
71+ where
72+ unstream_list (S.Stream next s0 len) = unfold s0
73+ where
74+ unfold !s = case next s of
75+ S.Done -> []
76+ S.Skip s' -> seq s' $ unfold s'
77+ S.Yield x s' -> seq s' $ x : unfold s'
78+{-# INLINE [1] unpack #-}
79+
80+-- | Convert a character into a Text.
81+-- Subject to array fusion.
82+singleton :: Char -> Text
83+singleton c = unstream (Stream next (c:[]) 1)
84+ where
85+ {-# INLINE next #-}
86+ next (c:cs) = Yield c cs
87+ next [] = Done
88+{-# INLINE [1] singleton #-}
89+
90+decode :: Encoding -> ByteString -> Text
91+decode enc bs = unstream (stream_bs enc bs)
92+{-# INLINE decode #-}
93+
94+encode :: Encoding -> Text -> ByteString
95+encode enc txt = unstream_bs (restream enc (stream txt))
96+{-# INLINE encode #-}
97+
98+-- -----------------------------------------------------------------------------
99+-- * Basic functions
100+
101+-- | /O(n)/ Adds a character to the front of a 'Text'. This function is more
102+-- costly than its 'List' counterpart because it requires copying a new array.
103+-- Subject to array fusion.
104+cons :: Char -> Text -> Text
105+cons c t = unstream (S.cons c (stream t))
106+{-# INLINE cons #-}
107+
108+-- | /O(n)/ Adds a character to the end of a 'Text'. This copies the entire
109+-- array in the process.
110+-- Subject to array fusion.
111+snoc :: Text -> Char -> Text
112+snoc t c = unstream (S.snoc (stream t) c)
113+{-# INLINE snoc #-}
114+
115+-- | /O(n)/ Appends one Text to the other by copying both of them into a new
116+-- Text.
117+-- Subject to array fusion
118+append :: Text -> Text -> Text
119+append (Text arr1 off1 len1) (Text arr2 off2 len2) = Text (runSTUArray x) 0 len
120+ where
121+ len = len1+len2
122+ x = do
123+ arr <- unsafeNewArray_ (0,len-1) :: ST s (STUArray s Int Word16)
124+ copy arr1 off1 (len1+off1) arr 0
125+ copy arr2 off2 (len2+off2) arr len1
126+ return arr
127+ where
128+ copy arr i max arr' j
129+ | i >= max = return ()
130+ | otherwise = do unsafeWrite arr' j (arr `unsafeAt` i)
131+ copy arr (i+1) max arr' (j+1)
132+{-# INLINE append #-}
133+
134+{-# RULES
135+"TEXT append -> fused" [~1] forall t1 t2.
136+ append t1 t2 = unstream (S.append (stream t1) (stream t2))
137+"TEXT append -> unfused" [1] forall t1 t2.
138+ unstream (S.append (stream t1) (stream t2)) = append t1 t2
139+ #-}
140+
141+-- | /O(1)/ Returns the first character of a Text, which must be non-empty.
142+-- Subject to array fusion.
143+head :: Text -> Char
144+head t = S.head (stream t)
145+{-# INLINE head #-}
146+
147+-- | /O(n)/ Returns the last character of a Text, which must be non-empty.
148+-- Subject to array fusion.
149+last :: Text -> Char
150+last (Text arr off len)
151+ | len <= 0 = errorEmptyList "last"
152+ | n < 0xDC00 || n > 0xDFFF = unsafeChr n
153+ | otherwise = U16.chr2 n0 n
154+ where
155+ n = unsafeAt arr (off+len-1)
156+ n0 = unsafeAt arr (off+len-2)
157+{-# INLINE [1] last #-}
158+
159+{-# RULES
160+"TEXT last -> fused" [~1] forall t.
161+ last t = S.last (stream t)
162+"TEXT last -> unfused" [1] forall t.
163+ S.last (stream t) = last t
164+ #-}
165+
166+
167+-- | /O(1)/ Returns all characters after the head of a Text, which must
168+-- be non-empty.
169+-- Subject to array fusion.
170+tail :: Text -> Text
171+tail (Text arr off len)
172+ | len <= 0 = errorEmptyList "tail"
173+ | n >= 0xD800 && n <= 0xDBFF = Text arr (off+2) (len-2)
174+ | otherwise = Text arr (off+1) (len-1)
175+ where
176+ n = unsafeAt arr off
177+{-# INLINE [1] tail #-}
178+
179+
180+
181+-- | /O(1)/ Returns all but the last character of a Text, which
182+-- must be non-empty.
183+-- Subject to array fusion.
184+init :: Text -> Text
185+init (Text arr off len) | len <= 0 = errorEmptyList "init"
186+ | n >= 0xDC00 && n <= 0xDFFF = Text arr off (len-2)
187+ | otherwise = Text arr off (len-1)
188+ where
189+ n = unsafeAt arr (off+len-1)
190+{-# INLINE [1] init #-}
191+
192+{-# RULES
193+"TEXT init -> fused" [~1] forall t.
194+ init t = unstream (S.init (stream t))
195+"TEXT init -> unfused" [1] forall t.
196+ unstream (S.init (stream t)) = init t
197+ #-}
198+
199+-- | /O(1)/ Tests whether a Text is empty or not.
200+-- Subject to array fusion.
201+null :: Text -> Bool
202+null t = S.null (stream t)
203+{-# INLINE null #-}
204+
205+-- | /O(n)/ Returns the number of characters in a text.
206+-- Subject to array fusion.
207+length :: Text -> Int
208+length t = S.length (stream t)
209+{-# INLINE length #-}
210+
211+-- -----------------------------------------------------------------------------
212+-- * Transformations
213+-- | /O(n)/ 'map' @f @xs is the Text obtained by applying @f@ to each
214+-- element of @xs@.
215+-- Subject to array fusion.
216+map :: (Char -> Char) -> Text -> Text
217+map f t = unstream (S.map f (stream t))
218+{-# INLINE [1] map #-}
219+
220+-- | /O(n)/ The 'intersperse' function takes a character and places it between
221+-- the characters of a Text.
222+-- Subject to array fusion.
223+intersperse :: Char -> Text -> Text
224+intersperse c t = unstream (S.intersperse c (stream t))
225+{-# INLINE intersperse #-}
226+
227+-- | /O(n)/ The 'transpose' function transposes the rows and columns of its
228+-- Text argument. Note that this function uses pack, unpack, and the 'List'
229+-- version of transpose and is thus not very efficient.
230+transpose :: [Text] -> [Text]
231+transpose ts = P.map pack (L.transpose (P.map unpack ts))
232+
233+-- -----------------------------------------------------------------------------
234+-- * Reducing 'Text's (folds)
235+
236+-- | 'foldl', applied to a binary operator, a starting value (typically the
237+-- left-identity of the operator), and a Text, reduces the Text using the
238+-- binary operator, from left to right.
239+-- Subject to array fusion.
240+foldl :: (b -> Char -> b) -> b -> Text -> b
241+foldl f z t = S.foldl f z (stream t)
242+{-# INLINE foldl #-}
243+
244+-- | A strict version of 'foldl'.
245+-- Subject to array fusion.
246+foldl' :: (b -> Char -> b) -> b -> Text -> b
247+foldl' f z t = S.foldl' f z (stream t)
248+{-# INLINE foldl' #-}
249+
250+-- | 'foldl1' is a variant of 'foldl' that has no starting value argument,
251+-- and thus must be applied to non-empty 'Text's.
252+-- Subject to array fusion.
253+foldl1 :: (Char -> Char -> Char) -> Text -> Char
254+foldl1 f t = S.foldl1 f (stream t)
255+{-# INLINE foldl1 #-}
256+
257+-- | A strict version of 'foldl1'.
258+-- Subject to array fusion.
259+foldl1' :: (Char -> Char -> Char) -> Text -> Char
260+foldl1' f t = S.foldl1' f (stream t)
261+{-# INLINE foldl1' #-}
262+
263+-- | 'foldr', applied to a binary operator, a starting value (typically the
264+-- right-identity of the operator), and a Text, reduces the Text using the
265+-- binary operator, from right to left.
266+-- Subject to array fusion.
267+foldr :: (Char -> b -> b) -> b -> Text -> b
268+foldr f z t = S.foldr f z (stream t)
269+{-# INLINE foldr #-}
270+
271+-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
272+-- and thust must be applied to non-empty 'Text's.
273+-- Subject to array fusion.
274+foldr1 :: (Char -> Char -> Char) -> Text -> Char
275+foldr1 f t = S.foldr1 f (stream t)
276+{-# INLINE foldr1 #-}
277+
278+-- -----------------------------------------------------------------------------
279+-- ** Special folds
280+
281+-- | /O(n)/ Concatenate a list of 'Text's. Subject to array fusion.
282+concat :: [Text] -> Text
283+concat ts = unstream (S.concat (L.map stream ts))
284+{-# INLINE concat #-}
285+
286+-- | Map a function over a Text that results in a Text and concatenate the
287+-- results. This function is subject to array fusion, and note that if in
288+-- 'concatMap' @f @xs, @f@ is defined in terms of fusible functions it will
289+-- also be fusible.
290+concatMap :: (Char -> Text) -> Text -> Text
291+concatMap f t = unstream (S.concatMap (stream . f) (stream t))
292+{-# INLINE concatMap #-}
293+
294+-- | 'any' @p @xs determines if any character in the 'Text' @xs@ satisifes the
295+-- predicate @p@. Subject to array fusion.
296+any :: (Char -> Bool) -> Text -> Bool
297+any p t = S.any p (stream t)
298+{-# INLINE any #-}
299+
300+-- | 'all' @p @xs determines if all characters in the 'Text' @xs@ satisify the
301+-- predicate @p@. Subject to array fusion.
302+all :: (Char -> Bool) -> Text -> Bool
303+all p t = S.all p (stream t)
304+{-# INLINE all #-}
305+
306+-- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which must be
307+-- non-empty. Subject to array fusion.
308+maximum :: Text -> Char
309+maximum t = S.maximum (stream t)
310+{-# INLINE maximum #-}
311+
312+-- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which must be
313+-- non-empty. Subject to array fusion.
314+minimum :: Text -> Char
315+minimum t = S.minimum (stream t)
316+{-# INLINE minimum #-}
317+
318+-- -----------------------------------------------------------------------------
319+-- * Building 'Text's
320+
321+-- -----------------------------------------------------------------------------
322+-- ** Generating and unfolding 'Text's
323+
324+-- /O(n)/, where @n@ is the length of the result. The unfoldr function
325+-- is analogous to the List 'unfoldr'. unfoldr builds a Text
326+-- from a seed value. The function takes the element and returns
327+-- Nothing if it is done producing the Text or returns Just
328+-- (a,b), in which case, a is the next Char in the string, and b is
329+-- the seed value for further production.
330+unfoldr :: (a -> Maybe (Char,a)) -> a -> Text
331+unfoldr f s = unstream (S.unfoldr f s)
332+{-# INLINE unfoldr #-}
333+
334+-- O(n) Like unfoldr, unfoldrN builds a Text from a seed
335+-- value. However, the length of the result should be limited by the
336+-- first argument to unfoldrN. This function is more efficient than
337+-- unfoldr when the maximum length of the result and correct,
338+-- otherwise its complexity performance is similar to 'unfoldr'
339+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Text
340+unfoldrN n f s = unstream (S.unfoldrN n f s)
341+{-# INLINE unfoldrN #-}
342+
343+-- -----------------------------------------------------------------------------
344+-- * Substrings
345+
346+-- O(n) 'take' @n, applied to a Text, returns the prefix of the
347+-- Text of length n, or the Text itself if n is greater than the
348+-- length of the Text.
349+take :: Int -> Text -> Text
350+take n (Text arr off len) = Text arr off (loop off 0)
351+ where
352+ end = off+len
353+ loop !i !count
354+ | i >= end || count >= n = i - off
355+ | c < 0xD800 || c > 0xDBFF = loop (i+1) (count+1)
356+ | otherwise = loop (i+2) (count+1)
357+ where
358+ c = arr `unsafeAt` i
359+{-# INLINE [1] take #-}
360+
361+{-# RULES
362+"TEXT take -> fused" [~1] forall n t.
363+ take n t = unstream (S.take n (stream t))
364+"TEXT take -> unfused" [1] forall n t.
365+ unstream (S.take n (stream t)) = take n t
366+ #-}
367+
368+-- /O(n)/ 'drop' @n, applied to a Text, returns the suffix of the
369+-- Text of length @n, or the empty Text if @n is greater than the
370+-- length of the Text.
371+drop :: Int -> Text -> Text
372+drop n (Text arr off len) = (Text arr newOff newLen)
373+ where
374+ (newOff, newLen) = loop off 0 len
375+ end = off + len
376+ loop !i !count !l
377+ | i >= end || count >= n = (i,l)
378+ | c < 0xD800 || c > 0xDBFF = loop (i+1) (count+1) (l-1)
379+ | otherwise = loop (i+2) (count+1) (l-2)
380+ where
381+ c = arr `unsafeAt` i
382+{-# INLINE [1] drop #-}
383+
384+{-# RULES
385+"TEXT drop -> fused" [~1] forall n t.
386+ drop n t = unstream (S.drop n (stream t))
387+"TEXT drop -> unfused" [1] forall n t.
388+ unstream (S.drop n (stream t)) = drop n t
389+ #-}
390+
391+-- | 'takeWhile', applied to a predicate @p@ and a stream, returns the
392+-- longest prefix (possibly empty) of elements that satisfy p.
393+takeWhile :: (Char -> Bool) -> Text -> Text
394+takeWhile p t = unstream (S.takeWhile p (stream t))
395+
396+-- | 'dropWhile' @p @xs returns the suffix remaining after 'takeWhile' @p @xs.
397+dropWhile :: (Char -> Bool) -> Text -> Text
398+dropWhile p t = unstream (S.dropWhile p (stream t))
399+
400+-- ----------------------------------------------------------------------------
401+-- * Searching
402+
403+-------------------------------------------------------------------------------
404+-- ** Searching by equality
405+
406+-- | /O(n)/ 'elem' is the 'Text' membership predicate.
407+elem :: Char -> Text -> Bool
408+elem c t = S.elem c (stream t)
409+{-# INLINE elem #-}
410+
411+-------------------------------------------------------------------------------
412+-- ** Searching with a predicate
413+
414+-- | /O(n)/ The 'find' function takes a predicate and a 'Text',
415+-- and returns the first element in matching the predicate, or 'Nothing'
416+-- if there is no such element.
417+find :: (Char -> Bool) -> Text -> Maybe Char
418+find p t = S.find p (stream t)
419+{-# INLINE find #-}
420+
421+-- | /O(n)/ 'filter', applied to a predicate and a 'Text',
422+-- returns a 'Text' containing those characters that satisfy the
423+-- predicate.
424+filter :: (Char -> Bool) -> Text -> Text
425+filter p t = unstream (S.filter p (stream t))
426+{-# INLINE filter #-}
427+
428+
429+-------------------------------------------------------------------------------
430+-- ** Indexing 'Text's
431+
432+-- | /O(1)/ 'Text' index (subscript) operator, starting from 0.
433+index :: Text -> Int -> Char
434+index t n = S.index (stream t) n
435+{-# INLINE index #-}
436+
437+-- | The 'findIndex' function takes a predicate and a 'Text' and
438+-- returns the index of the first element in the 'Text'
439+-- satisfying the predicate.
440+findIndex :: (Char -> Bool) -> Text -> Maybe Int
441+findIndex p t = S.findIndex p (stream t)
442+{-# INLINE findIndex #-}
443+
444+-- | /O(n)/ The 'elemIndex' function returns the index of the first
445+-- element in the given 'Text' which is equal to the query element, or
446+-- 'Nothing' if there is no such element.
447+elemIndex :: Char -> Text -> Maybe Int
448+elemIndex c t = S.elemIndex c (stream t)
449+
450+-------------------------------------------------------------------------------
451+-- * Zipping
452+
453+-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
454+-- given as the first argument, instead of a tupling function.
455+zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
456+zipWith f t1 t2 = unstream (S.zipWith f (stream t1) (stream t2))
457+
458+-- File I/O
459+
460+readFile :: Encoding -> FilePath -> IO Text
461+readFile enc f = B.readFile f >>= return . unstream . stream_bs enc
462+{-# INLINE [1] readFile #-}
463+
464+words :: Text -> [Text]
465+words (Text arr off len) = loop0 off off
466+ where
467+ loop0 start n
468+ | isSpace (unsafeChr c) = if start == n
469+ then loop0 (start+1) (start+1)
470+ else (Text arr start (n-start)):loop0 (n+1) (n+1)
471+ | n < (off+len) = loop0 start (n+1)
472+ | otherwise = if start == n
473+ then []
474+ else [(Text arr start (n-start))]
475+ where
476+ c = arr `unsafeAt` n
477+{-# INLINE words #-}
Text/Fusion.hsnew file+887
@@ -0,0 +1,887 @@
1+{-# OPTIONS_GHC -fglasgow-exts #-}
2+{-# LANGUAGE BangPatterns #-}
3+
4+module Text.Fusion where
5+
6+import Prelude hiding (map, tail, head, foldr, filter,concat)
7+
8+import Char
9+import Control.Exception(assert)
10+import Control.Monad(liftM2)
11+import Control.Monad.ST(runST,ST(..))
12+import Data.Array.Base
13+import Data.Bits
14+import qualified Data.ByteString as B
15+import Data.ByteString.Internal(ByteString(..),mallocByteString,memcpy)
16+import qualified Data.List as L
17+import Data.Word(Word8(..),Word16(..),Word32(..))
18+import Foreign.ForeignPtr(withForeignPtr,ForeignPtr(..))
19+import Foreign.Storable(pokeByteOff)
20+import GHC.Exts
21+import System.IO.Unsafe(unsafePerformIO)
22+
23+import Text.Internal(Text(..),empty)
24+import Text.UnsafeChar(unsafeChr,unsafeChr8,unsafeChr32)
25+import qualified Text.Utf8 as U8
26+import qualified Text.Utf16 as U16
27+import qualified Text.Utf32 as U32
28+
29+default(Int)
30+
31+infixl 2 :!:
32+data PairS a b = !a :!: !b
33+
34+data Switch = S1 | S2
35+
36+data EitherS a b = LeftS !a | RightS !b
37+
38+data Stream a = forall s. Stream (s -> Step s a) !s {-# UNPACK #-}!Int
39+
40+data Step s a = Done
41+ | Skip !s
42+ | Yield !a !s
43+
44+data Encoding = ASCII | Utf8 | Utf16BE | Utf16LE | Utf32BE | Utf32LE
45+
46+-- | /O(n)/ Convert a Text into a Stream Char.
47+stream :: Text -> Stream Char
48+stream (Text arr off len) = Stream next off len
49+ where
50+ end = off+len
51+ {-# INLINE next #-}
52+ next !i
53+ | i >= end = Done
54+ | n >= 0xD800 && n <= 0xDBFF = Yield (U16.chr2 n n2) (i + 2)
55+ | otherwise = Yield (unsafeChr n) (i + 1)
56+ where
57+ n = unsafeAt arr i
58+ n2 = unsafeAt arr (i + 1)
59+{-# INLINE [0] stream #-}
60+
61+-- | /O(n)/ Convert a Stream Char into a Text.
62+unstream :: Stream Char -> Text
63+unstream (Stream next0 s0 len) = x `seq` Text (fst x) 0 (snd x)
64+ where
65+ x :: ((UArray Int Word16),Int)
66+ x = runST ((unsafeNewArray_ (0,len+1) :: ST s (STUArray s Int Word16))
67+ >>= (\arr -> loop arr 0 (len+1) s0))
68+ loop arr !i !max !s
69+ | i + 1 > max = do arr' <- unsafeNewArray_ (0,max*2)
70+ case next0 s of
71+ Done -> liftM2 (,) (unsafeFreezeSTUArray arr) (return i)
72+ _ -> copy arr arr' >> loop arr' i (max*2) s
73+ | otherwise = case next0 s of
74+ Done -> liftM2 (,) (unsafeFreezeSTUArray arr) (return i)
75+ Skip s' -> loop arr i max s'
76+ Yield x s'
77+ | n < 0x10000 -> do
78+ unsafeWrite arr i (fromIntegral n :: Word16)
79+ loop arr (i+1) max s'
80+ | otherwise -> do
81+ unsafeWrite arr i l
82+ unsafeWrite arr (i + 1) r
83+ loop arr (i+2) max s'
84+ where
85+ n :: Int
86+ n = ord x
87+ m :: Int
88+ m = n - 0x10000
89+ l :: Word16
90+ l = fromIntegral $ (shiftR m 10) + (0xD800 :: Int)
91+ r :: Word16
92+ r = fromIntegral $ (m .&. (0x3FF :: Int)) + (0xDC00 :: Int)
93+{-# INLINE [0] unstream #-}
94+
95+
96+copy src dest = (do
97+ (_,max) <- getBounds src
98+ copy_loop 0 max)
99+ where
100+ copy_loop !i !max
101+ | i > max = return ()
102+ | otherwise = do v <- unsafeRead src i
103+ unsafeWrite dest i v
104+ copy_loop (i+1) max
105+
106+-- | /O(n)/ Determines if two streams are equal.
107+eq :: Ord a => Stream a -> Stream a -> Bool
108+eq (Stream next1 s1 _) (Stream next2 s2 _) = compare (next1 s1) (next2 s2)
109+ where
110+ compare Done Done = True
111+ compare Done _ = False
112+ compare _ Done = False
113+ compare (Skip s1') (Skip s2') = compare (next1 s1') (next2 s2')
114+ compare (Skip s1') x2 = compare (next1 s1') x2
115+ compare x1 (Skip s2') = compare x1 (next2 s2')
116+ compare (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
117+ compare (next1 s1') (next2 s2')
118+{-# SPECIALISE eq :: Stream Char -> Stream Char -> Bool #-}
119+
120+
121+-- | /O(n) Convert a ByteString into a Stream Char, using the specified encoding standard.
122+stream_bs :: Encoding -> ByteString -> Stream Char
123+stream_bs ASCII bs = Stream next 0 (B.length bs)
124+ where
125+ {-# INLINE next #-}
126+ next i
127+ | i >= l = Done
128+ | otherwise = Yield (unsafeChr8 x1) (i+1)
129+ where
130+ l = B.length bs
131+ x1 = B.index bs i
132+stream_bs Utf8 bs = Stream next 0 (B.length bs)
133+ where
134+ {-# INLINE next #-}
135+ next i
136+ | i >= l = Done
137+ | U8.validate1 x1 = Yield (unsafeChr8 x1) (i+1)
138+ | i+1 < l && U8.validate2 x1 x2 = Yield (U8.chr2 x1 x2) (i+2)
139+ | i+2 < l && U8.validate3 x1 x2 x3 = Yield (U8.chr3 x1 x2 x3) (i+3)
140+ | i+3 < l && U8.validate4 x1 x2 x3 x4 = Yield (U8.chr4 x1 x2 x3 x4) (i+4)
141+ | otherwise = error "bsStream: bad UTF-8 stream"
142+ where
143+ l = B.length bs
144+ x1 = index i
145+ x2 = index (i + 1)
146+ x3 = index (i + 2)
147+ x4 = index (i + 3)
148+ index = B.index bs
149+stream_bs Utf16LE bs = Stream next 0 (B.length bs)
150+ where
151+ {-# INLINE next #-}
152+ next i
153+ | i >= l = Done
154+ | i+1 < l && U16.validate1 x1 = Yield (unsafeChr x1) (i+2)
155+ | i+3 < l && U16.validate2 x1 x2 = Yield (U16.chr2 x1 x2) (i+4)
156+ | otherwise = error $ "bsStream: bad UTF-16LE stream"
157+ where
158+ x1 :: Word16
159+ x1 = (shiftL (index (i + 1)) 8) + (index i)
160+ x2 :: Word16
161+ x2 = (shiftL (index (i + 3)) 8) + (index (i + 2))
162+ l = B.length bs
163+ index = fromIntegral . B.index bs :: Int -> Word16
164+stream_bs Utf16BE bs = Stream next 0 (B.length bs)
165+ where
166+ {-# INLINE next #-}
167+ next i
168+ | i >= l = Done
169+ | i+1 < l && U16.validate1 x1 = Yield (unsafeChr x1) (i+2)
170+ | i+3 < l && U16.validate2 x1 x2 = Yield (U16.chr2 x1 x2) (i+4)
171+ | otherwise = error $ "bsStream: bad UTF16-BE stream "
172+ where
173+ x1 :: Word16
174+ x1 = (shiftL (index i) 8) + (index (i + 1))
175+ x2 :: Word16
176+ x2 = (shiftL (index (i + 2)) 8) + (index (i + 3))
177+ l = B.length bs
178+ index = fromIntegral . B.index bs
179+stream_bs Utf32BE bs = Stream next 0 (B.length bs)
180+ where
181+ {-# INLINE next #-}
182+ next i
183+ | i >= l = Done
184+ | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4)
185+ | otherwise = error "bsStream: bad UTF-32BE stream"
186+ where
187+ l = B.length bs
188+ x = shiftL x1 24 + shiftL x2 16 + shiftL x3 8 + x4
189+ x1 = index i
190+ x2 = index (i+1)
191+ x3 = index (i+2)
192+ x4 = index (i+3)
193+ index = fromIntegral . B.index bs :: Int -> Word32
194+stream_bs Utf32LE bs = Stream next 0 (B.length bs)
195+ where
196+ {-# INLINE next #-}
197+ next i
198+ | i >= l = Done
199+ | i+3 < l && U32.validate x = Yield (unsafeChr32 x) (i+4)
200+ | otherwise = error "bsStream: bad UTF-32LE stream"
201+ where
202+ l = B.length bs
203+ x = shiftL x4 24 + shiftL x3 16 + shiftL x2 8 + x1
204+ x1 = index i
205+ x2 = index $ i+1
206+ x3 = index $ i+2
207+ x4 = index $ i+3
208+ index = fromIntegral . B.index bs :: Int -> Word32
209+{-# INLINE [0] stream_bs #-}
210+
211+-- | /O(n)/ Convert a Stream Char into a Stream Word8 using the specified encoding standard.
212+restream :: Encoding -> Stream Char -> Stream Word8
213+restream ASCII (Stream next0 s0 len) = Stream next s0 (len*2)
214+ where
215+ next !s = case next0 s of
216+ Done -> Done
217+ Skip s' -> Skip s'
218+ Yield x xs -> Yield x' xs
219+ where x' = fromIntegral (ord x) :: Word8
220+restream Utf8 (Stream next0 s0 len) =
221+ Stream next ((Just s0) :!: Nothing :!: Nothing :!: Nothing) (len*2)
222+ where
223+ {-# INLINE next #-}
224+ next ((Just s) :!: Nothing :!: Nothing :!: Nothing) = case next0 s of
225+ Done -> Done
226+ Skip s' -> Skip ((Just s') :!: Nothing :!: Nothing :!: Nothing)
227+ Yield x xs
228+ | n <= 0x7F -> Yield c ((Just xs) :!: Nothing :!: Nothing :!: Nothing)
229+ | n <= 0x07FF -> Yield (fst c2) ((Just xs) :!: (Just $ snd c2) :!: Nothing :!: Nothing)
230+ | n <= 0xFFFF -> Yield (fst3 c3) ((Just xs) :!: (Just $ snd3 c3) :!: (Just $ trd3 c3) :!: Nothing)
231+ | otherwise -> Yield (fst4 c4) ((Just xs) :!: (Just $ snd4 c4) :!: (Just $ trd4 c4) :!: (Just $ fth4 c4))
232+ where
233+ n = ord x
234+ c = fromIntegral n
235+ c2 = U8.ord2 x
236+ c3 = U8.ord3 x
237+ c4 = U8.ord4 x
238+ next ((Just s) :!: (Just x2) :!: Nothing :!: Nothing) = Yield x2 ((Just s) :!: Nothing :!: Nothing :!: Nothing)
239+ next ((Just s) :!: (Just x2) :!: x3 :!: Nothing) = Yield x2 ((Just s) :!: x3 :!: Nothing :!: Nothing)
240+ next ((Just s) :!: (Just x2) :!: x3 :!: x4) = Yield x2 ((Just s) :!: x3 :!: x4 :!: Nothing)
241+restream Utf16BE (Stream next0 s0 len) =
242+ Stream next (Just s0 :!: Nothing :!: Nothing :!: Nothing) (len*2)
243+ where
244+ {-# INLINE next #-}
245+ next (Just s :!: Nothing :!: Nothing :!: Nothing) = case next0 s of
246+ Done -> Done
247+ Skip s' -> Skip (Just s' :!: Nothing :!: Nothing :!: Nothing)
248+ Yield x xs
249+ | n < 0x10000 -> Yield (fromIntegral $ shiftR n 8) (Just xs :!: Just (fromIntegral n) :!: Nothing :!: Nothing)
250+ | otherwise -> Yield c1 (Just xs :!: Just c2 :!: Just c3 :!: Just c4)
251+ where
252+ n = ord x
253+ n1 = n - 0x10000
254+ c1 = fromIntegral (shiftR n1 18 + 0xD8)
255+ c2 = fromIntegral (shiftR n1 10)
256+ n2 = n1 .&. 0x3FF
257+ c3 = fromIntegral (shiftR n2 8 + 0xDC)
258+ c4 = fromIntegral n2
259+ next ((Just s) :!: (Just x2) :!: Nothing :!: Nothing) = Yield x2 ((Just s) :!: Nothing :!: Nothing :!: Nothing)
260+ next ((Just s) :!: (Just x2) :!: x3 :!: Nothing) = Yield x2 ((Just s) :!: x3 :!: Nothing :!: Nothing)
261+ next ((Just s) :!: (Just x2) :!: x3 :!: x4) = Yield x2 ((Just s) :!: x3 :!: x4 :!: Nothing)
262+restream Utf16LE (Stream next0 s0 len) =
263+ Stream next (Just s0 :!: Nothing :!: Nothing :!: Nothing) (len*2)
264+ where
265+ {-# INLINE next #-}
266+ next (Just s :!: Nothing :!: Nothing :!: Nothing) = case next0 s of
267+ Done -> Done
268+ Skip s' -> Skip (Just s' :!: Nothing :!: Nothing :!: Nothing)
269+ Yield x xs
270+ | n < 0x10000 -> Yield (fromIntegral n) (Just xs :!: Just (fromIntegral $ shiftR n 8) :!: Nothing :!: Nothing)
271+ | otherwise -> Yield c1 (Just xs :!: Just c2 :!: Just c3 :!: Just c4)
272+ where
273+ n = ord x
274+ n1 = n - 0x10000
275+ c2 = fromIntegral (shiftR n1 18 + 0xD8)
276+ c1 = fromIntegral (shiftR n1 10)
277+ n2 = n1 .&. 0x3FF
278+ c4 = fromIntegral (shiftR n2 8 + 0xDC)
279+ c3 = fromIntegral n2
280+ next ((Just s) :!: (Just x2) :!: Nothing :!: Nothing) = Yield x2 ((Just s) :!: Nothing :!: Nothing :!: Nothing)
281+ next ((Just s) :!: (Just x2) :!: x3 :!: Nothing) = Yield x2 ((Just s) :!: x3 :!: Nothing :!: Nothing)
282+ next ((Just s) :!: (Just x2) :!: x3 :!: x4) = Yield x2 ((Just s) :!: x3 :!: x4 :!: Nothing)
283+restream Utf32BE (Stream next0 s0 len) =
284+ Stream next (Just s0 :!: Nothing :!: Nothing :!: Nothing) (len*2)
285+ where
286+ {-# INLINE next #-}
287+ next (Just s :!: Nothing :!: Nothing :!: Nothing) = case next0 s of
288+ Done -> Done
289+ Skip s' -> Skip (Just s' :!: Nothing :!: Nothing :!: Nothing)
290+ Yield x xs -> Yield c1 (Just xs :!: Just c2 :!: Just c3 :!: Just c4)
291+ where
292+ n = ord x
293+ c1 = fromIntegral $ shiftR n 24
294+ c2 = fromIntegral $ shiftR n 16
295+ c3 = fromIntegral $ shiftR n 8
296+ c4 = fromIntegral n
297+ next ((Just s) :!: (Just x2) :!: Nothing :!: Nothing) = Yield x2 ((Just s) :!: Nothing :!: Nothing :!: Nothing)
298+ next ((Just s) :!: (Just x2) :!: x3 :!: Nothing) = Yield x2 ((Just s) :!: x3 :!: Nothing :!: Nothing)
299+ next ((Just s) :!: (Just x2) :!: x3 :!: x4) = Yield x2 ((Just s) :!: x3 :!: x4 :!: Nothing)
300+restream Utf32LE (Stream next0 s0 len) =
301+ Stream next (Just s0 :!: Nothing :!: Nothing :!: Nothing) (len*2)
302+ where
303+ {-# INLINE next #-}
304+ next (Just s :!: Nothing :!: Nothing :!: Nothing) = case next0 s of
305+ Done -> Done
306+ Skip s' -> Skip (Just s' :!: Nothing :!: Nothing :!: Nothing)
307+ Yield x xs -> Yield c1 (Just xs :!: Just c2 :!: Just c3 :!: Just c4)
308+ where
309+ n = ord x
310+ c4 = fromIntegral $ shiftR n 24
311+ c3 = fromIntegral $ shiftR n 16
312+ c2 = fromIntegral $ shiftR n 8
313+ c1 = fromIntegral n
314+ next ((Just s) :!: (Just x2) :!: Nothing :!: Nothing) = Yield x2 ((Just s) :!: Nothing :!: Nothing :!: Nothing)
315+ next ((Just s) :!: (Just x2) :!: x3 :!: Nothing) = Yield x2 ((Just s) :!: x3 :!: Nothing :!: Nothing)
316+ next ((Just s) :!: (Just x2) :!: x3 :!: x4) = Yield x2 ((Just s) :!: x3 :!: x4 :!: Nothing)
317+{-# INLINE restream #-}
318+
319+
320+fst3 (x1,_,_) = x1
321+snd3 (_,x2,_) = x2
322+trd3 (_,_,x3) = x3
323+fst4 (x1,_,_,_) = x1
324+snd4 (_,x2,_,_) = x2
325+trd4 (_,_,x3,_) = x3
326+fth4 (_,_,_,x4) = x4
327+
328+-- | /O(n)/ Convert a Stream Word8 to a ByteString
329+unstream_bs :: Stream Word8 -> ByteString
330+unstream_bs (Stream next s0 len) = unsafePerformIO $ do
331+ fp0 <- mallocByteString len
332+ loop fp0 len 0 s0
333+ where
334+ loop !fp !n !off !s = case next s of
335+ Done -> trimUp fp n off
336+ Skip s' -> loop fp n off s'
337+ Yield x s'
338+ | n == off -> realloc fp n off s' x
339+ | otherwise -> do
340+ withForeignPtr fp $ \p -> pokeByteOff p off x
341+ loop fp n (off+1) s'
342+ {-# NOINLINE realloc #-}
343+ realloc fp n off s x = do
344+ let n' = n+n
345+ fp' <- copy0 fp n n'
346+ withForeignPtr fp' $ \p -> pokeByteOff p off x
347+ loop fp' n' (off+1) s
348+ {-# NOINLINE trimUp #-}
349+ trimUp fp _ off = return $! PS fp 0 off
350+ copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)
351+ copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do
352+ dest <- mallocByteString destLen
353+ withForeignPtr src $ \src' ->
354+ withForeignPtr dest $ \dest' ->
355+ memcpy dest' src' (fromIntegral destLen)
356+ return dest
357+{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
358+
359+-- ----------------------------------------------------------------------------
360+-- * Basic stream functions
361+
362+-- | /O(n)/ Adds a character to the front of a Stream Char.
363+cons :: Char -> Stream Char -> Stream Char
364+cons w (Stream next0 s0 len) = Stream next (S2 :!: s0) (len+2)
365+ where
366+ {-# INLINE next #-}
367+ next (S2 :!: s) = Yield w (S1 :!: s)
368+ next (S1 :!: s) = case next0 s of
369+ Done -> Done
370+ Skip s' -> Skip (S1 :!: s')
371+ Yield x s' -> Yield x (S1 :!: s')
372+{-# INLINE [0] cons #-}
373+
374+-- | /O(n)/ Adds a character to the end of a stream.
375+snoc :: Stream Char -> Char -> Stream Char
376+snoc (Stream next0 xs0 len) w = Stream next (Just xs0) (len+2)
377+ where
378+ {-# INLINE next #-}
379+ next (Just xs) = case next0 xs of
380+ Done -> Yield w Nothing
381+ Skip xs' -> Skip (Just xs')
382+ Yield x xs' -> Yield x (Just xs')
383+ next Nothing = Done
384+{-# INLINE [0] snoc #-}
385+
386+-- | /O(n)/ Appends one Stream to the other.
387+append :: Stream Char -> Stream Char -> Stream Char
388+append (Stream next0 s01 len1) (Stream next1 s02 len2) =
389+ Stream next (Left s01) (len1 + len2)
390+ where
391+ {-# INLINE next #-}
392+ next (Left s1) = case next0 s1 of
393+ Done -> Skip (Right s02)
394+ Skip s1' -> Skip (Left s1')
395+ Yield x s1' -> Yield x (Left s1')
396+ next (Right s2) = case next1 s2 of
397+ Done -> Done
398+ Skip s2' -> Skip (Right s2')
399+ Yield x s2' -> Yield x (Right s2')
400+{-# INLINE [0] append #-}
401+
402+-- | /O(1)/ Returns the first character of a Text, which must be non-empty.
403+-- Subject to array fusion.
404+head :: Stream Char -> Char
405+head (Stream next s0 len) = loop_head s0
406+ where
407+ loop_head !s = case next s of
408+ Yield x _ -> x
409+ Skip s' -> loop_head s'
410+ Done -> error "head: Empty list"
411+{-# INLINE [0] head #-}
412+
413+-- | /O(n)/ Returns the last character of a Stream Char, which must be non-empty.
414+last :: Stream Char -> Char
415+last (Stream next s0 len) = loop0_last s0
416+ where
417+ loop0_last !s = case next s of
418+ Done -> error "last: Empty list"
419+ Skip s' -> seq s' $ loop0_last s'
420+ Yield x s' -> seq s' $ loop_last x s'
421+ loop_last !x !s = case next s of
422+ Done -> x
423+ Skip s' -> seq s' $ loop_last x s'
424+ Yield x' s' -> seq s' $ loop_last x' s'
425+{-# INLINE[0] last #-}
426+
427+-- | /O(1)/ Returns all characters after the head of a Stream Char, which must
428+-- be non-empty.
429+tail :: Stream Char -> Stream Char
430+tail (Stream next0 s0 len) = Stream next (False :!: s0) (len-1)
431+ where
432+ {-# INLINE next #-}
433+ next (False :!: s) = case next0 s of
434+ Done -> error "tail"
435+ Skip s' -> Skip (False :!: s')
436+ Yield _ s' -> Skip (True :!: s')
437+ next (True :!: s) = case next0 s of
438+ Done -> Done
439+ Skip s' -> Skip (True :!: s')
440+ Yield x s' -> Yield x (True :!: s')
441+{-# INLINE [0] tail #-}
442+
443+
444+-- | /O(1)/ Returns all but the last character of a Stream Char, which
445+-- must be non-empty.
446+init :: Stream Char -> Stream Char
447+init (Stream next0 s0 len) = Stream next (Nothing :!: s0) (len-1)
448+ where
449+ {-# INLINE next #-}
450+ next (Nothing :!: s) = case next0 s of
451+ Done -> errorEmptyList "init"
452+ Skip s' -> seq s' $ Skip (Nothing :!: s')
453+ Yield x s' -> seq s' $ Skip (Just x :!: s')
454+ next (Just x :!: s) = case next0 s of
455+ Done -> Done
456+ Skip s' -> seq s' $ Skip (Just x :!: s')
457+ Yield x' s' -> seq s' $ Yield x (Just x' :!: s')
458+{-# INLINE [0] init #-}
459+
460+-- | /O(1)/ Tests whether a Stream Char is empty or not.
461+null :: Stream Char -> Bool
462+null (Stream next s0 len) = loop_null s0
463+ where
464+ loop_null !s = case next s of
465+ Done -> True
466+ Yield _ _ -> False
467+ Skip s' -> loop_null s'
468+{-# INLINE[0] null #-}
469+
470+-- | /O(n)/ Returns the number of characters in a text.
471+length :: Stream Char -> Int
472+length (Stream next s0 len) = loop_length 0# s0
473+ where
474+
475+ loop_length z# !s = case next s of
476+ Done -> (I# z#)
477+ Skip s' -> loop_length z# s'
478+ Yield _ s' -> loop_length (z# +# 1#) s'
479+{-# INLINE[0] length #-}
480+
481+-- ----------------------------------------------------------------------------
482+-- * Stream transformations
483+
484+-- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@ to each element of
485+-- @xs@.
486+map :: (Char -> Char) -> Stream Char -> Stream Char
487+map f (Stream next0 s0 len) = Stream next s0 len
488+ where
489+ {-# INLINE next #-}
490+ next !s = case next0 s of
491+ Done -> Done
492+ Skip s' -> Skip s'
493+ Yield x s' -> Yield (f x) s'
494+{-# INLINE [0] map #-}
495+
496+{-#
497+ RULES "STREAM map/map fusion" forall f g s.
498+ map f (map g s) = map (\x -> f (g x)) s
499+ #-}
500+
501+-- | /O(n)/ The 'intersperse' function takes a character and places it between each of
502+-- the characters of a Stream.
503+intersperse :: Char -> Stream Char -> Stream Char
504+intersperse c (Stream next0 s0 len) = Stream next (s0 :!: Nothing :!: S1) len
505+ where
506+ {-# INLINE next #-}
507+ next (s :!: Nothing :!: S1) = case next0 s of
508+ Done -> Done
509+ Skip s' -> Skip (s' :!: Nothing :!: S1)
510+ Yield x s' -> Skip (s' :!: Just x :!: S1)
511+ next (s :!: Just x :!: S1) = Yield x (s :!: Nothing :!: S2)
512+ next (s :!: Nothing :!: S2) = case next0 s of
513+ Done -> Done
514+ Skip s' -> Skip (s' :!: Nothing :!: S2)
515+ Yield x s' -> Yield c (s' :!: Just x :!: S1)
516+
517+-- ----------------------------------------------------------------------------
518+-- * Reducing Streams (folds)
519+
520+-- | foldl, applied to a binary operator, a starting value (typically the
521+-- left-identity of the operator), and a Stream, reduces the Stream using the
522+-- binary operator, from left to right.
523+foldl :: (b -> Char -> b) -> b -> Stream Char -> b
524+foldl f z0 (Stream next s0 len) = loop_foldl z0 s0
525+ where
526+ loop_foldl z !s = case next s of
527+ Done -> z
528+ Skip s' -> loop_foldl z s'
529+ Yield x s' -> loop_foldl (f z x) s'
530+{-# INLINE [0] foldl #-}
531+
532+-- | A strict version of foldl.
533+foldl' :: (b -> Char -> b) -> b -> Stream Char -> b
534+foldl' f z0 (Stream next s0 len) = loop_foldl' z0 s0
535+ where
536+ loop_foldl' !z !s = case next s of
537+ Done -> z
538+ Skip s' -> loop_foldl' z s'
539+ Yield x s' -> loop_foldl' (f z x) s'
540+{-# INLINE [0] foldl' #-}
541+
542+-- | foldl1 is a variant of foldl that has no starting value argument,
543+-- and thus must be applied to non-empty Streams.
544+foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char
545+foldl1 f (Stream next s0 len) = loop0_foldl1 s0
546+ where
547+ loop0_foldl1 !s = case next s of
548+ Skip s' -> loop0_foldl1 s'
549+ Yield x s' -> loop_foldl1 x s'
550+ Done -> errorEmptyList "foldl1"
551+ loop_foldl1 z !s = case next s of
552+ Done -> z
553+ Skip s' -> loop_foldl1 z s'
554+ Yield x s' -> loop_foldl1 (f z x) s'
555+{-# INLINE [0] foldl1 #-}
556+
557+-- | A strict version of foldl1.
558+foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char
559+foldl1' f (Stream next s0 len) = loop0_foldl1' s0
560+ where
561+ loop0_foldl1' !s = case next s of
562+ Skip s' -> loop0_foldl1' s'
563+ Yield x s' -> loop_foldl1' x s'
564+ Done -> errorEmptyList "foldl1"
565+ loop_foldl1' !z !s = case next s of
566+ Done -> z
567+ Skip s' -> loop_foldl1' z s'
568+ Yield x s' -> loop_foldl1' (f z x) s'
569+{-# INLINE [0] foldl1' #-}
570+
571+-- | 'foldr', applied to a binary operator, a starting value (typically the
572+-- right-identity of the operator), and a stream, reduces the stream using the
573+-- binary operator, from right to left.
574+foldr :: (Char -> b -> b) -> b -> Stream Char -> b
575+foldr f z (Stream next s0 len) = loop_foldr s0
576+ where
577+ loop_foldr !s = case next s of
578+ Done -> z
579+ Skip s' -> loop_foldr s'
580+ Yield x s' -> f x (loop_foldr s')
581+{-# INLINE [0] foldr #-}
582+
583+-- | foldr1 is a variant of 'foldr' that has no starting value argument,
584+-- and thust must be applied to non-empty streams.
585+-- Subject to array fusion.
586+foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char
587+foldr1 f (Stream next s0 len) = loop0_foldr1 s0
588+ where
589+ loop0_foldr1 !s = case next s of
590+ Done -> error "foldr1"
591+ Skip s' -> loop0_foldr1 s'
592+ Yield x s' -> loop_foldr1 x s'
593+
594+ loop_foldr1 x !s = case next s of
595+ Done -> x
596+ Skip s' -> loop_foldr1 x s'
597+ Yield x' s' -> f x (loop_foldr1 x' s')
598+{-# INLINE [0] foldr1 #-}
599+
600+-- ----------------------------------------------------------------------------
601+-- ** Special folds
602+
603+-- | /O(n)/ Concatenate a list of streams. Subject to array fusion.
604+concat :: [Stream Char] -> Stream Char
605+concat = L.foldr append (Stream next Done 0)
606+ where
607+ next Done = Done
608+
609+-- | Map a function over a stream that results in a steram and concatenate the
610+-- results.
611+concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char
612+concatMap f = foldr (append . f) (stream empty)
613+
614+-- | /O(n)/ any @p @xs determines if any character in the stream
615+-- @xs@ satisifes the predicate @p@.
616+any :: (Char -> Bool) -> Stream Char -> Bool
617+any p (Stream next0 s0 len) = loop_any s0
618+ where
619+ loop_any !s = case next0 s of
620+ Done -> False
621+ Skip s' -> seq s' $ loop_any s'
622+ Yield x s' | p x -> True
623+ | otherwise -> seq s' $ loop_any s'
624+
625+-- | /O(n)/ all @p @xs determines if all characters in the 'Text'
626+-- @xs@ satisify the predicate @p@.
627+all :: (Char -> Bool) -> Stream Char -> Bool
628+all p (Stream next0 s0 len) = loop_all s0
629+ where
630+ loop_all !s = case next0 s of
631+ Done -> True
632+ Skip s' -> seq s' $ loop_all s'
633+ Yield x s' | p x -> seq s' $ loop_all s'
634+ | otherwise -> False
635+
636+-- | /O(n)/ maximum returns the maximum value from a stream, which must be
637+-- non-empty.
638+maximum :: Stream Char -> Char
639+maximum (Stream next0 s0 len) = loop0_maximum s0
640+ where
641+ loop0_maximum !s = case next0 s of
642+ Done -> errorEmptyList "maximum"
643+ Skip s' -> seq s' $ loop0_maximum s'
644+ Yield x s' -> seq s' $ loop_maximum x s'
645+ loop_maximum !z !s = case next0 s of
646+ Done -> z
647+ Skip s' -> seq s' $ loop_maximum z s'
648+ Yield x s'
649+ | x > z -> seq s' $ loop_maximum x s'
650+ | otherwise -> seq s' $ loop_maximum z s'
651+
652+-- | /O(n)/ minimum returns the minimum value from a 'Text', which must be
653+-- non-empty.
654+minimum :: Stream Char -> Char
655+minimum (Stream next0 s0 len) = loop0_minimum s0
656+ where
657+ loop0_minimum !s = case next0 s of
658+ Done -> errorEmptyList "minimum"
659+ Skip s' -> seq s' $ loop0_minimum s'
660+ Yield x s' -> seq s' $ loop_minimum x s'
661+ loop_minimum !z !s = case next0 s of
662+ Done -> z
663+ Skip s' -> seq s' $ loop_minimum z s'
664+ Yield x s'
665+ | x < z -> seq s' $ loop_minimum x s'
666+ | otherwise -> seq s' $ loop_minimum z s'
667+
668+
669+
670+
671+-- -----------------------------------------------------------------------------
672+-- * Building streams
673+
674+-- -----------------------------------------------------------------------------
675+-- ** Generating and unfolding streams
676+
677+-- | /O(n)/, where @n@ is the length of the result. The unfoldr function
678+-- is analogous to the List 'unfoldr'. unfoldr builds a stream
679+-- from a seed value. The function takes the element and returns
680+-- Nothing if it is done producing the stream or returns Just
681+-- (a,b), in which case, a is the next Char in the string, and b is
682+-- the seed value for further production.
683+unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char
684+unfoldr f s0 = Stream next s0 1
685+ where
686+ {-# INLINE next #-}
687+ next !s = case f s of
688+ Nothing -> Done
689+ Just (w, s') -> Yield w s'
690+{-# INLINE [0] unfoldr #-}
691+
692+-- | O(n) Like unfoldr, unfoldrN builds a stream from a seed
693+-- value. However, the length of the result should be limited by the
694+-- first argument to unfoldrN. This function is more efficient than
695+-- unfoldr when the maximum length of the result and correct,
696+-- otherwise its complexity performance is similar to 'unfoldr'
697+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
698+unfoldrN n f s0 = Stream next (0 :!: s0) (n*2)
699+ where
700+ {-# INLINE next #-}
701+ next (z :!: s) = case f s of
702+ Nothing -> Done
703+ Just (w, s') | z >= n -> Done
704+ | otherwise -> Yield w ((z + 1) :!: s')
705+-------------------------------------------------------------------------------
706+-- * Substreams
707+
708+-- | /O(n)/ take n, applied to a stream, returns the prefix of the
709+-- stream of length @n@, or the stream itself if @n@ is greater than the
710+-- length of the stream.
711+take :: Int -> Stream Char -> Stream Char
712+take n0 (Stream next0 s0 len) = Stream next (n0 :!: s0) len
713+ where
714+ {-# INLINE next #-}
715+ next (n :!: s) | n <= 0 = Done
716+ | otherwise = case next0 s of
717+ Done -> Done
718+ Skip s' -> Skip (n :!: s')
719+ Yield x s' -> Yield x ((n-1) :!: s')
720+{-# INLINE [0] take #-}
721+
722+-- | /O(n)/ drop n, applied to a stream, returns the suffix of the
723+-- stream of length @n@, or the empty stream if @n@ is greater than the
724+-- length of the stream.
725+drop :: Int -> Stream Char -> Stream Char
726+drop n0 (Stream next0 s0 len) = Stream next (Just ((max 0 n0)) :!: s0) (len - n0)
727+ where
728+ {-# INLINE next #-}
729+ next (Just !n :!: s)
730+ | n == 0 = Skip (Nothing :!: s)
731+ | otherwise = case next0 s of
732+ Done -> Done
733+ Skip s' -> Skip (Just n :!: s')
734+ Yield _ s' -> Skip (Just (n-1) :!: s')
735+ next (Nothing :!: s) = case next0 s of
736+ Done -> Done
737+ Skip s' -> Skip (Nothing :!: s')
738+ Yield x s' -> Yield x (Nothing :!: s')
739+{-# INLINE [0] drop #-}
740+
741+-- | takeWhile, applied to a predicate @p@ and a stream, returns the
742+-- longest prefix (possibly empty) of elements that satisfy p.
743+takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char
744+takeWhile p (Stream next0 s0 len) = Stream next s0 len
745+ where
746+ {-# INLINE next #-}
747+ next !s = case next0 s of
748+ Done -> Done
749+ Skip s' -> Skip s'
750+ Yield x s' | p x -> Yield x s'
751+ | otherwise -> Done
752+{-# INLINE [0] takeWhile #-}
753+
754+-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
755+dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
756+dropWhile p (Stream next0 s0 len) = Stream next (S1 :!: s0) len
757+ where
758+ {-# INLINE next #-}
759+ next (S1 :!: s) = case next0 s of
760+ Done -> Done
761+ Skip s' -> Skip (S1 :!: s')
762+ Yield x s' | p x -> Skip (S1 :!: s')
763+ | otherwise -> Yield x (S2 :!: s')
764+ next (S2 :!: s) = case next0 s of
765+ Done -> Done
766+ Skip s' -> Skip (S2 :!: s')
767+ Yield x s' -> Yield x (S2 :!: s')
768+{-# INLINE [0] dropWhile #-}
769+
770+-- ----------------------------------------------------------------------------
771+-- * Searching
772+
773+-------------------------------------------------------------------------------
774+-- ** Searching by equality
775+
776+-- | /O(n)/ elem is the stream membership predicate.
777+elem :: Char -> Stream Char -> Bool
778+elem w (Stream next s0 len) = loop_elem s0
779+ where
780+ loop_elem !s = case next s of
781+ Done -> False
782+ Skip s' -> loop_elem s'
783+ Yield x s' | x == w -> True
784+ | otherwise -> loop_elem s'
785+{-# INLINE [0] elem #-}
786+
787+-------------------------------------------------------------------------------
788+-- ** Searching with a predicate
789+
790+-- | /O(n)/ The 'find' function takes a predicate and a stream,
791+-- and returns the first element in matching the predicate, or 'Nothing'
792+-- if there is no such element.
793+
794+find :: (Char -> Bool) -> Stream Char -> Maybe Char
795+find p (Stream next s0 len) = loop_find s0
796+ where
797+ loop_find !s = case next s of
798+ Done -> Nothing
799+ Skip s' -> loop_find s'
800+ Yield x s' | p x -> Just x
801+ | otherwise -> loop_find s'
802+{-# INLINE [0] find #-}
803+
804+-- | /O(n)/ 'filter', applied to a predicate and a stream,
805+-- returns a stream containing those characters that satisfy the
806+-- predicate.
807+filter :: (Char -> Bool) -> Stream Char -> Stream Char
808+filter p (Stream next0 s0 len) = Stream next s0 len
809+ where
810+ {-# INLINE next #-}
811+ next !s = case next0 s of
812+ Done -> Done
813+ Skip s' -> Skip s'
814+ Yield x s' | p x -> Yield x s'
815+ | otherwise -> Skip s'
816+{-# INLINE [0] filter #-}
817+
818+{-# RULES
819+ "Stream filter/filter fusion" forall p q s.
820+ filter p (filter q s) = filter (\x -> q x && p x) s
821+ #-}
822+
823+-------------------------------------------------------------------------------
824+-- ** Indexing streams
825+
826+-- | /O(1)/ stream index (subscript) operator, starting from 0.
827+index :: Stream Char -> Int -> Char
828+index (Stream next s0 len) n0
829+ | n0 < 0 = error "Stream.(!!): negative index"
830+ | otherwise = loop_index n0 s0
831+ where
832+ loop_index !n !s = case next s of
833+ Done -> error "Stream.(!!): index too large"
834+ Skip s' -> loop_index n s'
835+ Yield x s' | n == 0 -> x
836+ | otherwise -> loop_index (n-1) s'
837+{-# INLINE [0] index #-}
838+
839+-- | The 'findIndex' function takes a predicate and a stream and
840+-- returns the index of the first element in the stream
841+-- satisfying the predicate.
842+findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
843+findIndex p (Stream next s0 len) = loop_findIndex 0 s0
844+ where
845+ loop_findIndex !i !s = case next s of
846+ Done -> Nothing
847+ Skip s' -> loop_findIndex i s' -- hmm. not caught by QC
848+ Yield x s' | p x -> Just i
849+ | otherwise -> loop_findIndex (i+1) s'
850+{-# INLINE [0] findIndex #-}
851+
852+-- | /O(n)/ The 'elemIndex' function returns the index of the first
853+-- element in the given stream which is equal to the query
854+-- element, or 'Nothing' if there is no such element.
855+elemIndex :: Char -> Stream Char -> Maybe Int
856+elemIndex a (Stream next s0 len) = loop_elemIndex 0 s0
857+ where
858+ loop_elemIndex !i !s = case next s of
859+ Done -> Nothing
860+ Skip s' -> loop_elemIndex i s'
861+ Yield x s' | a == x -> Just i
862+ | otherwise -> loop_elemIndex (i+1) s'
863+{-# INLINE [0] elemIndex #-}
864+
865+-------------------------------------------------------------------------------
866+-- * Zipping
867+
868+-- | zipWith generalises 'zip' by zipping with the function given as
869+-- the first argument, instead of a tupling function.
870+zipWith :: (Char -> Char -> Char) -> Stream Char -> Stream Char -> Stream Char
871+zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) = Stream next (sa0 :!: sb0 :!: Nothing) (min len1 len2)
872+ where
873+ {-# INLINE next #-}
874+ next (sa :!: sb :!: Nothing) = case next0 sa of
875+ Done -> Done
876+ Skip sa' -> Skip (sa' :!: sb :!: Nothing)
877+ Yield a sa' -> Skip (sa' :!: sb :!: Just a)
878+
879+ next (sa' :!: sb :!: Just a) = case next1 sb of
880+ Done -> Done
881+ Skip sb' -> Skip (sa' :!: sb' :!: Just a)
882+ Yield b sb' -> Yield (f a b) (sa' :!: sb' :!: Nothing)
883+{-# INLINE [0] zipWith #-}
884+
885+errorEmptyList :: String -> a
886+errorEmptyList fun =
887+ error ("Prelude." ++ fun ++ ": empty list")
Text/Internal.hsnew file+11
@@ -0,0 +1,11 @@
1+module Text.Internal where
2+
3+import Data.Array.ST(newArray_,runSTUArray)
4+import Data.Array.Unboxed(UArray(..))
5+import Data.Word(Word16(..))
6+
7+data Text = Text !(UArray Int Word16) {-# UNPACK #-}!Int {-# UNPACK #-}!Int
8+
9+empty :: Text
10+empty = Text (runSTUArray (newArray_ (0,0))) 0 0
11+{-# INLINE [1] empty #-}
Text/UnsafeChar.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# OPTIONS_GHC -fglasgow-exts #-}
2+
3+module Text.UnsafeChar where
4+
5+import GHC.Exts
6+import GHC.Word
7+
8+unsafeChr :: Word16 -> Char
9+unsafeChr (W16# w#) = C# (chr# (word2Int# w#))
10+{-# INLINE unsafeChr #-}
11+
12+unsafeChr8 :: Word8 -> Char
13+unsafeChr8 (W8# w#) = C# (chr# (word2Int# w#))
14+{-# INLINE unsafeChr8 #-}
15+
16+unsafeChr32 :: Word32 -> Char
17+unsafeChr32 (W32# w#) = C# (chr# (word2Int# w#))
18+{-# INLINE unsafeChr32 #-}
Text/Utf16.hsnew file+24
@@ -0,0 +1,24 @@
1+{-# OPTIONS_GHC -fglasgow-exts #-}
2+
3+module Text.Utf16 where
4+
5+import GHC.Exts
6+import GHC.Word
7+
8+import Data.Word
9+
10+chr2 :: Word16 -> Word16 -> Char
11+chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#))
12+ where
13+ x# = word2Int# a#
14+ y# = word2Int# b#
15+ upper# = uncheckedIShiftL# (x# -# 0xD800#) 10#
16+ lower# = y# -# 0xDC00#
17+{-# INLINE chr2 #-}
18+
19+validate1 :: Word16 -> Bool
20+validate1 x1 = (x1 >= 0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 < 0x10000)
21+
22+validate2 :: Word16 -> Word16 -> Bool
23+validate2 x1 x2 = (x1 >= 0xD800 && x1 <= 0xDBFF) &&
24+ (x2 >= 0xDC00 && x2 <= 0xDFFF)
Text/Utf32.hsnew file+8
@@ -0,0 +1,8 @@
1+module Text.Utf32 where
2+
3+import Data.Bits
4+import Char
5+import Data.Word
6+
7+validate :: Word32 -> Bool
8+validate x1 = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)
Text/Utf32/Fusion.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# OPTIONS_GHC -fbang-patterns #-}
2+
3+module Text.Utf32.Fusion where
4+
5+import Text.Fusion hiding (stream, unstream)
6+import Text.Utf32.Internal
7+import Text.UnsafeChar
8+import Data.Array.Base
9+import Data.Word
10+import Data.Array.ST
11+import Control.Monad.ST
12+import Char
13+import Control.Monad
14+
15+stream :: Text -> Stream Char
16+stream (Text arr off len) = Stream next off len
17+ where
18+ end = off+len
19+ {-# INLINE next #-}
20+ next !i
21+ | i >= end = Done
22+ | otherwise = Yield (unsafeChr32 (arr `unsafeAt` i)) (i+1)
23+{-# INLINE [0] stream #-}
24+
25+unstream :: Stream Char -> Text
26+unstream (Stream next0 s0 len) = x `seq` Text (fst x) 0 (snd x)
27+ where
28+ x :: ((UArray Int Word32),Int)
29+ x = runST ((unsafeNewArray_ (0,len) :: ST s (STUArray s Int Word32))
30+ >>= (\arr -> loop arr 0 (len) s0))
31+ loop arr !i !max !s
32+ | i > max = do arr' <-unsafeNewArray_ (0,max*2)
33+ copy arr arr'
34+ loop arr' i (max*2) s
35+ | otherwise = case next0 s of
36+ Done -> liftM2 (,) (unsafeFreezeSTUArray arr) (return i)
37+ Skip s' -> loop arr i max s'
38+ Yield x s' -> do
39+ unsafeWrite arr i n
40+ loop arr (i+1) max s'
41+ where
42+ n :: Word32
43+ n = fromIntegral $ ord x
44+{-# INLINE [0] unstream #-}
45+
46+{-# RULES
47+"STREAM stream/unstream fusion" forall s.
48+ stream (unstream s) = s
49+ #-}
Text/Utf32/Internal.hsnew file+8
@@ -0,0 +1,8 @@
1+{-# OPTIONS_GHC -fglasgow-exts #-}
2+
3+module Text.Utf32.Internal where
4+
5+import Data.Array.Unboxed
6+import Data.Word
7+
8+data Text = Text !(UArray Int Word32) !Int !Int
Text/Utf8.hsnew file+134
@@ -0,0 +1,134 @@
1+{-# OPTIONS_GHC -fglasgow-exts #-}
2+module Text.Utf8 where
3+
4+import Char(ord)
5+import Data.Bits
6+import Data.Word
7+
8+import GHC.Exts
9+import GHC.Prim
10+import GHC.Word
11+
12+between :: Word8 -> Word8 -> Word8 -> Bool
13+between x y z = x >= y && x <= z
14+{-# INLINE between #-}
15+
16+ord2 :: Char -> (Word8,Word8)
17+ord2 c = (x1,x2)
18+ where
19+ n = ord c
20+ x1 = fromIntegral $ (shiftR n 6) + (0xC0 :: Int) :: Word8
21+ x2 = fromIntegral $ (n .&. 0x3F) + (0x80 :: Int) :: Word8
22+
23+ord3 :: Char -> (Word8,Word8,Word8)
24+ord3 c = (x1,x2,x3)
25+ where
26+ n = ord c
27+ x1 = fromIntegral $ (shiftR n 12) + (0xE0::Int) :: Word8
28+ x2 = fromIntegral $ ((shiftR n 6) .&. (0x3F::Int)) + (0x80::Int) :: Word8
29+ x3 = fromIntegral $ (n .&. (0x3F::Int)) + (0x80::Int) :: Word8
30+
31+ord4 :: Char -> (Word8,Word8,Word8,Word8)
32+ord4 c = (x1,x2,x3,x4)
33+ where
34+ n = ord c
35+ x1 = fromIntegral $ (shiftR n 18) + (0xF0::Int) :: Word8
36+ x2 = fromIntegral $ ((shiftR n 12) .&. (0x3F::Int)) + (0x80::Int) :: Word8
37+ x3 = fromIntegral $ ((shiftR n 6) .&. (0x3F::Int)) + (0x80::Int) :: Word8
38+ x4 = fromIntegral $ (n .&. (0x3F::Int)) + (0x80::Int) :: Word8
39+
40+chr2 :: Word8 -> Word8 -> Char
41+chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
42+ where
43+ y1# = word2Int# x1#
44+ y2# = word2Int# x2#
45+ z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6#
46+ z2# = y2# -# 0x8F#
47+{-# INLINE chr2 #-}
48+
49+chr3 :: Word8 -> Word8 -> Word8 -> Char
50+chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
51+ where
52+ y1# = word2Int# x1#
53+ y2# = word2Int# x2#
54+ y3# = word2Int# x3#
55+ z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12#
56+ z2# = uncheckedIShiftL# (y2# -# 0x80#) 6#
57+ z3# = y3# -# 0x80#
58+{-# INLINE chr3 #-}
59+
60+chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
61+chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
62+ C# (chr# (z1# +# z2# +# z3# +# z4#))
63+ where
64+ y1# = word2Int# x1#
65+ y2# = word2Int# x2#
66+ y3# = word2Int# x3#
67+ y4# = word2Int# x4#
68+ z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18#
69+ z2# = uncheckedIShiftL# (y2# -# 0x80#) 12#
70+ z3# = uncheckedIShiftL# (y3# -# 0x80#) 6#
71+ z4# = y4# -# 0x80#
72+{-# INLINE chr4 #-}
73+
74+validate1 :: Word8 -> Bool
75+validate1 x1 = between x1 0x00 0x7F
76+{-# INLINE validate1 #-}
77+
78+validate2 :: Word8 -> Word8 -> Bool
79+validate2 x1 x2 = between x1 0xC2 0xDF && between x2 0x80 0xBF
80+{-# INLINE validate2 #-}
81+
82+validate3 :: Word8 -> Word8 -> Word8 -> Bool
83+validate3 x1 x2 x3 = validate3_1 x1 x2 x3 ||
84+ validate3_2 x1 x2 x3 ||
85+ validate3_3 x1 x2 x3 ||
86+ validate3_4 x1 x2 x3
87+{-# INLINE validate3 #-}
88+
89+validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
90+validate4 x1 x2 x3 x4 = validate4_1 x1 x2 x3 x4 ||
91+ validate4_2 x1 x2 x3 x4 ||
92+ validate4_3 x1 x2 x3 x4
93+{-# INLINE validate4 #-}
94+
95+
96+
97+validate3_1 x1 x2 x3 = (x1 == 0xE0) &&
98+ between x2 0xA0 0xBF &&
99+ between x3 0x80 0xBF
100+{-# INLINE validate3_1 #-}
101+
102+validate3_2 x1 x2 x3 = between x1 0xE1 0xEC &&
103+ between x2 0x80 0xBF &&
104+ between x3 0x80 0xBF
105+{-# INLINE validate3_2 #-}
106+
107+validate3_3 x1 x2 x3 = x1 == 0xED &&
108+ between x2 0x80 0x9F &&
109+ between x3 0x80 0xBF
110+{-# INLINE validate3_3 #-}
111+
112+validate3_4 x1 x2 x3 = between x1 0xEE 0xEF &&
113+ between x2 0x80 0xBF &&
114+ between x2 0x80 0xBF
115+{-# INLINE validate3_4 #-}
116+
117+
118+validate4_1 x1 x2 x3 x4 = x1 == 0xF0 &&
119+ between x2 0x90 0xBF &&
120+ between x3 0x80 0xBF &&
121+ between x4 0x80 0xBF
122+{-# INLINE validate4_1 #-}
123+
124+validate4_2 x1 x2 x3 x4 = between x1 0xF1 0xF3 &&
125+ between x2 0x80 0xBF &&
126+ between x3 0x80 0xBF &&
127+ between x4 0x80 0xBF
128+{-# INLINE validate4_2 #-}
129+
130+validate4_3 x1 x2 x3 x4 = x1 == 0xF4 &&
131+ between x2 0x80 0x8F &&
132+ between x3 0x80 0xBF &&
133+ between x4 0x80 0xBF
134+{-# INLINE validate4_3 #-}
Text/Utf8/Fusion.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# OPTIONS_GHC -fbang-patterns -fglasgow-exts #-}
2+
3+module Text.Utf8.Fusion where
4+
5+import Data.Array.Base
6+import Data.Word
7+import Control.Monad.ST
8+import Data.Text.UnsafeChar
9+import Control.Monad
10+import Char
11+
12+import Text.Utf8
13+import Text.Utf8.Internal
14+import Text.Fusion hiding (stream,unstream)
15+
16+stream :: Text -> Stream Char
17+stream (Text arr off len) = Stream next off len
18+ where
19+ end = off+len
20+ {-# INLINE next #-}
21+ next !i
22+ | i >= end = Done
23+ | n <= 0x7F = Yield (unsafeChr8 n) (i + 1)
24+ | n <= 0xDF = Yield (chr2 n n2) (i + 2)
25+ | n <= 0xEF = Yield (chr3 n n2 n3) (i + 3)
26+ | otherwise = Yield (chr4 n n2 n3 n4) (i + 4)
27+ where
28+ n = arr `unsafeAt` i
29+ n2 = arr `unsafeAt` (i + 1)
30+ n3 = arr `unsafeAt` (i + 2)
31+ n4 = arr `unsafeAt` (i + 3)
32+{-# INLINE [0] stream #-}
33+
34+
35+unstream :: Stream Char -> Text
36+unstream (Stream next0 s0 len) = x `seq` (Text (fst x) 0 (snd x))
37+ where
38+ x :: ((UArray Int Word8), Int)
39+ x = runST ((unsafeNewArray_ (0,len+4) :: ST s (STUArray s Int Word8))
40+ >>= (\arr -> loop arr 0 (len+4) s0))
41+ loop !arr !i !max !s
42+ | i + 4 > max = do arr' <- unsafeNewArray_ (0,max*2)
43+ copy arr arr'
44+ loop arr' i (max*2) s
45+ | otherwise = case next0 s of
46+ Done -> liftM2 (,) (unsafeFreezeSTUArray arr) (return i)
47+ Skip s' -> loop arr i max s'
48+ Yield x s'
49+ | n <= 0x7F -> do
50+ unsafeWrite arr i n
51+ loop arr (i+1) max s'
52+ | n <= 0x07FF -> do
53+ unsafeWrite arr i (fst n2)
54+ unsafeWrite arr (i+1) (snd n2)
55+ loop arr (i+2) max s'
56+ | n <= 0xFFFF -> do
57+ unsafeWrite arr i (fst3 n3)
58+ unsafeWrite arr (i+1) (snd3 n3)
59+ unsafeWrite arr (i+2) (trd3 n3)
60+ loop arr (i+3) max s'
61+ | otherwise -> do
62+ unsafeWrite arr i (fst4 n4)
63+ unsafeWrite arr (i+1) (snd4 n4)
64+ unsafeWrite arr (i+2) (trd4 n4)
65+ unsafeWrite arr (i+3) (fth4 n4)
66+ loop arr (i+4) max s'
67+ where
68+ n = (fromIntegral . ord) x :: Word8
69+ n2 = ord2 x
70+ n3 = ord3 x
71+ n4 = ord4 x
72+ fst3 !x = let (x1,_,_) = x in x1
73+ snd3 !x = let (_,x2,_) = x in x2
74+ trd3 !x = let (_,_,x3) = x in x3
75+ fst4 !x = let (x1,_,_,_) = x in x1
76+ snd4 !x = let (_,x2,_,_) = x in x2
77+ trd4 !x = let (_,_,x3,_) = x in x3
78+ fth4 !x = let (_,_,_,x4) = x in x4
79+{-# INLINE [0] unstream #-}
80+
81+{-# RULES
82+"STREAM stream/unstream fusion" forall s.
83+ stream (unstream s) = s
84+ #-}
Text/Utf8/Internal.hsnew file+6
@@ -0,0 +1,6 @@
1+module Text.Utf8.Internal where
2+
3+import Data.Array.Unboxed
4+import Data.Word
5+
6+data Text = Text !(UArray Int Word8) !Int !Int