on master help sign in
wip text as jsstring
commitd1c5d185a28405918a91173daea2f7d61aaeaba1 authorLuigy Leon <luigy@outlook.com> dateMon 26 Sep 2016, 11:40 (10 years ago) parentbb3d862
23 files changed+2438−2613
Data/JSString/Text.hs+64 Data/Text.hs+616−505 Data/Text/Encoding.hs+105−64 Data/Text/IO.hs+16 Data/Text/Internal.hs+42−125 Data/Text/Internal/Builder.hs+47−5 Data/Text/Internal/Encoding/Fusion.hs+10−8 Data/Text/Internal/Encoding/Fusion/Common.hs+8−4 Data/Text/Internal/Fusion.hs+42−180 Data/Text/Internal/Fusion/Common.hs+968−922 Data/Text/Internal/Fusion/Types.hs+102−99 Data/Text/Internal/IO.hs+8 Data/Text/Internal/Lazy.hs+18−10 Data/Text/Internal/Lazy/Encoding/Fusion.hs+26 Data/Text/Internal/Lazy/Fusion.hs+42−38 Data/Text/Internal/Lazy/Search.hs+55−11 Data/Text/Internal/Private.hs+8−1 Data/Text/Internal/Search.hs+40−37 Data/Text/Lazy.hs+58−52 Data/Text/Lazy/Builder/Int.hs+9−259 Data/Text/Lazy/Builder/RealFloat.hs+2−233 Data/Text/Unsafe.hs+87 text.cabal+65−60
Data/JSString/Text.hsnew file+64
@@ -0,0 +1,64 @@
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+616−505
@@ -6,7 +6,7 @@
66#if __GLASGOW_HASKELL__ >= 708
77{-# LANGUAGE TypeFamilies #-}
88#endif
9−
9+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
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,6 +246,28 @@ 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+
249271-- $strict
250272--
251273-- This package provides both strict and lazy 'Text' types. The
@@ -321,17 +343,17 @@ import Text.Printf (PrintfArg, formatArg, formatString)
321343-- Functions that can be fused by the compiler are documented with the
322344-- phrase \"Subject to fusion\".
323345
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 (==) #-}
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 (==) #-}
329351
330−instance Ord Text where
331− compare = compareText
352+-- instance Ord Text where
353+-- compare = compareText
332354
333−instance Read Text where
334− readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
355+-- instance Read Text where
356+-- readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
335357
336358#if MIN_VERSION_base(4,9,0)
337359-- Semigroup orphan instances for older GHCs are provided by
@@ -341,17 +363,17 @@ instance Semigroup Text where
341363 (<>) = append
342364#endif
343365
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
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
352374
353−instance IsString Text where
354− fromString = pack
375+-- instance IsString Text where
376+-- fromString = pack
355377
356378#if __GLASGOW_HASKELL__ >= 708
357379instance Exts.IsList Text where
@@ -387,18 +409,18 @@ instance Binary Text where
387409-- and 'Data.Map.Map' is archived here:
388410-- <http://markmail.org/message/trovdc6zkphyi3cr#query:+page:1+mid:a46der3iacwjcf6n+state:results Proposal: Allow gunfold for Data.Map, ... >
389411
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
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
397419
398420#if MIN_VERSION_base(4,7,0)
399421-- | Only defined for @base-4.7.0.0@ and later
400422instance PrintfArg Text where
401− formatArg txt = formatString $ unpack txt
423+ formatArg t = formatString $ unpack t
402424#endif
403425
404426packConstr :: Constr
@@ -407,19 +429,19 @@ packConstr = mkConstr textDataType "pack" [] Prefix
407429textDataType :: DataType
408430textDataType = mkDataType "Data.Text.Text" [packConstr]
409431
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
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
423445
424446-- -----------------------------------------------------------------------------
425447-- * Conversion to/from 'Text'
@@ -427,7 +449,8 @@ compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
427449-- | /O(n)/ Convert a 'String' into a 'Text'. Subject to
428450-- fusion. Performs replacement on invalid scalar values.
429451pack :: String -> Text
430−pack = unstream . S.map safe . S.streamList
452+pack = coerce JSS.pack
453+-- pack = unstream . S.map safe . S.streamList
431454{-# INLINE [1] pack #-}
432455
433456-- -----------------------------------------------------------------------------
@@ -438,7 +461,8 @@ pack = unstream . S.map safe . S.streamList
438461-- copying a new array. Subject to fusion. Performs replacement on
439462-- invalid scalar values.
440463cons :: Char -> Text -> Text
441−cons c t = unstream (S.cons (safe c) (stream t))
464+cons = coerce JSS.cons
465+-- cons c t = unstream (S.cons (safe c) (stream t))
442466{-# INLINE cons #-}
443467
444468infixr 5 `cons`
@@ -447,47 +471,51 @@ infixr 5 `cons`
447471-- entire array in the process, unless fused. Subject to fusion.
448472-- Performs replacement on invalid scalar values.
449473snoc :: Text -> Char -> Text
450−snoc t c = unstream (S.snoc (stream t) (safe c))
474+snoc = coerce JSS.snoc
475+-- snoc t c = unstream (S.snoc (stream t) (safe c))
451476{-# INLINE snoc #-}
452477
453478-- | /O(n)/ Appends one 'Text' to the other by copying both of them
454479-- into a new 'Text'. Subject to fusion.
455480append :: Text -> Text -> Text
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
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
469495{-# NOINLINE append #-}
470496
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− #-}
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+-- #-}
477503
478504-- | /O(1)/ Returns the first character of a 'Text', which must be
479505-- non-empty. Subject to fusion.
480506head :: Text -> Char
481−head t = S.head (stream t)
507+head = coerce JSS.head
508+-- head t = S.head (stream t)
482509{-# INLINE head #-}
483510
484511-- | /O(1)/ Returns the first character and rest of a 'Text', or
485512-- 'Nothing' if empty. Subject to fusion.
486513uncons :: Text -> Maybe (Char, Text)
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))
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))
491519{-# INLINE [1] uncons #-}
492520
493521-- | Lifted from Control.Arrow and specialized.
@@ -497,81 +525,86 @@ second f (a, b) = (a, f b)
497525-- | /O(1)/ Returns the last character of a 'Text', which must be
498526-- non-empty. Subject to fusion.
499527last :: Text -> Char
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)
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)
506535{-# INLINE [1] last #-}
507536
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− #-}
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+-- #-}
514543
515544-- | /O(1)/ Returns all characters after the head of a 'Text', which
516545-- must be non-empty. Subject to fusion.
517546tail :: Text -> Text
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
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
522552{-# INLINE [1] tail #-}
523553
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− #-}
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+-- #-}
530560
531561-- | /O(1)/ Returns all but the last character of a 'Text', which must
532562-- be non-empty. Subject to fusion.
533563init :: Text -> Text
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)
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)
539570{-# INLINE [1] init #-}
540571
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− #-}
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+-- #-}
547578
548579-- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to
549580-- fusion.
550581null :: Text -> Bool
551−null (Text _arr _off len) =
552−#if defined(ASSERTS)
553− assert (len >= 0) $
554−#endif
555− len <= 0
582+null = coerce JSS.null
583+-- null (Text _arr _off len) =
584+-- #if defined(ASSERTS)
585+-- assert (len >= 0) $
586+-- #endif
587+-- len <= 0
556588{-# INLINE [1] null #-}
557589
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− #-}
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+-- #-}
564596
565597-- | /O(1)/ Tests whether a 'Text' contains exactly one character.
566598-- Subject to fusion.
567−isSingleton :: Text -> Bool
568−isSingleton = S.isSingleton . stream
569−{-# INLINE isSingleton #-}
599+-- isSingleton :: Text -> Bool
600+-- isSingleton = S.isSingleton . stream
601+-- {-# INLINE isSingleton #-}
570602
571603-- | /O(n)/ Returns the number of characters in a 'Text'.
572604-- Subject to fusion.
573605length :: Text -> Int
574−length t = S.length (stream t)
606+length = coerce JSS.length
607+-- length t = S.length (stream t)
575608{-# INLINE [0] length #-}
576609-- length needs to be phased after the compareN/length rules otherwise
577610-- it may inline before the rules have an opportunity to fire.
@@ -583,43 +616,44 @@ length t = S.length (stream t)
583616-- of 'length', but can short circuit if the count of characters is
584617-- greater than the number, and hence be more efficient.
585618compareLength :: Text -> Int -> Ordering
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− #-}
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+-- #-}
623657
624658-- -----------------------------------------------------------------------------
625659-- * Transformations
@@ -627,26 +661,30 @@ compareLength t n = S.compareLengthI (stream t) n
627661-- each element of @t@. Subject to fusion. Performs replacement on
628662-- invalid scalar values.
629663map :: (Char -> Char) -> Text -> Text
630−map f t = unstream (S.map (safe . f) (stream t))
664+map = coerce JSS.map
665+-- map f t = unstream (S.map (safe . f) (stream t))
631666{-# INLINE [1] map #-}
632667
633668-- | /O(n)/ The 'intercalate' function takes a 'Text' and a list of
634669-- 'Text's and concatenates the list after interspersing the first
635670-- argument between each element of the list.
636671intercalate :: Text -> [Text] -> Text
637−intercalate t = concat . (F.intersperse t)
672+intercalate = coerce JSS.intercalate
673+-- intercalate t = concat . (F.intersperse t)
638674{-# INLINE intercalate #-}
639675
640676-- | /O(n)/ The 'intersperse' function takes a character and places it
641677-- between the characters of a 'Text'. Subject to fusion. Performs
642678-- replacement on invalid scalar values.
643679intersperse :: Char -> Text -> Text
644−intersperse c t = unstream (S.intersperse (safe c) (stream t))
680+intersperse = coerce JSS.intersperse
681+-- intersperse c t = unstream (S.intersperse (safe c) (stream t))
645682{-# INLINE intersperse #-}
646683
647684-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
648685reverse :: Text -> Text
649−reverse t = S.reverse (stream t)
686+reverse = coerce JSS.reverse
687+-- reverse t = S.reverse (stream t)
650688{-# INLINE reverse #-}
651689
652690-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
@@ -680,28 +718,29 @@ replace :: Text
680718 -> Text
681719 -- ^ @haystack@ in which to search.
682720 -> Text
683−replace needle@(Text _ _ neeLen)
684− (Text repArr repOff repLen)
685− haystack@(Text hayArr hayOff hayLen)
686− | neeLen == 0 = emptyError "replace"
687− | L.null ixs = haystack
688− | len > 0 = Text (A.run x) 0 len
689− | otherwise = empty
690− where
691− ixs = indices needle haystack
692− len = hayLen - (neeLen - repLen) `mul` L.length ixs
693− x :: ST s (A.MArray s)
694− x = do
695− marr <- A.new len
696− let loop (i:is) o d = do
697− let d0 = d + i - o
698− d1 = d0 + repLen
699− A.copyI marr d hayArr (hayOff+o) d0
700− A.copyI marr d0 repArr repOff d1
701− loop is (i + neeLen) d1
702− loop [] o d = A.copyI marr d hayArr (hayOff+o) len
703− loop ixs 0 0
704− return marr
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
705744
706745-- ----------------------------------------------------------------------------
707746-- ** Case conversions (folds)
@@ -740,7 +779,8 @@ replace needle@(Text _ _ neeLen)
740779-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
741780-- instead of itself.
742781toCaseFold :: Text -> Text
743−toCaseFold t = unstream (S.toCaseFold (stream t))
782+-- toCaseFold t = unstream (S.toCaseFold (stream t))
783+toCaseFold = coerce JSS.toCaseFold
744784{-# INLINE toCaseFold #-}
745785
746786-- | /O(n)/ Convert a string to lower case, using simple case
@@ -751,7 +791,8 @@ toCaseFold t = unstream (S.toCaseFold (stream t))
751791-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
752792-- followed by \" &#x307;\" (combining dot above, U+0307).
753793toLower :: Text -> Text
754−toLower t = unstream (S.toLower (stream t))
794+-- toLower t = unstream (S.toLower (stream t))
795+toLower = coerce JSS.toLower
755796{-# INLINE toLower #-}
756797
757798-- | /O(n)/ Convert a string to upper case, using simple case
@@ -761,7 +802,8 @@ toLower t = unstream (S.toLower (stream t))
761802-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
762803-- two-letter sequence \"SS\".
763804toUpper :: Text -> Text
764−toUpper t = unstream (S.toUpper (stream t))
805+-- toUpper t = unstream (S.toUpper (stream t))
806+toUpper = coerce JSS.toUpper
765807{-# INLINE toUpper #-}
766808
767809-- | /O(n)/ Convert a string to title case, using simple case
@@ -783,7 +825,8 @@ toUpper t = unstream (S.toUpper (stream t))
783825-- Fox\" is correctly title cased&#x2014;but this function will
784826-- capitalize /every/ word.
785827toTitle :: Text -> Text
786−toTitle t = unstream (S.toTitle (stream t))
828+toTitle = coerce JSS.toTitle
829+-- toTitle t = unstream (S.toTitle (stream t))
787830{-# INLINE toTitle #-}
788831
789832-- | /O(n)/ Left-justify a string to the given length, using the
@@ -795,18 +838,19 @@ toTitle t = unstream (S.toTitle (stream t))
795838-- > justifyLeft 7 'x' "foo" == "fooxxxx"
796839-- > justifyLeft 3 'x' "foobar" == "foobar"
797840justifyLeft :: Int -> Char -> Text -> Text
798−justifyLeft k c t
799− | len >= k = t
800− | otherwise = t `append` replicateChar (k-len) c
801− where len = length t
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
802846{-# INLINE [1] justifyLeft #-}
803847
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− #-}
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+-- #-}
810854
811855-- | /O(n)/ Right-justify a string to the given length, using the
812856-- specified fill character on the left. Performs replacement on
@@ -817,10 +861,11 @@ justifyLeft k c t
817861-- > justifyRight 7 'x' "bar" == "xxxxbar"
818862-- > justifyRight 3 'x' "foobar" == "foobar"
819863justifyRight :: Int -> Char -> Text -> Text
820−justifyRight k c t
821− | len >= k = t
822− | otherwise = replicateChar (k-len) c `append` t
823− where len = length t
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
824869{-# INLINE justifyRight #-}
825870
826871-- | /O(n)/ Center a string to the given length, using the specified
@@ -831,13 +876,14 @@ justifyRight k c t
831876--
832877-- > center 8 'x' "HS" = "xxxHSxxx"
833878center :: Int -> Char -> Text -> Text
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
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
841887{-# INLINE center #-}
842888
843889-- | /O(n)/ The 'transpose' function transposes the rows and columns
@@ -845,7 +891,8 @@ center k c t
845891-- 'unpack', and the list version of transpose, and is thus not very
846892-- efficient.
847893transpose :: [Text] -> [Text]
848−transpose ts = P.map pack (L.transpose (P.map unpack ts))
894+transpose = coerce JSS.transpose
895+-- transpose ts = P.map pack (L.transpose (P.map unpack ts))
849896
850897-- -----------------------------------------------------------------------------
851898-- * Reducing 'Text's (folds)
@@ -855,23 +902,27 @@ transpose ts = P.map pack (L.transpose (P.map unpack ts))
855902-- reduces the 'Text' using the binary operator, from left to right.
856903-- Subject to fusion.
857904foldl :: (a -> Char -> a) -> a -> Text -> a
858−foldl f z t = S.foldl f z (stream t)
905+foldl f a0 (Text t) = JSS.foldl f a0 t
906+-- foldl f z t = S.foldl f z (stream t)
859907{-# INLINE foldl #-}
860908
861909-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
862910foldl' :: (a -> Char -> a) -> a -> Text -> a
863−foldl' f z t = S.foldl' f z (stream t)
911+foldl' f a0 (Text t) = JSS.foldl' f a0 t
912+-- foldl' f z t = S.foldl' f z (stream t)
864913{-# INLINE foldl' #-}
865914
866915-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
867916-- and thus must be applied to a non-empty 'Text'. Subject to fusion.
868917foldl1 :: (Char -> Char -> Char) -> Text -> Char
869−foldl1 f t = S.foldl1 f (stream t)
918+foldl1 = coerce JSS.foldl1
919+-- foldl1 f t = S.foldl1 f (stream t)
870920{-# INLINE foldl1 #-}
871921
872922-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
873923foldl1' :: (Char -> Char -> Char) -> Text -> Char
874−foldl1' f t = S.foldl1' f (stream t)
924+foldl1' = coerce JSS.foldl1'
925+-- foldl1' f t = S.foldl1' f (stream t)
875926{-# INLINE foldl1' #-}
876927
877928-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
@@ -879,14 +930,16 @@ foldl1' f t = S.foldl1' f (stream t)
879930-- reduces the 'Text' using the binary operator, from right to left.
880931-- Subject to fusion.
881932foldr :: (Char -> a -> a) -> a -> Text -> a
882−foldr f z t = S.foldr f z (stream t)
933+foldr f a0 (Text t) = JSS.foldr f a0 t
934+-- foldr f z t = S.foldr f z (stream t)
883935{-# INLINE foldr #-}
884936
885937-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
886938-- and thus must be applied to a non-empty 'Text'. Subject to
887939-- fusion.
888940foldr1 :: (Char -> Char -> Char) -> Text -> Char
889−foldr1 f t = S.foldr1 f (stream t)
941+foldr1 = coerce JSS.foldr1
942+-- foldr1 f t = S.foldr1 f (stream t)
890943{-# INLINE foldr1 #-}
891944
892945-- -----------------------------------------------------------------------------
@@ -894,48 +947,54 @@ foldr1 f t = S.foldr1 f (stream t)
894947
895948-- | /O(n)/ Concatenate a list of 'Text's.
896949concat :: [Text] -> Text
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
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
910964
911965-- | /O(n)/ Map a function over a 'Text' that results in a 'Text', and
912966-- concatenate the results.
913967concatMap :: (Char -> Text) -> Text -> Text
914−concatMap f = concat . foldr ((:) . f) []
968+concatMap = coerce JSS.concatMap
969+-- concatMap f = concat . foldr ((:) . f) []
915970{-# INLINE concatMap #-}
916971
917972-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
918973-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
919974any :: (Char -> Bool) -> Text -> Bool
920−any p t = S.any p (stream t)
975+any = coerce JSS.any
976+-- any p t = S.any p (stream t)
921977{-# INLINE any #-}
922978
923979-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
924980-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
925981all :: (Char -> Bool) -> Text -> Bool
926−all p t = S.all p (stream t)
982+all = coerce JSS.all
983+-- all p t = S.all p (stream t)
927984{-# INLINE all #-}
928985
929986-- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which
930987-- must be non-empty. Subject to fusion.
931988maximum :: Text -> Char
932−maximum t = S.maximum (stream t)
989+maximum = coerce JSS.maximum
990+-- maximum t = S.maximum (stream t)
933991{-# INLINE maximum #-}
934992
935993-- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which
936994-- must be non-empty. Subject to fusion.
937995minimum :: Text -> Char
938−minimum t = S.minimum (stream t)
996+minimum = coerce JSS.minimum
997+-- minimum t = S.minimum (stream t)
939998{-# INLINE minimum #-}
940999
9411000-- -----------------------------------------------------------------------------
@@ -951,8 +1010,9 @@ minimum t = S.minimum (stream t)
9511010--
9521011-- > last (scanl f z xs) == foldl f z xs.
9531012scanl :: (Char -> Char -> Char) -> Char -> Text -> Text
954−scanl f z t = unstream (S.scanl g z (stream t))
955− where g a b = safe (f a b)
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)
9561016{-# INLINE scanl #-}
9571017
9581018-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
@@ -961,8 +1021,9 @@ scanl f z t = unstream (S.scanl g z (stream t))
9611021--
9621022-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
9631023scanl1 :: (Char -> Char -> Char) -> Text -> Text
964−scanl1 f t | null t = empty
965− | otherwise = scanl f (unsafeHead t) (unsafeTail t)
1024+scanl1 = coerce JSS.scanl1
1025+-- scanl1 f t | null t = empty
1026+-- | otherwise = scanl f (unsafeHead t) (unsafeTail t)
9661027{-# INLINE scanl1 #-}
9671028
9681029-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
@@ -970,16 +1031,18 @@ scanl1 f t | null t = empty
9701031--
9711032-- > scanr f v == reverse . scanl (flip f) v . reverse
9721033scanr :: (Char -> Char -> Char) -> Char -> Text -> Text
973−scanr f z = S.reverse . S.reverseScanr g z . reverseStream
974− where g a b = safe (f a b)
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)
9751037{-# INLINE scanr #-}
9761038
9771039-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
9781040-- value argument. Subject to fusion. Performs replacement on
9791041-- invalid scalar values.
9801042scanr1 :: (Char -> Char -> Char) -> Text -> Text
981−scanr1 f t | null t = empty
982− | otherwise = scanr f (last t) (init t)
1043+scanr1 = coerce JSS.scanr1
1044+-- scanr1 f t | null t = empty
1045+-- | otherwise = scanr f (last t) (init t)
9831046{-# INLINE scanr1 #-}
9841047
9851048-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
@@ -987,8 +1050,11 @@ scanr1 f t | null t = empty
9871050-- parameter from left to right, and returns a final 'Text'. Performs
9881051-- replacement on invalid scalar values.
9891052mapAccumL :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
990−mapAccumL f z0 = S.mapAccumL g z0 . stream
991− where g a b = second safe (f a b)
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)
9921058{-# INLINE mapAccumL #-}
9931059
9941060-- | The 'mapAccumR' function behaves like a combination of 'map' and
@@ -998,8 +1064,11 @@ mapAccumL f z0 = S.mapAccumL g z0 . stream
9981064-- 'Text'.
9991065-- Performs replacement on invalid scalar values.
10001066mapAccumR :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
1001−mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
1002− where g a b = second safe (f a b)
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)
10031072{-# INLINE mapAccumR #-}
10041073
10051074-- -----------------------------------------------------------------------------
@@ -1008,32 +1077,33 @@ mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
10081077-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'Text' consisting of the input
10091078-- @t@ repeated @n@ times.
10101079replicate :: Int -> Text -> Text
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
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
10251095{-# INLINE [1] replicate #-}
10261096
1027−{-# RULES
1028−"TEXT replicate/singleton -> replicateChar" [~1] forall n c.
1029− replicate n (singleton c) = replicateChar n c
1030− #-}
1097+-- {-# RULES
1098+-- "TEXT replicate/singleton -> replicateChar" [~1] forall n c.
1099+-- replicate n (singleton c) = replicateChar n c
1100+-- #-}
10311101
10321102-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the
10331103-- value of every element. Subject to fusion.
1034−replicateChar :: Int -> Char -> Text
1035−replicateChar n c = unstream (S.replicateCharI n (safe c))
1036−{-# INLINE replicateChar #-}
1104+-- replicateChar :: Int -> Char -> Text
1105+-- replicateChar n c = unstream (S.replicateCharI n (safe c))
1106+-- {-# INLINE replicateChar #-}
10371107
10381108-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
10391109-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
@@ -1043,7 +1113,8 @@ replicateChar n c = unstream (S.replicateCharI n (safe c))
10431113-- string, and @b@ is the seed value for further production. Subject
10441114-- to fusion. Performs replacement on invalid scalar values.
10451115unfoldr :: (a -> Maybe (Char,a)) -> a -> Text
1046−unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
1116+unfoldr f a = Text $ JSS.unfoldr f a
1117+-- unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
10471118{-# INLINE unfoldr #-}
10481119
10491120-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Text' from a seed
@@ -1053,7 +1124,8 @@ unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
10531124-- correct, otherwise its performance is similar to 'unfoldr'. Subject
10541125-- to fusion. Performs replacement on invalid scalar values.
10551126unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Text
1056−unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
1127+unfoldrN n f a0 = Text $ JSS.unfoldrN n f a0
1128+-- unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
10571129{-# INLINE unfoldrN #-}
10581130
10591131-- -----------------------------------------------------------------------------
@@ -1063,25 +1135,26 @@ unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
10631135-- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than
10641136-- the length of the Text. Subject to fusion.
10651137take :: Int -> Text -> Text
1066−take n t@(Text arr off len)
1067− | n <= 0 = empty
1068− | n >= len = t
1069− | otherwise = text arr off (iterN n t)
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)
10701143{-# INLINE [1] take #-}
10711144
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
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
10781151
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− #-}
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+-- #-}
10851158
10861159-- | /O(n)/ 'takeEnd' @n@ @t@ returns the suffix remaining after
10871160-- taking @n@ characters from the end of @t@.
@@ -1090,37 +1163,39 @@ iterN n t@(Text _arr _off len) = loop 0 0
10901163--
10911164-- > takeEnd 3 "foobar" == "bar"
10921165takeEnd :: Int -> Text -> Text
1093−takeEnd n t@(Text arr off len)
1094− | n <= 0 = empty
1095− | n >= len = t
1096− | otherwise = text arr (off+i) (len-i)
1097− where i = iterNEnd n t
1098−
1099−iterNEnd :: Int -> Text -> Int
1100−iterNEnd n t@(Text _arr _off len) = loop (len-1) n
1101− where loop i !m
1102− | i <= 0 = 0
1103− | m <= 1 = i
1104− | otherwise = loop (i+d) (m-1)
1105− where d = reverseIter_ t i
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
11061180
11071181-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
11081182-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
11091183-- is greater than the length of the 'Text'. Subject to fusion.
11101184drop :: Int -> Text -> Text
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
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
11161191{-# INLINE [1] drop #-}
11171192
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− #-}
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+-- #-}
11241199
11251200-- | /O(n)/ 'dropEnd' @n@ @t@ returns the prefix remaining after
11261201-- dropping @n@ characters from the end of @t@.
@@ -1129,28 +1204,30 @@ drop n t@(Text arr off len)
11291204--
11301205-- > dropEnd 3 "foobar" == "foo"
11311206dropEnd :: Int -> Text -> Text
1132−dropEnd n t@(Text arr off len)
1133− | n <= 0 = t
1134− | n >= len = empty
1135− | otherwise = text arr off (iterNEnd n t)
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)
11361212
11371213-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
11381214-- returns the longest prefix (possibly empty) of elements that
11391215-- satisfy @p@. Subject to fusion.
11401216takeWhile :: (Char -> Bool) -> Text -> Text
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
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
11461223{-# INLINE [1] takeWhile #-}
11471224
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− #-}
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+-- #-}
11541231
11551232-- | /O(n)/ 'takeWhileEnd', applied to a predicate @p@ and a 'Text',
11561233-- returns the longest suffix (possibly empty) of elements that
@@ -1159,36 +1236,39 @@ takeWhile p t@(Text arr off len) = loop 0
11591236--
11601237-- > takeWhileEnd (=='o') "foo" == "oo"
11611238takeWhileEnd :: (Char -> Bool) -> Text -> Text
1162−takeWhileEnd p t@(Text arr off len) = loop (len-1) len
1163− where loop !i !l | l <= 0 = t
1164− | p c = loop (i+d) (l+d)
1165− | otherwise = text arr (off+l) (len-l)
1166− where (c,d) = reverseIter t i
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
11671246{-# INLINE [1] takeWhileEnd #-}
11681247
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− #-}
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+-- #-}
11751254
11761255-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
11771256-- 'takeWhile' @p@ @t@. Subject to fusion.
11781257dropWhile :: (Char -> Bool) -> Text -> Text
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
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+
11841264{-# INLINE [1] dropWhile #-}
11851265
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− #-}
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+-- #-}
11921272
11931273-- | /O(n)/ 'dropWhileEnd' @p@ @t@ returns the prefix remaining after
11941274-- dropping characters that satisfy the predicate @p@ from the end of
@@ -1198,19 +1278,20 @@ dropWhile p t@(Text arr off len) = loop 0 0
11981278--
11991279-- > dropWhileEnd (=='.') "foo..." == "foo"
12001280dropWhileEnd :: (Char -> Bool) -> Text -> Text
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
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
12061287{-# INLINE [1] dropWhileEnd #-}
12071288
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− #-}
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+-- #-}
12141295
12151296-- | /O(n)/ 'dropAround' @p@ @t@ returns the substring remaining after
12161297-- dropping characters that satisfy the predicate @p@ from both the
@@ -1245,45 +1326,49 @@ strip = dropAround isSpace
12451326-- prefix of @t@ of length @n@, and whose second is the remainder of
12461327-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
12471328splitAt :: Int -> Text -> (Text, Text)
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))
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))
12531335
12541336-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
12551337-- a pair whose first element is the longest prefix (possibly empty)
12561338-- of @t@ of elements that satisfy @p@, and whose second is the
12571339-- remainder of the list.
12581340span :: (Char -> Bool) -> Text -> (Text, Text)
1259−span p t = case span_ p t of
1260− (# hd,tl #) -> (hd,tl)
1341+span = coerce JSS.span
1342+-- span p t = case span_ p t of
1343+-- (# hd,tl #) -> (hd,tl)
12611344{-# INLINE span #-}
12621345
12631346-- | /O(n)/ 'break' is like 'span', but the prefix returned is
12641347-- over elements that fail the predicate @p@.
12651348break :: (Char -> Bool) -> Text -> (Text, Text)
1266−break p = span (not . p)
1349+break = coerce JSS.break
1350+-- break p = span (not . p)
12671351{-# INLINE break #-}
12681352
12691353-- | /O(n)/ Group characters in a string according to a predicate.
12701354groupBy :: (Char -> Char -> Bool) -> Text -> [Text]
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))
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))
12781363
12791364-- | Returns the /array/ index (in units of 'Word16') at which a
12801365-- character may be found. This is /not/ the same as the logical
12811366-- index returned by e.g. 'findIndex'.
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
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
12871372
12881373-- | /O(n)/ Group characters in a string by equality.
12891374group :: Text -> [Text]
@@ -1292,15 +1377,17 @@ group = groupBy (==)
12921377-- | /O(n)/ Return all initial segments of the given 'Text', shortest
12931378-- first.
12941379inits :: Text -> [Text]
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)
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)
12981384
12991385-- | /O(n)/ Return all final segments of the given 'Text', longest
13001386-- first.
13011387tails :: Text -> [Text]
1302−tails t | null t = [empty]
1303− | otherwise = t : tails (unsafeTail t)
1388+tails = coerce JSS.tails
1389+-- tails t | null t = [empty]
1390+-- | otherwise = t : tails (unsafeTail t)
13041391
13051392-- $split
13061393--
@@ -1333,19 +1420,20 @@ splitOn :: Text
13331420 -> Text
13341421 -- ^ Input text.
13351422 -> [Text]
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)]
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)]
13431431{-# INLINE [1] splitOn #-}
13441432
1345−{-# RULES
1346−"TEXT splitOn/singleton -> split/==" [~1] forall c t.
1347− splitOn (singleton c) t = split (==c) t
1348− #-}
1433+-- {-# RULES
1434+-- "TEXT splitOn/singleton -> split/==" [~1] forall c t.
1435+-- splitOn (singleton c) t = split (==c) t
1436+-- #-}
13491437
13501438-- | /O(n)/ Splits a 'Text' into components delimited by separators,
13511439-- where the predicate returns True for a separator element. The
@@ -1355,11 +1443,12 @@ splitOn pat@(Text _ _ l) src@(Text arr off len)
13551443-- > split (=='a') "aabbaca" == ["","","bb","c",""]
13561444-- > split (=='a') "" == [""]
13571445split :: (Char -> Bool) -> Text -> [Text]
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
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
13631452{-# INLINE split #-}
13641453
13651454-- | /O(n)/ Splits a 'Text' into components of length @k@. The last
@@ -1369,11 +1458,12 @@ split p t = loop t
13691458-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
13701459-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
13711460chunksOf :: Int -> Text -> [Text]
1372−chunksOf k = go
1373− where
1374− go t = case splitAt k t of
1375− (a,b) | null a -> []
1376− | otherwise -> a : go b
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
13771467{-# INLINE chunksOf #-}
13781468
13791469-- ----------------------------------------------------------------------------
@@ -1386,7 +1476,8 @@ chunksOf k = go
13861476-- returns the first element matching the predicate, or 'Nothing' if
13871477-- there is no such element.
13881478find :: (Char -> Bool) -> Text -> Maybe Char
1389−find p t = S.findBy p (stream t)
1479+find = coerce JSS.find
1480+-- find p t = S.findBy p (stream t)
13901481{-# INLINE find #-}
13911482
13921483-- | /O(n)/ The 'partition' function takes a predicate and a 'Text',
@@ -1395,14 +1486,16 @@ find p t = S.findBy p (stream t)
13951486--
13961487-- > partition p t == (filter p t, filter (not . p) t)
13971488partition :: (Char -> Bool) -> Text -> (Text, Text)
1398−partition p t = (filter p t, filter (not . p) t)
1489+partition = coerce JSS.partition
1490+-- partition p t = (filter p t, filter (not . p) t)
13991491{-# INLINE partition #-}
14001492
14011493-- | /O(n)/ 'filter', applied to a predicate and a 'Text',
14021494-- returns a 'Text' containing those characters that satisfy the
14031495-- predicate.
14041496filter :: (Char -> Bool) -> Text -> Text
1405−filter p t = unstream (S.filter p (stream t))
1497+filter = coerce JSS.filter
1498+-- filter p t = unstream (S.filter p (stream t))
14061499{-# INLINE filter #-}
14071500
14081501-- | /O(n+m)/ Find the first instance of @needle@ (which must be
@@ -1427,11 +1520,12 @@ filter p t = unstream (S.filter p (stream t))
14271520-- In (unlikely) bad cases, this function's time complexity degrades
14281521-- towards /O(n*m)/.
14291522breakOn :: Text -> Text -> (Text, Text)
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))
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))
14351529{-# INLINE breakOn #-}
14361530
14371531-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
@@ -1443,8 +1537,9 @@ breakOn pat src@(Text arr off len)
14431537--
14441538-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
14451539breakOnEnd :: Text -> Text -> (Text, Text)
1446−breakOnEnd pat src = (reverse b, reverse a)
1447− where (a,b) = breakOn (reverse pat) (reverse src)
1540+breakOnEnd = coerce JSS.breakOnEnd
1541+-- breakOnEnd pat src = (reverse b, reverse a)
1542+-- where (a,b) = breakOn (reverse pat) (reverse src)
14481543{-# INLINE breakOnEnd #-}
14491544
14501545-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
@@ -1468,12 +1563,13 @@ breakOnEnd pat src = (reverse b, reverse a)
14681563breakOnAll :: Text -- ^ @needle@ to search for
14691564 -> Text -- ^ @haystack@ in which to search
14701565 -> [(Text, Text)]
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
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
14771573{-# INLINE breakOnAll #-}
14781574
14791575-------------------------------------------------------------------------------
@@ -1497,14 +1593,16 @@ breakOnAll pat src@(Text arr off slen)
14971593
14981594-- | /O(n)/ 'Text' index (subscript) operator, starting from 0.
14991595index :: Text -> Int -> Char
1500−index t n = S.index (stream t) n
1596+index = coerce JSS.index
1597+-- index t n = S.index (stream t) n
15011598{-# INLINE index #-}
15021599
15031600-- | /O(n)/ The 'findIndex' function takes a predicate and a 'Text'
15041601-- and returns the index of the first element in the 'Text' satisfying
15051602-- the predicate. Subject to fusion.
15061603findIndex :: (Char -> Bool) -> Text -> Maybe Int
1507−findIndex p t = S.findIndex p (stream t)
1604+findIndex = coerce JSS.findIndex
1605+-- findIndex p t = S.findIndex p (stream t)
15081606{-# INLINE findIndex #-}
15091607
15101608-- | /O(n+m)/ The 'count' function returns the number of times the
@@ -1514,22 +1612,23 @@ findIndex p t = S.findIndex p (stream t)
15141612-- In (unlikely) bad cases, this function's time complexity degrades
15151613-- towards /O(n*m)/.
15161614count :: Text -> Text -> Int
1517−count pat src
1518− | null pat = emptyError "count"
1519− | isSingleton pat = countChar (unsafeHead pat) src
1520− | otherwise = L.length (indices pat src)
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)
15211620{-# INLINE [1] count #-}
15221621
1523−{-# RULES
1524−"TEXT count/singleton -> countChar" [~1] forall c t.
1525− count (singleton c) t = countChar c t
1526− #-}
1622+-- {-# RULES
1623+-- "TEXT count/singleton -> countChar" [~1] forall c t.
1624+-- count (singleton c) t = countChar c t
1625+-- #-}
15271626
15281627-- | /O(n)/ The 'countChar' function returns the number of times the
15291628-- query element appears in the given 'Text'. Subject to fusion.
1530−countChar :: Char -> Text -> Int
1531−countChar c t = S.countChar c (stream t)
1532−{-# INLINE countChar #-}
1629+-- countChar :: Char -> Text -> Int
1630+-- countChar c t = S.countChar c (stream t)
1631+-- {-# INLINE countChar #-}
15331632
15341633-------------------------------------------------------------------------------
15351634-- * Zipping
@@ -1539,42 +1638,46 @@ countChar c t = S.countChar c (stream t)
15391638-- excess elements of the longer 'Text' are discarded. This is
15401639-- equivalent to a pair of 'unpack' operations.
15411640zip :: Text -> Text -> [(Char,Char)]
1542−zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1641+zip = coerce JSS.zip
1642+-- zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
15431643{-# INLINE zip #-}
15441644
15451645-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
15461646-- given as the first argument, instead of a tupling function.
15471647-- Performs replacement on invalid scalar values.
15481648zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
1549−zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
1550− where g a b = safe (f a b)
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)
15511652{-# INLINE zipWith #-}
15521653
15531654-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's
15541655-- representing white space.
15551656words :: Text -> [Text]
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
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
15681670{-# INLINE words #-}
15691671
15701672-- | /O(n)/ Breaks a 'Text' up into a list of 'Text's at
15711673-- newline 'Char's. The resulting strings do not contain newlines.
15721674lines :: Text -> [Text]
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
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
15781681{-# INLINE lines #-}
15791682
15801683{-
@@ -1602,34 +1705,38 @@ lines' ps | null ps = []
16021705-- | /O(n)/ Joins lines, after appending a terminating newline to
16031706-- each.
16041707unlines :: [Text] -> Text
1605−unlines = concat . L.map (`snoc` '\n')
1708+unlines = coerce JSS.unlines
1709+-- unlines = concat . L.map (`snoc` '\n')
16061710{-# INLINE unlines #-}
16071711
16081712-- | /O(n)/ Joins words using single space characters.
16091713unwords :: [Text] -> Text
1610−unwords = intercalate (singleton ' ')
1714+unwords = coerce JSS.unwords
1715+-- unwords = intercalate (singleton ' ')
16111716{-# INLINE unwords #-}
16121717
16131718-- | /O(n)/ The 'isPrefixOf' function takes two 'Text's and returns
16141719-- 'True' iff the first is a prefix of the second. Subject to fusion.
16151720isPrefixOf :: Text -> Text -> Bool
1616−isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
1617− alen <= blen && S.isPrefixOf (stream a) (stream b)
1721+isPrefixOf = coerce JSS.isPrefixOf
1722+-- isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
1723+-- alen <= blen && S.isPrefixOf (stream a) (stream b)
16181724{-# INLINE [1] isPrefixOf #-}
16191725
1620−{-# RULES
1621−"TEXT isPrefixOf -> fused" [~1] forall s t.
1622− isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1623− #-}
1726+-- {-# RULES
1727+-- "TEXT isPrefixOf -> fused" [~1] forall s t.
1728+-- isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1729+-- #-}
16241730
16251731-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns
16261732-- 'True' iff the first is a suffix of the second.
16271733isSuffixOf :: Text -> Text -> Bool
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
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
16331740{-# INLINE isSuffixOf #-}
16341741
16351742-- | /O(n+m)/ The 'isInfixOf' function takes two 'Text's and returns
@@ -1639,16 +1746,17 @@ isSuffixOf a@(Text _aarr _aoff alen) b@(Text barr boff blen) =
16391746-- In (unlikely) bad cases, this function's time complexity degrades
16401747-- towards /O(n*m)/.
16411748isInfixOf :: Text -> Text -> Bool
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
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
16461754{-# INLINE [1] isInfixOf #-}
16471755
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− #-}
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+-- #-}
16521760
16531761-------------------------------------------------------------------------------
16541762-- * View patterns
@@ -1672,9 +1780,10 @@ isInfixOf needle haystack
16721780-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
16731781-- > fnordLength _ = -1
16741782stripPrefix :: Text -> Text -> Maybe Text
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
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
16781787
16791788-- | /O(n)/ Find the longest non-empty common prefix of two strings
16801789-- and return it, along with the suffixes of each string at which they
@@ -1689,15 +1798,16 @@ stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
16891798-- > commonPrefixes "veeble" "fetzer" == Nothing
16901799-- > commonPrefixes "" "baz" == Nothing
16911800commonPrefixes :: Text -> Text -> Maybe (Text,Text,Text)
1692−commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
1693− where
1694− go !i !j | i < len0 && j < len1 && a == b = go (i+d0) (j+d1)
1695− | i > 0 = Just (Text arr0 off0 i,
1696− text arr0 (off0+i) (len0-i),
1697− text arr1 (off1+j) (len1-j))
1698− | otherwise = Nothing
1699− where Iter a d0 = iter t0 i
1700− Iter b d1 = iter t1 j
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
17011811
17021812-- | /O(n)/ Return the prefix of the second string if its suffix
17031813-- matches the entire first string.
@@ -1718,21 +1828,22 @@ commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
17181828-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
17191829-- > quuxLength _ = -1
17201830stripSuffix :: Text -> Text -> Maybe Text
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"
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"
17361847
17371848overflowError :: String -> a
17381849overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
@@ -1746,10 +1857,10 @@ overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
17461857-- copy \"breaks the link\" to the original array, allowing it to be
17471858-- garbage collected if there are no other live references to it.
17481859copy :: Text -> Text
1749−copy (Text arr off len) = Text (A.run go) 0 len
1750− where
1751− go :: ST s (A.MArray s)
1752− go = do
1753− marr <- A.new len
1754− A.copyI marr 0 arr off len
1755− return marr
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+
Data/Text/Encoding.hs+105−64
@@ -3,6 +3,7 @@
33#if __GLASGOW_HASKELL__ >= 702
44{-# LANGUAGE Trustworthy #-}
55#endif
6+{-# LANGUAGE UnboxedTuples #-}
67-- |
78-- Module : Data.Text.Encoding
89-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,
@@ -73,10 +74,10 @@ import Data.ByteString as B
7374import Data.ByteString.Internal as B hiding (c2w)
7475import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
7576import Data.Text.Internal (Text(..), safe, text)
76−import Data.Text.Internal.Private (runText)
77+-- import Data.Text.Internal.Private (runText)
7778import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
7879import Data.Text.Internal.Unsafe.Shift (shiftR)
79−import Data.Text.Show ()
80+-- import Data.Text.Show ()
8081import Data.Text.Unsafe (unsafeDupablePerformIO)
8182import Data.Word (Word8, Word32)
8283import Foreign.C.Types (CSize(..))
@@ -94,7 +95,23 @@ import qualified Data.Text.Internal.Encoding.Fusion as E
9495import qualified Data.Text.Internal.Encoding.Utf16 as U16
9596import qualified Data.Text.Internal.Fusion as F
9697
98+import GHC.Exts (ByteArray#, Int(..), Int#, Any)
99+{-
97100#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+
98115
99116-- $strict
100117--
@@ -120,39 +137,55 @@ decodeASCII = decodeUtf8
120137-- 'decodeLatin1' is semantically equivalent to
121138-- @Data.Text.pack . Data.ByteString.Char8.unpack@
122139decodeLatin1 :: ByteString -> Text
123−decodeLatin1 (PS fp off len) = text a 0 len
124− where
125− a = A.run (A.new len >>= unsafeIOToST . go)
126− go dest = withForeignPtr fp $ \ptr -> do
127− c_decode_latin1 (A.maBA dest) (ptr `plusPtr` off) (ptr `plusPtr` (off+len))
128− return dest
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
129158
130159-- | Decode a 'ByteString' containing UTF-8 encoded text.
131160decodeUtf8With :: OnDecodeError -> ByteString -> Text
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"
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"
156189{- INLINE[0] decodeUtf8With #-}
157190
158191-- $stream
@@ -252,8 +285,9 @@ streamDecodeUtf8With onErr = decodeChunk B.empty 0 0
252285 let end = ptr `plusPtr` (off + len)
253286 loop curPtr = do
254287 poke curPtrPtr curPtr
255− curPtr' <- c_decode_utf8_with_state (A.maBA dest) destOffPtr
256− curPtrPtr end codepointPtr statePtr
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
257291 state <- peek statePtr
258292 case state of
259293 UTF8_REJECT -> do
@@ -296,8 +330,8 @@ streamDecodeUtf8With onErr = decodeChunk B.empty 0 0
296330decodeUtf8 :: ByteString -> Text
297331decodeUtf8 = decodeUtf8With strictDecode
298332{-# INLINE[0] decodeUtf8 #-}
299−{-# RULES "STREAM stream/decodeUtf8 fusion" [1]
300− forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-}
333+-- {-# RULES "STREAM stream/decodeUtf8 fusion" [1]
334+-- forall bs. F.stream (decodeUtf8 bs) = E.streamUtf8 strictDecode bs #-}
301335
302336-- | Decode a 'ByteString' containing UTF-8 encoded text.
303337--
@@ -326,9 +360,13 @@ encodeUtf8BuilderEscaped be =
326360 where
327361 bound = max 4 $ BP.sizeBound be
328362
329− mkBuildstep (Text arr off len) !k =
363+ mkBuildstep (Text t) !k =
364+ -- mkBuildstep (Text arr off len) !k =
330365 outerLoop off
331366 where
367+ off = 0
368+ (arr, len) = let (# ba, len' #) = js_fromString t
369+ in (A.Array ba, I# len')
332370 iend = off + len
333371
334372 outerLoop !i0 !br@(B.BufferRange op0 ope)
@@ -368,24 +406,27 @@ encodeUtf8BuilderEscaped be =
368406 where
369407 poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8)
370408
409+
410+
371411-- | Encode text using UTF-8 encoding.
372412encodeUtf8 :: Text -> ByteString
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)
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)
389430
390431-- | Decode text from little endian UTF-16 encoding.
391432decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
@@ -463,17 +504,17 @@ encodeUtf32BE :: Text -> ByteString
463504encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt))
464505{-# INLINE encodeUtf32BE #-}
465506
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)
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)
469510
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)
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)
474515
475−foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
476− :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
516+-- foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
517+-- :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
477518
478−foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
479− :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()
519+-- foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
520+-- :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()
Data/Text/IO.hs+16
@@ -185,7 +185,11 @@ hPutStr h t = do
185185 | otherwise -> writeBlocksRaw h buf str
186186
187187hPutChars :: Handle -> Stream Char -> IO ()
188+#ifndef __GHCJS__
188189hPutChars h (Stream next0 s0 _len) = loop s0
190+#else
191+hPutChars h (Stream next0 s0) = loop s0
192+#endif
189193 where
190194 loop !s = case next0 s of
191195 Done -> return ()
@@ -203,7 +207,11 @@ hPutChars h (Stream next0 s0 _len) = loop s0
203207-- handling gave a few more percent on top.
204208
205209writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO ()
210+#ifndef __GHCJS__
206211writeLines 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
207215 where
208216 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
209217 where
@@ -223,7 +231,11 @@ writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0
223231 commit = commitBuffer h raw len
224232
225233writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
234+#ifndef __GHCJS__
226235writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
236+#else
237+writeBlocksCRLF h buf0 (Stream next0 s0) = outer s0 buf0
238+#endif
227239 where
228240 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
229241 where
@@ -239,7 +251,11 @@ writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
239251 commit = commitBuffer h raw len
240252
241253writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
254+#ifndef __GHCJS__
242255writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
256+#else
257+writeBlocksRaw h buf0 (Stream next0 s0) = outer s0 buf0
258+#endif
243259 where
244260 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
245261 where
Data/Text/Internal.hs+42−125
@@ -1,127 +1,61 @@
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−
1+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples, MagicHash,
2+ BangPatterns, ForeignFunctionInterface, JavaScriptFFI, GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes,
4+ GHCForeignImportPrim, MagicHash, FlexibleInstances #-}
275module Data.Text.Internal
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
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
4924
50−#if defined(ASSERTS)
51−import Control.Exception (assert)
52−#endif
5325import Data.Bits
5426import Data.Int (Int32, Int64)
55−import Data.Text.Internal.Unsafe.Char (ord)
27+-- import Data.Text.Internal.Unsafe.Char (ord)
5628import Data.Typeable (Typeable)
57−import qualified Data.Text.Array as A
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
5833
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)
6534
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_ #-}
35+newtype Text = Text JSString
36+ deriving ( Show, Eq, Ord, IsString, Monoid, Read, Data
37+ , PToJSVal, PFromJSVal, FromJSVal, ToJSVal
38+ )
7939
80−-- | /O(1)/ The empty 'Text'.
8140empty :: Text
82−empty = Text A.empty 0 0
41+empty = Text JSS.empty
8342{-# INLINE [1] empty #-}
8443
85−-- | A non-inlined version of 'empty'.
8644empty_ :: Text
87−empty_ = Text A.empty 0 0
45+empty_ = Text JSS.empty
8846{-# NOINLINE empty_ #-}
8947
48+foreign import javascript unsafe
49+ "String.fromCharCode.apply(null, $1['u8'])"
50+ js_decodeBytes :: ByteArray# -> JSString
51+
9052-- | Construct a 'Text' without invisibly pinning its byte array in
9153-- memory if its length has dwindled to zero.
9254text :: A.Array -> Int -> Int -> Text
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
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)
12559
12660-- | Checked multiplication. Calls 'error' if the result would
12761-- overflow.
@@ -168,21 +102,4 @@ mul32 a b = case fromIntegral a * fromIntegral b of
168102{-# INLINE mul32 #-}
169103infixl 7 `mul32`
170104
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.
105+--------------------------------------
Data/Text/Internal/Builder.hs+47−5
@@ -1,4 +1,6 @@
11{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, UnboxedTuples,
3+ MagicHash #-}
24{-# OPTIONS_HADDOCK not-home #-}
35
46-----------------------------------------------------------------------------
@@ -73,6 +75,8 @@ import qualified Data.Text as S
7375import qualified Data.Text.Array as A
7476import qualified Data.Text.Lazy as L
7577
78+import Data.JSString (JSString)
79+import GHC.Exts (ByteArray#, Int#, Int(I#))
7680------------------------------------------------------------------------
7781
7882-- | A @Builder@ is an efficient way to build lazy @Text@ values.
@@ -164,10 +168,17 @@ copyLimit = 128
164168-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
165169--
166170fromText :: S.Text -> Builder
167−fromText t@(Text arr off l)
171+fromText t@(Text t')
168172 | S.null t = empty
169173 | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
170174 | 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 :)
171182{-# INLINE [1] fromText #-}
172183
173184{-# RULES
@@ -182,10 +193,10 @@ fromText t@(Text arr off l)
182193fromString :: String -> Builder
183194fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
184195 let loop !marr !o !u !l [] = k (Buffer marr o u l)
185− loop marr o u l s@(c:cs)
196+ loop marr o@(I# o#) u@(I# u#) l s@(c:cs)
186197 | l <= 1 = do
187198 arr <- A.unsafeFreeze marr
188− let !t = Text arr o u
199+ let !t = Text $ js_toString (A.aBA arr) o# u#
189200 marr' <- A.new chunkSize
190201 ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
191202 return $ t : ts
@@ -195,6 +206,21 @@ fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
195206 in loop p0 o0 u0 l0 str
196207 where
197208 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
198224{-# INLINE fromString #-}
199225
200226-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
@@ -234,16 +260,24 @@ toLazyTextWith chunkSize m = L.fromChunks (runST $
234260-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
235261-- yielding a new chunk in the result lazy @Text@.
236262flush :: Builder
237−flush = Builder $ \ k buf@(Buffer p o u l) ->
263+flush = Builder $ \ k buf@(Buffer p o@(I# o#) u@(I# u#) l) ->
238264 if u == 0
239265 then k buf
240266 else do arr <- A.unsafeFreeze p
241267 let !b = Buffer p (o+u) 0 l
242− !t = Text arr o u
268+ !t = Text $ js_toString (A.aBA arr) o# u#
243269 ts <- inlineInterleaveST (k b)
244270 return $! t : ts
245271{-# INLINE [1] flush #-}
246272-- 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
247281
248282------------------------------------------------------------------------
249283
@@ -327,3 +361,11 @@ append' (Builder f) (Builder g) = Builder (f . g)
327361 append flush flush = flush
328362
329363 #-}
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+10−8
@@ -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,8 +166,10 @@ 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− let mlen = upperBound 4 len
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
171173 mallocByteString mlen >>= loop mlen 0 s0
172174 where
173175 loop !n !off !s fp = case next s of
Data/Text/Internal/Encoding/Fusion/Common.hs+8−4
@@ -37,7 +37,8 @@ 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)
40+-- restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
41+restreamUtf16BE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
4142 where
4243 next (RS0 s) = case next0 s of
4344 Done -> Done
@@ -61,7 +62,8 @@ restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
6162{-# INLINE restreamUtf16BE #-}
6263
6364restreamUtf16LE :: Stream Char -> Stream Word8
64−restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
65+-- restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
66+restreamUtf16LE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
6567 where
6668 next (RS0 s) = case next0 s of
6769 Done -> Done
@@ -85,7 +87,8 @@ restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
8587{-# INLINE restreamUtf16LE #-}
8688
8789restreamUtf32BE :: Stream Char -> Stream Word8
88−restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
90+restreamUtf32BE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
91+-- restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
8992 where
9093 next (RS0 s) = case next0 s of
9194 Done -> Done
@@ -104,7 +107,8 @@ restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
104107{-# INLINE restreamUtf32BE #-}
105108
106109restreamUtf32LE :: Stream Char -> Stream Word8
107−restreamUtf32LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
110+restreamUtf32LE (Stream next0 s0) = Stream next (RS0 s0) -- (len * 2)
111+-- restreamUtf32LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
108112 where
109113 next (RS0 s) = case next0 s of
110114 Done -> Done
Data/Text/Internal/Fusion.hs+42−180
@@ -28,217 +28,79 @@ module Data.Text.Internal.Fusion
2828 , unstream
2929 , reverseStream
3030
31− , length
31+ , Data.Text.Internal.Fusion.length
3232
3333 -- * Transformations
34− , reverse
34+ , Data.Text.Internal.Fusion.reverse
3535
3636 -- * Construction
3737 -- ** Scans
3838 , reverseScanr
3939
4040 -- ** Accumulating maps
41− , mapAccumL
41+ , Data.Text.Internal.Fusion.mapAccumL
4242
4343 -- ** Generation and unfolding
4444 , unfoldrN
4545
4646 -- * Indexing
47− , index
48− , findIndex
47+ , Data.Text.Internal.Fusion.index
48+ , Data.Text.Internal.Fusion.findIndex
4949 , countChar
5050 ) where
5151
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
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(..))
6670
6771default(Int)
6872
69−-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
7073stream :: Text -> Stream Char
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.
74+stream = coerce JSS.stream
75+
8576reverseStream :: Text -> Stream Char
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'.
77+reverseStream = coerce JSS.reverseStream
78+
9979unstream :: Stream Char -> Text
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
80+unstream = coerce JSS.unstream
13681
13782length :: Stream Char -> Int
138−length = S.lengthI
139−{-# INLINE[0] length #-}
83+length = JSS.length
14084
141−-- | /O(n)/ Reverse the characters of a string.
14285reverse :: Stream Char -> Text
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.
86+reverse = coerce JSS.reverse
87+
17888reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
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.
194−unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
195−unfoldrN n = S.unfoldrNI n
196−{-# INLINE [0] unfoldrN #-}
89+reverseScanr = JSS.reverseScanr
19790
198−-------------------------------------------------------------------------------
199−-- ** Indexing streams
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+
96+unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
97+unfoldrN = JSS.unfoldrN
20098
201−-- | /O(n)/ stream index (subscript) operator, starting from 0.
20299index :: Stream Char -> Int -> Char
203−index = S.indexI
204−{-# INLINE [0] index #-}
100+index = JSS.index
205101
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.
209102findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
210−findIndex = S.findIndexI
211−{-# INLINE [0] findIndex #-}
103+findIndex = JSS.findIndex
212104
213−-- | /O(n)/ The 'count' function returns the number of times the query
214−-- element appears in the given stream.
215105countChar :: Char -> Stream Char -> Int
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 #-}
106+countChar = JSS.countChar
Data/Text/Internal/Fusion/Common.hs+968−922
@@ -14,925 +14,971 @@
1414--
1515-- Common stream fusion functionality for text.
1616
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"
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"
Data/Text/Internal/Fusion/Types.hs+102−99
@@ -19,104 +19,107 @@
1919
2020module Data.Text.Internal.Fusion.Types
2121 (
22− CC(..)
23− , PairS(..)
24− , Scan(..)
25− , RS(..)
26− , Step(..)
27− , Stream(..)
28− , empty
22+ -- CC(..)
23+ -- , PairS(..)
24+ -- , Scan(..)
25+ -- , RS(..)
26+ -- , Step(..)
27+ -- , Stream(..)
28+ -- , empty
29+ module Data.JSString.Internal.Fusion.Types
2930 ) where
3031
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 #-}
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 #-}
Data/Text/Internal/IO.hs+8
@@ -95,7 +95,11 @@ unpack !buf !r !w
9595 | r >= w = return T.empty
9696 | otherwise = withRawBuffer buf go
9797 where
98+#ifndef __GHCJS__
9899 go pbuf = return $! unstream (Stream next r (exactSize (w-r)))
100+#else
101+ go pbuf = return $! unstream (Stream next r)
102+#endif
99103 where
100104 next !i | i >= w = Done
101105 | otherwise = Yield (ix i) (i+1)
@@ -108,7 +112,11 @@ unpack_nl !buf !r !w
108112 | otherwise = withRawBuffer buf $ go
109113 where
110114 go pbuf = do
115+#ifndef __GHCJS__
111116 let !t = unstream (Stream next r (maxSize (w-r)))
117+#else
118+ let !t = unstream (Stream next r)
119+#endif
112120 w' = w - 1
113121 return $ if ix w' == '\r'
114122 then (t,w')
Data/Text/Internal/Lazy.hs+18−10
@@ -44,6 +44,10 @@ 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+
4751data Text = Empty
4852 | Chunk {-# UNPACK #-} !T.Text Text
4953 deriving (Typeable)
@@ -57,18 +61,20 @@ data Text = Empty
5761-- | Check the invariant strictly.
5862strictInvariant :: Text -> Bool
5963strictInvariant Empty = True
60−strictInvariant x@(Chunk (T.Text _ _ len) cs)
61− | len > 0 = strictInvariant cs
62− | otherwise = error $ "Data.Text.Lazy: invariant violation: "
63− ++ showStructure x
64+-- 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
6469
6570-- | Check the invariant lazily.
6671lazyInvariant :: Text -> Text
6772lazyInvariant Empty = Empty
68−lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)
69− | len > 0 = Chunk c (lazyInvariant cs)
70− | otherwise = error $ "Data.Text.Lazy: invariant violation: "
71− ++ showStructure x
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
7278
7379-- | Display the internal structure of a lazy 'Text'.
7480showStructure :: Text -> String
@@ -80,8 +86,10 @@ showStructure (Chunk t ts) =
8086-- | Smart constructor for 'Chunk'. Guarantees the data type invariant.
8187chunk :: T.Text -> Text -> Text
8288{-# INLINE chunk #-}
83−chunk t@(T.Text _ _ len) ts | len == 0 = ts
84− | otherwise = Chunk t ts
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
8593
8694-- | Smart constructor for 'Empty'.
8795empty :: Text
Data/Text/Internal/Lazy/Encoding/Fusion.hs+26
@@ -38,7 +38,9 @@ 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__
4142import Data.Text.Internal.Fusion.Size
43+#endif
4244import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
4345import Data.Text.Internal.Unsafe.Shift (shiftL)
4446import Data.Word (Word8, Word16, Word32)
@@ -65,7 +67,11 @@ data T = T !ByteString !S {-# UNPACK #-} !Int
6567-- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using
6668-- UTF-8 encoding.
6769streamUtf8 :: OnDecodeError -> ByteString -> Stream Char
70+#ifndef __GHCJS__
6871streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize
72+#else
73+streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
74+#endif
6975 where
7076 next (T bs@(Chunk ps _) S0 i)
7177 | i < len && U8.validate1 a =
@@ -107,7 +113,11 @@ streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize
107113-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
108114-- endian UTF-16 encoding.
109115streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char
116+#ifndef __GHCJS__
110117streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
118+#else
119+streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
120+#endif
111121 where
112122 next (T bs@(Chunk ps _) S0 i)
113123 | i + 1 < len && U16.validate1 x1 =
@@ -147,7 +157,11 @@ streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
147157-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
148158-- endian UTF-16 encoding.
149159streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char
160+#ifndef __GHCJS__
150161streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
162+#else
163+streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
164+#endif
151165 where
152166 next (T bs@(Chunk ps _) S0 i)
153167 | i + 1 < len && U16.validate1 x1 =
@@ -187,7 +201,11 @@ streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
187201-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
188202-- endian UTF-32 encoding.
189203streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char
204+#ifndef __GHCJS__
190205streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
206+#else
207+streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
208+#endif
191209 where
192210 next (T bs@(Chunk ps _) S0 i)
193211 | i + 3 < len && U32.validate x =
@@ -231,7 +249,11 @@ streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
231249-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
232250-- endian UTF-32 encoding.
233251streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char
252+#ifndef __GHCJS__
234253streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
254+#else
255+streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
256+#endif
235257 where
236258 next (T bs@(Chunk ps _) S0 i)
237259 | i + 3 < len && U32.validate x =
@@ -274,7 +296,11 @@ streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
274296
275297-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.
276298unstreamChunks :: Int -> Stream Word8 -> ByteString
299+#ifndef __GHCJS__
277300unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
301+#else
302+unstreamChunks chunkSize (Stream next s0) = chunk s0 4
303+#endif
278304 where chunk s1 len1 = unsafeDupablePerformIO $ do
279305 let len = max 4 (min len1 chunkSize)
280306 mallocByteString len >>= loop len 0 s1
Data/Text/Internal/Lazy/Fusion.hs+42−38
@@ -35,55 +35,59 @@ import qualified Data.Text.Internal as I
3535import qualified Data.Text.Array as A
3636import Data.Text.Internal.Unsafe.Char (unsafeWrite)
3737import Data.Text.Internal.Unsafe.Shift (shiftL)
38−import Data.Text.Unsafe (Iter(..), iter)
38+-- import Data.Text.Unsafe (Iter(..), iter)
3939import Data.Int (Int64)
4040
4141default(Int64)
4242
43+-- TODO
4344-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
4445stream :: Text -> Stream Char
45−stream text = Stream next (text :*: 0) unknownSize
46− where
47− next (Empty :*: _) = Done
48− next (txt@(Chunk t@(I.Text _ _ len) ts) :*: i)
49− | i >= len = next (ts :*: 0)
50− | otherwise = Yield c (txt :*: i+d)
51− where Iter c d = iter t i
46+stream = undefined
47+-- stream text = Stream next (text :*: 0) unknownSize
48+-- where
49+-- next (Empty :*: _) = Done
50+-- next (txt@(Chunk t@(I.Text _ _ len) ts) :*: i)
51+-- | i >= len = next (ts :*: 0)
52+-- | otherwise = Yield c (txt :*: i+d)
53+ -- where Iter c d = iter t i
5254{-# INLINE [0] stream #-}
5355
56+-- TODO
5457-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given
5558-- chunk size.
5659unstreamChunks :: Int -> Stream Char -> Text
57−unstreamChunks !chunkSize (Stream next s0 len0)
58− | isEmpty len0 = Empty
59− | otherwise = outer s0
60− where
61− outer so = {-# SCC "unstreamChunks/outer" #-}
62− case next so of
63− Done -> Empty
64− Skip s' -> outer s'
65− Yield x s' -> runST $ do
66− a <- A.new unknownLength
67− unsafeWrite a 0 x >>= inner a unknownLength s'
68− where unknownLength = 4
69− where
70− inner marr !len s !i
71− | i + 1 >= chunkSize = finish marr i s
72− | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
73− let newLen = min (len `shiftL` 1) chunkSize
74− marr' <- A.new newLen
75− A.copyM marr' 0 marr 0 len
76− inner marr' newLen s i
77− | otherwise =
78− {-# SCC "unstreamChunks/inner" #-}
79− case next s of
80− Done -> finish marr i s
81− Skip s' -> inner marr len s' i
82− Yield x s' -> do d <- unsafeWrite marr i x
83− inner marr len s' (i+d)
84− finish marr len s' = do
85− arr <- A.unsafeFreeze marr
86− return (I.Text arr 0 len `Chunk` outer s')
60+unstreamChunks = undefined
61+-- unstreamChunks !chunkSize (Stream next s0 len0)
62+-- | isEmpty len0 = Empty
63+-- | otherwise = outer s0
64+-- where
65+-- outer so = {-# SCC "unstreamChunks/outer" #-}
66+-- case next so of
67+-- Done -> Empty
68+-- Skip s' -> outer s'
69+-- Yield x s' -> runST $ do
70+-- a <- A.new unknownLength
71+-- unsafeWrite a 0 x >>= inner a unknownLength s'
72+-- where unknownLength = 4
73+-- where
74+-- inner marr !len s !i
75+-- | i + 1 >= chunkSize = finish marr i s
76+-- | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
77+-- let newLen = min (len `shiftL` 1) chunkSize
78+-- marr' <- A.new newLen
79+-- A.copyM marr' 0 marr 0 len
80+-- inner marr' newLen s i
81+-- | otherwise =
82+-- {-# SCC "unstreamChunks/inner" #-}
83+-- case next s of
84+-- Done -> finish marr i s
85+-- Skip s' -> inner marr len s' i
86+-- Yield x s' -> do d <- unsafeWrite marr i x
87+-- inner marr len s' (i+d)
88+-- finish marr len s' = do
89+-- arr <- A.unsafeFreeze marr
90+-- return (I.Text arr 0 len `Chunk` outer s')
8791{-# INLINE [0] unstreamChunks #-}
8892
8993-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using
Data/Text/Internal/Lazy/Search.hs+55−11
@@ -1,4 +1,7 @@
11{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI,
3+ UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim,
4+ MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-}
25
36-- |
47-- Module : Data.Text.Lazy.Search
@@ -31,6 +34,17 @@ import Data.Text.Internal.Lazy (Text(..), foldlChunks)
3134import Data.Bits ((.|.), (.&.))
3235import Data.Text.Internal.Unsafe.Shift (shiftL)
3336
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+
3448-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
3549-- @needle@ within @haystack@.
3650--
@@ -47,8 +61,10 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
4761 | nlen == 1 = indicesOne (nindex 0) 0 k ks
4862 | otherwise = advance k ks 0 0
4963 where
50− advance x@(T.Text _ _ l) xs = scan
64+ -- advance x@(T.Text _ _ l) xs = scan
65+ advance x xs = scan
5166 where
67+ l = TT.length x
5268 scan !g !i
5369 | i >= m = case xs of
5470 Empty -> []
@@ -72,11 +88,23 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
7288 nlast = nlen - 1
7389 nindex = index n ns
7490 z = foldlChunks fin 0 needle
75− where fin _ (T.Text farr foff flen) = A.unsafeIndex farr (foff+flen-1)
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)
7699 (mask :: Word64) :*: skip = buildTable n ns 0 0 0 (nlen-2)
77100 swizzle w = 1 `shiftL` (fromIntegral w .&. 0x3f)
78− buildTable (T.Text xarr xoff xlen) xs = go
101+ -- buildTable (T.Text xarr xoff xlen) xs = go
102+ buildTable t xs = go
79103 where
104+ xoff = 0
105+ (xarr, xlen) =
106+ let (# ba, len #) = fromString t
107+ in (A.Array ba, I# len)
80108 go !(g::Int64) !i !msk !skp
81109 | i >= xlast = case xs of
82110 Empty -> (msk .|. swizzle z) :*: skp
@@ -91,17 +119,22 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
91119 -- given offset would fail.
92120 lackingHay q = go 0
93121 where
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
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+
98130indices _ _ = []
99131
100132-- | Fast index into a partly unpacked 'Text'. We take into account
101133-- the possibility that the caller might try to access one element
102134-- past the end.
103135index :: T.Text -> Text -> Int64 -> Word16
104−index (T.Text arr off len) xs !i
136+-- index (T.Text arr off len) xs !i
137+index t xs !i
105138 | j < len = A.unsafeIndex arr (off+j)
106139 | otherwise = case xs of
107140 Empty
@@ -110,14 +143,24 @@ index (T.Text arr off len) xs !i
110143 -- should never happen, due to lackingHay above
111144 | otherwise -> emptyError "index"
112145 Chunk c cs -> index c cs (i-fromIntegral len)
113− where j = fromIntegral i
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')
114152
115153-- | A variant of 'indices' that scans linearly for a single 'Word16'.
116154indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64]
117155indicesOne c = chunk
118156 where
119− chunk !i (T.Text oarr ooff olen) os = go 0
157+ -- chunk !i (T.Text oarr ooff olen) os = go 0
158+ chunk !i t os = go 0
120159 where
160+ ooff = 0
161+ (oarr, olen) =
162+ let (# ba, len #) = fromString t
163+ in (A.Array ba, I# len)
121164 go h | h >= olen = case os of
122165 Empty -> []
123166 Chunk y ys -> chunk (i+fromIntegral olen) y ys
@@ -128,7 +171,8 @@ indicesOne c = chunk
128171-- | The number of 'Word16' values in a 'Text'.
129172wordLength :: Text -> Int64
130173wordLength = foldlChunks sumLength 0
131− where sumLength i (T.Text _ _ l) = i + fromIntegral l
174+ where sumLength i t = i + fromIntegral (TT.length t)
175+ -- where sumLength i (T.Text _ _ l) = i + fromIntegral l
132176
133177emptyError :: String -> a
134178emptyError fun = error ("Data.Text.Lazy.Search." ++ fun ++ ": empty input")
Data/Text/Internal/Private.hs+8−1
@@ -1,4 +1,4 @@
1−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}
1+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, CPP #-}
22
33-- |
44-- Module : Data.Text.Internal.Private
@@ -19,8 +19,12 @@ 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
2225
2326span_ :: (Char -> Bool) -> Text -> (# Text, Text #)
27+#ifndef __GHCJS__
2428span_ p t@(Text arr off len) = (# hd,tl #)
2529 where hd = text arr off k
2630 tl = text arr (off+k) (len-k)
@@ -28,6 +32,9 @@ span_ p t@(Text arr off len) = (# hd,tl #)
2832 loop !i | i < len && p c = loop (i+d)
2933 | otherwise = i
3034 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
3138{-# INLINE span_ #-}
3239
3340runText :: (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text
Data/Text/Internal/Search.hs+40−37
@@ -37,6 +37,8 @@ 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+
4042data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
4143
4244-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
@@ -49,41 +51,42 @@ data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
4951indices :: Text -- ^ Substring to search for (@needle@)
5052 -> Text -- ^ Text to search in (@haystack@)
5153 -> [Int]
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)
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)
8992{-# INLINE indices #-}
Data/Text/Lazy.hs+58−52
@@ -301,15 +301,16 @@ equal :: Text -> Text -> Bool
301301equal Empty Empty = True
302302equal Empty _ = False
303303equal _ Empty = False
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
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
313314
314315instance Eq Text where
315316 (==) = equal
@@ -322,18 +323,19 @@ compareText :: Text -> Text -> Ordering
322323compareText Empty Empty = EQ
323324compareText Empty _ = LT
324325compareText _ Empty = GT
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
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
337339
338340instance Show Text where
339341 showsPrec p ps r = showsPrec p (unpack ps) r
@@ -545,7 +547,7 @@ tail Empty = emptyError "tail"
545547 unstream (S.tail (stream t)) = tail t
546548 #-}
547549
548−-- | /O(n\/c)/ Returns all but the last character of a 'Text', which must
550+-- | /O(1)/ Returns all but the last character of a 'Text', which must
549551-- be non-empty. Subject to fusion.
550552init :: Text -> Text
551553init (Chunk t0 ts0) = go t0 ts0
@@ -581,7 +583,7 @@ isSingleton :: Text -> Bool
581583isSingleton = S.isSingleton . stream
582584{-# INLINE isSingleton #-}
583585
584−-- | /O(n\/c)/ Returns the last character of a 'Text', which must be
586+-- | /O(1)/ Returns the last character of a 'Text', which must be
585587-- non-empty. Subject to fusion.
586588last :: Text -> Char
587589last Empty = emptyError "last"
@@ -1114,16 +1116,17 @@ dropEnd n t0
11141116-- values dropped, or the empty 'Text' if @n@ is greater than the
11151117-- number of 'Word16' values present.
11161118dropWords :: Int64 -> Text -> Text
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
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
11271130
11281131-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
11291132-- returns the longest prefix (possibly empty) of elements that
@@ -1244,12 +1247,13 @@ splitAt = loop
12441247-- values, and whose second is the remainder of the string.
12451248splitAtWord :: Int64 -> Text -> PairS Text Text
12461249splitAtWord _ Empty = empty :*: empty
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
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
12531257
12541258-- | /O(n+m)/ Find the first instance of @needle@ (which must be
12551259-- non-'null') in @haystack@. The first element of the returned tuple
@@ -1421,15 +1425,16 @@ splitOn :: Text
14211425 -> Text
14221426 -- ^ Input text.
14231427 -> [Text]
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
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
14331438{-# INLINE [1] splitOn #-}
14341439
14351440{-# RULES
@@ -1531,10 +1536,11 @@ isSuffixOf x y = reverse x `isPrefixOf` reverse y
15311536-- In (unlikely) bad cases, this function's time complexity degrades
15321537-- towards /O(n*m)/.
15331538isInfixOf :: Text -> Text -> Bool
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
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
15381544{-# INLINE [1] isInfixOf #-}
15391545
15401546{-# RULES
Data/Text/Lazy/Builder/Int.hs+9−259
@@ -1,262 +1,12 @@
1−{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, ScopedTypeVariables,
2− UnboxedTuples #-}
3−#if __GLASGOW_HASKELL__ >= 702
4−{-# LANGUAGE Trustworthy #-}
5−#endif
1+module Data.Text.Lazy.Builder.Int where
62
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
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
519
5210decimal :: Integral a => a -> Builder
53−{-# RULES "decimal/Int8" decimal = boundedDecimal :: Int8 -> Builder #-}
54−{-# RULES "decimal/Int" decimal = boundedDecimal :: Int -> Builder #-}
55−{-# RULES "decimal/Int16" decimal = boundedDecimal :: Int16 -> Builder #-}
56−{-# RULES "decimal/Int32" decimal = boundedDecimal :: Int32 -> Builder #-}
57−{-# RULES "decimal/Int64" decimal = boundedDecimal :: Int64 -> Builder #-}
58−{-# RULES "decimal/Word" decimal = positive :: Data.Word.Word -> Builder #-}
59−{-# RULES "decimal/Word8" decimal = positive :: Word8 -> Builder #-}
60−{-# RULES "decimal/Word16" decimal = positive :: Word16 -> Builder #-}
61−{-# RULES "decimal/Word32" decimal = positive :: Word32 -> Builder #-}
62−{-# RULES "decimal/Word64" decimal = positive :: Word64 -> Builder #-}
63−{-# RULES "decimal/Integer" decimal = integer 10 :: Integer -> Builder #-}
64−decimal i = decimal' (<= -128) i
65−{-# NOINLINE decimal #-}
66−
67−boundedDecimal :: (Integral a, Bounded a) => a -> Builder
68−{-# SPECIALIZE boundedDecimal :: Int -> Builder #-}
69−{-# SPECIALIZE boundedDecimal :: Int8 -> Builder #-}
70−{-# SPECIALIZE boundedDecimal :: Int16 -> Builder #-}
71−{-# SPECIALIZE boundedDecimal :: Int32 -> Builder #-}
72−{-# SPECIALIZE boundedDecimal :: Int64 -> Builder #-}
73−boundedDecimal i = decimal' (== minBound) i
74−
75−decimal' :: (Integral a) => (a -> Bool) -> a -> Builder
76−{-# INLINE decimal' #-}
77−decimal' p i
78− | i < 0 = if p i
79− then let (q, r) = i `quotRem` 10
80− qq = -q
81− !n = countDigits qq
82− in writeN (n + 2) $ \marr off -> do
83− unsafeWrite marr off minus
84− posDecimal marr (off+1) n qq
85− unsafeWrite marr (off+n+1) (i2w (-r))
86− else let j = -i
87− !n = countDigits j
88− in writeN (n + 1) $ \marr off ->
89− unsafeWrite marr off minus >> posDecimal marr (off+1) n j
90− | otherwise = positive i
91−
92−positive :: (Integral a) => a -> Builder
93−{-# SPECIALIZE positive :: Int -> Builder #-}
94−{-# SPECIALIZE positive :: Int8 -> Builder #-}
95−{-# SPECIALIZE positive :: Int16 -> Builder #-}
96−{-# SPECIALIZE positive :: Int32 -> Builder #-}
97−{-# SPECIALIZE positive :: Int64 -> Builder #-}
98−{-# SPECIALIZE positive :: Word -> Builder #-}
99−{-# SPECIALIZE positive :: Word8 -> Builder #-}
100−{-# SPECIALIZE positive :: Word16 -> Builder #-}
101−{-# SPECIALIZE positive :: Word32 -> Builder #-}
102−{-# SPECIALIZE positive :: Word64 -> Builder #-}
103−positive i
104− | i < 10 = writeN 1 $ \marr off -> unsafeWrite marr off (i2w i)
105− | otherwise = let !n = countDigits i
106− in writeN n $ \marr off -> posDecimal marr off n i
107−
108−posDecimal :: (Integral a) =>
109− forall s. MArray s -> Int -> Int -> a -> ST s ()
110−{-# INLINE posDecimal #-}
111−posDecimal marr off0 ds v0 = go (off0 + ds - 1) v0
112− where go off v
113− | v >= 100 = do
114− let (q, r) = v `quotRem` 100
115− write2 off r
116− go (off - 2) q
117− | v < 10 = unsafeWrite marr off (i2w v)
118− | otherwise = write2 off v
119− write2 off i0 = do
120− let i = fromIntegral i0; j = i + i
121− unsafeWrite marr off $ get (j + 1)
122− unsafeWrite marr (off - 1) $ get j
123− get = fromIntegral . B.unsafeIndex digits
124−
125−minus, zero :: Word16
126−{-# INLINE minus #-}
127−{-# INLINE zero #-}
128−minus = 45
129−zero = 48
130−
131−i2w :: (Integral a) => a -> Word16
132−{-# INLINE i2w #-}
133−i2w v = zero + fromIntegral v
134−
135−countDigits :: (Integral a) => a -> Int
136−{-# INLINE countDigits #-}
137−countDigits v0
138− | fromIntegral v64 == v0 = go 1 v64
139− | otherwise = goBig 1 (fromIntegral v0)
140− where v64 = fromIntegral v0
141− goBig !k (v :: Integer)
142− | v > big = goBig (k + 19) (v `quot` big)
143− | otherwise = go k (fromIntegral v)
144− big = 10000000000000000000
145− go !k (v :: Word64)
146− | v < 10 = k
147− | v < 100 = k + 1
148− | v < 1000 = k + 2
149− | v < 1000000000000 =
150− k + if v < 100000000
151− then if v < 1000000
152− then if v < 10000
153− then 3
154− else 4 + fin v 100000
155− else 6 + fin v 10000000
156− else if v < 10000000000
157− then 8 + fin v 1000000000
158− else 10 + fin v 100000000000
159− | otherwise = go (k + 12) (v `quot` 1000000000000)
160− fin v n = if v >= n then 1 else 0
161−
162−hexadecimal :: Integral a => a -> Builder
163−{-# SPECIALIZE hexadecimal :: Int -> Builder #-}
164−{-# SPECIALIZE hexadecimal :: Int8 -> Builder #-}
165−{-# SPECIALIZE hexadecimal :: Int16 -> Builder #-}
166−{-# SPECIALIZE hexadecimal :: Int32 -> Builder #-}
167−{-# SPECIALIZE hexadecimal :: Int64 -> Builder #-}
168−{-# SPECIALIZE hexadecimal :: Word -> Builder #-}
169−{-# SPECIALIZE hexadecimal :: Word8 -> Builder #-}
170−{-# SPECIALIZE hexadecimal :: Word16 -> Builder #-}
171−{-# SPECIALIZE hexadecimal :: Word32 -> Builder #-}
172−{-# SPECIALIZE hexadecimal :: Word64 -> Builder #-}
173−{-# RULES "hexadecimal/Integer"
174− hexadecimal = hexInteger :: Integer -> Builder #-}
175−hexadecimal i
176− | i < 0 = error hexErrMsg
177− | otherwise = go i
178− where
179− go n | n < 16 = hexDigit n
180− | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16)
181−{-# NOINLINE[0] hexadecimal #-}
182−
183−hexInteger :: Integer -> Builder
184−hexInteger i
185− | i < 0 = error hexErrMsg
186− | otherwise = integer 16 i
187−
188−hexErrMsg :: String
189−hexErrMsg = "Data.Text.Lazy.Builder.Int.hexadecimal: applied to negative number"
190−
191−hexDigit :: Integral a => a -> Builder
192−hexDigit n
193− | n <= 9 = singleton $! i2d (fromIntegral n)
194− | otherwise = singleton $! toEnum (fromIntegral n + 87)
195−{-# INLINE hexDigit #-}
196−
197−data T = T !Integer !Int
198−
199−integer :: Int -> Integer -> Builder
200−#ifdef INTEGER_GMP
201−integer 10 (S# i#) = decimal (I# i#)
202−integer 16 (S# i#) = hexadecimal (I# i#)
203−#endif
204−integer base i
205− | i < 0 = singleton '-' <> go (-i)
206− | otherwise = go i
207− where
208− go n | n < maxInt = int (fromInteger n)
209− | otherwise = putH (splitf (maxInt * maxInt) n)
210−
211− splitf p n
212− | p > n = [n]
213− | otherwise = splith p (splitf (p*p) n)
214−
215− splith p (n:ns) = case n `quotRemInteger` p of
216− PAIR(q,r) | q > 0 -> q : r : splitb p ns
217− | otherwise -> r : splitb p ns
218− splith _ _ = error "splith: the impossible happened."
219−
220− splitb p (n:ns) = case n `quotRemInteger` p of
221− PAIR(q,r) -> q : r : splitb p ns
222− splitb _ _ = []
223−
224− T maxInt10 maxDigits10 =
225− until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)
226− where mi = fromIntegral (maxBound :: Int)
227− T maxInt16 maxDigits16 =
228− until ((>mi) . (*16) . fstT) (\(T n d) -> T (n*16) (d+1)) (T 16 1)
229− where mi = fromIntegral (maxBound :: Int)
230−
231− fstT (T a _) = a
232−
233− maxInt | base == 10 = maxInt10
234− | otherwise = maxInt16
235− maxDigits | base == 10 = maxDigits10
236− | otherwise = maxDigits16
237−
238− putH (n:ns) = case n `quotRemInteger` maxInt of
239− PAIR(x,y)
240− | q > 0 -> int q <> pblock r <> putB ns
241− | otherwise -> int r <> putB ns
242− where q = fromInteger x
243− r = fromInteger y
244− putH _ = error "putH: the impossible happened"
245−
246− putB (n:ns) = case n `quotRemInteger` maxInt of
247− PAIR(x,y) -> pblock q <> pblock r <> putB ns
248− where q = fromInteger x
249− r = fromInteger y
250− putB _ = Data.Monoid.mempty
251−
252− int :: Int -> Builder
253− int x | base == 10 = decimal x
254− | otherwise = hexadecimal x
255−
256− pblock = loop maxDigits
257− where
258− loop !d !n
259− | d == 1 = hexDigit n
260− | otherwise = loop (d-1) q <> hexDigit r
261− where q = n `quotInt` base
262− r = n `remInt` base
11+-- decimal n = L.fromChunks [T.Text $ JSS.decimal n]
12+decimal _ = mempty
Data/Text/Lazy/Builder/RealFloat.hs+2−233
@@ -1,29 +1,4 @@
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
1+module Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) where
272
283-- | Control the rendering of floating point numbers.
294data FPFormat = Exponent
@@ -33,210 +8,4 @@ data FPFormat = Exponent
338 | Generic
349 -- ^ Use decimal notation for values between @0.1@ and
3510 -- @9,999,999@, and scientific notation otherwise.
36− deriving (Enum, Read, Show)
37−
38−-- | Show a signed 'RealFloat' value to full precision,
39−-- using standard decimal notation for arguments whose absolute value lies
40−-- between @0.1@ and @9,999,999@, and scientific notation otherwise.
41−realFloat :: (RealFloat a) => a -> Builder
42−{-# SPECIALIZE realFloat :: Float -> Builder #-}
43−{-# SPECIALIZE realFloat :: Double -> Builder #-}
44−realFloat x = formatRealFloat Generic Nothing x
45−
46−formatRealFloat :: (RealFloat a) =>
47− FPFormat
48− -> Maybe Int -- ^ Number of decimal places to render.
49− -> a
50− -> Builder
51−{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Float -> Builder #-}
52−{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Double -> Builder #-}
53−formatRealFloat fmt decs x
54− | isNaN x = "NaN"
55− | isInfinite x = if x < 0 then "-Infinity" else "Infinity"
56− | x < 0 || isNegativeZero x = singleton '-' <> doFmt fmt (floatToDigits (-x))
57− | otherwise = doFmt fmt (floatToDigits x)
58− where
59− doFmt format (is, e) =
60− let ds = map i2d is in
61− case format of
62− Generic ->
63− doFmt (if e < 0 || e > 7 then Exponent else Fixed)
64− (is,e)
65− Exponent ->
66− case decs of
67− Nothing ->
68− let show_e' = decimal (e-1) in
69− case ds of
70− "0" -> "0.0e0"
71− [d] -> singleton d <> ".0e" <> show_e'
72− (d:ds') -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> show_e'
73− [] -> error "formatRealFloat/doFmt/Exponent: []"
74− Just dec ->
75− let dec' = max dec 1 in
76− case is of
77− [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0"
78− _ ->
79− let
80− (ei,is') = roundTo (dec'+1) is
81− (d:ds') = map i2d (if ei > 0 then init is' else is')
82− in
83− singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei)
84− Fixed ->
85− let
86− mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls}
87− in
88− case decs of
89− Nothing
90− | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds
91− | otherwise ->
92− let
93− f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs
94− f n s "" = f (n-1) ('0':s) ""
95− f n s (r:rs) = f (n-1) (r:s) rs
96− in
97− f e "" ds
98− Just dec ->
99− let dec' = max dec 0 in
100− if e >= 0 then
101− let
102− (ei,is') = roundTo (dec' + e) is
103− (ls,rs) = splitAt (e+ei) (map i2d is')
104− in
105− mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs)
106− else
107− let
108− (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)
109− d:ds' = map i2d (if ei > 0 then is' else 0:is')
110− in
111− singleton d <> (if null ds' then "" else singleton '.' <> fromString ds')
112−
113−
114−-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
115−-- by R.G. Burger and R.K. Dybvig in PLDI 96.
116−-- This version uses a much slower logarithm estimator. It should be improved.
117−
118−-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,
119−-- and returns a list of digits and an exponent.
120−-- In particular, if @x>=0@, and
121−--
122−-- > floatToDigits base x = ([d1,d2,...,dn], e)
123−--
124−-- then
125−--
126−-- (1) @n >= 1@
127−--
128−-- (2) @x = 0.d1d2...dn * (base**e)@
129−--
130−-- (3) @0 <= di <= base-1@
131−
132−floatToDigits :: (RealFloat a) => a -> ([Int], Int)
133−{-# SPECIALIZE floatToDigits :: Float -> ([Int], Int) #-}
134−{-# SPECIALIZE floatToDigits :: Double -> ([Int], Int) #-}
135−floatToDigits 0 = ([0], 0)
136−floatToDigits x =
137− let
138− (f0, e0) = decodeFloat x
139− (minExp0, _) = floatRange x
140− p = floatDigits x
141− b = floatRadix x
142− minExp = minExp0 - p -- the real minimum exponent
143− -- Haskell requires that f be adjusted so denormalized numbers
144− -- will have an impossibly low exponent. Adjust for this.
145− (f, e) =
146− let n = minExp - e0 in
147− if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0)
148− (r, s, mUp, mDn) =
149− if e >= 0 then
150− let be = expt b e in
151− if f == expt b (p-1) then
152− (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig
153− else
154− (f*be*2, 2, be, be)
155− else
156− if e > minExp && f == expt b (p-1) then
157− (f*b*2, expt b (-e+1)*2, b, 1)
158− else
159− (f*2, expt b (-e)*2, 1, 1)
160− k :: Int
161− k =
162− let
163− k0 :: Int
164− k0 =
165− if b == 2 then
166− -- logBase 10 2 is very slightly larger than 8651/28738
167− -- (about 5.3558e-10), so if log x >= 0, the approximation
168− -- k1 is too small, hence we add one and need one fixup step less.
169− -- If log x < 0, the approximation errs rather on the high side.
170− -- That is usually more than compensated for by ignoring the
171− -- fractional part of logBase 2 x, but when x is a power of 1/2
172− -- or slightly larger and the exponent is a multiple of the
173− -- denominator of the rational approximation to logBase 10 2,
174− -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x,
175− -- we get a leading zero-digit we don't want.
176− -- With the approximation 3/10, this happened for
177− -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above.
178− -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x
179− -- for IEEE-ish floating point types with exponent fields
180− -- <= 17 bits and mantissae of several thousand bits, earlier
181− -- convergents to logBase 10 2 would fail for long double.
182− -- Using quot instead of div is a little faster and requires
183− -- fewer fixup steps for negative lx.
184− let lx = p - 1 + e0
185− k1 = (lx * 8651) `quot` 28738
186− in if lx >= 0 then k1 + 1 else k1
187− else
188− -- f :: Integer, log :: Float -> Float,
189− -- ceiling :: Float -> Int
190− ceiling ((log (fromInteger (f+1) :: Float) +
191− fromIntegral e * log (fromInteger b)) /
192− log 10)
193−--WAS: fromInt e * log (fromInteger b))
194−
195− fixup n =
196− if n >= 0 then
197− if r + mUp <= expt 10 n * s then n else fixup (n+1)
198− else
199− if expt 10 (-n) * (r + mUp) <= s then n else fixup (n+1)
200− in
201− fixup k0
202−
203− gen ds rn sN mUpN mDnN =
204− let
205− (dn, rn') = (rn * 10) `quotRem` sN
206− mUpN' = mUpN * 10
207− mDnN' = mDnN * 10
208− in
209− case (rn' < mDnN', rn' + mUpN' > sN) of
210− (True, False) -> dn : ds
211− (False, True) -> dn+1 : ds
212− (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
213− (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
214−
215− rds =
216− if k >= 0 then
217− gen [] r (s * expt 10 k) mUp mDn
218− else
219− let bk = expt 10 (-k) in
220− gen [] (r * bk) s (mUp * bk) (mDn * bk)
221− in
222− (map fromIntegral (reverse rds), k)
223−
224−-- Exponentiation with a cache for the most common numbers.
225−minExpt, maxExpt :: Int
226−minExpt = 0
227−maxExpt = 1100
228−
229−expt :: Integer -> Int -> Integer
230−expt base n
231− | base == 2 && n >= minExpt && n <= maxExpt = expts `unsafeAt` n
232− | base == 10 && n <= maxExpt10 = expts10 `unsafeAt` n
233− | otherwise = base^n
234−
235−expts :: Array Int Integer
236−expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
237−
238−maxExpt10 :: Int
239−maxExpt10 = 324
240−
241−expts10 :: Array Int Integer
242−expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]]
11+ deriving (Enum, Read, Show)
Data/Text/Unsafe.hs+87
@@ -1,4 +1,7 @@
11{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
2+#ifdef __GHCJS__
3+{-# LANGUAGE JavaScriptFFI, ForeignFunctionInterface, UnliftedFFITypes #-}
4+#endif
25-- |
36-- Module : Data.Text.Unsafe
47-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
@@ -32,31 +35,47 @@ import Control.Exception (assert)
3235import Data.Text.Internal.Encoding.Utf16 (chr2)
3336import Data.Text.Internal (Text(..))
3437import 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
3545import Data.Text.Internal.Unsafe.Char (unsafeChr)
3646import qualified Data.Text.Array as A
47+#endif
3748import GHC.IO (unsafeDupablePerformIO)
3849
3950-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
4051-- omits the check for the empty case, so there is an obligation on
4152-- the programmer to provide a proof that the 'Text' is non-empty.
4253unsafeHead :: Text -> Char
54+#ifndef __GHCJS__
4355unsafeHead (Text arr off _len)
4456 | m < 0xD800 || m > 0xDBFF = unsafeChr m
4557 | otherwise = chr2 m n
4658 where m = A.unsafeIndex arr off
4759 n = A.unsafeIndex arr (off+1)
60+#else
61+unsafeHead = coerce JSS.rawHead
62+#endif
4863{-# INLINE unsafeHead #-}
4964
5065-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeTail'
5166-- omits the check for the empty case, so there is an obligation on
5267-- the programmer to provide a proof that the 'Text' is non-empty.
5368unsafeTail :: Text -> Text
69+#ifndef __GHCJS__
5470unsafeTail t@(Text arr off len) =
5571#if defined(ASSERTS)
5672 assert (d <= len) $
5773#endif
5874 Text arr (off+d) (len-d)
5975 where d = iter_ t 0
76+#else
77+unsafeTail = coerce JSS.rawTail
78+#endif
6079{-# INLINE unsafeTail #-}
6180
6281data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
@@ -65,6 +84,7 @@ data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
6584-- array, returning the current character and the delta to add to give
6685-- the next offset to iterate at.
6786iter :: Text -> Int -> Iter
87+#ifndef __GHCJS__
6888iter (Text arr off _len) i
6989 | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1
7090 | otherwise = Iter (chr2 m n) 2
@@ -72,20 +92,40 @@ iter (Text arr off _len) i
7292 n = A.unsafeIndex arr k
7393 j = off + i
7494 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
75107{-# INLINE iter #-}
76108
77109-- | /O(1)/ Iterate one step through a UTF-16 array, returning the
78110-- delta to add to give the next offset to iterate at.
79111iter_ :: Text -> Int -> Int
112+#ifndef __GHCJS__
80113iter_ (Text arr off _len) i | m < 0xD800 || m > 0xDBFF = 1
81114 | otherwise = 2
82115 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
83122{-# INLINE iter_ #-}
84123
85124-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
86125-- returning the current character and the delta to add (i.e. a
87126-- negative number) to give the next offset to iterate at.
88127reverseIter :: Text -> Int -> (Char,Int)
128+#ifndef __GHCJS__
89129reverseIter (Text arr off _len) i
90130 | m < 0xDC00 || m > 0xDFFF = (unsafeChr m, -1)
91131 | otherwise = (chr2 n m, -2)
@@ -93,31 +133,78 @@ reverseIter (Text arr off _len) i
93133 n = A.unsafeIndex arr k
94134 j = off + i
95135 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
96148{-# INLINE reverseIter #-}
97149
98150-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
99151-- returning the delta to add (i.e. a negative number) to give the
100152-- next offset to iterate at.
101153reverseIter_ :: Text -> Int -> Int
154+#ifndef __GHCJS__
102155reverseIter_ (Text arr off _len) i
103156 | m < 0xDC00 || m > 0xDFFF = -1
104157 | otherwise = -2
105158 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
106167{-# INLINE reverseIter_ #-}
107168
108169-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This
109170-- is useful for sizing a target array appropriately before using
110171-- 'unsafeCopyToPtr'.
111172lengthWord16 :: Text -> Int
173+#ifndef __GHCJS__
112174lengthWord16 (Text _arr _off len) = len
175+#else
176+lengthWord16 (Text t) = js_length t
177+#endif
113178{-# INLINE lengthWord16 #-}
114179
115180-- | /O(1)/ Unchecked take of 'k' 'Word16's from the front of a 'Text'.
116181takeWord16 :: Int -> Text -> Text
182+#ifndef __GHCJS__
117183takeWord16 k (Text arr off _len) = Text arr off k
184+#else
185+takeWord16 k (Text txt) = Text $ js_take k txt
186+#endif
118187{-# INLINE takeWord16 #-}
119188
120189-- | /O(1)/ Unchecked drop of 'k' 'Word16's from the front of a 'Text'.
121190dropWord16 :: Int -> Text -> Text
191+#ifndef __GHCJS__
122192dropWord16 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
123196{-# 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+65−60
@@ -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,18 +124,23 @@ 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− other-modules:
132− Data.Text.Show
131+ -- moved from ghcjs-base
132+ -- reflex-dom depends in it
133+ Data.JSString.Text
134+ -- other-modules:
135+ -- Data.Text.Show
133136
134137 build-depends:
135− array >= 0.3,
138+ -- array >= 0.3,
136139 base >= 4.2 && < 5,
137140 binary,
138141 deepseq >= 1.1.0.0,
142+ ghcjs-base,
143+ ghcjs-prim,
139144 ghc-prim >= 0.2
140145
141146 if flag(bytestring-builder)
@@ -158,51 +163,51 @@ library
158163 cpp-options: -DINTEGER_GMP
159164 build-depends: integer-gmp >= 0.2
160165
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
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