git.iko.soy/text
on master help sign in
swap
bb3d8620 ahead, 2 behind
23 files changed+2575−2458
since splitsnapshots
unifiedsplit
Data/JSString/Text.hs−64 Data/Text.hs+505−616 Data/Text/Encoding.hs+64−105 Data/Text/IO.hs−16 Data/Text/Internal.hs+125−42 Data/Text/Internal/Builder.hs+5−47 Data/Text/Internal/Encoding/Fusion.hs+8−10 Data/Text/Internal/Encoding/Fusion/Common.hs+4−8 Data/Text/Internal/Fusion.hs+180−42 Data/Text/Internal/Fusion/Common.hs+922−968 Data/Text/Internal/Fusion/Types.hs+99−102 Data/Text/Internal/IO.hs−8 Data/Text/Internal/Lazy.hs+10−18 Data/Text/Internal/Lazy/Encoding/Fusion.hs−26 Data/Text/Internal/Lazy/Fusion.hs−62 Data/Text/Internal/Lazy/Search.hs+11−55 Data/Text/Internal/Private.hs+1−8 Data/Text/Internal/Search.hs+37−40 Data/Text/Lazy.hs+52−58 Data/Text/Lazy/Builder/Int.hs+259−9 Data/Text/Lazy/Builder/RealFloat.hs+233−2 Data/Text/Unsafe.hs−87 text.cabal+60−65
Data/JSString/Text.hsdeleted−64
@@ -1,64 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI,
2− UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim,
3− MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-}
4−
5−{- | Conversion between 'Data.Text.Text' and 'Data.JSString.JSString'
6−
7− -}
8−
9−-- | Moved from ghcjs-base with text-jsstring support.
10−
11−module Data.JSString.Text
12− ( textToJSString
13− , textFromJSString
14− , lazyTextToJSString
15− , lazyTextFromJSString
16− , textFromJSVal
17− , lazyTextFromJSVal
18− ) where
19−
20−import GHCJS.Prim
21−
22−import GHC.Exts (Any)
23−
24−import Control.DeepSeq
25−
26−import qualified Data.Text as T
27−import qualified Data.Text.Internal as T
28−import qualified Data.Text.Lazy as TL
29−import Data.JSString (JSString)
30−
31−import GHCJS.Marshal.Pure
32−import Unsafe.Coerce
33−
34−textToJSString :: T.Text -> JSString
35−textToJSString (T.Text txt) = txt
36−{-# INLINE textToJSString #-}
37−
38−textFromJSString :: JSString -> T.Text
39−textFromJSString = T.Text
40−{-# INLINE textFromJSString #-}
41−
42−lazyTextToJSString :: TL.Text -> JSString
43−lazyTextToJSString t = rnf t `seq` js_lazyTextToString (unsafeCoerce t)
44−{-# INLINE lazyTextToJSString #-}
45−
46−lazyTextFromJSString :: JSString -> TL.Text
47−lazyTextFromJSString = TL.fromStrict . textFromJSString
48−{-# INLINE lazyTextFromJSString #-}
49−
50−-- | returns the empty Text if not a string
51−textFromJSVal :: JSVal -> T.Text
52−textFromJSVal v = T.Text $ pFromJSVal v -- TODO check if val is a string?
53−{-# INLINE textFromJSVal #-}
54−
55−-- | returns the empty Text if not a string
56−lazyTextFromJSVal :: JSVal -> TL.Text
57−lazyTextFromJSVal = TL.fromStrict . textFromJSVal
58−{-# INLINE lazyTextFromJSVal #-}
59−
60−-- ----------------------------------------------------------------------------
61−
62−foreign import javascript unsafe
63− "h$lazyTextToString"
64− js_lazyTextToString :: Any -> JSString
Data/Text.hs+505−616
@@ -6,7 +6,7 @@
66#if __GLASGOW_HASKELL__ >= 708
77{-# LANGUAGE TypeFamilies #-}
88#endif
9−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
9+
1010-- |
1111-- Module : Data.Text
1212-- Copyright : (c) 2009, 2010, 2011, 2012 Bryan O'Sullivan,
@@ -223,16 +223,16 @@ import qualified Data.Text.Internal.Fusion as S
223223import qualified Data.Text.Internal.Fusion.Common as S
224224import Data.Text.Encoding (decodeUtf8', encodeUtf8)
225225import Data.Text.Internal.Fusion (stream, reverseStream, unstream)
226−-- import Data.Text.Internal.Private (span_)
226+import Data.Text.Internal.Private (span_)
227227import Data.Text.Internal (Text(..), empty, firstf, mul, safe, text)
228−-- import Data.Text.Show (singleton, unpack, unpackCString#)
228+import Data.Text.Show (singleton, unpack, unpackCString#)
229229import qualified Prelude as P
230230import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter,
231231 reverseIter_, unsafeHead, unsafeTail)
232232import Data.Text.Internal.Unsafe.Char (unsafeChr)
233233import qualified Data.Text.Internal.Functions as F
234234import qualified Data.Text.Internal.Encoding.Utf16 as U16
235−-- import Data.Text.Internal.Search (indices)
235+import Data.Text.Internal.Search (indices)
236236#if defined(__HADDOCK__)
237237import Data.ByteString (ByteString)
238238import qualified Data.Text.Lazy as L
@@ -246,28 +246,6 @@ import qualified GHC.Exts as Exts
246246import Text.Printf (PrintfArg, formatArg, formatString)
247247#endif
248248
249−-- GHCJS ------------------------------------------------------------
250−import Data.JSString (JSString)
251−import qualified Data.JSString as JSS
252−import qualified Data.JSString.Internal.Fusion as SJS
253−import qualified Data.JSString.Internal.Fusion.Common as SJS
254−import Data.Coerce
255−import GHC.Exts (Addr#)
256−
257−unpack :: Text -> String
258−unpack = coerce JSS.unpack
259−
260−singleton :: Char -> Text
261−singleton = coerce JSS.singleton
262−{-# INLINE [1] singleton #-}
263−
264−
265−-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion.
266−unpackCString# :: Addr# -> Text
267−unpackCString# addr# = Text $ SJS.unstream (SJS.streamCString# addr#)
268−{-# NOINLINE unpackCString# #-}
269−---------------------------------------------------------------------
270−
271249-- $strict
272250--
273251-- This package provides both strict and lazy 'Text' types. The
@@ -343,17 +321,17 @@ unpackCString# addr# = Text $ SJS.unstream (SJS.streamCString# addr#)
343321-- Functions that can be fused by the compiler are documented with the
344322-- phrase \"Subject to fusion\".
345323
346−-- instance Eq Text where
347−-- Text arrA offA lenA == Text arrB offB lenB
348−-- | lenA == lenB = A.equal arrA offA arrB offB lenA
349−-- | otherwise = False
350−-- {-# INLINE (==) #-}
324+instance Eq Text where
325+ Text arrA offA lenA == Text arrB offB lenB
326+ | lenA == lenB = A.equal arrA offA arrB offB lenA
327+ | otherwise = False
328+ {-# INLINE (==) #-}
351329
352−-- instance Ord Text where
353−-- compare = compareText
330+instance Ord Text where
331+ compare = compareText
354332
355−-- instance Read Text where
356−-- readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
333+instance Read Text where
334+ readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
357335
358336#if MIN_VERSION_base(4,9,0)
359337-- Semigroup orphan instances for older GHCs are provided by
@@ -363,17 +341,17 @@ instance Semigroup Text where
363341 (<>) = append
364342#endif
365343
366−-- instance Monoid Text where
367−-- mempty = empty
368−-- #if MIN_VERSION_base(4,9,0)
369−-- mappend = (<>) -- future-proof definition
370−-- #else
371−-- mappend = append
372−-- #endif
373−-- mconcat = concat
344+instance Monoid Text where
345+ mempty = empty
346+#if MIN_VERSION_base(4,9,0)
347+ mappend = (<>) -- future-proof definition
348+#else
349+ mappend = append
350+#endif
351+ mconcat = concat
374352
375−-- instance IsString Text where
376−-- fromString = pack
353+instance IsString Text where
354+ fromString = pack
377355
378356#if __GLASGOW_HASKELL__ >= 708
379357instance Exts.IsList Text where
@@ -409,18 +387,18 @@ instance Binary Text where
409387-- and 'Data.Map.Map' is archived here:
410388-- <http://markmail.org/message/trovdc6zkphyi3cr#query:+page:1+mid:a46der3iacwjcf6n+state:results Proposal: Allow gunfold for Data.Map, ... >
411389
412−-- instance Data Text where
413−-- gfoldl f z txt = z pack `f` (unpack txt)
414−-- toConstr _ = packConstr
415−-- gunfold k z c = case constrIndex c of
416−-- 1 -> k (z pack)
417−-- _ -> P.error "gunfold"
418−-- dataTypeOf _ = textDataType
390+instance Data Text where
391+ gfoldl f z txt = z pack `f` (unpack txt)
392+ toConstr _ = packConstr
393+ gunfold k z c = case constrIndex c of
394+ 1 -> k (z pack)
395+ _ -> P.error "gunfold"
396+ dataTypeOf _ = textDataType
419397
420398#if MIN_VERSION_base(4,7,0)
421399-- | Only defined for @base-4.7.0.0@ and later
422400instance PrintfArg Text where
423− formatArg t = formatString $ unpack t
401+ formatArg txt = formatString $ unpack txt
424402#endif
425403
426404packConstr :: Constr
@@ -429,19 +407,19 @@ packConstr = mkConstr textDataType "pack" [] Prefix
429407textDataType :: DataType
430408textDataType = mkDataType "Data.Text.Text" [packConstr]
431409
432−-- -- | /O(n)/ Compare two 'Text' values lexicographically.
433−-- compareText :: Text -> Text -> Ordering
434−-- compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
435−-- | lenA == 0 && lenB == 0 = EQ
436−-- | otherwise = go 0 0
437−-- where
438−-- go !i !j
439−-- | i >= lenA || j >= lenB = compare lenA lenB
440−-- | a < b = LT
441−-- | a > b = GT
442−-- | otherwise = go (i+di) (j+dj)
443−-- where Iter a di = iter ta i
444−-- Iter b dj = iter tb j
410+-- | /O(n)/ Compare two 'Text' values lexicographically.
411+compareText :: Text -> Text -> Ordering
412+compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
413+ | lenA == 0 && lenB == 0 = EQ
414+ | otherwise = go 0 0
415+ where
416+ go !i !j
417+ | i >= lenA || j >= lenB = compare lenA lenB
418+ | a < b = LT
419+ | a > b = GT
420+ | otherwise = go (i+di) (j+dj)
421+ where Iter a di = iter ta i
422+ Iter b dj = iter tb j
445423
446424-- -----------------------------------------------------------------------------
447425-- * Conversion to/from 'Text'
@@ -449,8 +427,7 @@ textDataType = mkDataType "Data.Text.Text" [packConstr]
449427-- | /O(n)/ Convert a 'String' into a 'Text'. Subject to
450428-- fusion. Performs replacement on invalid scalar values.
451429pack :: String -> Text
452−pack = coerce JSS.pack
453−-- pack = unstream . S.map safe . S.streamList
430+pack = unstream . S.map safe . S.streamList
454431{-# INLINE [1] pack #-}
455432
456433-- -----------------------------------------------------------------------------
@@ -461,8 +438,7 @@ pack = coerce JSS.pack
461438-- copying a new array. Subject to fusion. Performs replacement on
462439-- invalid scalar values.
463440cons :: Char -> Text -> Text
464−cons = coerce JSS.cons
465−-- cons c t = unstream (S.cons (safe c) (stream t))
441+cons c t = unstream (S.cons (safe c) (stream t))
466442{-# INLINE cons #-}
467443
468444infixr 5 `cons`
@@ -471,51 +447,47 @@ infixr 5 `cons`
471447-- entire array in the process, unless fused. Subject to fusion.
472448-- Performs replacement on invalid scalar values.
473449snoc :: Text -> Char -> Text
474−snoc = coerce JSS.snoc
475−-- snoc t c = unstream (S.snoc (stream t) (safe c))
450+snoc t c = unstream (S.snoc (stream t) (safe c))
476451{-# INLINE snoc #-}
477452
478453-- | /O(n)/ Appends one 'Text' to the other by copying both of them
479454-- into a new 'Text'. Subject to fusion.
480455append :: Text -> Text -> Text
481−append = coerce JSS.append
482−-- append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2)
483−-- | len1 == 0 = b
484−-- | len2 == 0 = a
485−-- | len > 0 = Text (A.run x) 0 len
486−-- | otherwise = overflowError "append"
487−-- where
488−-- len = len1+len2
489−-- x :: ST s (A.MArray s)
490−-- x = do
491−-- arr <- A.new len
492−-- A.copyI arr 0 arr1 off1 len1
493−-- A.copyI arr len1 arr2 off2 len
494−-- return arr
456+append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2)
457+ | len1 == 0 = b
458+ | len2 == 0 = a
459+ | len > 0 = Text (A.run x) 0 len
460+ | otherwise = overflowError "append"
461+ where
462+ len = len1+len2
463+ x :: ST s (A.MArray s)
464+ x = do
465+ arr <- A.new len
466+ A.copyI arr 0 arr1 off1 len1
467+ A.copyI arr len1 arr2 off2 len
468+ return arr
495469{-# NOINLINE append #-}
496470
497−-- {-# RULES
498−-- "TEXT append -> fused" [~1] forall t1 t2.
499−-- append t1 t2 = unstream (S.append (stream t1) (stream t2))
500−-- "TEXT append -> unfused" [1] forall t1 t2.
501−-- unstream (S.append (stream t1) (stream t2)) = append t1 t2
502−-- #-}
471+{-# RULES
472+"TEXT append -> fused" [~1] forall t1 t2.
473+ append t1 t2 = unstream (S.append (stream t1) (stream t2))
474+"TEXT append -> unfused" [1] forall t1 t2.
475+ unstream (S.append (stream t1) (stream t2)) = append t1 t2
476+ #-}
503477
504478-- | /O(1)/ Returns the first character of a 'Text', which must be
505479-- non-empty. Subject to fusion.
506480head :: Text -> Char
507−head = coerce JSS.head
508−-- head t = S.head (stream t)
481+head t = S.head (stream t)
509482{-# INLINE head #-}
510483
511484-- | /O(1)/ Returns the first character and rest of a 'Text', or
512485-- 'Nothing' if empty. Subject to fusion.
513486uncons :: Text -> Maybe (Char, Text)
514−uncons = coerce JSS.uncons
515−-- uncons t@(Text arr off len)
516−-- | len <= 0 = Nothing
517−-- | otherwise = Just $ let !(Iter c d) = iter t 0
518−-- in (c, text arr (off+d) (len-d))
487+uncons t@(Text arr off len)
488+ | len <= 0 = Nothing
489+ | otherwise = Just $ let !(Iter c d) = iter t 0
490+ in (c, text arr (off+d) (len-d))
519491{-# INLINE [1] uncons #-}
520492
521493-- | Lifted from Control.Arrow and specialized.
@@ -525,86 +497,81 @@ second f (a, b) = (a, f b)
525497-- | /O(1)/ Returns the last character of a 'Text', which must be
526498-- non-empty. Subject to fusion.
527499last :: Text -> Char
528−last = coerce JSS.last
529−-- last (Text arr off len)
530−-- | len <= 0 = emptyError "last"
531−-- | n < 0xDC00 || n > 0xDFFF = unsafeChr n
532−-- | otherwise = U16.chr2 n0 n
533−-- where n = A.unsafeIndex arr (off+len-1)
534−-- n0 = A.unsafeIndex arr (off+len-2)
500+last (Text arr off len)
501+ | len <= 0 = emptyError "last"
502+ | n < 0xDC00 || n > 0xDFFF = unsafeChr n
503+ | otherwise = U16.chr2 n0 n
504+ where n = A.unsafeIndex arr (off+len-1)
505+ n0 = A.unsafeIndex arr (off+len-2)
535506{-# INLINE [1] last #-}
536507
537−-- {-# RULES
538−-- "TEXT last -> fused" [~1] forall t.
539−-- last t = S.last (stream t)
540−-- "TEXT last -> unfused" [1] forall t.
541−-- S.last (stream t) = last t
542−-- #-}
508+{-# RULES
509+"TEXT last -> fused" [~1] forall t.
510+ last t = S.last (stream t)
511+"TEXT last -> unfused" [1] forall t.
512+ S.last (stream t) = last t
513+ #-}
543514
544515-- | /O(1)/ Returns all characters after the head of a 'Text', which
545516-- must be non-empty. Subject to fusion.
546517tail :: Text -> Text
547−tail = coerce JSS.tail
548−-- tail t@(Text arr off len)
549−-- | len <= 0 = emptyError "tail"
550−-- | otherwise = text arr (off+d) (len-d)
551−-- where d = iter_ t 0
518+tail t@(Text arr off len)
519+ | len <= 0 = emptyError "tail"
520+ | otherwise = text arr (off+d) (len-d)
521+ where d = iter_ t 0
552522{-# INLINE [1] tail #-}
553523
554−-- {-# RULES
555−-- "TEXT tail -> fused" [~1] forall t.
556−-- tail t = unstream (S.tail (stream t))
557−-- "TEXT tail -> unfused" [1] forall t.
558−-- unstream (S.tail (stream t)) = tail t
559−-- #-}
524+{-# RULES
525+"TEXT tail -> fused" [~1] forall t.
526+ tail t = unstream (S.tail (stream t))
527+"TEXT tail -> unfused" [1] forall t.
528+ unstream (S.tail (stream t)) = tail t
529+ #-}
560530
561531-- | /O(1)/ Returns all but the last character of a 'Text', which must
562532-- be non-empty. Subject to fusion.
563533init :: Text -> Text
564−init = coerce JSS.init
565−-- init (Text arr off len) | len <= 0 = emptyError "init"
566−-- | n >= 0xDC00 && n <= 0xDFFF = text arr off (len-2)
567−-- | otherwise = text arr off (len-1)
568−-- where
569−-- n = A.unsafeIndex arr (off+len-1)
534+init (Text arr off len) | len <= 0 = emptyError "init"
535+ | n >= 0xDC00 && n <= 0xDFFF = text arr off (len-2)
536+ | otherwise = text arr off (len-1)
537+ where
538+ n = A.unsafeIndex arr (off+len-1)
570539{-# INLINE [1] init #-}
571540
572−-- {-# RULES
573−-- "TEXT init -> fused" [~1] forall t.
574−-- init t = unstream (S.init (stream t))
575−-- "TEXT init -> unfused" [1] forall t.
576−-- unstream (S.init (stream t)) = init t
577−-- #-}
541+{-# RULES
542+"TEXT init -> fused" [~1] forall t.
543+ init t = unstream (S.init (stream t))
544+"TEXT init -> unfused" [1] forall t.
545+ unstream (S.init (stream t)) = init t
546+ #-}
578547
579548-- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to
580549-- fusion.
581550null :: Text -> Bool
582−null = coerce JSS.null
583−-- null (Text _arr _off len) =
584−-- #if defined(ASSERTS)
585−-- assert (len >= 0) $
586−-- #endif
587−-- len <= 0
551+null (Text _arr _off len) =
552+#if defined(ASSERTS)
553+ assert (len >= 0) $
554+#endif
555+ len <= 0
588556{-# INLINE [1] null #-}
589557
590−-- {-# RULES
591−-- "TEXT null -> fused" [~1] forall t.
592−-- null t = S.null (stream t)
593−-- "TEXT null -> unfused" [1] forall t.
594−-- S.null (stream t) = null t
595−-- #-}
558+{-# RULES
559+"TEXT null -> fused" [~1] forall t.
560+ null t = S.null (stream t)
561+"TEXT null -> unfused" [1] forall t.
562+ S.null (stream t) = null t
563+ #-}
596564
597565-- | /O(1)/ Tests whether a 'Text' contains exactly one character.
598566-- Subject to fusion.
599−-- isSingleton :: Text -> Bool
600−-- isSingleton = S.isSingleton . stream
601−-- {-# INLINE isSingleton #-}
567+isSingleton :: Text -> Bool
568+isSingleton = S.isSingleton . stream
569+{-# INLINE isSingleton #-}
602570
603571-- | /O(n)/ Returns the number of characters in a 'Text'.
604572-- Subject to fusion.
605573length :: Text -> Int
606−length = coerce JSS.length
607−-- length t = S.length (stream t)
574+length t = S.length (stream t)
608575{-# INLINE [0] length #-}
609576-- length needs to be phased after the compareN/length rules otherwise
610577-- it may inline before the rules have an opportunity to fire.
@@ -616,44 +583,43 @@ length = coerce JSS.length
616583-- of 'length', but can short circuit if the count of characters is
617584-- greater than the number, and hence be more efficient.
618585compareLength :: Text -> Int -> Ordering
619−compareLength t n = compare (length t) n
620−-- compareLength t n = S.compareLengthI (stream t) n
621−-- {-# INLINE [1] compareLength #-}
622−--
623−-- {-# RULES
624−-- "TEXT compareN/length -> compareLength" [~1] forall t n.
625−-- compare (length t) n = compareLength t n
626−-- #-}
627−--
628−-- {-# RULES
629−-- "TEXT ==N/length -> compareLength/==EQ" [~1] forall t n.
630−-- eqInt (length t) n = compareLength t n == EQ
631−-- #-}
632−--
633−-- {-# RULES
634−-- "TEXT /=N/length -> compareLength//=EQ" [~1] forall t n.
635−-- neInt (length t) n = compareLength t n /= EQ
636−-- #-}
637−--
638−-- {-# RULES
639−-- "TEXT <N/length -> compareLength/==LT" [~1] forall t n.
640−-- ltInt (length t) n = compareLength t n == LT
641−-- #-}
642−--
643−-- {-# RULES
644−-- "TEXT <=N/length -> compareLength//=GT" [~1] forall t n.
645−-- leInt (length t) n = compareLength t n /= GT
646−-- #-}
647−--
648−-- {-# RULES
649−-- "TEXT >N/length -> compareLength/==GT" [~1] forall t n.
650−-- gtInt (length t) n = compareLength t n == GT
651−-- #-}
652−--
653−-- {-# RULES
654−-- "TEXT >=N/length -> compareLength//=LT" [~1] forall t n.
655−-- geInt (length t) n = compareLength t n /= LT
656−-- #-}
586+compareLength t n = S.compareLengthI (stream t) n
587+{-# INLINE [1] compareLength #-}
588+
589+{-# RULES
590+"TEXT compareN/length -> compareLength" [~1] forall t n.
591+ compare (length t) n = compareLength t n
592+ #-}
593+
594+{-# RULES
595+"TEXT ==N/length -> compareLength/==EQ" [~1] forall t n.
596+ eqInt (length t) n = compareLength t n == EQ
597+ #-}
598+
599+{-# RULES
600+"TEXT /=N/length -> compareLength//=EQ" [~1] forall t n.
601+ neInt (length t) n = compareLength t n /= EQ
602+ #-}
603+
604+{-# RULES
605+"TEXT <N/length -> compareLength/==LT" [~1] forall t n.
606+ ltInt (length t) n = compareLength t n == LT
607+ #-}
608+
609+{-# RULES
610+"TEXT <=N/length -> compareLength//=GT" [~1] forall t n.
611+ leInt (length t) n = compareLength t n /= GT
612+ #-}
613+
614+{-# RULES
615+"TEXT >N/length -> compareLength/==GT" [~1] forall t n.
616+ gtInt (length t) n = compareLength t n == GT
617+ #-}
618+
619+{-# RULES
620+"TEXT >=N/length -> compareLength//=LT" [~1] forall t n.
621+ geInt (length t) n = compareLength t n /= LT
622+ #-}
657623
658624-- -----------------------------------------------------------------------------
659625-- * Transformations
@@ -661,30 +627,26 @@ compareLength t n = compare (length t) n
661627-- each element of @t@. Subject to fusion. Performs replacement on
662628-- invalid scalar values.
663629map :: (Char -> Char) -> Text -> Text
664−map = coerce JSS.map
665−-- map f t = unstream (S.map (safe . f) (stream t))
630+map f t = unstream (S.map (safe . f) (stream t))
666631{-# INLINE [1] map #-}
667632
668633-- | /O(n)/ The 'intercalate' function takes a 'Text' and a list of
669634-- 'Text's and concatenates the list after interspersing the first
670635-- argument between each element of the list.
671636intercalate :: Text -> [Text] -> Text
672−intercalate = coerce JSS.intercalate
673−-- intercalate t = concat . (F.intersperse t)
637+intercalate t = concat . (F.intersperse t)
674638{-# INLINE intercalate #-}
675639
676640-- | /O(n)/ The 'intersperse' function takes a character and places it
677641-- between the characters of a 'Text'. Subject to fusion. Performs
678642-- replacement on invalid scalar values.
679643intersperse :: Char -> Text -> Text
680−intersperse = coerce JSS.intersperse
681−-- intersperse c t = unstream (S.intersperse (safe c) (stream t))
644+intersperse c t = unstream (S.intersperse (safe c) (stream t))
682645{-# INLINE intersperse #-}
683646
684647-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
685648reverse :: Text -> Text
686−reverse = coerce JSS.reverse
687−-- reverse t = S.reverse (stream t)
649+reverse t = S.reverse (stream t)
688650{-# INLINE reverse #-}
689651
690652-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
@@ -718,29 +680,28 @@ replace :: Text
718680 -> Text
719681 -- ^ @haystack@ in which to search.
720682 -> Text
721−replace = coerce JSS.replace
722−-- replace needle@(Text _ _ neeLen)
723−-- (Text repArr repOff repLen)
724−-- haystack@(Text hayArr hayOff hayLen)
725−-- | neeLen == 0 = emptyError "replace"
726−-- | L.null ixs = haystack
727−-- | len > 0 = Text (A.run x) 0 len
728−-- | otherwise = empty
729−-- where
730−-- ixs = indices needle haystack
731−-- len = hayLen - (neeLen - repLen) `mul` L.length ixs
732−-- x :: ST s (A.MArray s)
733−-- x = do
734−-- marr <- A.new len
735−-- let loop (i:is) o d = do
736−-- let d0 = d + i - o
737−-- d1 = d0 + repLen
738−-- A.copyI marr d hayArr (hayOff+o) d0
739−-- A.copyI marr d0 repArr repOff d1
740−-- loop is (i + neeLen) d1
741−-- loop [] o d = A.copyI marr d hayArr (hayOff+o) len
742−-- loop ixs 0 0
743−-- return marr
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
744705
745706-- ----------------------------------------------------------------------------
746707-- ** Case conversions (folds)
@@ -779,8 +740,7 @@ replace = coerce JSS.replace
779740-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
780741-- instead of itself.
781742toCaseFold :: Text -> Text
782−-- toCaseFold t = unstream (S.toCaseFold (stream t))
783−toCaseFold = coerce JSS.toCaseFold
743+toCaseFold t = unstream (S.toCaseFold (stream t))
784744{-# INLINE toCaseFold #-}
785745
786746-- | /O(n)/ Convert a string to lower case, using simple case
@@ -791,8 +751,7 @@ toCaseFold = coerce JSS.toCaseFold
791751-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
792752-- followed by \" &#x307;\" (combining dot above, U+0307).
793753toLower :: Text -> Text
794−-- toLower t = unstream (S.toLower (stream t))
795−toLower = coerce JSS.toLower
754+toLower t = unstream (S.toLower (stream t))
796755{-# INLINE toLower #-}
797756
798757-- | /O(n)/ Convert a string to upper case, using simple case
@@ -802,8 +761,7 @@ toLower = coerce JSS.toLower
802761-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
803762-- two-letter sequence \"SS\".
804763toUpper :: Text -> Text
805−-- toUpper t = unstream (S.toUpper (stream t))
806−toUpper = coerce JSS.toUpper
764+toUpper t = unstream (S.toUpper (stream t))
807765{-# INLINE toUpper #-}
808766
809767-- | /O(n)/ Convert a string to title case, using simple case
@@ -825,8 +783,7 @@ toUpper = coerce JSS.toUpper
825783-- Fox\" is correctly title cased&#x2014;but this function will
826784-- capitalize /every/ word.
827785toTitle :: Text -> Text
828−toTitle = coerce JSS.toTitle
829−-- toTitle t = unstream (S.toTitle (stream t))
786+toTitle t = unstream (S.toTitle (stream t))
830787{-# INLINE toTitle #-}
831788
832789-- | /O(n)/ Left-justify a string to the given length, using the
@@ -838,19 +795,18 @@ toTitle = coerce JSS.toTitle
838795-- > justifyLeft 7 'x' "foo" == "fooxxxx"
839796-- > justifyLeft 3 'x' "foobar" == "foobar"
840797justifyLeft :: Int -> Char -> Text -> Text
841−justifyLeft = coerce JSS.justifyLeft
842−-- justifyLeft k c t
843−-- | len >= k = t
844−-- | otherwise = t `append` replicateChar (k-len) c
845−-- where len = length t
798+justifyLeft k c t
799+ | len >= k = t
800+ | otherwise = t `append` replicateChar (k-len) c
801+ where len = length t
846802{-# INLINE [1] justifyLeft #-}
847803
848−-- {-# RULES
849−-- "TEXT justifyLeft -> fused" [~1] forall k c t.
850−-- justifyLeft k c t = unstream (S.justifyLeftI k c (stream t))
851−-- "TEXT justifyLeft -> unfused" [1] forall k c t.
852−-- unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t
853−-- #-}
804+{-# RULES
805+"TEXT justifyLeft -> fused" [~1] forall k c t.
806+ justifyLeft k c t = unstream (S.justifyLeftI k c (stream t))
807+"TEXT justifyLeft -> unfused" [1] forall k c t.
808+ unstream (S.justifyLeftI k c (stream t)) = justifyLeft k c t
809+ #-}
854810
855811-- | /O(n)/ Right-justify a string to the given length, using the
856812-- specified fill character on the left. Performs replacement on
@@ -861,11 +817,10 @@ justifyLeft = coerce JSS.justifyLeft
861817-- > justifyRight 7 'x' "bar" == "xxxxbar"
862818-- > justifyRight 3 'x' "foobar" == "foobar"
863819justifyRight :: Int -> Char -> Text -> Text
864−justifyRight = coerce JSS.justifyRight
865−-- justifyRight k c t
866−-- | len >= k = t
867−-- | otherwise = replicateChar (k-len) c `append` t
868−-- where len = length t
820+justifyRight k c t
821+ | len >= k = t
822+ | otherwise = replicateChar (k-len) c `append` t
823+ where len = length t
869824{-# INLINE justifyRight #-}
870825
871826-- | /O(n)/ Center a string to the given length, using the specified
@@ -876,14 +831,13 @@ justifyRight = coerce JSS.justifyRight
876831--
877832-- > center 8 'x' "HS" = "xxxHSxxx"
878833center :: Int -> Char -> Text -> Text
879−center = coerce JSS.center
880−-- center k c t
881−-- | len >= k = t
882−-- | otherwise = replicateChar l c `append` t `append` replicateChar r c
883−-- where len = length t
884−-- d = k - len
885−-- r = d `quot` 2
886−-- l = d - r
834+center k c t
835+ | len >= k = t
836+ | otherwise = replicateChar l c `append` t `append` replicateChar r c
837+ where len = length t
838+ d = k - len
839+ r = d `quot` 2
840+ l = d - r
887841{-# INLINE center #-}
888842
889843-- | /O(n)/ The 'transpose' function transposes the rows and columns
@@ -891,8 +845,7 @@ center = coerce JSS.center
891845-- 'unpack', and the list version of transpose, and is thus not very
892846-- efficient.
893847transpose :: [Text] -> [Text]
894−transpose = coerce JSS.transpose
895−-- transpose ts = P.map pack (L.transpose (P.map unpack ts))
848+transpose ts = P.map pack (L.transpose (P.map unpack ts))
896849
897850-- -----------------------------------------------------------------------------
898851-- * Reducing 'Text's (folds)
@@ -902,27 +855,23 @@ transpose = coerce JSS.transpose
902855-- reduces the 'Text' using the binary operator, from left to right.
903856-- Subject to fusion.
904857foldl :: (a -> Char -> a) -> a -> Text -> a
905−foldl f a0 (Text t) = JSS.foldl f a0 t
906−-- foldl f z t = S.foldl f z (stream t)
858+foldl f z t = S.foldl f z (stream t)
907859{-# INLINE foldl #-}
908860
909861-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
910862foldl' :: (a -> Char -> a) -> a -> Text -> a
911−foldl' f a0 (Text t) = JSS.foldl' f a0 t
912−-- foldl' f z t = S.foldl' f z (stream t)
863+foldl' f z t = S.foldl' f z (stream t)
913864{-# INLINE foldl' #-}
914865
915866-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
916867-- and thus must be applied to a non-empty 'Text'. Subject to fusion.
917868foldl1 :: (Char -> Char -> Char) -> Text -> Char
918−foldl1 = coerce JSS.foldl1
919−-- foldl1 f t = S.foldl1 f (stream t)
869+foldl1 f t = S.foldl1 f (stream t)
920870{-# INLINE foldl1 #-}
921871
922872-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
923873foldl1' :: (Char -> Char -> Char) -> Text -> Char
924−foldl1' = coerce JSS.foldl1'
925−-- foldl1' f t = S.foldl1' f (stream t)
874+foldl1' f t = S.foldl1' f (stream t)
926875{-# INLINE foldl1' #-}
927876
928877-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
@@ -930,16 +879,14 @@ foldl1' = coerce JSS.foldl1'
930879-- reduces the 'Text' using the binary operator, from right to left.
931880-- Subject to fusion.
932881foldr :: (Char -> a -> a) -> a -> Text -> a
933−foldr f a0 (Text t) = JSS.foldr f a0 t
934−-- foldr f z t = S.foldr f z (stream t)
882+foldr f z t = S.foldr f z (stream t)
935883{-# INLINE foldr #-}
936884
937885-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
938886-- and thus must be applied to a non-empty 'Text'. Subject to
939887-- fusion.
940888foldr1 :: (Char -> Char -> Char) -> Text -> Char
941−foldr1 = coerce JSS.foldr1
942−-- foldr1 f t = S.foldr1 f (stream t)
889+foldr1 f t = S.foldr1 f (stream t)
943890{-# INLINE foldr1 #-}
944891
945892-- -----------------------------------------------------------------------------
@@ -947,54 +894,48 @@ foldr1 = coerce JSS.foldr1
947894
948895-- | /O(n)/ Concatenate a list of 'Text's.
949896concat :: [Text] -> Text
950−concat = coerce JSS.concat
951−-- concat ts = case ts' of
952−-- [] -> empty
953−-- [t] -> t
954−-- _ -> Text (A.run go) 0 len
955−-- where
956−-- ts' = L.filter (not . null) ts
957−-- len = sumP "concat" $ L.map lengthWord16 ts'
958−-- go :: ST s (A.MArray s)
959−-- go = do
960−-- arr <- A.new len
961−-- let step i (Text a o l) =
962−-- let !j = i + l in A.copyI arr i a o j >> return j
963−-- foldM step 0 ts' >> return arr
897+concat ts = case ts' of
898+ [] -> empty
899+ [t] -> t
900+ _ -> Text (A.run go) 0 len
901+ where
902+ ts' = L.filter (not . null) ts
903+ len = sumP "concat" $ L.map lengthWord16 ts'
904+ go :: ST s (A.MArray s)
905+ go = do
906+ arr <- A.new len
907+ let step i (Text a o l) =
908+ let !j = i + l in A.copyI arr i a o j >> return j
909+ foldM step 0 ts' >> return arr
964910
965911-- | /O(n)/ Map a function over a 'Text' that results in a 'Text', and
966912-- concatenate the results.
967913concatMap :: (Char -> Text) -> Text -> Text
968−concatMap = coerce JSS.concatMap
969−-- concatMap f = concat . foldr ((:) . f) []
914+concatMap f = concat . foldr ((:) . f) []
970915{-# INLINE concatMap #-}
971916
972917-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
973918-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
974919any :: (Char -> Bool) -> Text -> Bool
975−any = coerce JSS.any
976−-- any p t = S.any p (stream t)
920+any p t = S.any p (stream t)
977921{-# INLINE any #-}
978922
979923-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
980924-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
981925all :: (Char -> Bool) -> Text -> Bool
982−all = coerce JSS.all
983−-- all p t = S.all p (stream t)
926+all p t = S.all p (stream t)
984927{-# INLINE all #-}
985928
986929-- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which
987930-- must be non-empty. Subject to fusion.
988931maximum :: Text -> Char
989−maximum = coerce JSS.maximum
990−-- maximum t = S.maximum (stream t)
932+maximum t = S.maximum (stream t)
991933{-# INLINE maximum #-}
992934
993935-- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which
994936-- must be non-empty. Subject to fusion.
995937minimum :: Text -> Char
996−minimum = coerce JSS.minimum
997−-- minimum t = S.minimum (stream t)
938+minimum t = S.minimum (stream t)
998939{-# INLINE minimum #-}
999940
1000941-- -----------------------------------------------------------------------------
@@ -1010,9 +951,8 @@ minimum = coerce JSS.minimum
1010951--
1011952-- > last (scanl f z xs) == foldl f z xs.
1012953scanl :: (Char -> Char -> Char) -> Char -> Text -> Text
1013−scanl = coerce JSS.scanl
1014−-- scanl f z t = unstream (S.scanl g z (stream t))
1015−-- where g a b = safe (f a b)
954+scanl f z t = unstream (S.scanl g z (stream t))
955+ where g a b = safe (f a b)
1016956{-# INLINE scanl #-}
1017957
1018958-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
@@ -1021,9 +961,8 @@ scanl = coerce JSS.scanl
1021961--
1022962-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
1023963scanl1 :: (Char -> Char -> Char) -> Text -> Text
1024−scanl1 = coerce JSS.scanl1
1025−-- scanl1 f t | null t = empty
1026−-- | otherwise = scanl f (unsafeHead t) (unsafeTail t)
964+scanl1 f t | null t = empty
965+ | otherwise = scanl f (unsafeHead t) (unsafeTail t)
1027966{-# INLINE scanl1 #-}
1028967
1029968-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
@@ -1031,18 +970,16 @@ scanl1 = coerce JSS.scanl1
1031970--
1032971-- > scanr f v == reverse . scanl (flip f) v . reverse
1033972scanr :: (Char -> Char -> Char) -> Char -> Text -> Text
1034−scanr = coerce JSS.scanr
1035−-- scanr f z = S.reverse . S.reverseScanr g z . reverseStream
1036−-- where g a b = safe (f a b)
973+scanr f z = S.reverse . S.reverseScanr g z . reverseStream
974+ where g a b = safe (f a b)
1037975{-# INLINE scanr #-}
1038976
1039977-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
1040978-- value argument. Subject to fusion. Performs replacement on
1041979-- invalid scalar values.
1042980scanr1 :: (Char -> Char -> Char) -> Text -> Text
1043−scanr1 = coerce JSS.scanr1
1044−-- scanr1 f t | null t = empty
1045−-- | otherwise = scanr f (last t) (init t)
981+scanr1 f t | null t = empty
982+ | otherwise = scanr f (last t) (init t)
1046983{-# INLINE scanr1 #-}
1047984
1048985-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
@@ -1050,11 +987,8 @@ scanr1 = coerce JSS.scanr1
1050987-- parameter from left to right, and returns a final 'Text'. Performs
1051988-- replacement on invalid scalar values.
1052989mapAccumL :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
1053−mapAccumL f z0 (Text a) =
1054− let (a', t) = JSS.mapAccumL f z0 a
1055− in (a', Text t)
1056−-- mapAccumL f z0 = S.mapAccumL g z0 . stream
1057−-- where g a b = second safe (f a b)
990+mapAccumL f z0 = S.mapAccumL g z0 . stream
991+ where g a b = second safe (f a b)
1058992{-# INLINE mapAccumL #-}
1059993
1060994-- | The 'mapAccumR' function behaves like a combination of 'map' and
@@ -1064,11 +998,8 @@ mapAccumL f z0 (Text a) =
1064998-- 'Text'.
1065999-- Performs replacement on invalid scalar values.
10661000mapAccumR :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
1067−mapAccumR f z0 (Text a) =
1068− let (a', t) = JSS.mapAccumR f z0 a
1069− in (a', Text t)
1070−-- mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
1071−-- where g a b = second safe (f a b)
1001+mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
1002+ where g a b = second safe (f a b)
10721003{-# INLINE mapAccumR #-}
10731004
10741005-- -----------------------------------------------------------------------------
@@ -1077,33 +1008,32 @@ mapAccumR f z0 (Text a) =
10771008-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'Text' consisting of the input
10781009-- @t@ repeated @n@ times.
10791010replicate :: Int -> Text -> Text
1080−replicate = coerce JSS.replicate
1081−-- replicate n t@(Text a o l)
1082−-- | n <= 0 || l <= 0 = empty
1083−-- | n == 1 = t
1084−-- | isSingleton t = replicateChar n (unsafeHead t)
1085−-- | otherwise = Text (A.run x) 0 len
1086−-- where
1087−-- len = l `mul` n
1088−-- x :: ST s (A.MArray s)
1089−-- x = do
1090−-- arr <- A.new len
1091−-- let loop !d !i | i >= n = return arr
1092−-- | otherwise = let m = d + l
1093−-- in A.copyI arr d a o m >> loop m (i+1)
1094−-- loop 0 0
1011+replicate n t@(Text a o l)
1012+ | n <= 0 || l <= 0 = empty
1013+ | n == 1 = t
1014+ | isSingleton t = replicateChar n (unsafeHead t)
1015+ | otherwise = Text (A.run x) 0 len
1016+ where
1017+ len = l `mul` n
1018+ x :: ST s (A.MArray s)
1019+ x = do
1020+ arr <- A.new len
1021+ let loop !d !i | i >= n = return arr
1022+ | otherwise = let m = d + l
1023+ in A.copyI arr d a o m >> loop m (i+1)
1024+ loop 0 0
10951025{-# INLINE [1] replicate #-}
10961026
1097−-- {-# RULES
1098−-- "TEXT replicate/singleton -> replicateChar" [~1] forall n c.
1099−-- replicate n (singleton c) = replicateChar n c
1100−-- #-}
1027+{-# RULES
1028+"TEXT replicate/singleton -> replicateChar" [~1] forall n c.
1029+ replicate n (singleton c) = replicateChar n c
1030+ #-}
11011031
11021032-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the
11031033-- value of every element. Subject to fusion.
1104−-- replicateChar :: Int -> Char -> Text
1105−-- replicateChar n c = unstream (S.replicateCharI n (safe c))
1106−-- {-# INLINE replicateChar #-}
1034+replicateChar :: Int -> Char -> Text
1035+replicateChar n c = unstream (S.replicateCharI n (safe c))
1036+{-# INLINE replicateChar #-}
11071037
11081038-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
11091039-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
@@ -1113,8 +1043,7 @@ replicate = coerce JSS.replicate
11131043-- string, and @b@ is the seed value for further production. Subject
11141044-- to fusion. Performs replacement on invalid scalar values.
11151045unfoldr :: (a -> Maybe (Char,a)) -> a -> Text
1116−unfoldr f a = Text $ JSS.unfoldr f a
1117−-- unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
1046+unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
11181047{-# INLINE unfoldr #-}
11191048
11201049-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Text' from a seed
@@ -1124,8 +1053,7 @@ unfoldr f a = Text $ JSS.unfoldr f a
11241053-- correct, otherwise its performance is similar to 'unfoldr'. Subject
11251054-- to fusion. Performs replacement on invalid scalar values.
11261055unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Text
1127−unfoldrN n f a0 = Text $ JSS.unfoldrN n f a0
1128−-- unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
1056+unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
11291057{-# INLINE unfoldrN #-}
11301058
11311059-- -----------------------------------------------------------------------------
@@ -1135,26 +1063,25 @@ unfoldrN n f a0 = Text $ JSS.unfoldrN n f a0
11351063-- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than
11361064-- the length of the Text. Subject to fusion.
11371065take :: Int -> Text -> Text
1138−take = coerce JSS.take
1139−-- take n t@(Text arr off len)
1140−-- | n <= 0 = empty
1141−-- | n >= len = t
1142−-- | otherwise = text arr off (iterN n t)
1066+take n t@(Text arr off len)
1067+ | n <= 0 = empty
1068+ | n >= len = t
1069+ | otherwise = text arr off (iterN n t)
11431070{-# INLINE [1] take #-}
11441071
1145−-- iterN :: Int -> Text -> Int
1146−-- iterN n t@(Text _arr _off len) = loop 0 0
1147−-- where loop !i !cnt
1148−-- | i >= len || cnt >= n = i
1149−-- | otherwise = loop (i+d) (cnt+1)
1150−-- where d = iter_ t i
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
11511078
1152−-- {-# RULES
1153−-- "TEXT take -> fused" [~1] forall n t.
1154−-- take n t = unstream (S.take n (stream t))
1155−-- "TEXT take -> unfused" [1] forall n t.
1156−-- unstream (S.take n (stream t)) = take n t
1157−-- #-}
1079+{-# RULES
1080+"TEXT take -> fused" [~1] forall n t.
1081+ take n t = unstream (S.take n (stream t))
1082+"TEXT take -> unfused" [1] forall n t.
1083+ unstream (S.take n (stream t)) = take n t
1084+ #-}
11581085
11591086-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
11601087-- taking @n@ characters from the end of @t@.
@@ -1163,39 +1090,37 @@ take = coerce JSS.take
11631090--
11641091-- > takeEnd 3 "foobar" == "bar"
11651092takeEnd :: Int -> Text -> Text
1166−takeEnd = coerce JSS.takeEnd
1167−-- takeEnd n t@(Text arr off len)
1168−-- | n <= 0 = empty
1169−-- | n >= len = t
1170−-- | otherwise = text arr (off+i) (len-i)
1171−-- where i = iterNEnd n t
1172−
1173−-- iterNEnd :: Int -> Text -> Int
1174−-- iterNEnd n t@(Text _arr _off len) = loop (len-1) n
1175−-- where loop i !m
1176−-- | i <= 0 = 0
1177−-- | m <= 1 = i
1178−-- | otherwise = loop (i+d) (m-1)
1179−-- where d = reverseIter_ t i
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
11801106
11811107-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
11821108-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
11831109-- is greater than the length of the 'Text'. Subject to fusion.
11841110drop :: Int -> Text -> Text
1185−drop = coerce JSS.drop
1186−-- drop n t@(Text arr off len)
1187−-- | n <= 0 = t
1188−-- | n >= len = empty
1189−-- | otherwise = text arr (off+i) (len-i)
1190−-- where i = iterN n t
1111+drop n t@(Text arr off len)
1112+ | n <= 0 = t
1113+ | n >= len = empty
1114+ | otherwise = text arr (off+i) (len-i)
1115+ where i = iterN n t
11911116{-# INLINE [1] drop #-}
11921117
1193−-- {-# RULES
1194−-- "TEXT drop -> fused" [~1] forall n t.
1195−-- drop n t = unstream (S.drop n (stream t))
1196−-- "TEXT drop -> unfused" [1] forall n t.
1197−-- unstream (S.drop n (stream t)) = drop n t
1198−-- #-}
1118+{-# RULES
1119+"TEXT drop -> fused" [~1] forall n t.
1120+ drop n t = unstream (S.drop n (stream t))
1121+"TEXT drop -> unfused" [1] forall n t.
1122+ unstream (S.drop n (stream t)) = drop n t
1123+ #-}
11991124
12001125-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
12011126-- dropping @n@ characters from the end of @t@.
@@ -1204,30 +1129,28 @@ drop = coerce JSS.drop
12041129--
12051130-- > dropEnd 3 "foobar" == "foo"
12061131dropEnd :: Int -> Text -> Text
1207−dropEnd = coerce JSS.dropEnd
1208−-- dropEnd n t@(Text arr off len)
1209−-- | n <= 0 = t
1210−-- | n >= len = empty
1211−-- | otherwise = text arr off (iterNEnd n t)
1132+dropEnd n t@(Text arr off len)
1133+ | n <= 0 = t
1134+ | n >= len = empty
1135+ | otherwise = text arr off (iterNEnd n t)
12121136
12131137-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
12141138-- returns the longest prefix (possibly empty) of elements that
12151139-- satisfy @p@. Subject to fusion.
12161140takeWhile :: (Char -> Bool) -> Text -> Text
1217−takeWhile = coerce JSS.takeWhile
1218−-- takeWhile p t@(Text arr off len) = loop 0
1219−-- where loop !i | i >= len = t
1220−-- | p c = loop (i+d)
1221−-- | otherwise = text arr off i
1222−-- where Iter c d = iter t i
1141+takeWhile p t@(Text arr off len) = loop 0
1142+ where loop !i | i >= len = t
1143+ | p c = loop (i+d)
1144+ | otherwise = text arr off i
1145+ where Iter c d = iter t i
12231146{-# INLINE [1] takeWhile #-}
12241147
1225−-- {-# RULES
1226−-- "TEXT takeWhile -> fused" [~1] forall p t.
1227−-- takeWhile p t = unstream (S.takeWhile p (stream t))
1228−-- "TEXT takeWhile -> unfused" [1] forall p t.
1229−-- unstream (S.takeWhile p (stream t)) = takeWhile p t
1230−-- #-}
1148+{-# RULES
1149+"TEXT takeWhile -> fused" [~1] forall p t.
1150+ takeWhile p t = unstream (S.takeWhile p (stream t))
1151+"TEXT takeWhile -> unfused" [1] forall p t.
1152+ unstream (S.takeWhile p (stream t)) = takeWhile p t
1153+ #-}
12311154
12321155-- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text',
12331156-- returns the longest suffix (possibly empty) of elements that
@@ -1236,39 +1159,36 @@ takeWhile = coerce JSS.takeWhile
12361159--
12371160-- > takeWhileEnd (=='o') "foo" == "oo"
12381161takeWhileEnd :: (Char -> Bool) -> Text -> Text
1239−takeWhileEnd = P.undefined -- TODO
1240−-- takeWhileEnd :: (Char -> Bool) -> Text -> Text
1241−-- takeWhileEnd p t@(Text arr off len) = loop (len-1) len
1242−-- where loop !i !l | l <= 0 = t
1243−-- | p c = loop (i+d) (l+d)
1244−-- | otherwise = text arr (off+l) (len-l)
1245−-- where (c,d) = reverseIter t i
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
12461167{-# INLINE [1] takeWhileEnd #-}
12471168
1248−-- {-# RULES
1249−-- "TEXT takeWhileEnd -> fused" [~1] forall p t.
1250−-- takeWhileEnd p t = S.reverse (S.takeWhile p (S.reverseStream t))
1251−-- "TEXT takeWhileEnd -> unfused" [1] forall p t.
1252−-- S.reverse (S.takeWhile p (S.reverseStream t)) = takeWhileEnd p t
1253−-- #-}
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+ #-}
12541175
12551176-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
12561177-- 'takeWhile' @p@ @t@. Subject to fusion.
12571178dropWhile :: (Char -> Bool) -> Text -> Text
1258−dropWhile = coerce JSS.dropWhile
1259−-- dropWhile p t@(Text arr off len) = loop 0 0
1260−-- where loop !i !l | l >= len = empty
1261−-- | p c = loop (i+d) (l+d)
1262−-- | otherwise = Text arr (off+i) (len-l)
1263−
1179+dropWhile p t@(Text arr off len) = loop 0 0
1180+ where loop !i !l | l >= len = empty
1181+ | p c = loop (i+d) (l+d)
1182+ | otherwise = Text arr (off+i) (len-l)
1183+ where Iter c d = iter t i
12641184{-# INLINE [1] dropWhile #-}
12651185
1266−-- {-# RULES
1267−-- "TEXT dropWhile -> fused" [~1] forall p t.
1268−-- dropWhile p t = unstream (S.dropWhile p (stream t))
1269−-- "TEXT dropWhile -> unfused" [1] forall p t.
1270−-- unstream (S.dropWhile p (stream t)) = dropWhile p t
1271−-- #-}
1186+{-# RULES
1187+"TEXT dropWhile -> fused" [~1] forall p t.
1188+ dropWhile p t = unstream (S.dropWhile p (stream t))
1189+"TEXT dropWhile -> unfused" [1] forall p t.
1190+ unstream (S.dropWhile p (stream t)) = dropWhile p t
1191+ #-}
12721192
12731193-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
12741194-- dropping characters that satisfy the predicate @p@ from the end of
@@ -1278,20 +1198,19 @@ dropWhile = coerce JSS.dropWhile
12781198--
12791199-- > dropWhileEnd (=='.') "foo..." == "foo"
12801200dropWhileEnd :: (Char -> Bool) -> Text -> Text
1281−dropWhileEnd = coerce JSS.dropWhileEnd
1282−-- dropWhileEnd p t@(Text arr off len) = loop (len-1) len
1283−-- where loop !i !l | l <= 0 = empty
1284−-- | p c = loop (i+d) (l+d)
1285−-- | otherwise = Text arr off l
1286−-- where (c,d) = reverseIter t i
1201+dropWhileEnd p t@(Text arr off len) = loop (len-1) len
1202+ where loop !i !l | l <= 0 = empty
1203+ | p c = loop (i+d) (l+d)
1204+ | otherwise = Text arr off l
1205+ where (c,d) = reverseIter t i
12871206{-# INLINE [1] dropWhileEnd #-}
12881207
1289−-- {-# RULES
1290−-- "TEXT dropWhileEnd -> fused" [~1] forall p t.
1291−-- dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t))
1292−-- "TEXT dropWhileEnd -> unfused" [1] forall p t.
1293−-- S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t
1294−-- #-}
1208+{-# RULES
1209+"TEXT dropWhileEnd -> fused" [~1] forall p t.
1210+ dropWhileEnd p t = S.reverse (S.dropWhile p (S.reverseStream t))
1211+"TEXT dropWhileEnd -> unfused" [1] forall p t.
1212+ S.reverse (S.dropWhile p (S.reverseStream t)) = dropWhileEnd p t
1213+ #-}
12951214
12961215-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
12971216-- dropping characters that satisfy the predicate @p@ from both the
@@ -1326,49 +1245,45 @@ strip = dropAround isSpace
13261245-- prefix of @t@ of length @n@, and whose second is the remainder of
13271246-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
13281247splitAt :: Int -> Text -> (Text, Text)
1329−splitAt = coerce JSS.splitAt
1330−-- splitAt n t@(Text arr off len)
1331−-- | n <= 0 = (empty, t)
1332−-- | n >= len = (t, empty)
1333−-- | otherwise = let k = iterN n t
1334−-- in (text arr off k, text arr (off+k) (len-k))
1248+splitAt n t@(Text arr off len)
1249+ | n <= 0 = (empty, t)
1250+ | n >= len = (t, empty)
1251+ | otherwise = let k = iterN n t
1252+ in (text arr off k, text arr (off+k) (len-k))
13351253
13361254-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
13371255-- a pair whose first element is the longest prefix (possibly empty)
13381256-- of @t@ of elements that satisfy @p@, and whose second is the
13391257-- remainder of the list.
13401258span :: (Char -> Bool) -> Text -> (Text, Text)
1341−span = coerce JSS.span
1342−-- span p t = case span_ p t of
1343−-- (# hd,tl #) -> (hd,tl)
1259+span p t = case span_ p t of
1260+ (# hd,tl #) -> (hd,tl)
13441261{-# INLINE span #-}
13451262
13461263-- | /O(n)/ 'break' is like 'span', but the prefix returned is
13471264-- over elements that fail the predicate @p@.
13481265break :: (Char -> Bool) -> Text -> (Text, Text)
1349−break = coerce JSS.break
1350−-- break p = span (not . p)
1266+break p = span (not . p)
13511267{-# INLINE break #-}
13521268
13531269-- | /O(n)/ Group characters in a string according to a predicate.
13541270groupBy :: (Char -> Char -> Bool) -> Text -> [Text]
1355−groupBy = coerce JSS.groupBy
1356−-- groupBy p = loop
1357−-- where
1358−-- loop t@(Text arr off len)
1359−-- | null t = []
1360−-- | otherwise = text arr off n : loop (text arr (off+n) (len-n))
1361−-- where Iter c d = iter t 0
1362−-- n = d + findAIndexOrEnd (not . p c) (Text arr (off+d) (len-d))
1271+groupBy p = loop
1272+ where
1273+ loop t@(Text arr off len)
1274+ | null t = []
1275+ | otherwise = text arr off n : loop (text arr (off+n) (len-n))
1276+ where Iter c d = iter t 0
1277+ n = d + findAIndexOrEnd (not . p c) (Text arr (off+d) (len-d))
13631278
13641279-- | Returns the /array/ index (in units of 'Word16') at which a
13651280-- character may be found. This is /not/ the same as the logical
13661281-- index returned by e.g. 'findIndex'.
1367−-- findAIndexOrEnd :: (Char -> Bool) -> Text -> Int
1368−-- findAIndexOrEnd q t@(Text _arr _off len) = go 0
1369−-- where go !i | i >= len || q c = i
1370−-- | otherwise = go (i+d)
1371−-- where Iter c d = iter t i
1282+findAIndexOrEnd :: (Char -> Bool) -> Text -> Int
1283+findAIndexOrEnd q t@(Text _arr _off len) = go 0
1284+ where go !i | i >= len || q c = i
1285+ | otherwise = go (i+d)
1286+ where Iter c d = iter t i
13721287
13731288-- | /O(n)/ Group characters in a string by equality.
13741289group :: Text -> [Text]
@@ -1377,17 +1292,15 @@ group = groupBy (==)
13771292-- | /O(n)/ Return all initial segments of the given 'Text', shortest
13781293-- first.
13791294inits :: Text -> [Text]
1380−inits = coerce JSS.inits
1381−-- inits t@(Text arr off len) = loop 0
1382−-- where loop i | i >= len = [t]
1383−-- | otherwise = Text arr off i : loop (i + iter_ t i)
1295+inits t@(Text arr off len) = loop 0
1296+ where loop i | i >= len = [t]
1297+ | otherwise = Text arr off i : loop (i + iter_ t i)
13841298
13851299-- | /O(n)/ Return all final segments of the given 'Text', longest
13861300-- first.
13871301tails :: Text -> [Text]
1388−tails = coerce JSS.tails
1389−-- tails t | null t = [empty]
1390−-- | otherwise = t : tails (unsafeTail t)
1302+tails t | null t = [empty]
1303+ | otherwise = t : tails (unsafeTail t)
13911304
13921305-- $split
13931306--
@@ -1420,20 +1333,19 @@ splitOn :: Text
14201333 -> Text
14211334 -- ^ Input text.
14221335 -> [Text]
1423−splitOn = coerce JSS.splitOn
1424−-- splitOn pat@(Text _ _ l) src@(Text arr off len)
1425−-- | l <= 0 = emptyError "splitOn"
1426−-- | isSingleton pat = split (== unsafeHead pat) src
1427−-- | otherwise = go 0 (indices pat src)
1428−-- where
1429−-- go !s (x:xs) = text arr (s+off) (x-s) : go (x+l) xs
1430−-- go s _ = [text arr (s+off) (len-s)]
1336+splitOn pat@(Text _ _ l) src@(Text arr off len)
1337+ | l <= 0 = emptyError "splitOn"
1338+ | isSingleton pat = split (== unsafeHead pat) src
1339+ | otherwise = go 0 (indices pat src)
1340+ where
1341+ go !s (x:xs) = text arr (s+off) (x-s) : go (x+l) xs
1342+ go s _ = [text arr (s+off) (len-s)]
14311343{-# INLINE [1] splitOn #-}
14321344
1433−-- {-# RULES
1434−-- "TEXT splitOn/singleton -> split/==" [~1] forall c t.
1435−-- splitOn (singleton c) t = split (==c) t
1436−-- #-}
1345+{-# RULES
1346+"TEXT splitOn/singleton -> split/==" [~1] forall c t.
1347+ splitOn (singleton c) t = split (==c) t
1348+ #-}
14371349
14381350-- | /O(n)/ Splits a 'Text' into components delimited by separators,
14391351-- where the predicate returns True for a separator element. The
@@ -1443,12 +1355,11 @@ splitOn = coerce JSS.splitOn
14431355-- > split (=='a') "aabbaca" == ["","","bb","c",""]
14441356-- > split (=='a') "" == [""]
14451357split :: (Char -> Bool) -> Text -> [Text]
1446−split = coerce JSS.split
1447−-- split _ t@(Text _off _arr 0) = [t]
1448−-- split p t = loop t
1449−-- where loop s | null s' = [l]
1450−-- | otherwise = l : loop (unsafeTail s')
1451−-- where (# l, s' #) = span_ (not . p) s
1358+split _ t@(Text _off _arr 0) = [t]
1359+split p t = loop t
1360+ where loop s | null s' = [l]
1361+ | otherwise = l : loop (unsafeTail s')
1362+ where (# l, s' #) = span_ (not . p) s
14521363{-# INLINE split #-}
14531364
14541365-- | /O(n)/ Splits a 'Text' into components of length @k@. The last
@@ -1458,12 +1369,11 @@ split = coerce JSS.split
14581369-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
14591370-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
14601371chunksOf :: Int -> Text -> [Text]
1461−chunksOf = coerce JSS.chunksOf
1462−-- chunksOf k = go
1463−-- where
1464−-- go t = case splitAt k t of
1465−-- (a,b) | null a -> []
1466−-- | otherwise -> a : go b
1372+chunksOf k = go
1373+ where
1374+ go t = case splitAt k t of
1375+ (a,b) | null a -> []
1376+ | otherwise -> a : go b
14671377{-# INLINE chunksOf #-}
14681378
14691379-- ----------------------------------------------------------------------------
@@ -1476,8 +1386,7 @@ chunksOf = coerce JSS.chunksOf
14761386-- returns the first element matching the predicate, or 'Nothing' if
14771387-- there is no such element.
14781388find :: (Char -> Bool) -> Text -> Maybe Char
1479−find = coerce JSS.find
1480−-- find p t = S.findBy p (stream t)
1389+find p t = S.findBy p (stream t)
14811390{-# INLINE find #-}
14821391
14831392-- | /O(n)/ The 'partition' function takes a predicate and a 'Text',
@@ -1486,16 +1395,14 @@ find = coerce JSS.find
14861395--
14871396-- > partition p t == (filter p t, filter (not . p) t)
14881397partition :: (Char -> Bool) -> Text -> (Text, Text)
1489−partition = coerce JSS.partition
1490−-- partition p t = (filter p t, filter (not . p) t)
1398+partition p t = (filter p t, filter (not . p) t)
14911399{-# INLINE partition #-}
14921400
14931401-- | /O(n)/ 'filter', applied to a predicate and a 'Text',
14941402-- returns a 'Text' containing those characters that satisfy the
14951403-- predicate.
14961404filter :: (Char -> Bool) -> Text -> Text
1497−filter = coerce JSS.filter
1498−-- filter p t = unstream (S.filter p (stream t))
1405+filter p t = unstream (S.filter p (stream t))
14991406{-# INLINE filter #-}
15001407
15011408-- | /O(n+m)/ Find the first instance of @needle@ (which must be
@@ -1520,12 +1427,11 @@ filter = coerce JSS.filter
15201427-- In (unlikely) bad cases, this function's time complexity degrades
15211428-- towards /O(n*m)/.
15221429breakOn :: Text -> Text -> (Text, Text)
1523−breakOn = coerce JSS.breakOn
1524−-- breakOn pat src@(Text arr off len)
1525−-- | null pat = emptyError "breakOn"
1526−-- | otherwise = case indices pat src of
1527−-- [] -> (src, empty)
1528−-- (x:_) -> (text arr off x, text arr (off+x) (len-x))
1430+breakOn pat src@(Text arr off len)
1431+ | null pat = emptyError "breakOn"
1432+ | otherwise = case indices pat src of
1433+ [] -> (src, empty)
1434+ (x:_) -> (text arr off x, text arr (off+x) (len-x))
15291435{-# INLINE breakOn #-}
15301436
15311437-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
@@ -1537,9 +1443,8 @@ breakOn = coerce JSS.breakOn
15371443--
15381444-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
15391445breakOnEnd :: Text -> Text -> (Text, Text)
1540−breakOnEnd = coerce JSS.breakOnEnd
1541−-- breakOnEnd pat src = (reverse b, reverse a)
1542−-- where (a,b) = breakOn (reverse pat) (reverse src)
1446+breakOnEnd pat src = (reverse b, reverse a)
1447+ where (a,b) = breakOn (reverse pat) (reverse src)
15431448{-# INLINE breakOnEnd #-}
15441449
15451450-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
@@ -1563,13 +1468,12 @@ breakOnEnd = coerce JSS.breakOnEnd
15631468breakOnAll :: Text -- ^ @needle@ to search for
15641469 -> Text -- ^ @haystack@ in which to search
15651470 -> [(Text, Text)]
1566−breakOnAll = coerce JSS.breakOnAll
1567−-- breakOnAll pat src@(Text arr off slen)
1568−-- | null pat = emptyError "breakOnAll"
1569−-- | otherwise = L.map step (indices pat src)
1570−-- where
1571−-- step x = (chunk 0 x, chunk x (slen-x))
1572−-- chunk !n !l = text arr (n+off) l
1471+breakOnAll pat src@(Text arr off slen)
1472+ | null pat = emptyError "breakOnAll"
1473+ | otherwise = L.map step (indices pat src)
1474+ where
1475+ step x = (chunk 0 x, chunk x (slen-x))
1476+ chunk !n !l = text arr (n+off) l
15731477{-# INLINE breakOnAll #-}
15741478
15751479-------------------------------------------------------------------------------
@@ -1593,16 +1497,14 @@ breakOnAll = coerce JSS.breakOnAll
15931497
15941498-- | /O(n)/ 'Text' index (subscript) operator, starting from 0.
15951499index :: Text -> Int -> Char
1596−index = coerce JSS.index
1597−-- index t n = S.index (stream t) n
1500+index t n = S.index (stream t) n
15981501{-# INLINE index #-}
15991502
16001503-- | /O(n)/ The 'findIndex' function takes a predicate and a 'Text'
16011504-- and returns the index of the first element in the 'Text' satisfying
16021505-- the predicate. Subject to fusion.
16031506findIndex :: (Char -> Bool) -> Text -> Maybe Int
1604−findIndex = coerce JSS.findIndex
1605−-- findIndex p t = S.findIndex p (stream t)
1507+findIndex p t = S.findIndex p (stream t)
16061508{-# INLINE findIndex #-}
16071509
16081510-- | /O(n+m)/ The 'count' function returns the number of times the
@@ -1612,23 +1514,22 @@ findIndex = coerce JSS.findIndex
16121514-- In (unlikely) bad cases, this function's time complexity degrades
16131515-- towards /O(n*m)/.
16141516count :: Text -> Text -> Int
1615−count = coerce JSS.count
1616−-- count pat src
1617−-- | null pat = emptyError "count"
1618−-- | isSingleton pat = countChar (unsafeHead pat) src
1619−-- | otherwise = L.length (indices pat src)
1517+count pat src
1518+ | null pat = emptyError "count"
1519+ | isSingleton pat = countChar (unsafeHead pat) src
1520+ | otherwise = L.length (indices pat src)
16201521{-# INLINE [1] count #-}
16211522
1622−-- {-# RULES
1623−-- "TEXT count/singleton -> countChar" [~1] forall c t.
1624−-- count (singleton c) t = countChar c t
1625−-- #-}
1523+{-# RULES
1524+"TEXT count/singleton -> countChar" [~1] forall c t.
1525+ count (singleton c) t = countChar c t
1526+ #-}
16261527
16271528-- | /O(n)/ The 'countChar' function returns the number of times the
16281529-- query element appears in the given 'Text'. Subject to fusion.
1629−-- countChar :: Char -> Text -> Int
1630−-- countChar c t = S.countChar c (stream t)
1631−-- {-# INLINE countChar #-}
1530+countChar :: Char -> Text -> Int
1531+countChar c t = S.countChar c (stream t)
1532+{-# INLINE countChar #-}
16321533
16331534-------------------------------------------------------------------------------
16341535-- * Zipping
@@ -1638,46 +1539,42 @@ count = coerce JSS.count
16381539-- excess elements of the longer 'Text' are discarded. This is
16391540-- equivalent to a pair of 'unpack' operations.
16401541zip :: Text -> Text -> [(Char,Char)]
1641−zip = coerce JSS.zip
1642−-- zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1542+zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
16431543{-# INLINE zip #-}
16441544
16451545-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
16461546-- given as the first argument, instead of a tupling function.
16471547-- Performs replacement on invalid scalar values.
16481548zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
1649−zipWith = coerce JSS.zipWith
1650−-- zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
1651−-- where g a b = safe (f a b)
1549+zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
1550+ where g a b = safe (f a b)
16521551{-# INLINE zipWith #-}
16531552
16541553-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's
16551554-- representing white space.
16561555words :: Text -> [Text]
1657−words = coerce JSS.words
1658−-- words t@(Text arr off len) = loop 0 0
1659−-- where
1660−-- loop !start !n
1661−-- | n >= len = if start == n
1662−-- then []
1663−-- else [Text arr (start+off) (n-start)]
1664−-- | isSpace c =
1665−-- if start == n
1666−-- then loop (start+1) (start+1)
1667−-- else Text arr (start+off) (n-start) : loop (n+d) (n+d)
1668−-- | otherwise = loop start (n+d)
1669−-- where Iter c d = iter t n
1556+words t@(Text arr off len) = loop 0 0
1557+ where
1558+ loop !start !n
1559+ | n >= len = if start == n
1560+ then []
1561+ else [Text arr (start+off) (n-start)]
1562+ | isSpace c =
1563+ if start == n
1564+ then loop (start+1) (start+1)
1565+ else Text arr (start+off) (n-start) : loop (n+d) (n+d)
1566+ | otherwise = loop start (n+d)
1567+ where Iter c d = iter t n
16701568{-# INLINE words #-}
16711569
16721570-- | /O(n)/ Breaks a 'Text' up into a list of 'Text's at
16731571-- newline 'Char's. The resulting strings do not contain newlines.
16741572lines :: Text -> [Text]
1675−lines = coerce JSS.lines
1676−-- lines ps | null ps = []
1677−-- | otherwise = h : if null t
1678−-- then []
1679−-- else lines (unsafeTail t)
1680−-- where (# h,t #) = span_ (/= '\n') ps
1573+lines ps | null ps = []
1574+ | otherwise = h : if null t
1575+ then []
1576+ else lines (unsafeTail t)
1577+ where (# h,t #) = span_ (/= '\n') ps
16811578{-# INLINE lines #-}
16821579
16831580{-
@@ -1705,38 +1602,34 @@ lines' ps | null ps = []
17051602-- | /O(n)/ Joins lines, after appending a terminating newline to
17061603-- each.
17071604unlines :: [Text] -> Text
1708−unlines = coerce JSS.unlines
1709−-- unlines = concat . L.map (`snoc` '\n')
1605+unlines = concat . L.map (`snoc` '\n')
17101606{-# INLINE unlines #-}
17111607
17121608-- | /O(n)/ Joins words using single space characters.
17131609unwords :: [Text] -> Text
1714−unwords = coerce JSS.unwords
1715−-- unwords = intercalate (singleton ' ')
1610+unwords = intercalate (singleton ' ')
17161611{-# INLINE unwords #-}
17171612
17181613-- | /O(n)/ The 'isPrefixOf' function takes two 'Text's and returns
17191614-- 'True' iff the first is a prefix of the second. Subject to fusion.
17201615isPrefixOf :: Text -> Text -> Bool
1721−isPrefixOf = coerce JSS.isPrefixOf
1722−-- isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
1723−-- alen <= blen && S.isPrefixOf (stream a) (stream b)
1616+isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
1617+ alen <= blen && S.isPrefixOf (stream a) (stream b)
17241618{-# INLINE [1] isPrefixOf #-}
17251619
1726−-- {-# RULES
1727−-- "TEXT isPrefixOf -> fused" [~1] forall s t.
1728−-- isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1729−-- #-}
1620+{-# RULES
1621+"TEXT isPrefixOf -> fused" [~1] forall s t.
1622+ isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1623+ #-}
17301624
17311625-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns
17321626-- 'True' iff the first is a suffix of the second.
17331627isSuffixOf :: Text -> Text -> Bool
1734−isSuffixOf = coerce JSS.isSuffixOf
1735−-- isSuffixOf a@(Text _aarr _aoff alen) b@(Text barr boff blen) =
1736−-- d >= 0 && a == b'
1737−-- where d = blen - alen
1738−-- b' | d == 0 = b
1739−-- | otherwise = Text barr (boff+d) alen
1628+isSuffixOf a@(Text _aarr _aoff alen) b@(Text barr boff blen) =
1629+ d >= 0 && a == b'
1630+ where d = blen - alen
1631+ b' | d == 0 = b
1632+ | otherwise = Text barr (boff+d) alen
17401633{-# INLINE isSuffixOf #-}
17411634
17421635-- | /O(n+m)/ The 'isInfixOf' function takes two 'Text's and returns
@@ -1746,17 +1639,16 @@ isSuffixOf = coerce JSS.isSuffixOf
17461639-- In (unlikely) bad cases, this function's time complexity degrades
17471640-- towards /O(n*m)/.
17481641isInfixOf :: Text -> Text -> Bool
1749−isInfixOf = coerce JSS.isInfixOf
1750−-- isInfixOf needle haystack
1751−-- | null needle = True
1752−-- | isSingleton needle = S.elem (unsafeHead needle) . S.stream $ haystack
1753−-- | otherwise = not . L.null . indices needle $ haystack
1642+isInfixOf needle haystack
1643+ | null needle = True
1644+ | isSingleton needle = S.elem (unsafeHead needle) . S.stream $ haystack
1645+ | otherwise = not . L.null . indices needle $ haystack
17541646{-# INLINE [1] isInfixOf #-}
17551647
1756−-- {-# RULES
1757−-- "TEXT isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.
1758−-- isInfixOf (singleton n) h = S.elem n (S.stream h)
1759−-- #-}
1648+{-# RULES
1649+"TEXT isInfixOf/singleton -> S.elem/S.stream" [~1] forall n h.
1650+ isInfixOf (singleton n) h = S.elem n (S.stream h)
1651+ #-}
17601652
17611653-------------------------------------------------------------------------------
17621654-- * View patterns
@@ -1780,10 +1672,9 @@ isInfixOf = coerce JSS.isInfixOf
17801672-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
17811673-- > fnordLength _ = -1
17821674stripPrefix :: Text -> Text -> Maybe Text
1783−stripPrefix = coerce JSS.stripPrefix
1784−-- stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1785−-- | p `isPrefixOf` t = Just $! text arr (off+plen) (len-plen)
1786−-- | otherwise = Nothing
1675+stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1676+ | p `isPrefixOf` t = Just $! text arr (off+plen) (len-plen)
1677+ | otherwise = Nothing
17871678
17881679-- | /O(n)/ Find the longest non-empty common prefix of two strings
17891680-- and return it, along with the suffixes of each string at which they
@@ -1798,16 +1689,15 @@ stripPrefix = coerce JSS.stripPrefix
17981689-- > commonPrefixes "veeble" "fetzer" == Nothing
17991690-- > commonPrefixes "" "baz" == Nothing
18001691commonPrefixes :: Text -> Text -> Maybe (Text,Text,Text)
1801−commonPrefixes = coerce JSS.commonPrefixes
1802−-- commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
1803−-- where
1804−-- go !i !j | i < len0 && j < len1 && a == b = go (i+d0) (j+d1)
1805−-- | i > 0 = Just (Text arr0 off0 i,
1806−-- text arr0 (off0+i) (len0-i),
1807−-- text arr1 (off1+j) (len1-j))
1808−-- | otherwise = Nothing
1809−-- where Iter a d0 = iter t0 i
1810−-- Iter b d1 = iter t1 j
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
18111701
18121702-- | /O(n)/ Return the prefix of the second string if its suffix
18131703-- matches the entire first string.
@@ -1828,22 +1718,21 @@ commonPrefixes = coerce JSS.commonPrefixes
18281718-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
18291719-- > quuxLength _ = -1
18301720stripSuffix :: Text -> Text -> Maybe Text
1831−stripSuffix = coerce JSS.stripSuffix
1832−-- stripSuffix p@(Text _arr _off plen) t@(Text arr off len)
1833−-- | p `isSuffixOf` t = Just $! text arr off (len-plen)
1834−-- | otherwise = Nothing
1835−
1836−-- -- | Add a list of non-negative numbers. Errors out on overflow.
1837−-- sumP :: String -> [Int] -> Int
1838−-- sumP fun = go 0
1839−-- where go !a (x:xs)
1840−-- | ax >= 0 = go ax xs
1841−-- | otherwise = overflowError fun
1842−-- where ax = a + x
1843−-- go a _ = a
1844−
1845−-- emptyError :: String -> a
1846−-- emptyError fun = P.error $ "Data.Text." ++ fun ++ ": empty input"
1721+stripSuffix p@(Text _arr _off plen) t@(Text arr off len)
1722+ | p `isSuffixOf` t = Just $! text arr off (len-plen)
1723+ | otherwise = Nothing
1724+
1725+-- | Add a list of non-negative numbers. Errors out on overflow.
1726+sumP :: String -> [Int] -> Int
1727+sumP fun = go 0
1728+ where go !a (x:xs)
1729+ | ax >= 0 = go ax xs
1730+ | otherwise = overflowError fun
1731+ where ax = a + x
1732+ go a _ = a
1733+
1734+emptyError :: String -> a
1735+emptyError fun = P.error $ "Data.Text." ++ fun ++ ": empty input"
18471736
18481737overflowError :: String -> a
18491738overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
@@ -1857,10 +1746,10 @@ overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
18571746-- copy \"breaks the link\" to the original array, allowing it to be
18581747-- garbage collected if there are no other live references to it.
18591748copy :: Text -> Text
1860−copy = P.id -- TODO
1861−-- copy (Text arr off len) = Text (A.run go) 0 len
1862−-- where
1863−-- go :: ST s (A.MArray s)
1864−-- go = do
1865−-- marr <- A.new len
1866−
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/Encoding.hs+64−105
@@ -3,7 +3,6 @@
33#if __GLASGOW_HASKELL__ >= 702
44{-# LANGUAGE Trustworthy #-}
55#endif
6−{-# LANGUAGE UnboxedTuples #-}
76-- |
87-- Module : Data.Text.Encoding
98-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,
@@ -74,10 +73,10 @@ import Data.ByteString as B
7473import Data.ByteString.Internal as B hiding (c2w)
7574import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
7675import Data.Text.Internal (Text(..), safe, text)
77−-- import Data.Text.Internal.Private (runText)
76+import Data.Text.Internal.Private (runText)
7877import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
7978import Data.Text.Internal.Unsafe.Shift (shiftR)
80−-- import Data.Text.Show ()
79+import Data.Text.Show ()
8180import Data.Text.Unsafe (unsafeDupablePerformIO)
8281import Data.Word (Word8, Word32)
8382import Foreign.C.Types (CSize(..))
@@ -95,23 +94,7 @@ import qualified Data.Text.Internal.Encoding.Fusion as E
9594import qualified Data.Text.Internal.Encoding.Utf16 as U16
9695import qualified Data.Text.Internal.Fusion as F
9796
98−import GHC.Exts (ByteArray#, Int(..), Int#, Any)
99−{-
10097#include "text_cbits.h"
101−-}
102−
103−import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
104−import Data.ByteString (ByteString)
105−import Data.Text.Internal (Text)
106−
107−-------------------------------------
108−import GHCJS.Types
109−import GHCJS.Buffer
110−import Data.JSString (JSString)
111−import Unsafe.Coerce
112−import System.IO.Unsafe
113−-------------------------------------
114−
11598
11699-- $strict
117100--
@@ -137,55 +120,39 @@ decodeASCII = decodeUtf8
137120-- 'decodeLatin1' is semantically equivalent to
138121-- @Data.Text.pack . Data.ByteString.Char8.unpack@
139122decodeLatin1 :: ByteString -> Text
140−decodeLatin1 = error "decodeLatin1"
141−-- decodeLatin1 (PS fp off len) = text a 0 len
142−-- where
143−-- a = A.run (A.new len >>= unsafeIOToST . go)
144−-- go dest = withForeignPtr fp $ \ptr -> do
145−-- c_decode_latin1 (A.maBA dest) (ptr `plusPtr` off) (ptr `plusPtr` (off+len))
146−-- return dest
147−
148−-- foreign import javascript unsafe "h$textToString" js_toString :: JSVal -> Text
149−
150−foreign import javascript unsafe "h$textFromString" js_fromString :: JSString -> (# ByteArray#, Int# #)
151−foreign import javascript unsafe "String['fromCharCode']['apply'](null, $1['u8'])" js_decodeBytes :: JSVal -> JSString
152−foreign import javascript unsafe "h$decodeUtf8z($1, $2)" js_fromByteStringBuffer :: Buffer -> Int -> JSString
153−foreign import javascript unsafe "h$encodeUtf8($1)" js_encodeUtf8 :: JSString -> Buffer
154−foreign import javascript unsafe "h$encodeUtf8($1)" js_encodeUtf8Mut :: JSString -> MutableBuffer
155−foreign import javascript unsafe "h$encodeUtf16($1)" js_encodeUtf16 :: JSString -> Buffer
156−foreign import javascript unsafe "$1['length']" js_length :: JSString -> Int
157−foreign import javascript unsafe "h$jsstringTake" js_take :: Int -> JSString -> JSString
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
158129
159130-- | Decode a 'ByteString' containing UTF-8 encoded text.
160131decodeUtf8With :: OnDecodeError -> ByteString -> Text
161−-- decodeUtf8With _ bs@(PS fp off len) = Text $ js_decodeBytes $ unsafeCoerce bs
162− -- decodeUtf8With _ bs = Text $ js_fromByteStringBuffer buf off
163−decodeUtf8With _ bs = Text $ js_take (len) $ js_fromByteStringBuffer buf off
164− where (buf, off, len) = fromByteString bs
165−-- decodeUtf8With onErr (PS fp off len) = runText $ \done -> do
166− -- let go dest = withForeignPtr fp $ \ptr ->
167− -- with (0::CSize) $ \destOffPtr -> do
168− -- let end = ptr `plusPtr` (off + len)
169− -- loop curPtr = do
170− -- curPtr' <- c_decode_utf8 (A.maBA dest) destOffPtr curPtr end
171− -- if curPtr' == end
172− -- then do
173− -- n <- peek destOffPtr
174− -- unsafeSTToIO (done dest (fromIntegral n))
175− -- else do
176− -- x <- peek curPtr'
177− -- case onErr desc (Just x) of
178− -- Nothing -> loop $ curPtr' `plusPtr` 1
179− -- Just c -> do
180− -- destOff <- peek destOffPtr
181− -- w <- unsafeSTToIO $
182− -- unsafeWrite dest (fromIntegral destOff) (safe c)
183− -- poke destOffPtr (destOff + fromIntegral w)
184− -- loop $ curPtr' `plusPtr` 1
185− -- loop (ptr `plusPtr` off)
186− -- (unsafeIOToST . go) =<< A.new len
187− -- where
188− -- desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
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
154+ where
155+ desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
189156{- INLINE[0] decodeUtf8With #-}
190157
191158-- $stream
@@ -285,9 +252,8 @@ streamDecodeUtf8With onErr = decodeChunk B.empty 0 0
285252 let end = ptr `plusPtr` (off + len)
286253 loop curPtr = do
287254 poke curPtrPtr curPtr
288− curPtr' <- error "c_decode_utf8_with_state: needs to be implemented"
289− -- curPtr' <- c_decode_utf8_with_state (A.maBA dest) destOffPtr
290− -- curPtrPtr end codepointPtr statePtr
255+ curPtr' <- c_decode_utf8_with_state (A.maBA dest) destOffPtr
256+ curPtrPtr end codepointPtr statePtr
291257 state <- peek statePtr
292258 case state of
293259 UTF8_REJECT -> do
@@ -330,8 +296,8 @@ streamDecodeUtf8With onErr = decodeChunk B.empty 0 0
330296decodeUtf8 :: ByteString -> Text
331297decodeUtf8 = decodeUtf8With strictDecode
332298{-# INLINE[0] decodeUtf8 #-}
333−-- {-# RULES "STREAM stream/decodeUtf8 fusion" [1]
334−-- forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-}
299+{-# RULES "STREAM stream/decodeUtf8 fusion" [1]
300+ forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-}
335301
336302-- | Decode a 'ByteString' containing UTF-8 encoded text.
337303--
@@ -360,13 +326,9 @@ encodeUtf8BuilderEscaped be =
360326 where
361327 bound = max 4 $ BP.sizeBound be
362328
363− mkBuildstep (Text t) !k =
364− -- mkBuildstep (Text arr off len) !k =
329+ mkBuildstep (Text arr off len) !k =
365330 outerLoop off
366331 where
367− off = 0
368− (arr, len) = let (# ba, len' #) = js_fromString t
369− in (A.Array ba, I# len')
370332 iend = off + len
371333
372334 outerLoop !i0 !br@(B.BufferRange op0 ope)
@@ -406,27 +368,24 @@ encodeUtf8BuilderEscaped be =
406368 where
407369 poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8)
408370
409−
410−
411371-- | Encode text using UTF-8 encoding.
412372encodeUtf8 :: Text -> ByteString
413−encodeUtf8 (Text txt) = toByteString 0 (Just (js_length txt)) $ js_encodeUtf8 txt
414−-- encodeUtf8 (Text arr off len)
415−-- | len == 0 = B.empty
416−-- | otherwise = unsafeDupablePerformIO $ do
417−-- fp <- mallocByteString (len*4)
418−-- withForeignPtr fp $ \ptr ->
419−-- with ptr $ \destPtr -> do
420−-- c_encode_utf8 destPtr (A.aBA arr) (fromIntegral off) (fromIntegral len)
421−-- newDest <- peek destPtr
422−-- let utf8len = newDest `minusPtr` ptr
423−-- if utf8len >= len `shiftR` 1
424−-- then return (PS fp 0 utf8len)
425−-- else do
426−-- fp' <- mallocByteString utf8len
427−-- withForeignPtr fp' $ \ptr' -> do
428−-- memcpy ptr' ptr (fromIntegral utf8len)
429−-- return (PS fp' 0 utf8len)
373+encodeUtf8 (Text arr off len)
374+ | len == 0 = B.empty
375+ | otherwise = unsafeDupablePerformIO $ do
376+ fp <- mallocByteString (len*4)
377+ withForeignPtr fp $ \ptr ->
378+ with ptr $ \destPtr -> do
379+ c_encode_utf8 destPtr (A.aBA arr) (fromIntegral off) (fromIntegral len)
380+ newDest <- peek destPtr
381+ let utf8len = newDest `minusPtr` ptr
382+ if utf8len >= len `shiftR` 1
383+ then return (PS fp 0 utf8len)
384+ else do
385+ fp' <- mallocByteString utf8len
386+ withForeignPtr fp' $ \ptr' -> do
387+ memcpy ptr' ptr (fromIntegral utf8len)
388+ return (PS fp' 0 utf8len)
430389
431390-- | Decode text from little endian UTF-16 encoding.
432391decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
@@ -504,17 +463,17 @@ encodeUtf32BE :: Text -> ByteString
504463encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt))
505464{-# INLINE encodeUtf32BE #-}
506465
507−-- foreign import ccall unsafe "_hs_text_decode_utf8" c_decode_utf8
508−-- :: MutableByteArray# s -> Ptr CSize
509−-- -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)
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)
510469
511−-- foreign import ccall unsafe "_hs_text_decode_utf8_state" c_decode_utf8_with_state
512−-- :: MutableByteArray# s -> Ptr CSize
513−-- -> Ptr (Ptr Word8) -> Ptr Word8
514−-- -> Ptr CodePoint -> Ptr DecoderState -> IO (Ptr Word8)
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)
515474
516−-- foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
517−-- :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
475+foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
476+ :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
518477
519−-- foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
520−-- :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()
478+foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
479+ :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()
Data/Text/IO.hs−16
@@ -185,11 +185,7 @@ hPutStr h t = do
185185 | otherwise -> writeBlocksRaw h buf str
186186
187187hPutChars :: Handle -> Stream Char -> IO ()
188−#ifndef __GHCJS__
189188hPutChars h (Stream next0 s0 _len) = loop s0
190−#else
191−hPutChars h (Stream next0 s0) = loop s0
192−#endif
193189 where
194190 loop !s = case next0 s of
195191 Done -> return ()
@@ -207,11 +203,7 @@ hPutChars h (Stream next0 s0) = loop s0
207203-- handling gave a few more percent on top.
208204
209205writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO ()
210−#ifndef __GHCJS__
211206writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0
212−#else
213−writeLines h nl buf0 (Stream next0 s0) = outer s0 buf0
214−#endif
215207 where
216208 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
217209 where
@@ -231,11 +223,7 @@ writeLines h nl buf0 (Stream next0 s0) = outer s0 buf0
231223 commit = commitBuffer h raw len
232224
233225writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
234−#ifndef __GHCJS__
235226writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
236−#else
237−writeBlocksCRLF h buf0 (Stream next0 s0) = outer s0 buf0
238−#endif
239227 where
240228 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
241229 where
@@ -251,11 +239,7 @@ writeBlocksCRLF h buf0 (Stream next0 s0) = outer s0 buf0
251239 commit = commitBuffer h raw len
252240
253241writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
254−#ifndef __GHCJS__
255242writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
256−#else
257−writeBlocksRaw h buf0 (Stream next0 s0) = outer s0 buf0
258−#endif
259243 where
260244 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
261245 where
Data/Text/Internal.hs+125−42
@@ -1,61 +1,127 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples, MagicHash,
2− BangPatterns, ForeignFunctionInterface, JavaScriptFFI, GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes,
4− GHCForeignImportPrim, MagicHash, FlexibleInstances #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}
2+{-# OPTIONS_HADDOCK not-home #-}
3+
4+-- |
5+-- Module : Data.Text.Internal
6+-- Copyright : (c) 2008, 2009 Tom Harper,
7+-- (c) 2009, 2010 Bryan O'Sullivan,
8+-- (c) 2009 Duncan Coutts
9+--
10+-- License : BSD-style
11+-- Maintainer : bos@serpentine.com
12+-- Stability : experimental
13+-- Portability : GHC
14+--
15+-- A module containing private 'Text' internals. This exposes the
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
26+
527module Data.Text.Internal
6− ( module Data.Text.Internal
7− , JSS.safe
8− , JSS.firstf
9− ) where
10−
11−import Data.String (IsString(..))
12−import Data.Coerce
13−import Data.Data
14−import Data.Maybe
15−import Data.Binary
16−import Control.DeepSeq
17−import Data.Semigroup
18−import Data.Char
19−import qualified Data.JSString as JSS
20−import qualified Data.JSString.Internal as JSSS
21−import qualified Data.JSString.Internal.Type as JSS
22−import Data.JSString hiding (empty)
23−import qualified Data.Text.Array as A
28+ (
29+ -- * Types
30+ -- $internals
31+ Text(..)
32+ -- * Construction
33+ , text
34+ , textP
35+ -- * Safety
36+ , safe
37+ -- * Code that must be here for accessibility
38+ , empty
39+ , empty_
40+ -- * Utilities
41+ , firstf
42+ -- * Checked multiplication
43+ , mul
44+ , mul32
45+ , mul64
46+ -- * Debugging
47+ , showText
48+ ) where
2449
50+#if defined(ASSERTS)
51+import Control.Exception (assert)
52+#endif
2553import Data.Bits
2654import Data.Int (Int32, Int64)
27−-- import Data.Text.Internal.Unsafe.Char (ord)
55+import Data.Text.Internal.Unsafe.Char (ord)
2856import Data.Typeable (Typeable)
29−import GHC.Exts (ByteArray#, Char(..), ord#, andI#, (/=#), isTrue#)
30−-- import qualified Data.Text.Array as A
31−import GHCJS.Marshal.Pure
32−import GHCJS.Marshal
57+import qualified Data.Text.Array as A
3358
59+-- | A space efficient, packed, unboxed Unicode text type.
60+data Text = Text
61+ {-# UNPACK #-} !A.Array -- payload (Word16 elements)
62+ {-# UNPACK #-} !Int -- offset (units of Word16, not Char)
63+ {-# UNPACK #-} !Int -- length (units of Word16, not Char)
64+ deriving (Typeable)
3465
35−newtype Text = Text JSString
36− deriving ( Show, Eq, Ord, IsString, Monoid, Read, Data
37− , PToJSVal, PFromJSVal, FromJSVal, ToJSVal
38− )
66+-- | Smart constructor.
67+text_ :: A.Array -> Int -> Int -> Text
68+text_ arr off len =
69+#if defined(ASSERTS)
70+ let c = A.unsafeIndex arr off
71+ alen = A.length arr
72+ in assert (len >= 0) .
73+ assert (off >= 0) .
74+ assert (alen == 0 || len == 0 || off < alen) .
75+ assert (len == 0 || c < 0xDC00 || c > 0xDFFF) $
76+#endif
77+ Text arr off len
78+{-# INLINE text_ #-}
3979
80+-- | /O(1)/ The empty 'Text'.
4081empty :: Text
41−empty = Text JSS.empty
82+empty = Text A.empty 0 0
4283{-# INLINE [1] empty #-}
4384
85+-- | A non-inlined version of 'empty'.
4486empty_ :: Text
45−empty_ = Text JSS.empty
87+empty_ = Text A.empty 0 0
4688{-# NOINLINE empty_ #-}
4789
48−foreign import javascript unsafe
49− "String.fromCharCode.apply(null, $1['u8'])"
50− js_decodeBytes :: ByteArray# -> JSString
51−
5290-- | Construct a 'Text' without invisibly pinning its byte array in
5391-- memory if its length has dwindled to zero.
5492text :: A.Array -> Int -> Int -> Text
55−-- text arr off len | len == 0 = empty
56−-- | otherwise = text_ arr off len
57−text (A.Array ba) off len | len == 0 = empty
58− | otherwise = Text (js_decodeBytes ba)
93+text arr off len | len == 0 = empty
94+ | otherwise = text_ arr off len
95+{-# INLINE text #-}
96+
97+textP :: A.Array -> Int -> Int -> Text
98+{-# DEPRECATED textP "Use text instead" #-}
99+textP = text
100+
101+-- | A useful 'show'-like function for debugging purposes.
102+showText :: Text -> String
103+showText (Text arr off len) =
104+ "Text " ++ show (A.toList arr off len) ++ ' ' :
105+ show off ++ ' ' : show len
106+
107+-- | Map a 'Char' to a 'Text'-safe value.
108+--
109+-- UTF-16 surrogate code points are not included in the set of Unicode
110+-- scalar values, but are unfortunately admitted as valid 'Char'
111+-- values by Haskell. They cannot be represented in a 'Text'. This
112+-- function remaps those code points to the Unicode replacement
113+-- character (U+FFFD, \'&#xfffd;\'), and leaves other code points
114+-- unchanged.
115+safe :: Char -> Char
116+safe c
117+ | ord c .&. 0x1ff800 /= 0xd800 = c
118+ | otherwise = '\xfffd'
119+{-# INLINE [0] safe #-}
120+
121+-- | Apply a function to the first element of an optional pair.
122+firstf :: (a -> c) -> Maybe (a,b) -> Maybe (c,b)
123+firstf f (Just (a, b)) = Just (f a, b)
124+firstf _ Nothing = Nothing
59125
60126-- | Checked multiplication. Calls 'error' if the result would
61127-- overflow.
@@ -102,4 +168,21 @@ mul32 a b = case fromIntegral a * fromIntegral b of
102168{-# INLINE mul32 #-}
103169infixl 7 `mul32`
104170
105−--------------------------------------
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.hs+5−47
@@ -1,6 +1,4 @@
11{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2−{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, UnboxedTuples,
3− MagicHash #-}
42{-# OPTIONS_HADDOCK not-home #-}
53
64-----------------------------------------------------------------------------
@@ -75,8 +73,6 @@ import qualified Data.Text as S
7573import qualified Data.Text.Array as A
7674import qualified Data.Text.Lazy as L
7775
78−import Data.JSString (JSString)
79−import GHC.Exts (ByteArray#, Int#, Int(I#))
8076------------------------------------------------------------------------
8177
8278-- | A @Builder@ is an efficient way to build lazy @Text@ values.
@@ -168,17 +164,10 @@ copyLimit = 128
168164-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
169165--
170166fromText :: S.Text -> Builder
171−fromText t@(Text t')
167+fromText t@(Text arr off l)
172168 | S.null t = empty
173169 | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
174170 | otherwise = flush `append` mapBuilder (t :)
175− where
176− (# ba, len #) = js_fromString t'
177− (arr, off, l) = (A.Array ba, 0, I# len)
178−-- fromText t@(Text arr off l)
179−-- | S.null t = empty
180−-- | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
181−-- | otherwise = flush `append` mapBuilder (t :)
182171{-# INLINE [1] fromText #-}
183172
184173{-# RULES
@@ -193,10 +182,10 @@ fromText t@(Text t')
193182fromString :: String -> Builder
194183fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
195184 let loop !marr !o !u !l [] = k (Buffer marr o u l)
196− loop marr o@(I# o#) u@(I# u#) l s@(c:cs)
185+ loop marr o u l s@(c:cs)
197186 | l <= 1 = do
198187 arr <- A.unsafeFreeze marr
199− let !t = Text $ js_toString (A.aBA arr) o# u#
188+ let !t = Text arr o u
200189 marr' <- A.new chunkSize
201190 ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
202191 return $ t : ts
@@ -206,21 +195,6 @@ fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
206195 in loop p0 o0 u0 l0 str
207196 where
208197 chunkSize = smallChunkSize
209−-- fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
210−-- let loop !marr !o !u !l [] = k (Buffer marr o u l)
211−-- loop marr o u l s@(c:cs)
212−-- | l <= 1 = do
213−-- arr <- A.unsafeFreeze marr
214−-- let !t = Text arr o u
215−-- marr' <- A.new chunkSize
216−-- ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
217−-- return $ t : ts
218−-- | otherwise = do
219−-- n <- unsafeWrite marr (o+u) c
220−-- loop marr o (u+n) (l-n) cs
221−-- in loop p0 o0 u0 l0 str
222−-- where
223−-- chunkSize = smallChunkSize
224198{-# INLINE fromString #-}
225199
226200-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
@@ -260,24 +234,16 @@ toLazyTextWith chunkSize m = L.fromChunks (runST $
260234-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
261235-- yielding a new chunk in the result lazy @Text@.
262236flush :: Builder
263−flush = Builder $ \ k buf@(Buffer p o@(I# o#) u@(I# u#) l) ->
237+flush = Builder $ \ k buf@(Buffer p o u l) ->
264238 if u == 0
265239 then k buf
266240 else do arr <- A.unsafeFreeze p
267241 let !b = Buffer p (o+u) 0 l
268− !t = Text $ js_toString (A.aBA arr) o# u#
242+ !t = Text arr o u
269243 ts <- inlineInterleaveST (k b)
270244 return $! t : ts
271245{-# INLINE [1] flush #-}
272246-- defer inlining so that flush/flush rule may fire.
273−-- flush = Builder $ \ k buf@(Buffer p o u l) ->
274−-- if u == 0
275−-- then k buf
276−-- else do arr <- A.unsafeFreeze p
277−-- let !b = Buffer p (o+u) 0 l
278−-- !t = Text arr o u
279−-- ts <- inlineInterleaveST (k b)
280−-- return $! t : ts
281247
282248------------------------------------------------------------------------
283249
@@ -361,11 +327,3 @@ append' (Builder f) (Builder g) = Builder (f . g)
361327 append flush flush = flush
362328
363329 #-}
364−
365−foreign import javascript unsafe
366− "h$textFromString"
367− js_fromString :: JSString -> (# ByteArray#, Int# #)
368−
369−foreign import javascript unsafe
370− "h$textToString"
371− js_toString :: ByteArray# -> Int# -> Int# -> JSString
Data/Text/Internal/Encoding/Fusion.hs+8−10
@@ -55,7 +55,7 @@ import qualified Data.Text.Internal.Encoding.Utf32 as U32
5555import Data.Text.Unsafe (unsafeDupablePerformIO)
5656
5757streamASCII :: ByteString -> Stream Char
58−streamASCII bs = Stream next 0 -- (maxSize l)
58+streamASCII bs = Stream next 0 (maxSize l)
5959 where
6060 l = B.length bs
6161 {-# INLINE next #-}
@@ -70,7 +70,7 @@ streamASCII bs = Stream next 0 -- (maxSize l)
7070-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8
7171-- encoding.
7272streamUtf8 :: OnDecodeError -> ByteString -> Stream Char
73−streamUtf8 onErr bs = Stream next 0 -- (maxSize l)
73+streamUtf8 onErr bs = Stream next 0 (maxSize l)
7474 where
7575 l = B.length bs
7676 next i
@@ -91,7 +91,7 @@ streamUtf8 onErr bs = Stream next 0 -- (maxSize l)
9191-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
9292-- endian UTF-16 encoding.
9393streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char
94−streamUtf16LE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 1))
94+streamUtf16LE onErr bs = Stream next 0 (maxSize (l `shiftR` 1))
9595 where
9696 l = B.length bs
9797 {-# INLINE next #-}
@@ -109,7 +109,7 @@ streamUtf16LE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 1))
109109-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
110110-- endian UTF-16 encoding.
111111streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char
112−streamUtf16BE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 1))
112+streamUtf16BE onErr bs = Stream next 0 (maxSize (l `shiftR` 1))
113113 where
114114 l = B.length bs
115115 {-# INLINE next #-}
@@ -127,7 +127,7 @@ streamUtf16BE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 1))
127127-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
128128-- endian UTF-32 encoding.
129129streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char
130−streamUtf32BE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 2))
130+streamUtf32BE onErr bs = Stream next 0 (maxSize (l `shiftR` 2))
131131 where
132132 l = B.length bs
133133 {-# INLINE next #-}
@@ -147,7 +147,7 @@ streamUtf32BE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 2))
147147-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
148148-- endian UTF-32 encoding.
149149streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char
150−streamUtf32LE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 2))
150+streamUtf32LE onErr bs = Stream next 0 (maxSize (l `shiftR` 2))
151151 where
152152 l = B.length bs
153153 {-# INLINE next #-}
@@ -166,10 +166,8 @@ streamUtf32LE onErr bs = Stream next 0 -- (maxSize (l `shiftR` 2))
166166
167167-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
168168unstream :: Stream Word8 -> ByteString
169−-- unstream (Stream next s0 len) = unsafeDupablePerformIO $ do
170−unstream (Stream next s0) = unsafeDupablePerformIO $ do
171− -- let mlen = upperBound 4 len
172− let mlen = 4
169+unstream (Stream next s0 len) = unsafeDupablePerformIO $ do
170+ let mlen = upperBound 4 len
173171 mallocByteString mlen >>= loop mlen 0 s0
174172 where
175173 loop !n !off !s fp = case next s of
Data/Text/Internal/Encoding/Fusion/Common.hs+4−8
@@ -37,8 +37,7 @@ import Data.Text.Internal.Unsafe.Shift (shiftR)
3737import Data.Word (Word8)
3838
3939restreamUtf16BE :: Stream Char -> Stream Word8
40−-- restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
41−restreamUtf16BE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
40+restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
4241 where
4342 next (RS0 s) = case next0 s of
4443 Done -> Done
@@ -62,8 +61,7 @@ restreamUtf16BE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
6261{-# INLINE restreamUtf16BE #-}
6362
6463restreamUtf16LE :: Stream Char -> Stream Word8
65−-- restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
66−restreamUtf16LE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
64+restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
6765 where
6866 next (RS0 s) = case next0 s of
6967 Done -> Done
@@ -87,8 +85,7 @@ restreamUtf16LE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
8785{-# INLINE restreamUtf16LE #-}
8886
8987restreamUtf32BE :: Stream Char -> Stream Word8
90−restreamUtf32BE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
91−-- restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
88+restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
9289 where
9390 next (RS0 s) = case next0 s of
9491 Done -> Done
@@ -107,8 +104,7 @@ restreamUtf32BE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
107104{-# INLINE restreamUtf32BE #-}
108105
109106restreamUtf32LE :: Stream Char -> Stream Word8
110−restreamUtf32LE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
111−-- restreamUtf32LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
107+restreamUtf32LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
112108 where
113109 next (RS0 s) = case next0 s of
114110 Done -> Done
Data/Text/Internal/Fusion.hs+180−42
@@ -28,79 +28,217 @@ module Data.Text.Internal.Fusion
2828 , unstream
2929 , reverseStream
3030
31− , Data.Text.Internal.Fusion.length
31+ , length
3232
3333 -- * Transformations
34− , Data.Text.Internal.Fusion.reverse
34+ , reverse
3535
3636 -- * Construction
3737 -- ** Scans
3838 , reverseScanr
3939
4040 -- ** Accumulating maps
41− , Data.Text.Internal.Fusion.mapAccumL
41+ , mapAccumL
4242
4343 -- ** Generation and unfolding
4444 , unfoldrN
4545
4646 -- * Indexing
47− , Data.Text.Internal.Fusion.index
48− , Data.Text.Internal.Fusion.findIndex
47+ , index
48+ , findIndex
4949 , countChar
5050 ) where
5151
52−import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))
53−
54−import Prelude hiding (length, reverse)
55−import Data.Char
56−
57−import Data.JSString.Internal.Type (JSString(..))
58−import qualified Data.JSString.Internal.Type as I
59−import Data.JSString.Internal.Fusion.Types
60−import qualified Data.JSString.Internal.Fusion.Common as S
61−
62−import System.IO.Unsafe
63−
64−import GHCJS.Prim
65−
66−import Data.Coerce
67−import Data.Text.Internal
68−import qualified Data.JSString.Internal.Fusion as JSS
69−import Data.JSString.Internal.Fusion.Types (Stream(..))
52+import Prelude (Bool(..), Char, Maybe(..), Monad(..), Int,
53+ Num(..), Ord(..), ($), (&&),
54+ fromIntegral, otherwise)
55+import Data.Bits ((.&.))
56+import Data.Text.Internal (Text(..))
57+import Data.Text.Internal.Private (runText)
58+import Data.Text.Internal.Unsafe.Char (ord, unsafeChr, unsafeWrite)
59+import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
60+import qualified Data.Text.Array as A
61+import qualified Data.Text.Internal.Fusion.Common as S
62+import Data.Text.Internal.Fusion.Types
63+import Data.Text.Internal.Fusion.Size
64+import qualified Data.Text.Internal as I
65+import qualified Data.Text.Internal.Encoding.Utf16 as U16
7066
7167default(Int)
7268
69+-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
7370stream :: Text -> Stream Char
74−stream = coerce JSS.stream
75−
71+stream (Text arr off len) = Stream next off (betweenSize (len `shiftR` 1) len)
72+ where
73+ !end = off+len
74+ next !i
75+ | i >= end = Done
76+ | n >= 0xD800 && n <= 0xDBFF = Yield (U16.chr2 n n2) (i + 2)
77+ | otherwise = Yield (unsafeChr n) (i + 1)
78+ where
79+ n = A.unsafeIndex arr i
80+ n2 = A.unsafeIndex arr (i + 1)
81+{-# INLINE [0] stream #-}
82+
83+-- | /O(n)/ Convert a 'Text' into a 'Stream Char', but iterate
84+-- backwards.
7685reverseStream :: Text -> Stream Char
77−reverseStream = coerce JSS.reverseStream
78−
86+reverseStream (Text arr off len) = Stream next (off+len-1) (betweenSize (len `shiftR` 1) len)
87+ where
88+ {-# INLINE next #-}
89+ next !i
90+ | i < off = Done
91+ | n >= 0xDC00 && n <= 0xDFFF = Yield (U16.chr2 n2 n) (i - 2)
92+ | otherwise = Yield (unsafeChr n) (i - 1)
93+ where
94+ n = A.unsafeIndex arr i
95+ n2 = A.unsafeIndex arr (i - 1)
96+{-# INLINE [0] reverseStream #-}
97+
98+-- | /O(n)/ Convert a 'Stream Char' into a 'Text'.
7999unstream :: Stream Char -> Text
80−unstream = coerce JSS.unstream
100+unstream (Stream next0 s0 len) = runText $ \done -> do
101+ -- Before encoding each char we perform a buffer realloc check assuming
102+ -- worst case encoding size of two 16-bit units for the char. Just add an
103+ -- extra space to the buffer so that we do not end up reallocating even when
104+ -- all the chars are encoded as single unit.
105+ let mlen = upperBound 4 len + 1
106+ arr0 <- A.new mlen
107+ let outer !arr !maxi = encode
108+ where
109+ -- keep the common case loop as small as possible
110+ encode !si !di =
111+ case next0 si of
112+ Done -> done arr di
113+ Skip si' -> encode si' di
114+ Yield c si'
115+ -- simply check for the worst case
116+ | maxi < di + 1 -> realloc si di
117+ | otherwise -> do
118+ n <- unsafeWrite arr di c
119+ encode si' (di + n)
120+
121+ -- keep uncommon case separate from the common case code
122+ {-# NOINLINE realloc #-}
123+ realloc !si !di = do
124+ let newlen = (maxi + 1) * 2
125+ arr' <- A.new newlen
126+ A.copyM arr' 0 arr 0 di
127+ outer arr' (newlen - 1) si di
128+
129+ outer arr0 (mlen - 1) s0 0
130+{-# INLINE [0] unstream #-}
131+{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
132+
133+
134+-- ----------------------------------------------------------------------------
135+-- * Basic stream functions
81136
82137length :: Stream Char -> Int
83−length = JSS.length
138+length = S.lengthI
139+{-# INLINE[0] length #-}
84140
141+-- | /O(n)/ Reverse the characters of a string.
85142reverse :: Stream Char -> Text
86−reverse = coerce JSS.reverse
87−
143+reverse (Stream next s len0)
144+ | isEmpty len0 = I.empty
145+ | otherwise = I.text arr off' len'
146+ where
147+ len0' = upperBound 4 (larger len0 4)
148+ (arr, (off', len')) = A.run2 (A.new len0' >>= loop s (len0'-1) len0')
149+ loop !s0 !i !len marr =
150+ case next s0 of
151+ Done -> return (marr, (j, len-j))
152+ where j = i + 1
153+ Skip s1 -> loop s1 i len marr
154+ Yield x s1 | i < least -> {-# SCC "reverse/resize" #-} do
155+ let newLen = len `shiftL` 1
156+ marr' <- A.new newLen
157+ A.copyM marr' (newLen-len) marr 0 len
158+ write s1 (len+i) newLen marr'
159+ | otherwise -> write s1 i len marr
160+ where n = ord x
161+ least | n < 0x10000 = 0
162+ | otherwise = 1
163+ m = n - 0x10000
164+ lo = fromIntegral $ (m `shiftR` 10) + 0xD800
165+ hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00
166+ write t j l mar
167+ | n < 0x10000 = do
168+ A.unsafeWrite mar j (fromIntegral n)
169+ loop t (j-1) l mar
170+ | otherwise = do
171+ A.unsafeWrite mar (j-1) lo
172+ A.unsafeWrite mar j hi
173+ loop t (j-2) l mar
174+{-# INLINE [0] reverse #-}
175+
176+-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
177+-- the input and result reversed.
88178reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
89−reverseScanr = JSS.reverseScanr
90−
91−mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, Text)
92−mapAccumL f z0 st =
93− let (a, t) = JSS.mapAccumL f z0 st
94− in (a, Text t)
95−
179+reverseScanr f z0 (Stream next0 s0 len) = Stream next (Scan1 z0 s0) (len+1) -- HINT maybe too low
180+ where
181+ {-# INLINE next #-}
182+ next (Scan1 z s) = Yield z (Scan2 z s)
183+ next (Scan2 z s) = case next0 s of
184+ Yield x s' -> let !x' = f x z
185+ in Yield x' (Scan2 x' s')
186+ Skip s' -> Skip (Scan2 z s')
187+ Done -> Done
188+{-# INLINE reverseScanr #-}
189+
190+-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
191+-- value. However, the length of the result is limited by the
192+-- first argument to 'unfoldrN'. This function is more efficient than
193+-- 'unfoldr' when the length of the result is known.
96194unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
97−unfoldrN = JSS.unfoldrN
195+unfoldrN n = S.unfoldrNI n
196+{-# INLINE [0] unfoldrN #-}
197+
198+-------------------------------------------------------------------------------
199+-- ** Indexing streams
98200
201+-- | /O(n)/ stream index (subscript) operator, starting from 0.
99202index :: Stream Char -> Int -> Char
100−index = JSS.index
203+index = S.indexI
204+{-# INLINE [0] index #-}
101205
206+-- | The 'findIndex' function takes a predicate and a stream and
207+-- returns the index of the first element in the stream
208+-- satisfying the predicate.
102209findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
103−findIndex = JSS.findIndex
210+findIndex = S.findIndexI
211+{-# INLINE [0] findIndex #-}
104212
213+-- | /O(n)/ The 'count' function returns the number of times the query
214+-- element appears in the given stream.
105215countChar :: Char -> Stream Char -> Int
106−countChar = JSS.countChar
216+countChar = S.countCharI
217+{-# INLINE [0] countChar #-}
218+
219+-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
220+-- function to each element of a 'Text', passing an accumulating
221+-- parameter from left to right, and returns a final 'Text'.
222+mapAccumL :: (a -> Char -> (a,Char)) -> a -> Stream Char -> (a, Text)
223+mapAccumL f z0 (Stream next0 s0 len) = (nz, I.text na 0 nl)
224+ where
225+ (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0)
226+ where mlen = upperBound 4 len
227+ outer arr top = loop
228+ where
229+ loop !z !s !i =
230+ case next0 s of
231+ Done -> return (arr, (z,i))
232+ Skip s' -> loop z s' i
233+ Yield x s'
234+ | j >= top -> {-# SCC "mapAccumL/resize" #-} do
235+ let top' = (top + 1) `shiftL` 1
236+ arr' <- A.new top'
237+ A.copyM arr' 0 arr 0 top
238+ outer arr' top' z s i
239+ | otherwise -> do d <- unsafeWrite arr i c
240+ loop z' s' (i+d)
241+ where (z',c) = f z x
242+ j | ord c < 0x10000 = i
243+ | otherwise = i + 1
244+{-# INLINE [0] mapAccumL #-}
Data/Text/Internal/Fusion/Common.hs+922−968
@@ -14,971 +14,925 @@
1414--
1515-- Common stream fusion functionality for text.
1616
17−module Data.Text.Internal.Fusion.Common (module Data.JSString.Internal.Fusion.Common) where
18−import Data.JSString.Internal.Fusion.Common
19−-- module Data.Text.Internal.Fusion.Common
20−-- (
21−-- -- * Creation and elimination
22−-- singleton
23−-- , streamList
24−-- , unstreamList
25−-- , streamCString#
26−
27−-- -- * Basic interface
28−-- , cons
29−-- , snoc
30−-- , append
31−-- , head
32−-- , uncons
33−-- , last
34−-- , tail
35−-- , init
36−-- , null
37−-- , lengthI
38−-- , compareLengthI
39−-- , isSingleton
40−
41−-- -- * Transformations
42−-- , map
43−-- , intercalate
44−-- , intersperse
45−
46−-- -- ** Case conversion
47−-- -- $case
48−-- , toCaseFold
49−-- , toLower
50−-- , toTitle
51−-- , toUpper
52−
53−-- -- ** Justification
54−-- , justifyLeftI
55−
56−-- -- * Folds
57−-- , foldl
58−-- , foldl'
59−-- , foldl1
60−-- , foldl1'
61−-- , foldr
62−-- , foldr1
63−
64−-- -- ** Special folds
65−-- , concat
66−-- , concatMap
67−-- , any
68−-- , all
69−-- , maximum
70−-- , minimum
71−
72−-- -- * Construction
73−-- -- ** Scans
74−-- , scanl
75−
76−-- -- ** Generation and unfolding
77−-- , replicateCharI
78−-- , replicateI
79−-- , unfoldr
80−-- , unfoldrNI
81−
82−-- -- * Substrings
83−-- -- ** Breaking strings
84−-- , take
85−-- , drop
86−-- , takeWhile
87−-- , dropWhile
88−
89−-- -- * Predicates
90−-- , isPrefixOf
91−
92−-- -- * Searching
93−-- , elem
94−-- , filter
95−
96−-- -- * Indexing
97−-- , findBy
98−-- , indexI
99−-- , findIndexI
100−-- , countCharI
101−
102−-- -- * Zipping and unzipping
103−-- , zipWith
104−-- ) where
105−
106−-- import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),
107−-- Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++),
108−-- (&&), fromIntegral, otherwise)
109−-- import qualified Data.List as L
110−-- import qualified Prelude as P
111−-- import Data.Bits (shiftL)
112−-- import Data.Char (isLetter)
113−-- import Data.Int (Int64)
114−-- import Data.Text.Internal.Fusion.Types
115−-- import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping,
116−-- upperMapping)
117−-- import Data.Text.Internal.Fusion.Size
118−-- import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)
119−-- import GHC.Types (Char(..), Int(..))
120−
121−-- singleton :: Char -> Stream Char
122−-- singleton c = Stream next False -- 1
123−-- where next False = Yield c True
124−-- next True = Done
125−-- {-# INLINE [0] singleton #-}
126−
127−-- streamList :: [a] -> Stream a
128−-- {-# INLINE [0] streamList #-}
129−-- streamList s = Stream next s -- unknownSize
130−-- where next [] = Done
131−-- next (x:xs) = Yield x xs
132−
133−-- unstreamList :: Stream a -> [a]
134−-- -- unstreamList (Stream next s0 _len) = unfold s0
135−-- unstreamList (Stream next s0) = unfold s0
136−-- where unfold !s = case next s of
137−-- Done -> []
138−-- Skip s' -> unfold s'
139−-- Yield x s' -> x : unfold s'
140−-- {-# INLINE [0] unstreamList #-}
141−
142−-- {-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}
143−
144−-- -- | Stream the UTF-8-like packed encoding used by GHC to represent
145−-- -- constant strings in generated code.
146−-- --
147−-- -- This encoding uses the byte sequence "\xc0\x80" to represent NUL,
148−-- -- and the string is NUL-terminated.
149−-- streamCString# :: Addr# -> Stream Char
150−-- streamCString# addr = Stream step 0 -- unknownSize
151−-- where
152−-- step !i
153−-- | b == 0 = Done
154−-- | b <= 0x7f = Yield (C# b#) (i+1)
155−-- | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1
156−-- in Yield c (i+2)
157−-- | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) +
158−-- (next 1 `shiftL` 6) +
159−-- next 2
160−-- in Yield c (i+3)
161−-- | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) +
162−-- (next 1 `shiftL` 12) +
163−-- (next 2 `shiftL` 6) +
164−-- next 3
165−-- in Yield c (i+4)
166−-- where b = I# (ord# b#)
167−-- next n = I# (ord# (at# (i+n))) - 0x80
168−-- !b# = at# i
169−-- at# (I# i#) = indexCharOffAddr# addr i#
170−-- chr (I# i#) = C# (chr# i#)
171−-- {-# INLINE [0] streamCString# #-}
172−
173−-- -- ----------------------------------------------------------------------------
174−-- -- * Basic stream functions
175−
176−-- data C s = C0 !s
177−-- | C1 !s
178−
179−-- -- | /O(n)/ Adds a character to the front of a Stream Char.
180−-- cons :: Char -> Stream Char -> Stream Char
181−-- -- cons !w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
182−-- cons !w (Stream next0 s0) = Stream next (C1 s0) -- (len+1)
183−-- where
184−-- next (C1 s) = Yield w (C0 s)
185−-- next (C0 s) = case next0 s of
186−-- Done -> Done
187−-- Skip s' -> Skip (C0 s')
188−-- Yield x s' -> Yield x (C0 s')
189−-- {-# INLINE [0] cons #-}
190−
191−-- data Snoc a = N
192−-- | J !a
193−
194−-- -- | /O(n)/ Adds a character to the end of a stream.
195−-- snoc :: Stream Char -> Char -> Stream Char
196−-- -- snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)
197−-- snoc (Stream next0 xs0) w = Stream next (J xs0) -- (len+1)
198−-- where
199−-- next (J xs) = case next0 xs of
200−-- Done -> Yield w N
201−-- Skip xs' -> Skip (J xs')
202−-- Yield x xs' -> Yield x (J xs')
203−-- next N = Done
204−-- {-# INLINE [0] snoc #-}
205−
206−-- data E l r = L !l
207−-- | R !r
208−
209−-- -- | /O(n)/ Appends one Stream to the other.
210−-- append :: Stream Char -> Stream Char -> Stream Char
211−-- -- append (Stream next0 s01 len1) (Stream next1 s02 len2) =
212−-- -- Stream next (L s01) (len1 + len2)
213−-- append (Stream next0 s01) (Stream next1 s02) =
214−-- Stream next (L s01)
215−-- where
216−-- next (L s1) = case next0 s1 of
217−-- Done -> Skip (R s02)
218−-- Skip s1' -> Skip (L s1')
219−-- Yield x s1' -> Yield x (L s1')
220−-- next (R s2) = case next1 s2 of
221−-- Done -> Done
222−-- Skip s2' -> Skip (R s2')
223−-- Yield x s2' -> Yield x (R s2')
224−-- {-# INLINE [0] append #-}
225−
226−-- -- | /O(1)/ Returns the first character of a Text, which must be non-empty.
227−-- -- Subject to array fusion.
228−-- head :: Stream Char -> Char
229−-- -- head (Stream next s0 _len) = loop_head s0
230−-- head (Stream next s0) = loop_head s0
231−-- where
232−-- loop_head !s = case next s of
233−-- Yield x _ -> x
234−-- Skip s' -> loop_head s'
235−-- Done -> head_empty
236−-- {-# INLINE [0] head #-}
237−
238−-- head_empty :: a
239−-- head_empty = streamError "head" "Empty stream"
240−-- {-# NOINLINE head_empty #-}
241−
242−-- -- | /O(1)/ Returns the first character and remainder of a 'Stream
243−-- -- Char', or 'Nothing' if empty. Subject to array fusion.
244−-- uncons :: Stream Char -> Maybe (Char, Stream Char)
245−-- -- uncons (Stream next s0 len) = loop_uncons s0
246−-- uncons (Stream next s0) = loop_uncons s0
247−-- where
248−-- loop_uncons !s = case next s of
249−-- Yield x s1 -> Just (x, Stream next s1)
250−-- Skip s' -> loop_uncons s'
251−-- Done -> Nothing
252−-- {-# INLINE [0] uncons #-}
253−
254−-- -- | /O(n)/ Returns the last character of a 'Stream Char', which must
255−-- -- be non-empty.
256−-- last :: Stream Char -> Char
257−-- -- last (Stream next s0 _len) = loop0_last s0
258−-- last (Stream next s0) = loop0_last s0
259−-- where
260−-- loop0_last !s = case next s of
261−-- Done -> emptyError "last"
262−-- Skip s' -> loop0_last s'
263−-- Yield x s' -> loop_last x s'
264−-- loop_last !x !s = case next s of
265−-- Done -> x
266−-- Skip s' -> loop_last x s'
267−-- Yield x' s' -> loop_last x' s'
268−-- {-# INLINE[0] last #-}
269−
270−-- -- | /O(1)/ Returns all characters after the head of a Stream Char, which must
271−-- -- be non-empty.
272−-- tail :: Stream Char -> Stream Char
273−-- -- tail (Stream next0 s0 len) = Stream next (C0 s0) (len-1)
274−-- tail (Stream next0 s0) = Stream next (C0 s0) -- (len-1)
275−-- where
276−-- next (C0 s) = case next0 s of
277−-- Done -> emptyError "tail"
278−-- Skip s' -> Skip (C0 s')
279−-- Yield _ s' -> Skip (C1 s')
280−-- next (C1 s) = case next0 s of
281−-- Done -> Done
282−-- Skip s' -> Skip (C1 s')
283−-- Yield x s' -> Yield x (C1 s')
284−-- {-# INLINE [0] tail #-}
285−
286−-- data Init s = Init0 !s
287−-- | Init1 {-# UNPACK #-} !Char !s
288−
289−-- -- | /O(1)/ Returns all but the last character of a Stream Char, which
290−-- -- must be non-empty.
291−-- init :: Stream Char -> Stream Char
292−-- -- init (Stream next0 s0 len) = Stream next (Init0 s0) (len-1)
293−-- init (Stream next0 s0) = Stream next (Init0 s0) -- (len-1)
294−-- where
295−-- next (Init0 s) = case next0 s of
296−-- Done -> emptyError "init"
297−-- Skip s' -> Skip (Init0 s')
298−-- Yield x s' -> Skip (Init1 x s')
299−-- next (Init1 x s) = case next0 s of
300−-- Done -> Done
301−-- Skip s' -> Skip (Init1 x s')
302−-- Yield x' s' -> Yield x (Init1 x' s')
303−-- {-# INLINE [0] init #-}
304−
305−-- -- | /O(1)/ Tests whether a Stream Char is empty or not.
306−-- null :: Stream Char -> Bool
307−-- -- null (Stream next s0 _len) = loop_null s0
308−-- null (Stream next s0) = loop_null s0
309−-- where
310−-- loop_null !s = case next s of
311−-- Done -> True
312−-- Yield _ _ -> False
313−-- Skip s' -> loop_null s'
314−-- {-# INLINE[0] null #-}
315−
316−-- -- | /O(n)/ Returns the number of characters in a string.
317−-- lengthI :: Integral a => Stream Char -> a
318−-- -- lengthI (Stream next s0 _len) = loop_length 0 s0
319−-- lengthI (Stream next s0) = loop_length 0 s0
320−-- where
321−-- loop_length !z s = case next s of
322−-- Done -> z
323−-- Skip s' -> loop_length z s'
324−-- Yield _ s' -> loop_length (z + 1) s'
325−-- {-# INLINE[0] lengthI #-}
326−
327−-- -- | /O(n)/ Compares the count of characters in a string to a number.
328−-- -- Subject to fusion.
329−-- --
330−-- -- This function gives the same answer as comparing against the result
331−-- -- of 'lengthI', but can short circuit if the count of characters is
332−-- -- greater than the number or if the stream can't possibly be as long
333−-- -- as the number supplied, and hence be more efficient.
334−-- compareLengthI :: Integral a => Stream Char -> a -> Ordering
335−-- -- compareLengthI (Stream next s0 len) n =
336−-- compareLengthI (Stream next s0) n =
337−-- -- case compareSize len (fromIntegral n) of
338−-- -- Just o -> o
339−-- -- Nothing -> loop_cmp 0 s0
340−-- loop_cmp 0 s0
341−-- where
342−-- loop_cmp !z s = case next s of
343−-- Done -> compare z n
344−-- Skip s' -> loop_cmp z s'
345−-- Yield _ s' | z > n -> GT
346−-- | otherwise -> loop_cmp (z + 1) s'
347−-- {-# INLINE[0] compareLengthI #-}
348−
349−-- -- | /O(n)/ Indicate whether a string contains exactly one element.
350−-- isSingleton :: Stream Char -> Bool
351−-- -- isSingleton (Stream next s0 _len) = loop 0 s0
352−-- isSingleton (Stream next s0) = loop 0 s0
353−-- where
354−-- loop !z s = case next s of
355−-- Done -> z == (1::Int)
356−-- Skip s' -> loop z s'
357−-- Yield _ s'
358−-- | z >= 1 -> False
359−-- | otherwise -> loop (z+1) s'
360−-- {-# INLINE[0] isSingleton #-}
361−
362−-- -- ----------------------------------------------------------------------------
363−-- -- * Stream transformations
364−
365−-- -- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@
366−-- -- to each element of @xs@.
367−-- map :: (Char -> Char) -> Stream Char -> Stream Char
368−-- -- map f (Stream next0 s0 len) = Stream next s0 len
369−-- map f (Stream next0 s0) = Stream next s0 -- len
370−-- where
371−-- next !s = case next0 s of
372−-- Done -> Done
373−-- Skip s' -> Skip s'
374−-- Yield x s' -> Yield (f x) s'
375−-- {-# INLINE [0] map #-}
376−
377−-- {-#
378−-- RULES "STREAM map/map fusion" forall f g s.
379−-- map f (map g s) = map (\x -> f (g x)) s
380−-- #-}
381−
382−-- data I s = I1 !s
383−-- | I2 !s {-# UNPACK #-} !Char
384−-- | I3 !s
385−
386−-- -- | /O(n)/ Take a character and place it between each of the
387−-- -- characters of a 'Stream Char'.
388−-- intersperse :: Char -> Stream Char -> Stream Char
389−-- intersperse c (Stream next0 s0) = Stream next (I1 s0) -- len
390−-- -- intersperse c (Stream next0 s0 len) = Stream next (I1 s0) len
391−-- where
392−-- next (I1 s) = case next0 s of
393−-- Done -> Done
394−-- Skip s' -> Skip (I1 s')
395−-- Yield x s' -> Skip (I2 s' x)
396−-- next (I2 s x) = Yield x (I3 s)
397−-- next (I3 s) = case next0 s of
398−-- Done -> Done
399−-- Skip s' -> Skip (I3 s')
400−-- Yield x s' -> Yield c (I2 s' x)
401−-- {-# INLINE [0] intersperse #-}
402−
403−-- -- ----------------------------------------------------------------------------
404−-- -- ** Case conversions (folds)
405−
406−-- -- $case
407−-- --
408−-- -- With Unicode text, it is incorrect to use combinators like @map
409−-- -- toUpper@ to case convert each character of a string individually.
410−-- -- Instead, use the whole-string case conversion functions from this
411−-- -- module. For correctness in different writing systems, these
412−-- -- functions may map one input character to two or three output
413−-- -- characters.
414−
415−-- caseConvert :: (forall s. Char -> s -> Step (CC s) Char)
416−-- -> Stream Char -> Stream Char
417−-- -- caseConvert remap (Stream next0 s0 len) = Stream next (CC s0 '\0' '\0') len
418−-- caseConvert remap (Stream next0 s0) = Stream next (CC s0 '\0' '\0') -- len
419−-- where
420−-- next (CC s '\0' _) =
421−-- case next0 s of
422−-- Done -> Done
423−-- Skip s' -> Skip (CC s' '\0' '\0')
424−-- Yield c s' -> remap c s'
425−-- next (CC s a b) = Yield a (CC s b '\0')
426−
427−-- -- | /O(n)/ Convert a string to folded case. This function is mainly
428−-- -- useful for performing caseless (or case insensitive) string
429−-- -- comparisons.
430−-- --
431−-- -- A string @x@ is a caseless match for a string @y@ if and only if:
432−-- --
433−-- -- @toCaseFold x == toCaseFold y@
434−-- --
435−-- -- The result string may be longer than the input string, and may
436−-- -- differ from applying 'toLower' to the input string. For instance,
437−-- -- the Armenian small ligature men now (U+FB13) is case folded to the
438−-- -- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is
439−-- -- case folded to the Greek small letter letter mu (U+03BC) instead of
440−-- -- itself.
441−-- toCaseFold :: Stream Char -> Stream Char
442−-- toCaseFold = caseConvert foldMapping
443−-- {-# INLINE [0] toCaseFold #-}
444−
445−-- -- | /O(n)/ Convert a string to upper case, using simple case
446−-- -- conversion. The result string may be longer than the input string.
447−-- -- For instance, the German eszett (U+00DF) maps to the two-letter
448−-- -- sequence SS.
449−-- toUpper :: Stream Char -> Stream Char
450−-- toUpper = caseConvert upperMapping
451−-- {-# INLINE [0] toUpper #-}
452−
453−-- -- | /O(n)/ Convert a string to lower case, using simple case
454−-- -- conversion. The result string may be longer than the input string.
455−-- -- For instance, the Latin capital letter I with dot above (U+0130)
456−-- -- maps to the sequence Latin small letter i (U+0069) followed by
457−-- -- combining dot above (U+0307).
458−-- toLower :: Stream Char -> Stream Char
459−-- toLower = caseConvert lowerMapping
460−-- {-# INLINE [0] toLower #-}
461−
462−-- -- | /O(n)/ Convert a string to title case, using simple case
463−-- -- conversion.
464−-- --
465−-- -- The first letter of the input is converted to title case, as is
466−-- -- every subsequent letter that immediately follows a non-letter.
467−-- -- Every letter that immediately follows another letter is converted
468−-- -- to lower case.
469−-- --
470−-- -- The result string may be longer than the input string. For example,
471−-- -- the Latin small ligature &#xfb02; (U+FB02) is converted to the
472−-- -- sequence Latin capital letter F (U+0046) followed by Latin small
473−-- -- letter l (U+006C).
474−-- --
475−-- -- /Note/: this function does not take language or culture specific
476−-- -- rules into account. For instance, in English, different style
477−-- -- guides disagree on whether the book name \"The Hill of the Red
478−-- -- Fox\" is correctly title cased&#x2014;but this function will
479−-- -- capitalize /every/ word.
480−-- toTitle :: Stream Char -> Stream Char
481−-- -- toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') len
482−-- toTitle (Stream next0 s0) = Stream next (CC (False :*: s0) '\0' '\0') -- len
483−-- where
484−-- next (CC (letter :*: s) '\0' _) =
485−-- case next0 s of
486−-- Done -> Done
487−-- Skip s' -> Skip (CC (letter :*: s') '\0' '\0')
488−-- Yield c s'
489−-- | letter' -> if letter
490−-- then lowerMapping c (letter' :*: s')
491−-- else titleMapping c (letter' :*: s')
492−-- | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0')
493−-- where letter' = isLetter c
494−-- next (CC s a b) = Yield a (CC s b '\0')
495−-- {-# INLINE [0] toTitle #-}
496−
497−-- data Justify i s = Just1 !i !s
498−-- | Just2 !i !s
499−
500−-- justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char
501−-- -- justifyLeftI k c (Stream next0 s0 len) =
502−-- justifyLeftI k c (Stream next0 s0) =
503−-- Stream next (Just1 0 s0) -- (larger (fromIntegral k) len)
504−-- where
505−-- next (Just1 n s) =
506−-- case next0 s of
507−-- Done -> next (Just2 n s)
508−-- Skip s' -> Skip (Just1 n s')
509−-- Yield x s' -> Yield x (Just1 (n+1) s')
510−-- next (Just2 n s)
511−-- | n < k = Yield c (Just2 (n+1) s)
512−-- | otherwise = Done
513−-- {-# INLINE next #-}
514−-- {-# INLINE [0] justifyLeftI #-}
515−
516−-- -- ----------------------------------------------------------------------------
517−-- -- * Reducing Streams (folds)
518−
519−-- -- | foldl, applied to a binary operator, a starting value (typically the
520−-- -- left-identity of the operator), and a Stream, reduces the Stream using the
521−-- -- binary operator, from left to right.
522−-- foldl :: (b -> Char -> b) -> b -> Stream Char -> b
523−-- -- foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0
524−-- foldl f z0 (Stream next s0) = 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−-- foldl' f z0 (Stream next s0) = loop_foldl' z0 s0
536−-- where
537−-- loop_foldl' !z !s = case next s of
538−-- Done -> z
539−-- Skip s' -> loop_foldl' z s'
540−-- Yield x s' -> loop_foldl' (f z x) s'
541−-- {-# INLINE [0] foldl' #-}
542−
543−-- -- | foldl1 is a variant of foldl that has no starting value argument,
544−-- -- and thus must be applied to non-empty Streams.
545−-- foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char
546−-- -- foldl1 f (Stream next s0 _len) = loop0_foldl1 s0
547−-- foldl1 f (Stream next s0) = loop0_foldl1 s0
548−-- where
549−-- loop0_foldl1 !s = case next s of
550−-- Skip s' -> loop0_foldl1 s'
551−-- Yield x s' -> loop_foldl1 x s'
552−-- Done -> emptyError "foldl1"
553−-- loop_foldl1 z !s = case next s of
554−-- Done -> z
555−-- Skip s' -> loop_foldl1 z s'
556−-- Yield x s' -> loop_foldl1 (f z x) s'
557−-- {-# INLINE [0] foldl1 #-}
558−
559−-- -- | A strict version of foldl1.
560−-- foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char
561−-- -- foldl1' f (Stream next s0 _len) = loop0_foldl1' s0
562−-- foldl1' f (Stream next s0) = loop0_foldl1' s0
563−-- where
564−-- loop0_foldl1' !s = case next s of
565−-- Skip s' -> loop0_foldl1' s'
566−-- Yield x s' -> loop_foldl1' x s'
567−-- Done -> emptyError "foldl1"
568−-- loop_foldl1' !z !s = case next s of
569−-- Done -> z
570−-- Skip s' -> loop_foldl1' z s'
571−-- Yield x s' -> loop_foldl1' (f z x) s'
572−-- {-# INLINE [0] foldl1' #-}
573−
574−-- -- | 'foldr', applied to a binary operator, a starting value (typically the
575−-- -- right-identity of the operator), and a stream, reduces the stream using the
576−-- -- binary operator, from right to left.
577−-- foldr :: (Char -> b -> b) -> b -> Stream Char -> b
578−-- -- foldr f z (Stream next s0 _len) = loop_foldr s0
579−-- foldr f z (Stream next s0) = loop_foldr s0
580−-- where
581−-- loop_foldr !s = case next s of
582−-- Done -> z
583−-- Skip s' -> loop_foldr s'
584−-- Yield x s' -> f x (loop_foldr s')
585−-- {-# INLINE [0] foldr #-}
586−
587−-- -- | foldr1 is a variant of 'foldr' that has no starting value argument,
588−-- -- and thus must be applied to non-empty streams.
589−-- -- Subject to array fusion.
590−-- foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char
591−-- -- foldr1 f (Stream next s0 _len) = loop0_foldr1 s0
592−-- foldr1 f (Stream next s0) = loop0_foldr1 s0
593−-- where
594−-- loop0_foldr1 !s = case next s of
595−-- Done -> emptyError "foldr1"
596−-- Skip s' -> loop0_foldr1 s'
597−-- Yield x s' -> loop_foldr1 x s'
598−
599−-- loop_foldr1 x !s = case next s of
600−-- Done -> x
601−-- Skip s' -> loop_foldr1 x s'
602−-- Yield x' s' -> f x (loop_foldr1 x' s')
603−-- {-# INLINE [0] foldr1 #-}
604−
605−-- intercalate :: Stream Char -> [Stream Char] -> Stream Char
606−-- intercalate s = concat . (L.intersperse s)
607−-- {-# INLINE [0] intercalate #-}
608−
609−-- -- ----------------------------------------------------------------------------
610−-- -- ** Special folds
611−
612−-- -- | /O(n)/ Concatenate a list of streams. Subject to array fusion.
613−-- concat :: [Stream Char] -> Stream Char
614−-- concat = L.foldr append empty
615−-- {-# INLINE [0] concat #-}
616−
617−-- -- | Map a function over a stream that results in a stream and concatenate the
618−-- -- results.
619−-- concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char
620−-- concatMap f = foldr (append . f) empty
621−-- {-# INLINE [0] concatMap #-}
622−
623−-- -- | /O(n)/ any @p @xs determines if any character in the stream
624−-- -- @xs@ satisfies the predicate @p@.
625−-- any :: (Char -> Bool) -> Stream Char -> Bool
626−-- -- any p (Stream next0 s0 _len) = loop_any s0
627−-- any p (Stream next0 s0) = loop_any s0
628−-- where
629−-- loop_any !s = case next0 s of
630−-- Done -> False
631−-- Skip s' -> loop_any s'
632−-- Yield x s' | p x -> True
633−-- | otherwise -> loop_any s'
634−-- {-# INLINE [0] any #-}
635−
636−-- -- | /O(n)/ all @p @xs determines if all characters in the 'Text'
637−-- -- @xs@ satisfy the predicate @p@.
638−-- all :: (Char -> Bool) -> Stream Char -> Bool
639−-- -- all p (Stream next0 s0 _len) = loop_all s0
640−-- all p (Stream next0 s0) = loop_all s0
641−-- where
642−-- loop_all !s = case next0 s of
643−-- Done -> True
644−-- Skip s' -> loop_all s'
645−-- Yield x s' | p x -> loop_all s'
646−-- | otherwise -> False
647−-- {-# INLINE [0] all #-}
648−
649−-- -- | /O(n)/ maximum returns the maximum value from a stream, which must be
650−-- -- non-empty.
651−-- maximum :: Stream Char -> Char
652−-- -- maximum (Stream next0 s0 _len) = loop0_maximum s0
653−-- maximum (Stream next0 s0) = loop0_maximum s0
654−-- where
655−-- loop0_maximum !s = case next0 s of
656−-- Done -> emptyError "maximum"
657−-- Skip s' -> loop0_maximum s'
658−-- Yield x s' -> loop_maximum x s'
659−-- loop_maximum !z !s = case next0 s of
660−-- Done -> z
661−-- Skip s' -> loop_maximum z s'
662−-- Yield x s'
663−-- | x > z -> loop_maximum x s'
664−-- | otherwise -> loop_maximum z s'
665−-- {-# INLINE [0] maximum #-}
666−
667−-- -- | /O(n)/ minimum returns the minimum value from a 'Text', which must be
668−-- -- non-empty.
669−-- minimum :: Stream Char -> Char
670−-- -- minimum (Stream next0 s0 _len) = loop0_minimum s0
671−-- minimum (Stream next0 s0) = loop0_minimum s0
672−-- where
673−-- loop0_minimum !s = case next0 s of
674−-- Done -> emptyError "minimum"
675−-- Skip s' -> loop0_minimum s'
676−-- Yield x s' -> loop_minimum x s'
677−-- loop_minimum !z !s = case next0 s of
678−-- Done -> z
679−-- Skip s' -> loop_minimum z s'
680−-- Yield x s'
681−-- | x < z -> loop_minimum x s'
682−-- | otherwise -> loop_minimum z s'
683−-- {-# INLINE [0] minimum #-}
684−
685−-- -- -----------------------------------------------------------------------------
686−-- -- * Building streams
687−
688−-- scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
689−-- -- scanl f z0 (Stream next0 s0 len) = Stream next (Scan1 z0 s0) (len+1) -- HINT maybe too low
690−-- scanl f z0 (Stream next0 s0) = Stream next (Scan1 z0 s0) -- (len+1) -- HINT maybe too low
691−-- where
692−-- {-# INLINE next #-}
693−-- next (Scan1 z s) = Yield z (Scan2 z s)
694−-- next (Scan2 z s) = case next0 s of
695−-- Yield x s' -> let !x' = f z x
696−-- in Yield x' (Scan2 x' s')
697−-- Skip s' -> Skip (Scan2 z s')
698−-- Done -> Done
699−-- {-# INLINE [0] scanl #-}
700−
701−-- -- -----------------------------------------------------------------------------
702−-- -- ** Generating and unfolding streams
703−
704−-- replicateCharI :: Integral a => a -> Char -> Stream Char
705−-- replicateCharI n c
706−-- | n < 0 = empty
707−-- | otherwise = Stream next 0 -- (fromIntegral n) -- HINT maybe too low
708−-- where
709−-- next i | i >= n = Done
710−-- | otherwise = Yield c (i + 1)
711−-- {-# INLINE [0] replicateCharI #-}
712−
713−-- data RI s = RI !s {-# UNPACK #-} !Int64
714−
715−-- replicateI :: Int64 -> Stream Char -> Stream Char
716−-- -- replicateI n (Stream next0 s0 len) =
717−-- replicateI n (Stream next0 s0) =
718−-- Stream next (RI s0 0) -- (fromIntegral (max 0 n) * len)
719−-- where
720−-- next (RI s k)
721−-- | k >= n = Done
722−-- | otherwise = case next0 s of
723−-- Done -> Skip (RI s0 (k+1))
724−-- Skip s' -> Skip (RI s' k)
725−-- Yield x s' -> Yield x (RI s' k)
726−-- {-# INLINE [0] replicateI #-}
727−
728−-- -- | /O(n)/, where @n@ is the length of the result. The unfoldr function
729−-- -- is analogous to the List 'unfoldr'. unfoldr builds a stream
730−-- -- from a seed value. The function takes the element and returns
731−-- -- Nothing if it is done producing the stream or returns Just
732−-- -- (a,b), in which case, a is the next Char in the string, and b is
733−-- -- the seed value for further production.
734−-- unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char
735−-- unfoldr f s0 = Stream next s0 -- 1 -- HINT maybe too low
736−-- where
737−-- {-# INLINE next #-}
738−-- next !s = case f s of
739−-- Nothing -> Done
740−-- Just (w, s') -> Yield w s'
741−-- {-# INLINE [0] unfoldr #-}
742−
743−-- -- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed
744−-- -- value. However, the length of the result is limited by the
745−-- -- first argument to 'unfoldrNI'. This function is more efficient than
746−-- -- 'unfoldr' when the length of the result is known.
747−-- unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char
748−-- unfoldrNI n f s0 | n < 0 = empty
749−-- | otherwise = Stream next (0 :*: s0) -- (fromIntegral (n*2)) -- HINT maybe too high
750−-- where
751−-- {-# INLINE next #-}
752−-- next (z :*: s) = case f s of
753−-- Nothing -> Done
754−-- Just (w, s') | z >= n -> Done
755−-- | otherwise -> Yield w ((z + 1) :*: s')
756−-- {-# INLINE unfoldrNI #-}
757−
758−-- -------------------------------------------------------------------------------
759−-- -- * Substreams
760−
761−-- -- | /O(n)/ take n, applied to a stream, returns the prefix of the
762−-- -- stream of length @n@, or the stream itself if @n@ is greater than the
763−-- -- length of the stream.
764−-- take :: Integral a => a -> Stream Char -> Stream Char
765−-- take n0 (Stream next0 s0) =
766−-- -- take n0 (Stream next0 s0 len) =
767−-- Stream next (n0 :*: s0) -- (smaller len (fromIntegral (max 0 n0)))
768−-- where
769−-- {-# INLINE next #-}
770−-- next (n :*: s) | n <= 0 = Done
771−-- | otherwise = case next0 s of
772−-- Done -> Done
773−-- Skip s' -> Skip (n :*: s')
774−-- Yield x s' -> Yield x ((n-1) :*: s')
775−-- {-# INLINE [0] take #-}
776−
777−-- data Drop a s = NS !s
778−-- | JS !a !s
779−
780−-- -- | /O(n)/ drop n, applied to a stream, returns the suffix of the
781−-- -- stream after the first @n@ characters, or the empty stream if @n@
782−-- -- is greater than the length of the stream.
783−-- drop :: Integral a => a -> Stream Char -> Stream Char
784−-- -- drop n0 (Stream next0 s0 len) =
785−-- drop n0 (Stream next0 s0) =
786−-- Stream next (JS n0 s0) -- (len - fromIntegral (max 0 n0))
787−-- where
788−-- {-# INLINE next #-}
789−-- next (JS n s)
790−-- | n <= 0 = Skip (NS s)
791−-- | otherwise = case next0 s of
792−-- Done -> Done
793−-- Skip s' -> Skip (JS n s')
794−-- Yield _ s' -> Skip (JS (n-1) s')
795−-- next (NS s) = case next0 s of
796−-- Done -> Done
797−-- Skip s' -> Skip (NS s')
798−-- Yield x s' -> Yield x (NS s')
799−-- {-# INLINE [0] drop #-}
800−
801−-- -- | takeWhile, applied to a predicate @p@ and a stream, returns the
802−-- -- longest prefix (possibly empty) of elements that satisfy p.
803−-- takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char
804−-- -- takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
805−-- takeWhile p (Stream next0 s0) = Stream next s0 -- len -- HINT maybe too high
806−-- where
807−-- {-# INLINE next #-}
808−-- next !s = case next0 s of
809−-- Done -> Done
810−-- Skip s' -> Skip s'
811−-- Yield x s' | p x -> Yield x s'
812−-- | otherwise -> Done
813−-- {-# INLINE [0] takeWhile #-}
814−
815−-- -- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
816−-- dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
817−-- -- dropWhile p (Stream next0 s0 len) = Stream next (L s0) len -- HINT maybe too high
818−-- dropWhile p (Stream next0 s0) = Stream next (L s0) -- len -- HINT maybe too high
819−-- where
820−-- {-# INLINE next #-}
821−-- next (L s) = case next0 s of
822−-- Done -> Done
823−-- Skip s' -> Skip (L s')
824−-- Yield x s' | p x -> Skip (L s')
825−-- | otherwise -> Yield x (R s')
826−-- next (R s) = case next0 s of
827−-- Done -> Done
828−-- Skip s' -> Skip (R s')
829−-- Yield x s' -> Yield x (R s')
830−-- {-# INLINE [0] dropWhile #-}
831−
832−-- -- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns
833−-- -- 'True' iff the first is a prefix of the second.
834−-- isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool
835−-- -- isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
836−-- isPrefixOf (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
837−-- where
838−-- loop Done _ = True
839−-- loop _ Done = False
840−-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
841−-- loop (Skip s1') x2 = loop (next1 s1') x2
842−-- loop x1 (Skip s2') = loop x1 (next2 s2')
843−-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
844−-- loop (next1 s1') (next2 s2')
845−-- {-# INLINE [0] isPrefixOf #-}
846−
847−-- -- ----------------------------------------------------------------------------
848−-- -- * Searching
849−
850−-- -------------------------------------------------------------------------------
851−-- -- ** Searching by equality
852−
853−-- -- | /O(n)/ elem is the stream membership predicate.
854−-- elem :: Char -> Stream Char -> Bool
855−-- -- elem w (Stream next s0 _len) = loop_elem s0
856−-- elem w (Stream next s0) = loop_elem s0
857−-- where
858−-- loop_elem !s = case next s of
859−-- Done -> False
860−-- Skip s' -> loop_elem s'
861−-- Yield x s' | x == w -> True
862−-- | otherwise -> loop_elem s'
863−-- {-# INLINE [0] elem #-}
864−
865−-- -------------------------------------------------------------------------------
866−-- -- ** Searching with a predicate
867−
868−-- -- | /O(n)/ The 'findBy' function takes a predicate and a stream,
869−-- -- and returns the first element in matching the predicate, or 'Nothing'
870−-- -- if there is no such element.
871−
872−-- findBy :: (Char -> Bool) -> Stream Char -> Maybe Char
873−-- -- findBy p (Stream next s0 _len) = loop_find s0
874−-- findBy p (Stream next s0) = loop_find s0
875−-- where
876−-- loop_find !s = case next s of
877−-- Done -> Nothing
878−-- Skip s' -> loop_find s'
879−-- Yield x s' | p x -> Just x
880−-- | otherwise -> loop_find s'
881−-- {-# INLINE [0] findBy #-}
882−
883−-- -- | /O(n)/ Stream index (subscript) operator, starting from 0.
884−-- indexI :: Integral a => Stream Char -> a -> Char
885−-- -- indexI (Stream next s0 _len) n0
886−-- indexI (Stream next s0) n0
887−-- | n0 < 0 = streamError "index" "Negative index"
888−-- | otherwise = loop_index n0 s0
889−-- where
890−-- loop_index !n !s = case next s of
891−-- Done -> streamError "index" "Index too large"
892−-- Skip s' -> loop_index n s'
893−-- Yield x s' | n == 0 -> x
894−-- | otherwise -> loop_index (n-1) s'
895−-- {-# INLINE [0] indexI #-}
896−
897−-- -- | /O(n)/ 'filter', applied to a predicate and a stream,
898−-- -- returns a stream containing those characters that satisfy the
899−-- -- predicate.
900−-- filter :: (Char -> Bool) -> Stream Char -> Stream Char
901−-- -- filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
902−-- filter p (Stream next0 s0) = Stream next s0 -- len -- HINT maybe too high
903−-- where
904−-- next !s = case next0 s of
905−-- Done -> Done
906−-- Skip s' -> Skip s'
907−-- Yield x s' | p x -> Yield x s'
908−-- | otherwise -> Skip s'
909−-- {-# INLINE [0] filter #-}
910−
911−-- {-# RULES
912−-- "STREAM filter/filter fusion" forall p q s.
913−-- filter p (filter q s) = filter (\x -> q x && p x) s
914−-- #-}
915−
916−-- -- | The 'findIndexI' function takes a predicate and a stream and
917−-- -- returns the index of the first element in the stream satisfying the
918−-- -- predicate.
919−-- findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a
920−-- findIndexI p s = case findIndicesI p s of
921−-- (i:_) -> Just i
922−-- _ -> Nothing
923−-- {-# INLINE [0] findIndexI #-}
924−
925−-- -- | The 'findIndicesI' function takes a predicate and a stream and
926−-- -- returns all indices of the elements in the stream satisfying the
927−-- -- predicate.
928−-- findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a]
929−-- -- findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0
930−-- findIndicesI p (Stream next s0) = loop_findIndex 0 s0
931−-- where
932−-- loop_findIndex !i !s = case next s of
933−-- Done -> []
934−-- Skip s' -> loop_findIndex i s' -- hmm. not caught by QC
935−-- Yield x s' | p x -> i : loop_findIndex (i+1) s'
936−-- | otherwise -> loop_findIndex (i+1) s'
937−-- {-# INLINE [0] findIndicesI #-}
938−
939−-- -------------------------------------------------------------------------------
940−-- -- * Zipping
941−
942−-- -- | Strict triple.
943−-- data Zip a b m = Z1 !a !b
944−-- | Z2 !a !b !m
945−
946−-- -- | zipWith generalises 'zip' by zipping with the function given as
947−-- -- the first argument, instead of a tupling function.
948−-- zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b
949−-- -- zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) =
950−-- zipWith f (Stream next0 sa0) (Stream next1 sb0) =
951−-- Stream next (Z1 sa0 sb0) -- (smaller len1 len2)
952−-- where
953−-- next (Z1 sa sb) = case next0 sa of
954−-- Done -> Done
955−-- Skip sa' -> Skip (Z1 sa' sb)
956−-- Yield a sa' -> Skip (Z2 sa' sb a)
957−
958−-- next (Z2 sa' sb a) = case next1 sb of
959−-- Done -> Done
960−-- Skip sb' -> Skip (Z2 sa' sb' a)
961−-- Yield b sb' -> Yield (f a b) (Z1 sa' sb')
962−-- {-# INLINE [0] zipWith #-}
963−
964−-- -- | /O(n)/ The 'countCharI' function returns the number of times the
965−-- -- query element appears in the given stream.
966−-- countCharI :: Integral a => Char -> Stream Char -> a
967−-- -- countCharI a (Stream next s0 _len) = loop 0 s0
968−-- countCharI a (Stream next s0) = loop 0 s0
969−-- where
970−-- loop !i !s = case next s of
971−-- Done -> i
972−-- Skip s' -> loop i s'
973−-- Yield x s' | a == x -> loop (i+1) s'
974−-- | otherwise -> loop i s'
975−-- {-# INLINE [0] countCharI #-}
976−
977−-- streamError :: String -> String -> a
978−-- streamError func msg = P.error $ "Data.Text.Internal.Fusion.Common." ++ func ++ ": " ++ msg
979−
980−-- emptyError :: String -> a
981−-- emptyError func = internalError func "Empty input"
982−
983−-- internalError :: String -> a
984−-- internalError func = streamError func "Internal error"
17+module Data.Text.Internal.Fusion.Common
18+ (
19+ -- * Creation and elimination
20+ singleton
21+ , streamList
22+ , unstreamList
23+ , streamCString#
24+
25+ -- * Basic interface
26+ , cons
27+ , snoc
28+ , append
29+ , head
30+ , uncons
31+ , last
32+ , tail
33+ , init
34+ , null
35+ , lengthI
36+ , compareLengthI
37+ , isSingleton
38+
39+ -- * Transformations
40+ , map
41+ , intercalate
42+ , intersperse
43+
44+ -- ** Case conversion
45+ -- $case
46+ , toCaseFold
47+ , toLower
48+ , toTitle
49+ , toUpper
50+
51+ -- ** Justification
52+ , justifyLeftI
53+
54+ -- * Folds
55+ , foldl
56+ , foldl'
57+ , foldl1
58+ , foldl1'
59+ , foldr
60+ , foldr1
61+
62+ -- ** Special folds
63+ , concat
64+ , concatMap
65+ , any
66+ , all
67+ , maximum
68+ , minimum
69+
70+ -- * Construction
71+ -- ** Scans
72+ , scanl
73+
74+ -- ** Generation and unfolding
75+ , replicateCharI
76+ , replicateI
77+ , unfoldr
78+ , unfoldrNI
79+
80+ -- * Substrings
81+ -- ** Breaking strings
82+ , take
83+ , drop
84+ , takeWhile
85+ , dropWhile
86+
87+ -- * Predicates
88+ , isPrefixOf
89+
90+ -- * Searching
91+ , elem
92+ , filter
93+
94+ -- * Indexing
95+ , findBy
96+ , indexI
97+ , findIndexI
98+ , countCharI
99+
100+ -- * Zipping and unzipping
101+ , zipWith
102+ ) where
103+
104+import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),
105+ Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++),
106+ (&&), fromIntegral, otherwise)
107+import qualified Data.List as L
108+import qualified Prelude as P
109+import Data.Bits (shiftL)
110+import Data.Char (isLetter)
111+import Data.Int (Int64)
112+import Data.Text.Internal.Fusion.Types
113+import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping,
114+ upperMapping)
115+import Data.Text.Internal.Fusion.Size
116+import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)
117+import GHC.Types (Char(..), Int(..))
118+
119+singleton :: Char -> Stream Char
120+singleton c = Stream next False 1
121+ where next False = Yield c True
122+ next True = Done
123+{-# INLINE [0] singleton #-}
124+
125+streamList :: [a] -> Stream a
126+{-# INLINE [0] streamList #-}
127+streamList s = Stream next s unknownSize
128+ where next [] = Done
129+ next (x:xs) = Yield x xs
130+
131+unstreamList :: Stream a -> [a]
132+unstreamList (Stream next s0 _len) = unfold s0
133+ where unfold !s = case next s of
134+ Done -> []
135+ Skip s' -> unfold s'
136+ Yield x s' -> x : unfold s'
137+{-# INLINE [0] unstreamList #-}
138+
139+{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}
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+
170+-- ----------------------------------------------------------------------------
171+-- * Basic stream functions
172+
173+data C s = C0 !s
174+ | C1 !s
175+
176+-- | /O(n)/ Adds a character to the front of a Stream Char.
177+cons :: Char -> Stream Char -> Stream Char
178+cons !w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
179+ where
180+ next (C1 s) = Yield w (C0 s)
181+ next (C0 s) = case next0 s of
182+ Done -> Done
183+ Skip s' -> Skip (C0 s')
184+ Yield x s' -> Yield x (C0 s')
185+{-# INLINE [0] cons #-}
186+
187+data Snoc a = N
188+ | J !a
189+
190+-- | /O(n)/ Adds a character to the end of a stream.
191+snoc :: Stream Char -> Char -> Stream Char
192+snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)
193+ where
194+ next (J xs) = case next0 xs of
195+ Done -> Yield w N
196+ Skip xs' -> Skip (J xs')
197+ Yield x xs' -> Yield x (J xs')
198+ next N = Done
199+{-# INLINE [0] snoc #-}
200+
201+data E l r = L !l
202+ | R !r
203+
204+-- | /O(n)/ Appends one Stream to the other.
205+append :: Stream Char -> Stream Char -> Stream Char
206+append (Stream next0 s01 len1) (Stream next1 s02 len2) =
207+ Stream next (L s01) (len1 + len2)
208+ where
209+ next (L s1) = case next0 s1 of
210+ Done -> Skip (R s02)
211+ Skip s1' -> Skip (L s1')
212+ Yield x s1' -> Yield x (L s1')
213+ next (R s2) = case next1 s2 of
214+ Done -> Done
215+ Skip s2' -> Skip (R s2')
216+ Yield x s2' -> Yield x (R s2')
217+{-# INLINE [0] append #-}
218+
219+-- | /O(1)/ Returns the first character of a Text, which must be non-empty.
220+-- Subject to array fusion.
221+head :: Stream Char -> Char
222+head (Stream next s0 _len) = loop_head s0
223+ where
224+ loop_head !s = case next s of
225+ Yield x _ -> x
226+ Skip s' -> loop_head s'
227+ Done -> head_empty
228+{-# INLINE [0] head #-}
229+
230+head_empty :: a
231+head_empty = streamError "head" "Empty stream"
232+{-# NOINLINE head_empty #-}
233+
234+-- | /O(1)/ Returns the first character and remainder of a 'Stream
235+-- Char', or 'Nothing' if empty. Subject to array fusion.
236+uncons :: Stream Char -> Maybe (Char, Stream Char)
237+uncons (Stream next s0 len) = loop_uncons s0
238+ where
239+ loop_uncons !s = case next s of
240+ Yield x s1 -> Just (x, Stream next s1 (len-1))
241+ Skip s' -> loop_uncons s'
242+ Done -> Nothing
243+{-# INLINE [0] uncons #-}
244+
245+-- | /O(n)/ Returns the last character of a 'Stream Char', which must
246+-- be non-empty.
247+last :: Stream Char -> Char
248+last (Stream next s0 _len) = loop0_last s0
249+ where
250+ loop0_last !s = case next s of
251+ Done -> emptyError "last"
252+ Skip s' -> loop0_last s'
253+ Yield x s' -> loop_last x s'
254+ loop_last !x !s = case next s of
255+ Done -> x
256+ Skip s' -> loop_last x s'
257+ Yield x' s' -> loop_last x' s'
258+{-# INLINE[0] last #-}
259+
260+-- | /O(1)/ Returns all characters after the head of a Stream Char, which must
261+-- be non-empty.
262+tail :: Stream Char -> Stream Char
263+tail (Stream next0 s0 len) = Stream next (C0 s0) (len-1)
264+ where
265+ next (C0 s) = case next0 s of
266+ Done -> emptyError "tail"
267+ Skip s' -> Skip (C0 s')
268+ Yield _ s' -> Skip (C1 s')
269+ next (C1 s) = case next0 s of
270+ Done -> Done
271+ Skip s' -> Skip (C1 s')
272+ Yield x s' -> Yield x (C1 s')
273+{-# INLINE [0] tail #-}
274+
275+data Init s = Init0 !s
276+ | Init1 {-# UNPACK #-} !Char !s
277+
278+-- | /O(1)/ Returns all but the last character of a Stream Char, which
279+-- must be non-empty.
280+init :: Stream Char -> Stream Char
281+init (Stream next0 s0 len) = Stream next (Init0 s0) (len-1)
282+ where
283+ next (Init0 s) = case next0 s of
284+ Done -> emptyError "init"
285+ Skip s' -> Skip (Init0 s')
286+ Yield x s' -> Skip (Init1 x s')
287+ next (Init1 x s) = case next0 s of
288+ Done -> Done
289+ Skip s' -> Skip (Init1 x s')
290+ Yield x' s' -> Yield x (Init1 x' s')
291+{-# INLINE [0] init #-}
292+
293+-- | /O(1)/ Tests whether a Stream Char is empty or not.
294+null :: Stream Char -> Bool
295+null (Stream next s0 _len) = loop_null s0
296+ where
297+ loop_null !s = case next s of
298+ Done -> True
299+ Yield _ _ -> False
300+ Skip s' -> loop_null s'
301+{-# INLINE[0] null #-}
302+
303+-- | /O(n)/ Returns the number of characters in a string.
304+lengthI :: Integral a => Stream Char -> a
305+lengthI (Stream next s0 _len) = loop_length 0 s0
306+ where
307+ loop_length !z s = case next s of
308+ Done -> z
309+ Skip s' -> loop_length z s'
310+ Yield _ s' -> loop_length (z + 1) s'
311+{-# INLINE[0] lengthI #-}
312+
313+-- | /O(n)/ Compares the count of characters in a string to a number.
314+-- Subject to fusion.
315+--
316+-- This function gives the same answer as comparing against the result
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
319+-- as the number supplied, and hence be more efficient.
320+compareLengthI :: Integral a => Stream Char -> a -> Ordering
321+compareLengthI (Stream next s0 len) n =
322+ case compareSize len (fromIntegral n) of
323+ Just o -> o
324+ Nothing -> loop_cmp 0 s0
325+ where
326+ loop_cmp !z s = case next s of
327+ Done -> compare z n
328+ Skip s' -> loop_cmp z s'
329+ Yield _ s' | z > n -> GT
330+ | otherwise -> loop_cmp (z + 1) s'
331+{-# INLINE[0] compareLengthI #-}
332+
333+-- | /O(n)/ Indicate whether a string contains exactly one element.
334+isSingleton :: Stream Char -> Bool
335+isSingleton (Stream next s0 _len) = loop 0 s0
336+ where
337+ loop !z s = case next s of
338+ Done -> z == (1::Int)
339+ Skip s' -> loop z s'
340+ Yield _ s'
341+ | z >= 1 -> False
342+ | otherwise -> loop (z+1) s'
343+{-# INLINE[0] isSingleton #-}
344+
345+-- ----------------------------------------------------------------------------
346+-- * Stream transformations
347+
348+-- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@
349+-- to each element of @xs@.
350+map :: (Char -> Char) -> Stream Char -> Stream Char
351+map f (Stream next0 s0 len) = Stream next s0 len
352+ where
353+ next !s = case next0 s of
354+ Done -> Done
355+ Skip s' -> Skip s'
356+ Yield x s' -> Yield (f x) s'
357+{-# INLINE [0] map #-}
358+
359+{-#
360+ RULES "STREAM map/map fusion" forall f g s.
361+ map f (map g s) = map (\x -> f (g x)) s
362+ #-}
363+
364+data I s = I1 !s
365+ | I2 !s {-# UNPACK #-} !Char
366+ | I3 !s
367+
368+-- | /O(n)/ Take a character and place it between each of the
369+-- characters of a 'Stream Char'.
370+intersperse :: Char -> Stream Char -> Stream Char
371+intersperse c (Stream next0 s0 len) = Stream next (I1 s0) len
372+ where
373+ next (I1 s) = case next0 s of
374+ Done -> Done
375+ Skip s' -> Skip (I1 s')
376+ Yield x s' -> Skip (I2 s' x)
377+ next (I2 s x) = Yield x (I3 s)
378+ next (I3 s) = case next0 s of
379+ Done -> Done
380+ Skip s' -> Skip (I3 s')
381+ Yield x s' -> Yield c (I2 s' x)
382+{-# INLINE [0] intersperse #-}
383+
384+-- ----------------------------------------------------------------------------
385+-- ** Case conversions (folds)
386+
387+-- $case
388+--
389+-- With Unicode text, it is incorrect to use combinators like @map
390+-- toUpper@ to case convert each character of a string individually.
391+-- Instead, use the whole-string case conversion functions from this
392+-- module. For correctness in different writing systems, these
393+-- functions may map one input character to two or three output
394+-- characters.
395+
396+caseConvert :: (forall s. Char -> s -> Step (CC s) Char)
397+ -> Stream Char -> Stream Char
398+caseConvert remap (Stream next0 s0 len) = Stream next (CC s0 '\0' '\0') len
399+ where
400+ next (CC s '\0' _) =
401+ case next0 s of
402+ Done -> Done
403+ Skip s' -> Skip (CC s' '\0' '\0')
404+ Yield c s' -> remap c s'
405+ next (CC s a b) = Yield a (CC s b '\0')
406+
407+-- | /O(n)/ Convert a string to folded case. This function is mainly
408+-- useful for performing caseless (or case insensitive) string
409+-- comparisons.
410+--
411+-- A string @x@ is a caseless match for a string @y@ if and only if:
412+--
413+-- @toCaseFold x == toCaseFold y@
414+--
415+-- The result string may be longer than the input string, and may
416+-- differ from applying 'toLower' to the input string. For instance,
417+-- the Armenian small ligature men now (U+FB13) is case folded to the
418+-- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is
419+-- case folded to the Greek small letter letter mu (U+03BC) instead of
420+-- itself.
421+toCaseFold :: Stream Char -> Stream Char
422+toCaseFold = caseConvert foldMapping
423+{-# INLINE [0] toCaseFold #-}
424+
425+-- | /O(n)/ Convert a string to upper case, using simple case
426+-- conversion. The result string may be longer than the input string.
427+-- For instance, the German eszett (U+00DF) maps to the two-letter
428+-- sequence SS.
429+toUpper :: Stream Char -> Stream Char
430+toUpper = caseConvert upperMapping
431+{-# INLINE [0] toUpper #-}
432+
433+-- | /O(n)/ Convert a string to lower case, using simple case
434+-- conversion. The result string may be longer than the input string.
435+-- For instance, the Latin capital letter I with dot above (U+0130)
436+-- maps to the sequence Latin small letter i (U+0069) followed by
437+-- combining dot above (U+0307).
438+toLower :: Stream Char -> Stream Char
439+toLower = caseConvert lowerMapping
440+{-# INLINE [0] toLower #-}
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+
479+justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char
480+justifyLeftI k c (Stream next0 s0 len) =
481+ Stream next (Just1 0 s0) (larger (fromIntegral k) len)
482+ where
483+ next (Just1 n s) =
484+ case next0 s of
485+ Done -> next (Just2 n s)
486+ Skip s' -> Skip (Just1 n s')
487+ Yield x s' -> Yield x (Just1 (n+1) s')
488+ next (Just2 n s)
489+ | n < k = Yield c (Just2 (n+1) s)
490+ | otherwise = Done
491+ {-# INLINE next #-}
492+{-# INLINE [0] justifyLeftI #-}
493+
494+-- ----------------------------------------------------------------------------
495+-- * Reducing Streams (folds)
496+
497+-- | foldl, applied to a binary operator, a starting value (typically the
498+-- left-identity of the operator), and a Stream, reduces the Stream using the
499+-- binary operator, from left to right.
500+foldl :: (b -> Char -> b) -> b -> Stream Char -> b
501+foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0
502+ where
503+ loop_foldl z !s = case next s of
504+ Done -> z
505+ Skip s' -> loop_foldl z s'
506+ Yield x s' -> loop_foldl (f z x) s'
507+{-# INLINE [0] foldl #-}
508+
509+-- | A strict version of foldl.
510+foldl' :: (b -> Char -> b) -> b -> Stream Char -> b
511+foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0
512+ where
513+ loop_foldl' !z !s = case next s of
514+ Done -> z
515+ Skip s' -> loop_foldl' z s'
516+ Yield x s' -> loop_foldl' (f z x) s'
517+{-# INLINE [0] foldl' #-}
518+
519+-- | foldl1 is a variant of foldl that has no starting value argument,
520+-- and thus must be applied to non-empty Streams.
521+foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char
522+foldl1 f (Stream next s0 _len) = loop0_foldl1 s0
523+ where
524+ loop0_foldl1 !s = case next s of
525+ Skip s' -> loop0_foldl1 s'
526+ Yield x s' -> loop_foldl1 x s'
527+ Done -> emptyError "foldl1"
528+ loop_foldl1 z !s = case next s of
529+ Done -> z
530+ Skip s' -> loop_foldl1 z s'
531+ Yield x s' -> loop_foldl1 (f z x) s'
532+{-# INLINE [0] foldl1 #-}
533+
534+-- | A strict version of foldl1.
535+foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char
536+foldl1' f (Stream next s0 _len) = loop0_foldl1' s0
537+ where
538+ loop0_foldl1' !s = case next s of
539+ Skip s' -> loop0_foldl1' s'
540+ Yield x s' -> loop_foldl1' x s'
541+ Done -> emptyError "foldl1"
542+ loop_foldl1' !z !s = case next s of
543+ Done -> z
544+ Skip s' -> loop_foldl1' z s'
545+ Yield x s' -> loop_foldl1' (f z x) s'
546+{-# INLINE [0] foldl1' #-}
547+
548+-- | 'foldr', applied to a binary operator, a starting value (typically the
549+-- right-identity of the operator), and a stream, reduces the stream using the
550+-- binary operator, from right to left.
551+foldr :: (Char -> b -> b) -> b -> Stream Char -> b
552+foldr f z (Stream next s0 _len) = loop_foldr s0
553+ where
554+ loop_foldr !s = case next s of
555+ Done -> z
556+ Skip s' -> loop_foldr s'
557+ Yield x s' -> f x (loop_foldr s')
558+{-# INLINE [0] foldr #-}
559+
560+-- | foldr1 is a variant of 'foldr' that has no starting value argument,
561+-- and thus must be applied to non-empty streams.
562+-- Subject to array fusion.
563+foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char
564+foldr1 f (Stream next s0 _len) = loop0_foldr1 s0
565+ where
566+ loop0_foldr1 !s = case next s of
567+ Done -> emptyError "foldr1"
568+ Skip s' -> loop0_foldr1 s'
569+ Yield x s' -> loop_foldr1 x s'
570+
571+ loop_foldr1 x !s = case next s of
572+ Done -> x
573+ Skip s' -> loop_foldr1 x s'
574+ Yield x' s' -> f x (loop_foldr1 x' s')
575+{-# INLINE [0] foldr1 #-}
576+
577+intercalate :: Stream Char -> [Stream Char] -> Stream Char
578+intercalate s = concat . (L.intersperse s)
579+{-# INLINE [0] intercalate #-}
580+
581+-- ----------------------------------------------------------------------------
582+-- ** Special folds
583+
584+-- | /O(n)/ Concatenate a list of streams. Subject to array fusion.
585+concat :: [Stream Char] -> Stream Char
586+concat = L.foldr append empty
587+{-# INLINE [0] concat #-}
588+
589+-- | Map a function over a stream that results in a stream and concatenate the
590+-- results.
591+concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char
592+concatMap f = foldr (append . f) empty
593+{-# INLINE [0] concatMap #-}
594+
595+-- | /O(n)/ any @p @xs determines if any character in the stream
596+-- @xs@ satisfies the predicate @p@.
597+any :: (Char -> Bool) -> Stream Char -> Bool
598+any p (Stream next0 s0 _len) = loop_any s0
599+ where
600+ loop_any !s = case next0 s of
601+ Done -> False
602+ Skip s' -> loop_any s'
603+ Yield x s' | p x -> True
604+ | otherwise -> loop_any s'
605+{-# INLINE [0] any #-}
606+
607+-- | /O(n)/ all @p @xs determines if all characters in the 'Text'
608+-- @xs@ satisfy the predicate @p@.
609+all :: (Char -> Bool) -> Stream Char -> Bool
610+all p (Stream next0 s0 _len) = loop_all s0
611+ where
612+ loop_all !s = case next0 s of
613+ Done -> True
614+ Skip s' -> loop_all s'
615+ Yield x s' | p x -> loop_all s'
616+ | otherwise -> False
617+{-# INLINE [0] all #-}
618+
619+-- | /O(n)/ maximum returns the maximum value from a stream, which must be
620+-- non-empty.
621+maximum :: Stream Char -> Char
622+maximum (Stream next0 s0 _len) = loop0_maximum s0
623+ where
624+ loop0_maximum !s = case next0 s of
625+ Done -> emptyError "maximum"
626+ Skip s' -> loop0_maximum s'
627+ Yield x s' -> loop_maximum x s'
628+ loop_maximum !z !s = case next0 s of
629+ Done -> z
630+ Skip s' -> loop_maximum z s'
631+ Yield x s'
632+ | x > z -> loop_maximum x s'
633+ | otherwise -> loop_maximum z s'
634+{-# INLINE [0] maximum #-}
635+
636+-- | /O(n)/ minimum returns the minimum value from a 'Text', which must be
637+-- non-empty.
638+minimum :: Stream Char -> Char
639+minimum (Stream next0 s0 _len) = loop0_minimum s0
640+ where
641+ loop0_minimum !s = case next0 s of
642+ Done -> emptyError "minimum"
643+ Skip s' -> loop0_minimum s'
644+ Yield x s' -> loop_minimum x s'
645+ loop_minimum !z !s = case next0 s of
646+ Done -> z
647+ Skip s' -> loop_minimum z s'
648+ Yield x s'
649+ | x < z -> loop_minimum x s'
650+ | otherwise -> loop_minimum z s'
651+{-# INLINE [0] minimum #-}
652+
653+-- -----------------------------------------------------------------------------
654+-- * Building streams
655+
656+scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
657+scanl f z0 (Stream next0 s0 len) = Stream next (Scan1 z0 s0) (len+1) -- HINT maybe too low
658+ where
659+ {-# INLINE next #-}
660+ next (Scan1 z s) = Yield z (Scan2 z s)
661+ next (Scan2 z s) = case next0 s of
662+ Yield x s' -> let !x' = f z x
663+ in Yield x' (Scan2 x' s')
664+ Skip s' -> Skip (Scan2 z s')
665+ Done -> Done
666+{-# INLINE [0] scanl #-}
667+
668+-- -----------------------------------------------------------------------------
669+-- ** Generating and unfolding streams
670+
671+replicateCharI :: Integral a => a -> Char -> Stream Char
672+replicateCharI !n !c
673+ | n < 0 = empty
674+ | otherwise = Stream next 0 (fromIntegral n) -- HINT maybe too low
675+ where
676+ next !i | i >= n = Done
677+ | otherwise = Yield c (i + 1)
678+{-# INLINE [0] replicateCharI #-}
679+
680+data RI s = RI !s {-# UNPACK #-} !Int64
681+
682+replicateI :: Int64 -> Stream Char -> Stream Char
683+replicateI n (Stream next0 s0 len) =
684+ Stream next (RI s0 0) (fromIntegral (max 0 n) * len)
685+ where
686+ next (RI s k)
687+ | k >= n = Done
688+ | otherwise = case next0 s of
689+ Done -> Skip (RI s0 (k+1))
690+ Skip s' -> Skip (RI s' k)
691+ Yield x s' -> Yield x (RI s' k)
692+{-# INLINE [0] replicateI #-}
693+
694+-- | /O(n)/, where @n@ is the length of the result. The unfoldr function
695+-- is analogous to the List 'unfoldr'. unfoldr builds a stream
696+-- from a seed value. The function takes the element and returns
697+-- Nothing if it is done producing the stream or returns Just
698+-- (a,b), in which case, a is the next Char in the string, and b is
699+-- the seed value for further production.
700+unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char
701+unfoldr f s0 = Stream next s0 1 -- HINT maybe too low
702+ where
703+ {-# INLINE next #-}
704+ next !s = case f s of
705+ Nothing -> Done
706+ Just (w, s') -> Yield w s'
707+{-# INLINE [0] unfoldr #-}
708+
709+-- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed
710+-- value. However, the length of the result is limited by the
711+-- first argument to 'unfoldrNI'. This function is more efficient than
712+-- 'unfoldr' when the length of the result is known.
713+unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char
714+unfoldrNI n f s0 | n < 0 = empty
715+ | otherwise = Stream next (0 :*: s0) (fromIntegral (n*2)) -- HINT maybe too high
716+ where
717+ {-# INLINE next #-}
718+ next (z :*: s) = case f s of
719+ Nothing -> Done
720+ Just (w, s') | z >= n -> Done
721+ | otherwise -> Yield w ((z + 1) :*: s')
722+{-# INLINE unfoldrNI #-}
723+
724+-------------------------------------------------------------------------------
725+-- * Substreams
726+
727+-- | /O(n)/ take n, applied to a stream, returns the prefix of the
728+-- stream of length @n@, or the stream itself if @n@ is greater than the
729+-- length of the stream.
730+take :: Integral a => a -> Stream Char -> Stream Char
731+take n0 (Stream next0 s0 len) =
732+ Stream next (n0 :*: s0) (smaller len (fromIntegral (max 0 n0)))
733+ where
734+ {-# INLINE next #-}
735+ next (n :*: s) | n <= 0 = Done
736+ | otherwise = case next0 s of
737+ Done -> Done
738+ Skip s' -> Skip (n :*: s')
739+ Yield x s' -> Yield x ((n-1) :*: s')
740+{-# INLINE [0] take #-}
741+
742+data Drop a s = NS !s
743+ | JS !a !s
744+
745+-- | /O(n)/ drop n, applied to a stream, returns the suffix of the
746+-- stream after the first @n@ characters, or the empty stream if @n@
747+-- is greater than the length of the stream.
748+drop :: Integral a => a -> Stream Char -> Stream Char
749+drop n0 (Stream next0 s0 len) =
750+ Stream next (JS n0 s0) (len - fromIntegral (max 0 n0))
751+ where
752+ {-# INLINE next #-}
753+ next (JS n s)
754+ | n <= 0 = Skip (NS s)
755+ | otherwise = case next0 s of
756+ Done -> Done
757+ Skip s' -> Skip (JS n s')
758+ Yield _ s' -> Skip (JS (n-1) s')
759+ next (NS s) = case next0 s of
760+ Done -> Done
761+ Skip s' -> Skip (NS s')
762+ Yield x s' -> Yield x (NS s')
763+{-# INLINE [0] drop #-}
764+
765+-- | takeWhile, applied to a predicate @p@ and a stream, returns the
766+-- longest prefix (possibly empty) of elements that satisfy p.
767+takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char
768+takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
769+ where
770+ {-# INLINE next #-}
771+ next !s = case next0 s of
772+ Done -> Done
773+ Skip s' -> Skip s'
774+ Yield x s' | p x -> Yield x s'
775+ | otherwise -> Done
776+{-# INLINE [0] takeWhile #-}
777+
778+-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
779+dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
780+dropWhile p (Stream next0 s0 len) = Stream next (L s0) len -- HINT maybe too high
781+ where
782+ {-# INLINE next #-}
783+ next (L s) = case next0 s of
784+ Done -> Done
785+ Skip s' -> Skip (L s')
786+ Yield x s' | p x -> Skip (L s')
787+ | otherwise -> Yield x (R s')
788+ next (R s) = case next0 s of
789+ Done -> Done
790+ Skip s' -> Skip (R s')
791+ Yield x s' -> Yield x (R s')
792+{-# INLINE [0] dropWhile #-}
793+
794+-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns
795+-- 'True' iff the first is a prefix of the second.
796+isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool
797+isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
798+ where
799+ loop Done _ = True
800+ loop _ Done = False
801+ loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
802+ loop (Skip s1') x2 = loop (next1 s1') x2
803+ loop x1 (Skip s2') = loop x1 (next2 s2')
804+ loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
805+ loop (next1 s1') (next2 s2')
806+{-# INLINE [0] isPrefixOf #-}
807+
808+-- ----------------------------------------------------------------------------
809+-- * Searching
810+
811+-------------------------------------------------------------------------------
812+-- ** Searching by equality
813+
814+-- | /O(n)/ elem is the stream membership predicate.
815+elem :: Char -> Stream Char -> Bool
816+elem w (Stream next s0 _len) = loop_elem s0
817+ where
818+ loop_elem !s = case next s of
819+ Done -> False
820+ Skip s' -> loop_elem s'
821+ Yield x s' | x == w -> True
822+ | otherwise -> loop_elem s'
823+{-# INLINE [0] elem #-}
824+
825+-------------------------------------------------------------------------------
826+-- ** Searching with a predicate
827+
828+-- | /O(n)/ The 'findBy' function takes a predicate and a stream,
829+-- and returns the first element in matching the predicate, or 'Nothing'
830+-- if there is no such element.
831+
832+findBy :: (Char -> Bool) -> Stream Char -> Maybe Char
833+findBy p (Stream next s0 _len) = loop_find s0
834+ where
835+ loop_find !s = case next s of
836+ Done -> Nothing
837+ Skip s' -> loop_find s'
838+ Yield x s' | p x -> Just x
839+ | otherwise -> loop_find s'
840+{-# INLINE [0] findBy #-}
841+
842+-- | /O(n)/ Stream index (subscript) operator, starting from 0.
843+indexI :: Integral a => Stream Char -> a -> Char
844+indexI (Stream next s0 _len) n0
845+ | n0 < 0 = streamError "index" "Negative index"
846+ | otherwise = loop_index n0 s0
847+ where
848+ loop_index !n !s = case next s of
849+ Done -> streamError "index" "Index too large"
850+ Skip s' -> loop_index n s'
851+ Yield x s' | n == 0 -> x
852+ | otherwise -> loop_index (n-1) s'
853+{-# INLINE [0] indexI #-}
854+
855+-- | /O(n)/ 'filter', applied to a predicate and a stream,
856+-- returns a stream containing those characters that satisfy the
857+-- predicate.
858+filter :: (Char -> Bool) -> Stream Char -> Stream Char
859+filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
860+ where
861+ next !s = case next0 s of
862+ Done -> Done
863+ Skip s' -> Skip s'
864+ Yield x s' | p x -> Yield x s'
865+ | otherwise -> Skip s'
866+{-# INLINE [0] filter #-}
867+
868+{-# RULES
869+ "STREAM filter/filter fusion" forall p q s.
870+ filter p (filter q s) = filter (\x -> q x && p x) s
871+ #-}
872+
873+-- | The 'findIndexI' function takes a predicate and a stream and
874+-- returns the index of the first element in the stream satisfying the
875+-- predicate.
876+findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a
877+findIndexI p s = case findIndicesI p s of
878+ (i:_) -> Just i
879+ _ -> Nothing
880+{-# INLINE [0] findIndexI #-}
881+
882+-- | The 'findIndicesI' function takes a predicate and a stream and
883+-- returns all indices of the elements in the stream satisfying the
884+-- predicate.
885+findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a]
886+findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0
887+ where
888+ loop_findIndex !i !s = case next s of
889+ Done -> []
890+ Skip s' -> loop_findIndex i s' -- hmm. not caught by QC
891+ Yield x s' | p x -> i : loop_findIndex (i+1) s'
892+ | otherwise -> loop_findIndex (i+1) s'
893+{-# INLINE [0] findIndicesI #-}
894+
895+-------------------------------------------------------------------------------
896+-- * Zipping
897+
898+-- | Strict triple.
899+data Zip a b m = Z1 !a !b
900+ | Z2 !a !b !m
901+
902+-- | zipWith generalises 'zip' by zipping with the function given as
903+-- the first argument, instead of a tupling function.
904+zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b
905+zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) =
906+ Stream next (Z1 sa0 sb0) (smaller len1 len2)
907+ where
908+ next (Z1 sa sb) = case next0 sa of
909+ Done -> Done
910+ Skip sa' -> Skip (Z1 sa' sb)
911+ Yield a sa' -> Skip (Z2 sa' sb a)
912+
913+ next (Z2 sa' sb a) = case next1 sb of
914+ Done -> Done
915+ Skip sb' -> Skip (Z2 sa' sb' a)
916+ Yield b sb' -> Yield (f a b) (Z1 sa' sb')
917+{-# INLINE [0] zipWith #-}
918+
919+-- | /O(n)/ The 'countCharI' function returns the number of times the
920+-- query element appears in the given stream.
921+countCharI :: Integral a => Char -> Stream Char -> a
922+countCharI a (Stream next s0 _len) = loop 0 s0
923+ where
924+ loop !i !s = case next s of
925+ Done -> i
926+ Skip s' -> loop i s'
927+ Yield x s' | a == x -> loop (i+1) s'
928+ | otherwise -> loop i s'
929+{-# INLINE [0] countCharI #-}
930+
931+streamError :: String -> String -> a
932+streamError func msg = P.error $ "Data.Text.Internal.Fusion.Common." ++ func ++ ": " ++ msg
933+
934+emptyError :: String -> a
935+emptyError func = internalError func "Empty input"
936+
937+internalError :: String -> a
938+internalError func = streamError func "Internal error"
Data/Text/Internal/Fusion/Types.hs+99−102
@@ -19,107 +19,104 @@
1919
2020module Data.Text.Internal.Fusion.Types
2121 (
22− -- CC(..)
23− -- , PairS(..)
24− -- , Scan(..)
25− -- , RS(..)
26− -- , Step(..)
27− -- , Stream(..)
28− -- , empty
29− module Data.JSString.Internal.Fusion.Types
22+ CC(..)
23+ , PairS(..)
24+ , Scan(..)
25+ , RS(..)
26+ , Step(..)
27+ , Stream(..)
28+ , empty
3029 ) where
3130
32−-- import Data.Text.Internal.Fusion.Size
33−-- import Data.Word (Word8)
34−
35−import Data.JSString.Internal.Fusion.Types
36−
37−-- -- | Specialised tuple for case conversion.
38−-- data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
39−
40−-- -- | Restreaming state.
41−-- data RS s
42−-- = RS0 !s
43−-- | RS1 !s {-# UNPACK #-} !Word8
44−-- | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
45−-- | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
46−
47−-- -- | Strict pair.
48−-- data PairS a b = !a :*: !b
49−-- -- deriving (Eq, Ord, Show)
50−-- infixl 2 :*:
51−
52−-- -- | An intermediate result in a scan.
53−-- data Scan s = Scan1 {-# UNPACK #-} !Char !s
54−-- | Scan2 {-# UNPACK #-} !Char !s
55−
56−-- -- | Intermediate result in a processing pipeline.
57−-- data Step s a = Done
58−-- | Skip !s
59−-- | Yield !a !s
60−
61−-- {-
62−-- instance (Show a) => Show (Step s a)
63−-- where show Done = "Done"
64−-- show (Skip _) = "Skip"
65−-- show (Yield x _) = "Yield " ++ show x
66−-- -}
67−
68−-- instance (Eq a) => Eq (Stream a) where
69−-- (==) = eq
70−
71−-- instance (Ord a) => Ord (Stream a) where
72−-- compare = cmp
73−
74−-- -- The length hint in a Stream has two roles. If its value is zero,
75−-- -- we trust it, and treat the stream as empty. Otherwise, we treat it
76−-- -- as a hint: it should usually be accurate, so we use it when
77−-- -- unstreaming to decide what size array to allocate. However, the
78−-- -- unstreaming functions must be able to cope with the hint being too
79−-- -- small or too large.
80−-- --
81−-- -- The size hint tries to track the UTF-16 code points in a stream,
82−-- -- but often counts the number of characters instead. It can easily
83−-- -- undercount if, for instance, a transformed stream contains astral
84−-- -- plane characters (those above 0x10000).
85−
86−-- data Stream a =
87−-- forall s. Stream
88−-- (s -> Step s a) -- stepper function
89−-- !s -- current state
90−-- !Size -- size hint
91−
92−-- -- | /O(n)/ Determines if two streams are equal.
93−-- eq :: (Eq a) => Stream a -> Stream a -> Bool
94−-- eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
95−-- where
96−-- loop Done Done = True
97−-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
98−-- loop (Skip s1') x2 = loop (next1 s1') x2
99−-- loop x1 (Skip s2') = loop x1 (next2 s2')
100−-- loop Done _ = False
101−-- loop _ Done = False
102−-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
103−-- loop (next1 s1') (next2 s2')
104−-- {-# INLINE [0] eq #-}
105−
106−-- cmp :: (Ord a) => Stream a -> Stream a -> Ordering
107−-- cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
108−-- where
109−-- loop Done Done = EQ
110−-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
111−-- loop (Skip s1') x2 = loop (next1 s1') x2
112−-- loop x1 (Skip s2') = loop x1 (next2 s2')
113−-- loop Done _ = LT
114−-- loop _ Done = GT
115−-- loop (Yield x1 s1') (Yield x2 s2') =
116−-- case compare x1 x2 of
117−-- EQ -> loop (next1 s1') (next2 s2')
118−-- other -> other
119−-- {-# INLINE [0] cmp #-}
120−
121−-- -- | The empty stream.
122−-- empty :: Stream a
123−-- empty = Stream next () 0
124−-- where next _ = Done
125−-- {-# INLINE [0] empty #-}
31+import Data.Text.Internal.Fusion.Size
32+import Data.Word (Word8)
33+
34+-- | Specialised tuple for case conversion.
35+data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
36+
37+-- | Restreaming state.
38+data RS s
39+ = RS0 !s
40+ | RS1 !s {-# UNPACK #-} !Word8
41+ | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
42+ | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
43+
44+-- | Strict pair.
45+data PairS a b = !a :*: !b
46+ -- deriving (Eq, Ord, Show)
47+infixl 2 :*:
48+
49+-- | An intermediate result in a scan.
50+data Scan s = Scan1 {-# UNPACK #-} !Char !s
51+ | Scan2 {-# UNPACK #-} !Char !s
52+
53+-- | Intermediate result in a processing pipeline.
54+data Step s a = Done
55+ | Skip !s
56+ | Yield !a !s
57+
58+{-
59+instance (Show a) => Show (Step s a)
60+ where show Done = "Done"
61+ show (Skip _) = "Skip"
62+ show (Yield x _) = "Yield " ++ show x
63+-}
64+
65+instance (Eq a) => Eq (Stream a) where
66+ (==) = eq
67+
68+instance (Ord a) => Ord (Stream a) where
69+ compare = cmp
70+
71+-- The length hint in a Stream has two roles. If its value is zero,
72+-- we trust it, and treat the stream as empty. Otherwise, we treat it
73+-- as a hint: it should usually be accurate, so we use it when
74+-- unstreaming to decide what size array to allocate. However, the
75+-- unstreaming functions must be able to cope with the hint being too
76+-- small or too large.
77+--
78+-- The size hint tries to track the UTF-16 code points in a stream,
79+-- but often counts the number of characters instead. It can easily
80+-- undercount if, for instance, a transformed stream contains astral
81+-- plane characters (those above 0x10000).
82+
83+data Stream a =
84+ forall s. Stream
85+ (s -> Step s a) -- stepper function
86+ !s -- current state
87+ !Size -- size hint
88+
89+-- | /O(n)/ Determines if two streams are equal.
90+eq :: (Eq a) => Stream a -> Stream a -> Bool
91+eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
92+ where
93+ loop Done Done = True
94+ loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
95+ loop (Skip s1') x2 = loop (next1 s1') x2
96+ loop x1 (Skip s2') = loop x1 (next2 s2')
97+ loop Done _ = False
98+ loop _ Done = False
99+ loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
100+ loop (next1 s1') (next2 s2')
101+{-# INLINE [0] eq #-}
102+
103+cmp :: (Ord a) => Stream a -> Stream a -> Ordering
104+cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
105+ where
106+ loop Done Done = EQ
107+ loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
108+ loop (Skip s1') x2 = loop (next1 s1') x2
109+ loop x1 (Skip s2') = loop x1 (next2 s2')
110+ loop Done _ = LT
111+ loop _ Done = GT
112+ loop (Yield x1 s1') (Yield x2 s2') =
113+ case compare x1 x2 of
114+ EQ -> loop (next1 s1') (next2 s2')
115+ other -> other
116+{-# INLINE [0] cmp #-}
117+
118+-- | The empty stream.
119+empty :: Stream a
120+empty = Stream next () 0
121+ where next _ = Done
122+{-# INLINE [0] empty #-}
Data/Text/Internal/IO.hs−8
@@ -95,11 +95,7 @@ unpack !buf !r !w
9595 | r >= w = return T.empty
9696 | otherwise = withRawBuffer buf go
9797 where
98−#ifndef __GHCJS__
9998 go pbuf = return $! unstream (Stream next r (exactSize (w-r)))
100−#else
101− go pbuf = return $! unstream (Stream next r)
102−#endif
10399 where
104100 next !i | i >= w = Done
105101 | otherwise = Yield (ix i) (i+1)
@@ -112,11 +108,7 @@ unpack_nl !buf !r !w
112108 | otherwise = withRawBuffer buf $ go
113109 where
114110 go pbuf = do
115−#ifndef __GHCJS__
116111 let !t = unstream (Stream next r (maxSize (w-r)))
117−#else
118− let !t = unstream (Stream next r)
119−#endif
120112 w' = w - 1
121113 return $ if ix w' == '\r'
122114 then (t,w')
Data/Text/Internal/Lazy.hs+10−18
@@ -44,10 +44,6 @@ import Data.Typeable (Typeable)
4444import Foreign.Storable (sizeOf)
4545import qualified Data.Text.Internal as T
4646
47−-- GHCJS
48−import qualified Data.Text as TT
49−--
50−
5147data Text = Empty
5248 | Chunk {-# UNPACK #-} !T.Text Text
5349 deriving (Typeable)
@@ -61,20 +57,18 @@ data Text = Empty
6157-- | Check the invariant strictly.
6258strictInvariant :: Text -> Bool
6359strictInvariant Empty = True
64−-- TODO only used for QuickCheck ?
65−-- strictInvariant x@(Chunk (T.Text _ _ len) cs)
66−-- | len > 0 = strictInvariant cs
67−-- | otherwise = error $ "Data.Text.Lazy: invariant violation: "
68−-- ++ showStructure x
60+strictInvariant x@(Chunk (T.Text _ _ len) cs)
61+ | len > 0 = strictInvariant cs
62+ | otherwise = error $ "Data.Text.Lazy: invariant violation: "
63+ ++ showStructure x
6964
7065-- | Check the invariant lazily.
7166lazyInvariant :: Text -> Text
7267lazyInvariant Empty = Empty
73−-- TODO only used for quickcheck
74−-- lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)
75−-- | len > 0 = Chunk c (lazyInvariant cs)
76−-- | otherwise = error $ "Data.Text.Lazy: invariant violation: "
77−-- ++ showStructure x
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
7872
7973-- | Display the internal structure of a lazy 'Text'.
8074showStructure :: Text -> String
@@ -86,10 +80,8 @@ showStructure (Chunk t ts) =
8680-- | Smart constructor for 'Chunk'. Guarantees the data type invariant.
8781chunk :: T.Text -> Text -> Text
8882{-# INLINE chunk #-}
89−chunk t ts | TT.length t == 0 = ts
90− | otherwise = Chunk t ts
91−-- chunk t@(T.Text _ _ len) ts | len == 0 = ts
92−-- | otherwise = Chunk t ts
83+chunk t@(T.Text _ _ len) ts | len == 0 = ts
84+ | otherwise = Chunk t ts
9385
9486-- | Smart constructor for 'Empty'.
9587empty :: Text
Data/Text/Internal/Lazy/Encoding/Fusion.hs−26
@@ -38,9 +38,7 @@ import qualified Data.ByteString.Unsafe as B
3838import Data.Text.Internal.Encoding.Fusion.Common
3939import Data.Text.Encoding.Error
4040import Data.Text.Internal.Fusion (Step(..), Stream(..))
41−#ifndef __GHCJS__
4241import Data.Text.Internal.Fusion.Size
43−#endif
4442import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
4543import Data.Text.Internal.Unsafe.Shift (shiftL)
4644import Data.Word (Word8, Word16, Word32)
@@ -67,11 +65,7 @@ data T = T !ByteString !S {-# UNPACK #-} !Int
6765-- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using
6866-- UTF-8 encoding.
6967streamUtf8 :: OnDecodeError -> ByteString -> Stream Char
70−#ifndef __GHCJS__
7168streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize
72−#else
73−streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
74−#endif
7569 where
7670 next (T bs@(Chunk ps _) S0 i)
7771 | i < len && U8.validate1 a =
@@ -113,11 +107,7 @@ streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
113107-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
114108-- endian UTF-16 encoding.
115109streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char
116−#ifndef __GHCJS__
117110streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
118−#else
119−streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
120−#endif
121111 where
122112 next (T bs@(Chunk ps _) S0 i)
123113 | i + 1 < len && U16.validate1 x1 =
@@ -157,11 +147,7 @@ streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
157147-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
158148-- endian UTF-16 encoding.
159149streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char
160−#ifndef __GHCJS__
161150streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
162−#else
163−streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
164−#endif
165151 where
166152 next (T bs@(Chunk ps _) S0 i)
167153 | i + 1 < len && U16.validate1 x1 =
@@ -201,11 +187,7 @@ streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
201187-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
202188-- endian UTF-32 encoding.
203189streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char
204−#ifndef __GHCJS__
205190streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
206−#else
207−streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
208−#endif
209191 where
210192 next (T bs@(Chunk ps _) S0 i)
211193 | i + 3 < len && U32.validate x =
@@ -249,11 +231,7 @@ streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
249231-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
250232-- endian UTF-32 encoding.
251233streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char
252−#ifndef __GHCJS__
253234streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
254−#else
255−streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
256−#endif
257235 where
258236 next (T bs@(Chunk ps _) S0 i)
259237 | i + 3 < len && U32.validate x =
@@ -296,11 +274,7 @@ streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
296274
297275-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.
298276unstreamChunks :: Int -> Stream Word8 -> ByteString
299−#ifndef __GHCJS__
300277unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
301−#else
302−unstreamChunks chunkSize (Stream next s0) = chunk s0 4
303−#endif
304278 where chunk s1 len1 = unsafeDupablePerformIO $ do
305279 let len = max 4 (min len1 chunkSize)
306280 mallocByteString len >>= loop len 0 s1
Data/Text/Internal/Lazy/Fusion.hs−62
@@ -1,10 +1,4 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE CPP #-}
3−#ifdef __GHCJS__
4−{-# LANGUAGE ForeignFunctionInterface #-}
5−{-# LANGUAGE MagicHash #-}
6−{-# LANGUAGE UnliftedFFITypes #-}
7−#endif
82-- |
93-- Module : Data.Text.Lazy.Fusion
104-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
@@ -35,14 +29,7 @@ import Prelude hiding (length)
3529import qualified Data.Text.Internal.Fusion.Common as S
3630import Control.Monad.ST (runST)
3731import Data.Text.Internal.Fusion.Types
38−#ifndef __GHCJS__
3932import Data.Text.Internal.Fusion.Size (isEmpty, unknownSize)
40−#else
41−import Data.JSString (JSString)
42−import qualified Data.JSString as JSS
43−import GHC.Base (Int(..))
44−import GHC.Exts (ByteArray#, Int#)
45−#endif
4633import Data.Text.Internal.Lazy
4734import qualified Data.Text.Internal as I
4835import qualified Data.Text.Array as A
@@ -55,7 +42,6 @@ default(Int64)
5542
5643-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
5744stream :: Text -> Stream Char
58−#ifndef __GHCJS__
5945stream text = Stream next (text :*: 0) unknownSize
6046 where
6147 next (Empty :*: _) = Done
@@ -63,22 +49,11 @@ stream text = Stream next (text :*: 0) unknownSize
6349 | i >= len = next (ts :*: 0)
6450 | otherwise = Yield c (txt :*: i+d)
6551 where Iter c d = iter t i
66−#else
67−stream text = Stream next (text :*: 0) -- unknownSize
68− where
69− next (Empty :*: _) = Done
70− next (txt@(Chunk t@(I.Text jst) ts) :*: i)
71− | i >= JSS.length jst = next (ts :*: 0)
72− | otherwise = Yield c (txt :*: i+d)
73− where Iter c d = iter t i
74−#endif
7552{-# INLINE [0] stream #-}
7653
77−-- TODO
7854-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given
7955-- chunk size.
8056unstreamChunks :: Int -> Stream Char -> Text
81−#ifndef __GHCJS__
8257unstreamChunks !chunkSize (Stream next s0 len0)
8358 | isEmpty len0 = Empty
8459 | otherwise = outer s0
@@ -109,36 +84,6 @@ unstreamChunks !chunkSize (Stream next s0 len0)
10984 finish marr len s' = do
11085 arr <- A.unsafeFreeze marr
11186 return (I.Text arr 0 len `Chunk` outer s')
112−#else
113−unstreamChunks !chunkSize (Stream next s0) = outer s0
114− where
115− outer so = {-# SCC "unstreamChunks/outer" #-}
116− case next so of
117− Done -> Empty
118− Skip s' -> outer s'
119− Yield x s' -> runST $ do
120− a <- A.new unknownLength
121− unsafeWrite a 0 x >>= inner a unknownLength s'
122− where unknownLength = 4
123− where
124− inner marr !len s !i
125− | i + 1 >= chunkSize = finish marr i s
126− | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
127− let newLen = min (len `shiftL` 1) chunkSize
128− marr' <- A.new newLen
129− A.copyM marr' 0 marr 0 len
130− inner marr' newLen s i
131− | otherwise =
132− {-# SCC "unstreamChunks/inner" #-}
133− case next s of
134− Done -> finish marr i s
135− Skip s' -> inner marr len s' i
136− Yield x s' -> do d <- unsafeWrite marr i x
137− inner marr len s' (i+d)
138− finish marr (I# len#) s' = do
139− arr <- A.unsafeFreeze marr
140− return (I.Text (js_toString (A.aBA arr) 0# len#) `Chunk` outer s')
141−#endif
14287{-# INLINE [0] unstreamChunks #-}
14388
14489-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using
@@ -173,10 +118,3 @@ index = S.indexI
173118countChar :: Char -> Stream Char -> Int64
174119countChar = S.countCharI
175120{-# INLINE [0] countChar #-}
176−
177−#ifdef __GHCJS__
178−foreign import javascript unsafe
179− "h$textToString"
180− js_toString :: ByteArray# -> Int# -> Int# -> JSString
181−#endif
182−
Data/Text/Internal/Lazy/Search.hs+11−55
@@ -1,7 +1,4 @@
11{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2−{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI,
3− UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim,
4− MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-}
52
63-- |
74-- Module : Data.Text.Lazy.Search
@@ -34,17 +31,6 @@ import Data.Text.Internal.Lazy (Text(..), foldlChunks)
3431import Data.Bits ((.|.), (.&.))
3532import Data.Text.Internal.Unsafe.Shift (shiftL)
3633
37−import Data.JSString (JSString)
38−import qualified Data.Text as TT
39−import GHC.Exts (Int(..), Int#, ByteArray#)
40−
41−foreign import javascript unsafe
42− "h$textFromString"
43− js_fromString :: JSString -> (# ByteArray#, Int# #)
44−
45−fromString :: T.Text -> (# ByteArray#, Int# #)
46−fromString (T.Text txt) = js_fromString txt
47−
4834-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
4935-- @needle@ within @haystack@.
5036--
@@ -61,10 +47,8 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
6147 | nlen == 1 = indicesOne (nindex 0) 0 k ks
6248 | otherwise = advance k ks 0 0
6349 where
64− -- advance x@(T.Text _ _ l) xs = scan
65− advance x xs = scan
50+ advance x@(T.Text _ _ l) xs = scan
6651 where
67− l = TT.length x
6852 scan !g !i
6953 | i >= m = case xs of
7054 Empty -> []
@@ -88,23 +72,11 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
8872 nlast = nlen - 1
8973 nindex = index n ns
9074 z = foldlChunks fin 0 needle
91− where
92− -- fin _ (T.Text farr foff flen) =
93− fin _ t =
94− let foff = 0
95− (farr, flen) =
96− let (# ba, len #) = fromString t
97− in (A.Array ba, I# len)
98− in A.unsafeIndex farr (foff+flen-1)
75+ where fin _ (T.Text farr foff flen) = A.unsafeIndex farr (foff+flen-1)
9976 (mask :: Word64) :*: skip = buildTable n ns 0 0 0 (nlen-2)
10077 swizzle w = 1 `shiftL` (fromIntegral w .&. 0x3f)
101− -- buildTable (T.Text xarr xoff xlen) xs = go
102− buildTable t xs = go
78+ buildTable (T.Text xarr xoff xlen) xs = go
10379 where
104− xoff = 0
105− (xarr, xlen) =
106− let (# ba, len #) = fromString t
107− in (A.Array ba, I# len)
10880 go !(g::Int64) !i !msk !skp
10981 | i >= xlast = case xs of
11082 Empty -> (msk .|. swizzle z) :*: skp
@@ -119,22 +91,17 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
11991 -- given offset would fail.
12092 lackingHay q = go 0
12193 where
122− -- go p (T.Text _ _ l) ps = p' < q && case ps of
123− go p t ps = p' < q && case ps of
124− Empty -> True
125− Chunk r rs -> go p' r rs
126− where
127− l = TT.length t
128− p' = p + fromIntegral l
129−
94+ go p (T.Text _ _ l) ps = p' < q && case ps of
95+ Empty -> True
96+ Chunk r rs -> go p' r rs
97+ where p' = p + fromIntegral l
13098indices _ _ = []
13199
132100-- | Fast index into a partly unpacked 'Text'. We take into account
133101-- the possibility that the caller might try to access one element
134102-- past the end.
135103index :: T.Text -> Text -> Int64 -> Word16
136−-- index (T.Text arr off len) xs !i
137−index t xs !i
104+index (T.Text arr off len) xs !i
138105 | j < len = A.unsafeIndex arr (off+j)
139106 | otherwise = case xs of
140107 Empty
@@ -143,24 +110,14 @@ index t xs !i
143110 -- should never happen, due to lackingHay above
144111 | otherwise -> emptyError "index"
145112 Chunk c cs -> index c cs (i-fromIntegral len)
146− where
147− j = fromIntegral i
148− off = 0
149− (arr, len) =
150− let (# ba, len' #) = fromString t
151− in (A.Array ba, I# len')
113+ where j = fromIntegral i
152114
153115-- | A variant of 'indices' that scans linearly for a single 'Word16'.
154116indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64]
155117indicesOne c = chunk
156118 where
157− -- chunk !i (T.Text oarr ooff olen) os = go 0
158− chunk !i t os = go 0
119+ chunk !i (T.Text oarr ooff olen) os = go 0
159120 where
160− ooff = 0
161− (oarr, olen) =
162− let (# ba, len #) = fromString t
163− in (A.Array ba, I# len)
164121 go h | h >= olen = case os of
165122 Empty -> []
166123 Chunk y ys -> chunk (i+fromIntegral olen) y ys
@@ -171,8 +128,7 @@ indicesOne c = chunk
171128-- | The number of 'Word16' values in a 'Text'.
172129wordLength :: Text -> Int64
173130wordLength = foldlChunks sumLength 0
174− where sumLength i t = i + fromIntegral (TT.length t)
175− -- where sumLength i (T.Text _ _ l) = i + fromIntegral l
131+ where sumLength i (T.Text _ _ l) = i + fromIntegral l
176132
177133emptyError :: String -> a
178134emptyError fun = error ("Data.Text.Lazy.Search." ++ fun ++ ": empty input")
Data/Text/Internal/Private.hs+1−8
@@ -1,4 +1,4 @@
1−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, CPP #-}
1+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
22
33-- |
44-- Module : Data.Text.Internal.Private
@@ -19,12 +19,8 @@ import Control.Monad.ST (ST, runST)
1919import Data.Text.Internal (Text(..), text)
2020import Data.Text.Unsafe (Iter(..), iter)
2121import qualified Data.Text.Array as A
22−#ifdef __GHCJS__
23−import qualified Data.JSString as JSS
24−#endif
2522
2623span_ :: (Char -> Bool) -> Text -> (# Text, Text #)
27−#ifndef __GHCJS__
2824span_ p t@(Text arr off len) = (# hd,tl #)
2925 where hd = text arr off k
3026 tl = text arr (off+k) (len-k)
@@ -32,9 +28,6 @@ span_ p t@(Text arr off len) = (# hd,tl #)
3228 loop !i | i < len && p c = loop (i+d)
3329 | otherwise = i
3430 where Iter c d = iter t i
35−#else
36−span_ p (Text t) = let (# a, b #) = JSS.span_ p t in (# Text a, Text b #)
37−#endif
3831{-# INLINE span_ #-}
3932
4033runText :: (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text
Data/Text/Internal/Search.hs+37−40
@@ -37,8 +37,6 @@ import Data.Text.Internal (Text(..))
3737import Data.Bits ((.|.), (.&.))
3838import Data.Text.Internal.Unsafe.Shift (shiftL)
3939
40−import qualified Data.JSString.Internal.Search as JSS
41−
4240data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
4341
4442-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
@@ -51,42 +49,41 @@ data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
5149indices :: Text -- ^ Substring to search for (@needle@)
5250 -> Text -- ^ Text to search in (@haystack@)
5351 -> [Int]
54−indices = coerce JSS.indices
55−-- indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
56−-- | nlen == 1 = scanOne (nindex 0)
57−-- | nlen <= 0 || ldiff < 0 = []
58−-- | otherwise = scan 0
59−-- where
60−-- ldiff = hlen - nlen
61−-- nlast = nlen - 1
62−-- z = nindex nlast
63−-- nindex k = A.unsafeIndex narr (noff+k)
64−-- hindex k = A.unsafeIndex harr (hoff+k)
65−-- hindex' k | k == hlen = 0
66−-- | otherwise = A.unsafeIndex harr (hoff+k)
67−-- buildTable !i !msk !skp
68−-- | i >= nlast = (msk .|. swizzle z) :* skp
69−-- | otherwise = buildTable (i+1) (msk .|. swizzle c) skp'
70−-- where c = nindex i
71−-- skp' | c == z = nlen - i - 2
72−-- | otherwise = skp
73−-- swizzle k = 1 `shiftL` (fromIntegral k .&. 0x3f)
74−-- scan !i
75−-- | i > ldiff = []
76−-- | c == z && candidateMatch 0 = i : scan (i + nlen)
77−-- | otherwise = scan (i + delta)
78−-- where c = hindex (i + nlast)
79−-- candidateMatch !j
80−-- | j >= nlast = True
81−-- | hindex (i+j) /= nindex j = False
82−-- | otherwise = candidateMatch (j+1)
83−-- delta | nextInPattern = nlen + 1
84−-- | c == z = skip + 1
85−-- | otherwise = 1
86−-- where nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0
87−-- !(mask :* skip) = buildTable 0 0 (nlen-2)
88−-- scanOne c = loop 0
89−-- where loop !i | i >= hlen = []
90−-- | hindex i == c = i : loop (i+1)
91−-- | otherwise = loop (i+1)
52+indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
53+ | nlen == 1 = scanOne (nindex 0)
54+ | nlen <= 0 || ldiff < 0 = []
55+ | otherwise = scan 0
56+ where
57+ ldiff = hlen - nlen
58+ nlast = nlen - 1
59+ z = nindex nlast
60+ nindex k = A.unsafeIndex narr (noff+k)
61+ hindex k = A.unsafeIndex harr (hoff+k)
62+ hindex' k | k == hlen = 0
63+ | otherwise = A.unsafeIndex harr (hoff+k)
64+ buildTable !i !msk !skp
65+ | i >= nlast = (msk .|. swizzle z) :* skp
66+ | otherwise = buildTable (i+1) (msk .|. swizzle c) skp'
67+ where c = nindex i
68+ skp' | c == z = nlen - i - 2
69+ | otherwise = skp
70+ swizzle k = 1 `shiftL` (fromIntegral k .&. 0x3f)
71+ scan !i
72+ | i > ldiff = []
73+ | c == z && candidateMatch 0 = i : scan (i + nlen)
74+ | otherwise = scan (i + delta)
75+ where c = hindex (i + nlast)
76+ candidateMatch !j
77+ | j >= nlast = True
78+ | hindex (i+j) /= nindex j = False
79+ | otherwise = candidateMatch (j+1)
80+ delta | nextInPattern = nlen + 1
81+ | c == z = skip + 1
82+ | otherwise = 1
83+ where nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0
84+ !(mask :* skip) = buildTable 0 0 (nlen-2)
85+ scanOne c = loop 0
86+ where loop !i | i >= hlen = []
87+ | hindex i == c = i : loop (i+1)
88+ | otherwise = loop (i+1)
9289{-# INLINE indices #-}
Data/Text/Lazy.hs+52−58
@@ -301,16 +301,15 @@ equal :: Text -> Text -> Bool
301301equal Empty Empty = True
302302equal Empty _ = False
303303equal _ Empty = False
304−equal _ _ = error "Data.Text.Lazy.equal: not implemented."
305−-- equal (Chunk a as) (Chunk b bs) =
306−-- case compare lenA lenB of
307−-- LT -> a == (T.takeWord16 lenA b) &&
308−-- as `equal` Chunk (T.dropWord16 lenA b) bs
309−-- EQ -> a == b && as `equal` bs
310−-- GT -> T.takeWord16 lenB a == b &&
311−-- Chunk (T.dropWord16 lenB a) as `equal` bs
312−-- where lenA = T.lengthWord16 a
313−-- lenB = T.lengthWord16 b
304+equal (Chunk a as) (Chunk b bs) =
305+ case compare lenA lenB of
306+ LT -> a == (T.takeWord16 lenA b) &&
307+ as `equal` Chunk (T.dropWord16 lenA b) bs
308+ EQ -> a == b && as `equal` bs
309+ GT -> T.takeWord16 lenB a == b &&
310+ Chunk (T.dropWord16 lenB a) as `equal` bs
311+ where lenA = T.lengthWord16 a
312+ lenB = T.lengthWord16 b
314313
315314instance Eq Text where
316315 (==) = equal
@@ -323,19 +322,18 @@ compareText :: Text -> Text -> Ordering
323322compareText Empty Empty = EQ
324323compareText Empty _ = LT
325324compareText _ Empty = GT
326−compareText (Chunk a0 as) (Chunk b0 bs) = error "Data.Text.Lazy.compareText: not implemented."
327−-- compareText (Chunk a0 as) (Chunk b0 bs) = outer a0 b0
328−-- where
329−-- outer ta@(T.Text arrA offA lenA) tb@(T.Text arrB offB lenB) = go 0 0
330−-- where
331−-- go !i !j
332−-- | i >= lenA = compareText as (chunk (T.Text arrB (offB+j) (lenB-j)) bs)
333−-- | j >= lenB = compareText (chunk (T.Text arrA (offA+i) (lenA-i)) as) bs
334−-- | a < b = LT
335−-- | a > b = GT
336−-- | otherwise = go (i+di) (j+dj)
337−-- where T.Iter a di = T.iter ta i
338−-- T.Iter b dj = T.iter tb j
325+compareText (Chunk a0 as) (Chunk b0 bs) = outer a0 b0
326+ where
327+ outer ta@(T.Text arrA offA lenA) tb@(T.Text arrB offB lenB) = go 0 0
328+ where
329+ go !i !j
330+ | i >= lenA = compareText as (chunk (T.Text arrB (offB+j) (lenB-j)) bs)
331+ | j >= lenB = compareText (chunk (T.Text arrA (offA+i) (lenA-i)) as) bs
332+ | a < b = LT
333+ | a > b = GT
334+ | otherwise = go (i+di) (j+dj)
335+ where T.Iter a di = T.iter ta i
336+ T.Iter b dj = T.iter tb j
339337
340338instance Show Text where
341339 showsPrec p ps r = showsPrec p (unpack ps) r
@@ -547,7 +545,7 @@ tail Empty = emptyError "tail"
547545 unstream (S.tail (stream t)) = tail t
548546 #-}
549547
550−-- | /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
551549-- be non-empty. Subject to fusion.
552550init :: Text -> Text
553551init (Chunk t0 ts0) = go t0 ts0
@@ -583,7 +581,7 @@ isSingleton :: Text -> Bool
583581isSingleton = S.isSingleton . stream
584582{-# INLINE isSingleton #-}
585583
586−-- | /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
587585-- non-empty. Subject to fusion.
588586last :: Text -> Char
589587last Empty = emptyError "last"
@@ -1116,17 +1114,16 @@ dropEnd n t0
11161114-- values dropped, or the empty 'Text' if @n@ is greater than the
11171115-- number of 'Word16' values present.
11181116dropWords :: Int64 -> Text -> Text
1119−dropWords = P.undefined
1120−-- dropWords i t0
1121−-- | i <= 0 = t0
1122−-- | otherwise = drop' i t0
1123−-- where drop' 0 ts = ts
1124−-- drop' _ Empty = Empty
1125−-- drop' n (Chunk (T.Text arr off len) ts)
1126−-- | n < len' = chunk (text arr (off+n') (len-n')) ts
1127−-- | otherwise = drop' (n - len') ts
1128−-- where len' = fromIntegral len
1129−-- n' = fromIntegral n
1117+dropWords i t0
1118+ | i <= 0 = t0
1119+ | otherwise = drop' i t0
1120+ where drop' 0 ts = ts
1121+ drop' _ Empty = Empty
1122+ drop' n (Chunk (T.Text arr off len) ts)
1123+ | n < len' = chunk (text arr (off+n') (len-n')) ts
1124+ | otherwise = drop' (n - len') ts
1125+ where len' = fromIntegral len
1126+ n' = fromIntegral n
11301127
11311128-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
11321129-- returns the longest prefix (possibly empty) of elements that
@@ -1247,13 +1244,12 @@ splitAt = loop
12471244-- values, and whose second is the remainder of the string.
12481245splitAtWord :: Int64 -> Text -> PairS Text Text
12491246splitAtWord _ Empty = empty :*: empty
1250−splitAtWord _ _ = P.undefined
1251−-- splitAtWord x (Chunk c@(T.Text arr off len) cs)
1252−-- | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
1253−-- in Chunk c h :*: t
1254−-- | otherwise = chunk (text arr off y) empty :*:
1255−-- chunk (text arr (off+y) (len-y)) cs
1256−-- where y = fromIntegral x
1247+splitAtWord x (Chunk c@(T.Text arr off len) cs)
1248+ | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
1249+ in Chunk c h :*: t
1250+ | otherwise = chunk (text arr off y) empty :*:
1251+ chunk (text arr (off+y) (len-y)) cs
1252+ where y = fromIntegral x
12571253
12581254-- | /O(n+m)/ Find the first instance of @needle@ (which must be
12591255-- non-'null') in @haystack@. The first element of the returned tuple
@@ -1425,16 +1421,15 @@ splitOn :: Text
14251421 -> Text
14261422 -- ^ Input text.
14271423 -> [Text]
1428−splitOn = P.undefined
1429−-- splitOn pat src
1430−-- | null pat = emptyError "splitOn"
1431−-- | isSingleton pat = split (== head pat) src
1432−-- | otherwise = go 0 (indices pat src) src
1433−-- where
1434−-- go _ [] cs = [cs]
1435−-- go !i (x:xs) cs = let h :*: t = splitAtWord (x-i) cs
1436−-- in h : go (x+l) xs (dropWords l t)
1437−-- l = foldlChunks (\a (T.Text _ _ b) -> a + fromIntegral b) 0 pat
1424+splitOn pat src
1425+ | null pat = emptyError "splitOn"
1426+ | isSingleton pat = split (== head pat) src
1427+ | otherwise = go 0 (indices pat src) src
1428+ where
1429+ go _ [] cs = [cs]
1430+ go !i (x:xs) cs = let h :*: t = splitAtWord (x-i) cs
1431+ in h : go (x+l) xs (dropWords l t)
1432+ l = foldlChunks (\a (T.Text _ _ b) -> a + fromIntegral b) 0 pat
14381433{-# INLINE [1] splitOn #-}
14391434
14401435{-# RULES
@@ -1536,11 +1531,10 @@ isSuffixOf x y = reverse x `isPrefixOf` reverse y
15361531-- In (unlikely) bad cases, this function's time complexity degrades
15371532-- towards /O(n*m)/.
15381533isInfixOf :: Text -> Text -> Bool
1539−isInfixOf _ _ = True
1540−-- isInfixOf needle haystack
1541−-- | null needle = True
1542−-- | isSingleton needle = S.elem (head needle) . S.stream $ haystack
1543−-- | otherwise = not . L.null . indices needle $ haystack
1534+isInfixOf needle haystack
1535+ | null needle = True
1536+ | isSingleton needle = S.elem (head needle) . S.stream $ haystack
1537+ | otherwise = not . L.null . indices needle $ haystack
15441538{-# INLINE [1] isInfixOf #-}
15451539
15461540{-# RULES
Data/Text/Lazy/Builder/Int.hs+259−9
@@ -1,12 +1,262 @@
1−module Data.Text.Lazy.Builder.Int where
1+{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, ScopedTypeVariables,
2+ UnboxedTuples #-}
3+#if __GLASGOW_HASKELL__ >= 702
4+{-# LANGUAGE Trustworthy #-}
5+#endif
26
3−import Data.Text.Lazy (Text)
4−import qualified Data.Text.Lazy as L
5−import qualified Data.Text as T
6−import qualified Data.JSString.Int as JSS
7−import Data.Text.Lazy.Builder
8−import Data.Monoid
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
951
1052decimal :: Integral a => a -> Builder
11−-- decimal n = L.fromChunks [T.Text $ JSS.decimal n]
12−decimal _ = mempty
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.hs+233−2
@@ -1,4 +1,29 @@
1−module Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) where
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
227
328-- | Control the rendering of floating point numbers.
429data FPFormat = Exponent
@@ -8,4 +33,210 @@ data FPFormat = Exponent
833 | Generic
934 -- ^ Use decimal notation for values between @0.1@ and
1035 -- @9,999,999@, and scientific notation otherwise.
11− deriving (Enum, Read, Show)
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/Unsafe.hs−87
@@ -1,7 +1,4 @@
11{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
2−#ifdef __GHCJS__
3−{-# LANGUAGE JavaScriptFFI, ForeignFunctionInterface, UnliftedFFITypes #-}
4−#endif
52-- |
63-- Module : Data.Text.Unsafe
74-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
@@ -35,47 +32,31 @@ import Control.Exception (assert)
3532import Data.Text.Internal.Encoding.Utf16 (chr2)
3633import Data.Text.Internal (Text(..))
3734import Data.Text.Internal.Unsafe (inlineInterleaveST, inlinePerformIO)
38−#ifdef __GHCJS__
39−import Data.Coerce
40−import qualified Data.JSString.Raw as JSS
41−import GHC.Exts (Int(..), Int#, chr#, int2Word#, Char(..))
42−import GHC.Word (Word16(..))
43−import Data.JSString (JSString)
44−#else
4535import Data.Text.Internal.Unsafe.Char (unsafeChr)
4636import qualified Data.Text.Array as A
47−#endif
4837import GHC.IO (unsafeDupablePerformIO)
4938
5039-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
5140-- omits the check for the empty case, so there is an obligation on
5241-- the programmer to provide a proof that the 'Text' is non-empty.
5342unsafeHead :: Text -> Char
54−#ifndef __GHCJS__
5543unsafeHead (Text arr off _len)
5644 | m < 0xD800 || m > 0xDBFF = unsafeChr m
5745 | otherwise = chr2 m n
5846 where m = A.unsafeIndex arr off
5947 n = A.unsafeIndex arr (off+1)
60−#else
61−unsafeHead = coerce JSS.rawHead
62−#endif
6348{-# INLINE unsafeHead #-}
6449
6550-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeTail'
6651-- omits the check for the empty case, so there is an obligation on
6752-- the programmer to provide a proof that the 'Text' is non-empty.
6853unsafeTail :: Text -> Text
69−#ifndef __GHCJS__
7054unsafeTail t@(Text arr off len) =
7155#if defined(ASSERTS)
7256 assert (d <= len) $
7357#endif
7458 Text arr (off+d) (len-d)
7559 where d = iter_ t 0
76−#else
77−unsafeTail = coerce JSS.rawTail
78−#endif
7960{-# INLINE unsafeTail #-}
8061
8162data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
@@ -84,7 +65,6 @@ data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
8465-- array, returning the current character and the delta to add to give
8566-- the next offset to iterate at.
8667iter :: Text -> Int -> Iter
87−#ifndef __GHCJS__
8868iter (Text arr off _len) i
8969 | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1
9070 | otherwise = Iter (chr2 m n) 2
@@ -92,40 +72,20 @@ iter (Text arr off _len) i
9272 n = A.unsafeIndex arr k
9373 j = off + i
9474 k = j + 1
95−#else
96−iter (Text txt) i
97− | m < 0xD800 || m > 0xDBFF = Iter (C# (chr# m#)) 1
98− | otherwise = Iter (chr2 m n) 2
99− where m# = js_charCodeAt j txt
100− n# = js_charCodeAt k txt
101− m = W16# (int2Word# m#)
102− n = W16# (int2Word# n#)
103− j = off + i
104− k = j + 1
105− off = 0
106−#endif
10775{-# INLINE iter #-}
10876
10977-- | /O(1)/ Iterate one step through a UTF-16 array, returning the
11078-- delta to add to give the next offset to iterate at.
11179iter_ :: Text -> Int -> Int
112−#ifndef __GHCJS__
11380iter_ (Text arr off _len) i | m < 0xD800 || m > 0xDBFF = 1
11481 | otherwise = 2
11582 where m = A.unsafeIndex arr (off+i)
116−#else
117−iter_ (Text txt) i | m < 0xD800 || m > 0xDBFF = 1
118− | otherwise = 2
119− where m# = js_charCodeAt i txt
120− m = W16# (int2Word# m#)
121−#endif
12283{-# INLINE iter_ #-}
12384
12485-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
12586-- returning the current character and the delta to add (i.e. a
12687-- negative number) to give the next offset to iterate at.
12788reverseIter :: Text -> Int -> (Char,Int)
128−#ifndef __GHCJS__
12989reverseIter (Text arr off _len) i
13090 | m < 0xDC00 || m > 0xDFFF = (unsafeChr m, -1)
13191 | otherwise = (chr2 n m, -2)
@@ -133,78 +93,31 @@ reverseIter (Text arr off _len) i
13393 n = A.unsafeIndex arr k
13494 j = off + i
13595 k = j - 1
136−#else
137−reverseIter (Text txt) i
138− | m < 0xDC00 || m > 0xDFFF = (C# (chr# m#), -1)
139− | otherwise = (chr2 n m, -2)
140− where m# = js_charCodeAt j txt
141− n# = js_charCodeAt k txt
142− m = W16# (int2Word# m#)
143− n = W16# (int2Word# n#)
144− j = off + i
145− k = j - 1
146− off = 0
147−#endif
14896{-# INLINE reverseIter #-}
14997
15098-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
15199-- returning the delta to add (i.e. a negative number) to give the
152100-- next offset to iterate at.
153101reverseIter_ :: Text -> Int -> Int
154−#ifndef __GHCJS__
155102reverseIter_ (Text arr off _len) i
156103 | m < 0xDC00 || m > 0xDFFF = -1
157104 | otherwise = -2
158105 where m = A.unsafeIndex arr (off+i)
159−#else
160−reverseIter_ (Text txt) i
161− | m < 0xDC00 || m > 0xDFFF = -1
162− | otherwise = -2
163− where m# = js_charCodeAt (off + i) txt
164− m = W16# (int2Word# m#)
165− off = 0
166−#endif
167106{-# INLINE reverseIter_ #-}
168107
169108-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This
170109-- is useful for sizing a target array appropriately before using
171110-- 'unsafeCopyToPtr'.
172111lengthWord16 :: Text -> Int
173−#ifndef __GHCJS__
174112lengthWord16 (Text _arr _off len) = len
175−#else
176−lengthWord16 (Text t) = js_length t
177−#endif
178113{-# INLINE lengthWord16 #-}
179114
180115-- | /O(1)/ Unchecked take of 'k' 'Word16's from the front of a 'Text'.
181116takeWord16 :: Int -> Text -> Text
182−#ifndef __GHCJS__
183117takeWord16 k (Text arr off _len) = Text arr off k
184−#else
185−takeWord16 k (Text txt) = Text $ js_take k txt
186−#endif
187118{-# INLINE takeWord16 #-}
188119
189120-- | /O(1)/ Unchecked drop of 'k' 'Word16's from the front of a 'Text'.
190121dropWord16 :: Int -> Text -> Text
191−#ifndef __GHCJS__
192122dropWord16 k (Text arr off len) = Text arr (off+k) (len-k)
193−#else
194−dropWord16 k (Text txt) = Text $ js_drop k txt
195−#endif
196123{-# INLINE dropWord16 #-}
197−
198−#ifdef __GHCJS__
199−foreign import javascript unsafe
200− "$2.charCodeAt($1)" js_charCodeAt :: Int -> JSString -> Int#
201−
202−foreign import javascript unsafe
203− "h$jsstringTake" js_take :: Int -> JSString -> JSString
204−
205−foreign import javascript unsafe
206− "h$jsstringDrop" js_drop :: Int -> JSString -> JSString
207−
208−foreign import javascript unsafe
209− "$1.length" js_length :: JSString -> Int
210−#endif
text.cabal+60−65
@@ -88,13 +88,13 @@ library
8888 Data.Text.Array
8989 Data.Text.Encoding
9090 Data.Text.Encoding.Error
91− -- Data.Text.Foreign
91+ Data.Text.Foreign
9292 Data.Text.IO
9393 Data.Text.Internal
9494 Data.Text.Internal.Builder
95− -- Data.Text.Internal.Builder.Functions
96− -- Data.Text.Internal.Builder.Int.Digits
97− -- Data.Text.Internal.Builder.RealFloat.Functions
95+ Data.Text.Internal.Builder.Functions
96+ Data.Text.Internal.Builder.Int.Digits
97+ Data.Text.Internal.Builder.RealFloat.Functions
9898 Data.Text.Internal.Encoding.Fusion
9999 Data.Text.Internal.Encoding.Fusion.Common
100100 Data.Text.Internal.Encoding.Utf16
@@ -106,14 +106,14 @@ library
106106 Data.Text.Internal.Fusion.Common
107107 Data.Text.Internal.Fusion.Size
108108 Data.Text.Internal.Fusion.Types
109− -- Data.Text.Internal.IO
109+ Data.Text.Internal.IO
110110 Data.Text.Internal.Lazy
111− -- Data.Text.Internal.Lazy.Encoding.Fusion
111+ Data.Text.Internal.Lazy.Encoding.Fusion
112112 Data.Text.Internal.Lazy.Fusion
113113 Data.Text.Internal.Lazy.Search
114− -- Data.Text.Internal.Private
114+ Data.Text.Internal.Private
115115 Data.Text.Internal.Read
116− -- Data.Text.Internal.Search
116+ Data.Text.Internal.Search
117117 Data.Text.Internal.Unsafe
118118 Data.Text.Internal.Unsafe.Char
119119 Data.Text.Internal.Unsafe.Shift
@@ -124,23 +124,18 @@ library
124124 Data.Text.Lazy.Encoding
125125 Data.Text.Lazy.IO
126126 Data.Text.Lazy.Internal
127− -- Data.Text.Lazy.Read
127+ Data.Text.Lazy.Read
128128 Data.Text.Read
129129 Data.Text.Unsafe
130130
131− -- moved from ghcjs-base
132− -- reflex-dom depends in it
133− Data.JSString.Text
134− -- other-modules:
135− -- Data.Text.Show
131+ other-modules:
132+ Data.Text.Show
136133
137134 build-depends:
138− -- array >= 0.3,
135+ array >= 0.3,
139136 base >= 4.2 && < 5,
140137 binary,
141138 deepseq >= 1.1.0.0,
142− ghcjs-base,
143− ghcjs-prim,
144139 ghc-prim >= 0.2
145140
146141 if flag(bytestring-builder)
@@ -163,51 +158,51 @@ library
163158 cpp-options: -DINTEGER_GMP
164159 build-depends: integer-gmp >= 0.2
165160
166−-- test-suite tests
167−-- type: exitcode-stdio-1.0
168−-- hs-source-dirs: tests .
169−-- main-is: Tests.hs
170−-- c-sources: cbits/cbits.c
171−-- include-dirs: include
172−
173−-- ghc-options:
174−-- -Wall -threaded -O0 -rtsopts
175−
176−-- cpp-options:
177−-- -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE
178−
179−-- build-depends:
180−-- HUnit >= 1.2,
181−-- QuickCheck >= 2.7,
182−-- array,
183−-- base,
184−-- binary,
185−-- deepseq,
186−-- directory,
187−-- ghc-prim,
188−-- quickcheck-unicode,
189−-- random,
190−-- test-framework >= 0.4,
191−-- test-framework-hunit >= 0.2,
192−-- test-framework-quickcheck2 >= 0.2
193−
194−-- if flag(bytestring-builder)
195−-- build-depends: bytestring >= 0.9 && < 0.10.4,
196−-- bytestring-builder >= 0.10.4
197−-- else
198−-- build-depends: bytestring >= 0.10.4
199−
200−-- if flag(integer-simple)
201−-- cpp-options: -DINTEGER_SIMPLE
202−-- build-depends: integer-simple >= 0.1 && < 0.5
203−-- else
204−-- cpp-options: -DINTEGER_GMP
205−-- build-depends: integer-gmp >= 0.2
206−
207−-- source-repository head
208−-- type: git
209−-- location: https://github.com/bos/text
210−
211−-- source-repository head
212−-- type: mercurial
213−-- location: https://bitbucket.org/bos/text
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
201+
202+source-repository head
203+ type: git
204+ location: https://github.com/bos/text
205+
206+source-repository head
207+ type: mercurial
208+ location: https://bitbucket.org/bos/text