on 90d36ec help sign in
Data/JSString/Text.hsnew file+64
since splitsnapshots
unifiedsplit
@@ -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+525−366
@@ -6,7 +6,7 @@
6#if __GLASGOW_HASKELL__ >= 708
6#if __GLASGOW_HASKELL__ >= 708
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8#endif
8#endif
9−
9+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
10-- |
10-- |
11-- Module : Data.Text
11-- Module : Data.Text
12-- Copyright : (c) 2009, 2010, 2011, 2012 Bryan O'Sullivan,
12-- Copyright : (c) 2009, 2010, 2011, 2012 Bryan O'Sullivan,
@@ -223,16 +223,16 @@ import qualified Data.Text.Internal.Fusion as S
223import qualified Data.Text.Internal.Fusion.Common as S
223import qualified Data.Text.Internal.Fusion.Common as S
224import Data.Text.Encoding (decodeUtf8', encodeUtf8)
224import Data.Text.Encoding (decodeUtf8', encodeUtf8)
225import Data.Text.Internal.Fusion (stream, reverseStream, unstream)
225import Data.Text.Internal.Fusion (stream, reverseStream, unstream)
226−import Data.Text.Internal.Private (span_)
226+-- import Data.Text.Internal.Private (span_)
227−import Data.Text.Internal (Text(..), empty, firstf, mul, safe, text)
227+import Data.Text.Internal (Text(..), empty, empty_, firstf, mul, safe, text)
228−import Data.Text.Show (singleton, unpack, unpackCString#)
228+-- import Data.Text.Show (singleton, unpack, unpackCString#)
229import qualified Prelude as P
229import qualified Prelude as P
230import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter,
230import Data.Text.Unsafe (Iter(..), iter, iter_, lengthWord16, reverseIter,
231 reverseIter_, unsafeHead, unsafeTail)
231 reverseIter_, unsafeHead, unsafeTail)
232import Data.Text.Internal.Unsafe.Char (unsafeChr)
232import Data.Text.Internal.Unsafe.Char (unsafeChr)
233import qualified Data.Text.Internal.Functions as F
233import qualified Data.Text.Internal.Functions as F
234import qualified Data.Text.Internal.Encoding.Utf16 as U16
234import qualified Data.Text.Internal.Encoding.Utf16 as U16
235−import Data.Text.Internal.Search (indices)
235+-- import Data.Text.Internal.Search (indices)
236#if defined(__HADDOCK__)
236#if defined(__HADDOCK__)
237import Data.ByteString (ByteString)
237import Data.ByteString (ByteString)
238import qualified Data.Text.Lazy as L
238import qualified Data.Text.Lazy as L
@@ -246,6 +246,53 @@ import qualified GHC.Exts as Exts
246import Text.Printf (PrintfArg, formatArg, formatString)
246import Text.Printf (PrintfArg, formatArg, formatString)
247#endif
247#endif
248
248
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+import qualified GHC.CString as GHC
257+
258+unpack :: Text -> String
259+unpack = coerce JSS.unpack
260+{-# INLINE [1] unpack #-}
261+
262+singleton :: Char -> Text
263+singleton = coerce JSS.singleton
264+{-# INLINE [1] singleton #-}
265+
266+{-# RULES
267+"JSSTRING singleton -> fused" [~1] forall a.
268+ singleton a = unstream (S.singleton (safe a))
269+"JSSTRING singleton -> unfused" [1] forall a.
270+ unstream (S.singleton (safe a)) = singleton a
271+ #-}
272+
273+-- | /O(n)/ Convert a literal string into a JSString. Subject to fusion.
274+unpackCString# :: Addr# -> Text
275+unpackCString# addr# = Text $ SJS.unstream (SJS.streamCString# addr#)
276+{-# NOINLINE unpackCString# #-}
277+
278+{-# RULES "TEXT literal" forall a.
279+ unstream (S.map safe (S.streamList (GHC.unpackCString# a)))
280+ = unpackCString# a #-}
281+
282+{-# RULES "TEXT literal UTF8" [1] forall a.
283+ unstream (S.map safe (S.streamList (GHC.unpackCStringUtf8# a)))
284+ = unpackCString# a #-}
285+
286+{-# RULES "TEXT empty literal" [1]
287+ unstream (S.map safe (S.streamList []))
288+ = empty_ #-}
289+
290+{-# RULES "TEXT singleton literal" [1] forall a.
291+ unstream (S.map safe (S.streamList [a]))
292+ = singleton a #-}
293+
294+---------------------------------------------------------------------
295+
249-- $strict
296-- $strict
250--
297--
251-- This package provides both strict and lazy 'Text' types. The
298-- This package provides both strict and lazy 'Text' types. The
@@ -321,17 +368,17 @@ import Text.Printf (PrintfArg, formatArg, formatString)
321-- Functions that can be fused by the compiler are documented with the
368-- Functions that can be fused by the compiler are documented with the
322-- phrase \"Subject to fusion\".
369-- phrase \"Subject to fusion\".
323
370
324−instance Eq Text where
371+-- instance Eq Text where
325− Text arrA offA lenA == Text arrB offB lenB
372+-- Text arrA offA lenA == Text arrB offB lenB
326− | lenA == lenB = A.equal arrA offA arrB offB lenA
373+-- | lenA == lenB = A.equal arrA offA arrB offB lenA
327− | otherwise = False
374+-- | otherwise = False
328− {-# INLINE (==) #-}
375+-- {-# INLINE (==) #-}
329
376
330−instance Ord Text where
377+-- instance Ord Text where
331− compare = compareText
378+-- compare = compareText
332
379
333−instance Read Text where
380+-- instance Read Text where
334− readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
381+-- readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str]
335
382
336#if MIN_VERSION_base(4,9,0)
383#if MIN_VERSION_base(4,9,0)
337-- Semigroup orphan instances for older GHCs are provided by
384-- Semigroup orphan instances for older GHCs are provided by
@@ -341,17 +388,17 @@ instance Semigroup Text where
341 (<>) = append
388 (<>) = append
342#endif
389#endif
343
390
344−instance Monoid Text where
391+-- instance Monoid Text where
345− mempty = empty
392+-- mempty = empty
346−#if MIN_VERSION_base(4,9,0)
393+-- #if MIN_VERSION_base(4,9,0)
347− mappend = (<>) -- future-proof definition
394+-- mappend = (<>) -- future-proof definition
348−#else
395+-- #else
349− mappend = append
396+-- mappend = append
350−#endif
397+-- #endif
351− mconcat = concat
398+-- mconcat = concat
352
399
353−instance IsString Text where
400+-- instance IsString Text where
354− fromString = pack
401+-- fromString = pack
355
402
356#if __GLASGOW_HASKELL__ >= 708
403#if __GLASGOW_HASKELL__ >= 708
357instance Exts.IsList Text where
404instance Exts.IsList Text where
@@ -387,18 +434,18 @@ instance Binary Text where
387-- and 'Data.Map.Map' is archived here:
434-- and 'Data.Map.Map' is archived here:
388-- <http://markmail.org/message/trovdc6zkphyi3cr#query:+page:1+mid:a46der3iacwjcf6n+state:results Proposal: Allow gunfold for Data.Map, ... >
435-- <http://markmail.org/message/trovdc6zkphyi3cr#query:+page:1+mid:a46der3iacwjcf6n+state:results Proposal: Allow gunfold for Data.Map, ... >
389
436
390−instance Data Text where
437+-- instance Data Text where
391− gfoldl f z txt = z pack `f` (unpack txt)
438+-- gfoldl f z txt = z pack `f` (unpack txt)
392− toConstr _ = packConstr
439+-- toConstr _ = packConstr
393− gunfold k z c = case constrIndex c of
440+-- gunfold k z c = case constrIndex c of
394− 1 -> k (z pack)
441+-- 1 -> k (z pack)
395− _ -> P.error "gunfold"
442+-- _ -> P.error "gunfold"
396− dataTypeOf _ = textDataType
443+-- dataTypeOf _ = textDataType
397
444
398#if MIN_VERSION_base(4,7,0)
445#if MIN_VERSION_base(4,7,0)
399-- | Only defined for @base-4.7.0.0@ and later
446-- | Only defined for @base-4.7.0.0@ and later
400instance PrintfArg Text where
447instance PrintfArg Text where
401− formatArg txt = formatString $ unpack txt
448+ formatArg t = formatString $ unpack t
402#endif
449#endif
403
450
404packConstr :: Constr
451packConstr :: Constr
@@ -407,19 +454,19 @@ packConstr = mkConstr textDataType "pack" [] Prefix
407textDataType :: DataType
454textDataType :: DataType
408textDataType = mkDataType "Data.Text.Text" [packConstr]
455textDataType = mkDataType "Data.Text.Text" [packConstr]
409
456
410−-- | /O(n)/ Compare two 'Text' values lexicographically.
457+-- -- | /O(n)/ Compare two 'Text' values lexicographically.
411−compareText :: Text -> Text -> Ordering
458+-- compareText :: Text -> Text -> Ordering
412−compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
459+-- compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
413− | lenA == 0 && lenB == 0 = EQ
460+-- | lenA == 0 && lenB == 0 = EQ
414− | otherwise = go 0 0
461+-- | otherwise = go 0 0
415− where
462+-- where
416− go !i !j
463+-- go !i !j
417− | i >= lenA || j >= lenB = compare lenA lenB
464+-- | i >= lenA || j >= lenB = compare lenA lenB
418− | a < b = LT
465+-- | a < b = LT
419− | a > b = GT
466+-- | a > b = GT
420− | otherwise = go (i+di) (j+dj)
467+-- | otherwise = go (i+di) (j+dj)
421− where Iter a di = iter ta i
468+-- where Iter a di = iter ta i
422− Iter b dj = iter tb j
469+-- Iter b dj = iter tb j
423
470
424-- -----------------------------------------------------------------------------
471-- -----------------------------------------------------------------------------
425-- * Conversion to/from 'Text'
472-- * Conversion to/from 'Text'
@@ -427,7 +474,8 @@ compareText ta@(Text _arrA _offA lenA) tb@(Text _arrB _offB lenB)
427-- | /O(n)/ Convert a 'String' into a 'Text'. Subject to
474-- | /O(n)/ Convert a 'String' into a 'Text'. Subject to
428-- fusion. Performs replacement on invalid scalar values.
475-- fusion. Performs replacement on invalid scalar values.
429pack :: String -> Text
476pack :: String -> Text
477+pack = coerce JSS.pack
430−pack = unstream . S.map safe . S.streamList
478+-- pack = unstream . S.map safe . S.streamList
431{-# INLINE [1] pack #-}
479{-# INLINE [1] pack #-}
432
480
433-- -----------------------------------------------------------------------------
481-- -----------------------------------------------------------------------------
@@ -438,7 +486,8 @@ pack = unstream . S.map safe . S.streamList
438-- copying a new array. Subject to fusion. Performs replacement on
486-- copying a new array. Subject to fusion. Performs replacement on
439-- invalid scalar values.
487-- invalid scalar values.
440cons :: Char -> Text -> Text
488cons :: Char -> Text -> Text
489+cons = coerce JSS.cons
441−cons c t = unstream (S.cons (safe c) (stream t))
490+-- cons c t = unstream (S.cons (safe c) (stream t))
442{-# INLINE cons #-}
491{-# INLINE cons #-}
443
492
444infixr 5 `cons`
493infixr 5 `cons`
@@ -447,25 +496,27 @@ infixr 5 `cons`
447-- entire array in the process, unless fused. Subject to fusion.
496-- entire array in the process, unless fused. Subject to fusion.
448-- Performs replacement on invalid scalar values.
497-- Performs replacement on invalid scalar values.
449snoc :: Text -> Char -> Text
498snoc :: Text -> Char -> Text
499+snoc = coerce JSS.snoc
450−snoc t c = unstream (S.snoc (stream t) (safe c))
500+-- snoc t c = unstream (S.snoc (stream t) (safe c))
451{-# INLINE snoc #-}
501{-# INLINE snoc #-}
452
502
453-- | /O(n)/ Appends one 'Text' to the other by copying both of them
503-- | /O(n)/ Appends one 'Text' to the other by copying both of them
454-- into a new 'Text'. Subject to fusion.
504-- into a new 'Text'. Subject to fusion.
455append :: Text -> Text -> Text
505append :: Text -> Text -> Text
506+append = coerce JSS.append
456−append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2)
507+-- append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2)
457− | len1 == 0 = b
508+-- | len1 == 0 = b
458− | len2 == 0 = a
509+-- | len2 == 0 = a
459− | len > 0 = Text (A.run x) 0 len
510+-- | len > 0 = Text (A.run x) 0 len
460− | otherwise = overflowError "append"
511+-- | otherwise = overflowError "append"
461− where
512+-- where
462− len = len1+len2
513+-- len = len1+len2
463− x :: ST s (A.MArray s)
514+-- x :: ST s (A.MArray s)
464− x = do
515+-- x = do
465− arr <- A.new len
516+-- arr <- A.new len
466− A.copyI arr 0 arr1 off1 len1
517+-- A.copyI arr 0 arr1 off1 len1
467− A.copyI arr len1 arr2 off2 len
518+-- A.copyI arr len1 arr2 off2 len
468− return arr
519+-- return arr
469{-# NOINLINE append #-}
520{-# NOINLINE append #-}
470
521
471{-# RULES
522{-# RULES
@@ -478,16 +529,18 @@ append a@(Text arr1 off1 len1) b@(Text arr2 off2 len2)
478-- | /O(1)/ Returns the first character of a 'Text', which must be
529-- | /O(1)/ Returns the first character of a 'Text', which must be
479-- non-empty. Subject to fusion.
530-- non-empty. Subject to fusion.
480head :: Text -> Char
531head :: Text -> Char
532+head = coerce JSS.head
481−head t = S.head (stream t)
533+-- head t = S.head (stream t)
482{-# INLINE head #-}
534{-# INLINE head #-}
483
535
484-- | /O(1)/ Returns the first character and rest of a 'Text', or
536-- | /O(1)/ Returns the first character and rest of a 'Text', or
485-- 'Nothing' if empty. Subject to fusion.
537-- 'Nothing' if empty. Subject to fusion.
486uncons :: Text -> Maybe (Char, Text)
538uncons :: Text -> Maybe (Char, Text)
539+uncons = coerce JSS.uncons
487−uncons t@(Text arr off len)
540+-- uncons t@(Text arr off len)
488− | len <= 0 = Nothing
541+-- | len <= 0 = Nothing
489− | otherwise = Just $ let !(Iter c d) = iter t 0
542+-- | otherwise = Just $ let !(Iter c d) = iter t 0
490− in (c, text arr (off+d) (len-d))
543+-- in (c, text arr (off+d) (len-d))
491{-# INLINE [1] uncons #-}
544{-# INLINE [1] uncons #-}
492
545
493-- | Lifted from Control.Arrow and specialized.
546-- | Lifted from Control.Arrow and specialized.
@@ -497,12 +550,13 @@ second f (a, b) = (a, f b)
497-- | /O(1)/ Returns the last character of a 'Text', which must be
550-- | /O(1)/ Returns the last character of a 'Text', which must be
498-- non-empty. Subject to fusion.
551-- non-empty. Subject to fusion.
499last :: Text -> Char
552last :: Text -> Char
553+last = coerce JSS.last
500−last (Text arr off len)
554+-- last (Text arr off len)
501− | len <= 0 = emptyError "last"
555+-- | len <= 0 = emptyError "last"
502− | n < 0xDC00 || n > 0xDFFF = unsafeChr n
556+-- | n < 0xDC00 || n > 0xDFFF = unsafeChr n
503− | otherwise = U16.chr2 n0 n
557+-- | otherwise = U16.chr2 n0 n
504− where n = A.unsafeIndex arr (off+len-1)
558+-- where n = A.unsafeIndex arr (off+len-1)
505− n0 = A.unsafeIndex arr (off+len-2)
559+-- n0 = A.unsafeIndex arr (off+len-2)
506{-# INLINE [1] last #-}
560{-# INLINE [1] last #-}
507
561
508{-# RULES
562{-# RULES
@@ -515,10 +569,11 @@ last (Text arr off len)
515-- | /O(1)/ Returns all characters after the head of a 'Text', which
569-- | /O(1)/ Returns all characters after the head of a 'Text', which
516-- must be non-empty. Subject to fusion.
570-- must be non-empty. Subject to fusion.
517tail :: Text -> Text
571tail :: Text -> Text
572+tail = coerce JSS.tail
518−tail t@(Text arr off len)
573+-- tail t@(Text arr off len)
519− | len <= 0 = emptyError "tail"
574+-- | len <= 0 = emptyError "tail"
520− | otherwise = text arr (off+d) (len-d)
575+-- | otherwise = text arr (off+d) (len-d)
521− where d = iter_ t 0
576+-- where d = iter_ t 0
522{-# INLINE [1] tail #-}
577{-# INLINE [1] tail #-}
523
578
524{-# RULES
579{-# RULES
@@ -531,11 +586,12 @@ tail t@(Text arr off len)
531-- | /O(1)/ Returns all but the last character of a 'Text', which must
586-- | /O(1)/ Returns all but the last character of a 'Text', which must
532-- be non-empty. Subject to fusion.
587-- be non-empty. Subject to fusion.
533init :: Text -> Text
588init :: Text -> Text
589+init = coerce JSS.init
534−init (Text arr off len) | len <= 0 = emptyError "init"
590+-- init (Text arr off len) | len <= 0 = emptyError "init"
535− | n >= 0xDC00 && n <= 0xDFFF = text arr off (len-2)
591+-- | n >= 0xDC00 && n <= 0xDFFF = text arr off (len-2)
536− | otherwise = text arr off (len-1)
592+-- | otherwise = text arr off (len-1)
537− where
593+-- where
538− n = A.unsafeIndex arr (off+len-1)
594+-- n = A.unsafeIndex arr (off+len-1)
539{-# INLINE [1] init #-}
595{-# INLINE [1] init #-}
540
596
541{-# RULES
597{-# RULES
@@ -548,11 +604,12 @@ init (Text arr off len) | len <= 0 = emptyError "init"
548-- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to
604-- | /O(1)/ Tests whether a 'Text' is empty or not. Subject to
549-- fusion.
605-- fusion.
550null :: Text -> Bool
606null :: Text -> Bool
607+null = coerce JSS.null
551−null (Text _arr _off len) =
608+-- null (Text _arr _off len) =
552−#if defined(ASSERTS)
609+-- #if defined(ASSERTS)
553− assert (len >= 0) $
610+-- assert (len >= 0) $
554−#endif
611+-- #endif
555− len <= 0
612+-- len <= 0
556{-# INLINE [1] null #-}
613{-# INLINE [1] null #-}
557
614
558{-# RULES
615{-# RULES
@@ -564,14 +621,15 @@ null (Text _arr _off len) =
564
621
565-- | /O(1)/ Tests whether a 'Text' contains exactly one character.
622-- | /O(1)/ Tests whether a 'Text' contains exactly one character.
566-- Subject to fusion.
623-- Subject to fusion.
567−isSingleton :: Text -> Bool
624+-- isSingleton :: Text -> Bool
568−isSingleton = S.isSingleton . stream
625+-- isSingleton = S.isSingleton . stream
569−{-# INLINE isSingleton #-}
626+-- {-# INLINE isSingleton #-}
570
627
571-- | /O(n)/ Returns the number of characters in a 'Text'.
628-- | /O(n)/ Returns the number of characters in a 'Text'.
572-- Subject to fusion.
629-- Subject to fusion.
573length :: Text -> Int
630length :: Text -> Int
631+length = coerce JSS.length
574−length t = S.length (stream t)
632+-- length t = S.length (stream t)
575{-# INLINE [0] length #-}
633{-# INLINE [0] length #-}
576-- length needs to be phased after the compareN/length rules otherwise
634-- length needs to be phased after the compareN/length rules otherwise
577-- it may inline before the rules have an opportunity to fire.
635-- it may inline before the rules have an opportunity to fire.
@@ -627,26 +685,30 @@ compareLength t n = S.compareLengthI (stream t) n
627-- each element of @t@. Subject to fusion. Performs replacement on
685-- each element of @t@. Subject to fusion. Performs replacement on
628-- invalid scalar values.
686-- invalid scalar values.
629map :: (Char -> Char) -> Text -> Text
687map :: (Char -> Char) -> Text -> Text
688+map = coerce JSS.map
630−map f t = unstream (S.map (safe . f) (stream t))
689+-- map f t = unstream (S.map (safe . f) (stream t))
631{-# INLINE [1] map #-}
690{-# INLINE [1] map #-}
632
691
633-- | /O(n)/ The 'intercalate' function takes a 'Text' and a list of
692-- | /O(n)/ The 'intercalate' function takes a 'Text' and a list of
634-- 'Text's and concatenates the list after interspersing the first
693-- 'Text's and concatenates the list after interspersing the first
635-- argument between each element of the list.
694-- argument between each element of the list.
636intercalate :: Text -> [Text] -> Text
695intercalate :: Text -> [Text] -> Text
696+intercalate = coerce JSS.intercalate
637−intercalate t = concat . (F.intersperse t)
697+-- intercalate t = concat . (F.intersperse t)
638{-# INLINE intercalate #-}
698{-# INLINE intercalate #-}
639
699
640-- | /O(n)/ The 'intersperse' function takes a character and places it
700-- | /O(n)/ The 'intersperse' function takes a character and places it
641-- between the characters of a 'Text'. Subject to fusion. Performs
701-- between the characters of a 'Text'. Subject to fusion. Performs
642-- replacement on invalid scalar values.
702-- replacement on invalid scalar values.
643intersperse :: Char -> Text -> Text
703intersperse :: Char -> Text -> Text
704+intersperse = coerce JSS.intersperse
644−intersperse c t = unstream (S.intersperse (safe c) (stream t))
705+-- intersperse c t = unstream (S.intersperse (safe c) (stream t))
645{-# INLINE intersperse #-}
706{-# INLINE intersperse #-}
646
707
647-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
708-- | /O(n)/ Reverse the characters of a string. Subject to fusion.
648reverse :: Text -> Text
709reverse :: Text -> Text
710+reverse = coerce JSS.reverse
649−reverse t = S.reverse (stream t)
711+-- reverse t = S.reverse (stream t)
650{-# INLINE reverse #-}
712{-# INLINE reverse #-}
651
713
652-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
714-- | /O(m+n)/ Replace every non-overlapping occurrence of @needle@ in
@@ -680,28 +742,29 @@ replace :: Text
680 -> Text
742 -> Text
681 -- ^ @haystack@ in which to search.
743 -- ^ @haystack@ in which to search.
682 -> Text
744 -> Text
745+replace = coerce JSS.replace
683−replace needle@(Text _ _ neeLen)
746+-- replace needle@(Text _ _ neeLen)
684− (Text repArr repOff repLen)
747+-- (Text repArr repOff repLen)
685− haystack@(Text hayArr hayOff hayLen)
748+-- haystack@(Text hayArr hayOff hayLen)
686− | neeLen == 0 = emptyError "replace"
749+-- | neeLen == 0 = emptyError "replace"
687− | L.null ixs = haystack
750+-- | L.null ixs = haystack
688− | len > 0 = Text (A.run x) 0 len
751+-- | len > 0 = Text (A.run x) 0 len
689− | otherwise = empty
752+-- | otherwise = empty
690− where
753+-- where
691− ixs = indices needle haystack
754+-- ixs = indices needle haystack
692− len = hayLen - (neeLen - repLen) `mul` L.length ixs
755+-- len = hayLen - (neeLen - repLen) `mul` L.length ixs
693− x :: ST s (A.MArray s)
756+-- x :: ST s (A.MArray s)
694− x = do
757+-- x = do
695− marr <- A.new len
758+-- marr <- A.new len
696− let loop (i:is) o d = do
759+-- let loop (i:is) o d = do
697− let d0 = d + i - o
760+-- let d0 = d + i - o
698− d1 = d0 + repLen
761+-- d1 = d0 + repLen
699− A.copyI marr d hayArr (hayOff+o) d0
762+-- A.copyI marr d hayArr (hayOff+o) d0
700− A.copyI marr d0 repArr repOff d1
763+-- A.copyI marr d0 repArr repOff d1
701− loop is (i + neeLen) d1
764+-- loop is (i + neeLen) d1
702− loop [] o d = A.copyI marr d hayArr (hayOff+o) len
765+-- loop [] o d = A.copyI marr d hayArr (hayOff+o) len
703− loop ixs 0 0
766+-- loop ixs 0 0
704− return marr
767+-- return marr
705
768
706-- ----------------------------------------------------------------------------
769-- ----------------------------------------------------------------------------
707-- ** Case conversions (folds)
770-- ** Case conversions (folds)
@@ -740,7 +803,8 @@ replace needle@(Text _ _ neeLen)
740-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
803-- U+00B5) is case folded to \"&#x3bc;\" (small letter mu, U+03BC)
741-- instead of itself.
804-- instead of itself.
742toCaseFold :: Text -> Text
805toCaseFold :: Text -> Text
743−toCaseFold t = unstream (S.toCaseFold (stream t))
806+-- toCaseFold t = unstream (S.toCaseFold (stream t))
807+toCaseFold = coerce JSS.toCaseFold
744{-# INLINE toCaseFold #-}
808{-# INLINE toCaseFold #-}
745
809
746-- | /O(n)/ Convert a string to lower case, using simple case
810-- | /O(n)/ Convert a string to lower case, using simple case
@@ -751,7 +815,8 @@ toCaseFold t = unstream (S.toCaseFold (stream t))
751-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
815-- U+0130) maps to the sequence \"i\" (Latin small letter i, U+0069)
752-- followed by \" &#x307;\" (combining dot above, U+0307).
816-- followed by \" &#x307;\" (combining dot above, U+0307).
753toLower :: Text -> Text
817toLower :: Text -> Text
754−toLower t = unstream (S.toLower (stream t))
818+-- toLower t = unstream (S.toLower (stream t))
819+toLower = coerce JSS.toLower
755{-# INLINE toLower #-}
820{-# INLINE toLower #-}
756
821
757-- | /O(n)/ Convert a string to upper case, using simple case
822-- | /O(n)/ Convert a string to upper case, using simple case
@@ -761,7 +826,8 @@ toLower t = unstream (S.toLower (stream t))
761-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
826-- instance, the German \"&#xdf;\" (eszett, U+00DF) maps to the
762-- two-letter sequence \"SS\".
827-- two-letter sequence \"SS\".
763toUpper :: Text -> Text
828toUpper :: Text -> Text
764−toUpper t = unstream (S.toUpper (stream t))
829+-- toUpper t = unstream (S.toUpper (stream t))
830+toUpper = coerce JSS.toUpper
765{-# INLINE toUpper #-}
831{-# INLINE toUpper #-}
766
832
767-- | /O(n)/ Convert a string to title case, using simple case
833-- | /O(n)/ Convert a string to title case, using simple case
@@ -783,7 +849,8 @@ toUpper t = unstream (S.toUpper (stream t))
783-- Fox\" is correctly title cased&#x2014;but this function will
849-- Fox\" is correctly title cased&#x2014;but this function will
784-- capitalize /every/ word.
850-- capitalize /every/ word.
785toTitle :: Text -> Text
851toTitle :: Text -> Text
852+toTitle = coerce JSS.toTitle
786−toTitle t = unstream (S.toTitle (stream t))
853+-- toTitle t = unstream (S.toTitle (stream t))
787{-# INLINE toTitle #-}
854{-# INLINE toTitle #-}
788
855
789-- | /O(n)/ Left-justify a string to the given length, using the
856-- | /O(n)/ Left-justify a string to the given length, using the
@@ -795,10 +862,11 @@ toTitle t = unstream (S.toTitle (stream t))
795-- > justifyLeft 7 'x' "foo" == "fooxxxx"
862-- > justifyLeft 7 'x' "foo" == "fooxxxx"
796-- > justifyLeft 3 'x' "foobar" == "foobar"
863-- > justifyLeft 3 'x' "foobar" == "foobar"
797justifyLeft :: Int -> Char -> Text -> Text
864justifyLeft :: Int -> Char -> Text -> Text
798−justifyLeft k c t
865+justifyLeft = coerce JSS.justifyLeft
866+-- justifyLeft k c t
799− | len >= k = t
867+-- | len >= k = t
800− | otherwise = t `append` replicateChar (k-len) c
868+-- | otherwise = t `append` replicateChar (k-len) c
801− where len = length t
869+-- where len = length t
802{-# INLINE [1] justifyLeft #-}
870{-# INLINE [1] justifyLeft #-}
803
871
804{-# RULES
872{-# RULES
@@ -817,10 +885,11 @@ justifyLeft k c t
817-- > justifyRight 7 'x' "bar" == "xxxxbar"
885-- > justifyRight 7 'x' "bar" == "xxxxbar"
818-- > justifyRight 3 'x' "foobar" == "foobar"
886-- > justifyRight 3 'x' "foobar" == "foobar"
819justifyRight :: Int -> Char -> Text -> Text
887justifyRight :: Int -> Char -> Text -> Text
820−justifyRight k c t
888+justifyRight = coerce JSS.justifyRight
889+-- justifyRight k c t
821− | len >= k = t
890+-- | len >= k = t
822− | otherwise = replicateChar (k-len) c `append` t
891+-- | otherwise = replicateChar (k-len) c `append` t
823− where len = length t
892+-- where len = length t
824{-# INLINE justifyRight #-}
893{-# INLINE justifyRight #-}
825
894
826-- | /O(n)/ Center a string to the given length, using the specified
895-- | /O(n)/ Center a string to the given length, using the specified
@@ -831,13 +900,14 @@ justifyRight k c t
831--
900--
832-- > center 8 'x' "HS" = "xxxHSxxx"
901-- > center 8 'x' "HS" = "xxxHSxxx"
833center :: Int -> Char -> Text -> Text
902center :: Int -> Char -> Text -> Text
834−center k c t
903+center = coerce JSS.center
904+-- center k c t
835− | len >= k = t
905+-- | len >= k = t
836− | otherwise = replicateChar l c `append` t `append` replicateChar r c
906+-- | otherwise = replicateChar l c `append` t `append` replicateChar r c
837− where len = length t
907+-- where len = length t
838− d = k - len
908+-- d = k - len
839− r = d `quot` 2
909+-- r = d `quot` 2
840− l = d - r
910+-- l = d - r
841{-# INLINE center #-}
911{-# INLINE center #-}
842
912
843-- | /O(n)/ The 'transpose' function transposes the rows and columns
913-- | /O(n)/ The 'transpose' function transposes the rows and columns
@@ -845,7 +915,8 @@ center k c t
845-- 'unpack', and the list version of transpose, and is thus not very
915-- 'unpack', and the list version of transpose, and is thus not very
846-- efficient.
916-- efficient.
847transpose :: [Text] -> [Text]
917transpose :: [Text] -> [Text]
918+transpose = coerce JSS.transpose
848−transpose ts = P.map pack (L.transpose (P.map unpack ts))
919+-- transpose ts = P.map pack (L.transpose (P.map unpack ts))
849
920
850-- -----------------------------------------------------------------------------
921-- -----------------------------------------------------------------------------
851-- * Reducing 'Text's (folds)
922-- * Reducing 'Text's (folds)
@@ -855,23 +926,27 @@ transpose ts = P.map pack (L.transpose (P.map unpack ts))
855-- reduces the 'Text' using the binary operator, from left to right.
926-- reduces the 'Text' using the binary operator, from left to right.
856-- Subject to fusion.
927-- Subject to fusion.
857foldl :: (a -> Char -> a) -> a -> Text -> a
928foldl :: (a -> Char -> a) -> a -> Text -> a
929+foldl f a0 (Text t) = JSS.foldl f a0 t
858−foldl f z t = S.foldl f z (stream t)
930+-- foldl f z t = S.foldl f z (stream t)
859{-# INLINE foldl #-}
931{-# INLINE foldl #-}
860
932
861-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
933-- | /O(n)/ A strict version of 'foldl'. Subject to fusion.
862foldl' :: (a -> Char -> a) -> a -> Text -> a
934foldl' :: (a -> Char -> a) -> a -> Text -> a
935+foldl' f a0 (Text t) = JSS.foldl' f a0 t
863−foldl' f z t = S.foldl' f z (stream t)
936+-- foldl' f z t = S.foldl' f z (stream t)
864{-# INLINE foldl' #-}
937{-# INLINE foldl' #-}
865
938
866-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
939-- | /O(n)/ A variant of 'foldl' that has no starting value argument,
867-- and thus must be applied to a non-empty 'Text'. Subject to fusion.
940-- and thus must be applied to a non-empty 'Text'. Subject to fusion.
868foldl1 :: (Char -> Char -> Char) -> Text -> Char
941foldl1 :: (Char -> Char -> Char) -> Text -> Char
942+foldl1 = coerce JSS.foldl1
869−foldl1 f t = S.foldl1 f (stream t)
943+-- foldl1 f t = S.foldl1 f (stream t)
870{-# INLINE foldl1 #-}
944{-# INLINE foldl1 #-}
871
945
872-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
946-- | /O(n)/ A strict version of 'foldl1'. Subject to fusion.
873foldl1' :: (Char -> Char -> Char) -> Text -> Char
947foldl1' :: (Char -> Char -> Char) -> Text -> Char
948+foldl1' = coerce JSS.foldl1'
874−foldl1' f t = S.foldl1' f (stream t)
949+-- foldl1' f t = S.foldl1' f (stream t)
875{-# INLINE foldl1' #-}
950{-# INLINE foldl1' #-}
876
951
877-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
952-- | /O(n)/ 'foldr', applied to a binary operator, a starting value
@@ -879,14 +954,16 @@ foldl1' f t = S.foldl1' f (stream t)
879-- reduces the 'Text' using the binary operator, from right to left.
954-- reduces the 'Text' using the binary operator, from right to left.
880-- Subject to fusion.
955-- Subject to fusion.
881foldr :: (Char -> a -> a) -> a -> Text -> a
956foldr :: (Char -> a -> a) -> a -> Text -> a
957+foldr f a0 (Text t) = JSS.foldr f a0 t
882−foldr f z t = S.foldr f z (stream t)
958+-- foldr f z t = S.foldr f z (stream t)
883{-# INLINE foldr #-}
959{-# INLINE foldr #-}
884
960
885-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
961-- | /O(n)/ A variant of 'foldr' that has no starting value argument,
886-- and thus must be applied to a non-empty 'Text'. Subject to
962-- and thus must be applied to a non-empty 'Text'. Subject to
887-- fusion.
963-- fusion.
888foldr1 :: (Char -> Char -> Char) -> Text -> Char
964foldr1 :: (Char -> Char -> Char) -> Text -> Char
965+foldr1 = coerce JSS.foldr1
889−foldr1 f t = S.foldr1 f (stream t)
966+-- foldr1 f t = S.foldr1 f (stream t)
890{-# INLINE foldr1 #-}
967{-# INLINE foldr1 #-}
891
968
892-- -----------------------------------------------------------------------------
969-- -----------------------------------------------------------------------------
@@ -894,48 +971,54 @@ foldr1 f t = S.foldr1 f (stream t)
894
971
895-- | /O(n)/ Concatenate a list of 'Text's.
972-- | /O(n)/ Concatenate a list of 'Text's.
896concat :: [Text] -> Text
973concat :: [Text] -> Text
974+concat = coerce JSS.concat
897−concat ts = case ts' of
975+-- concat ts = case ts' of
898− [] -> empty
976+-- [] -> empty
899− [t] -> t
977+-- [t] -> t
900− _ -> Text (A.run go) 0 len
978+-- _ -> Text (A.run go) 0 len
901− where
979+-- where
902− ts' = L.filter (not . null) ts
980+-- ts' = L.filter (not . null) ts
903− len = sumP "concat" $ L.map lengthWord16 ts'
981+-- len = sumP "concat" $ L.map lengthWord16 ts'
904− go :: ST s (A.MArray s)
982+-- go :: ST s (A.MArray s)
905− go = do
983+-- go = do
906− arr <- A.new len
984+-- arr <- A.new len
907− let step i (Text a o l) =
985+-- let step i (Text a o l) =
908− let !j = i + l in A.copyI arr i a o j >> return j
986+-- let !j = i + l in A.copyI arr i a o j >> return j
909− foldM step 0 ts' >> return arr
987+-- foldM step 0 ts' >> return arr
910
988
911-- | /O(n)/ Map a function over a 'Text' that results in a 'Text', and
989-- | /O(n)/ Map a function over a 'Text' that results in a 'Text', and
912-- concatenate the results.
990-- concatenate the results.
913concatMap :: (Char -> Text) -> Text -> Text
991concatMap :: (Char -> Text) -> Text -> Text
992+concatMap = coerce JSS.concatMap
914−concatMap f = concat . foldr ((:) . f) []
993+-- concatMap f = concat . foldr ((:) . f) []
915{-# INLINE concatMap #-}
994{-# INLINE concatMap #-}
916
995
917-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
996-- | /O(n)/ 'any' @p@ @t@ determines whether any character in the
918-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
997-- 'Text' @t@ satisfies the predicate @p@. Subject to fusion.
919any :: (Char -> Bool) -> Text -> Bool
998any :: (Char -> Bool) -> Text -> Bool
999+any = coerce JSS.any
920−any p t = S.any p (stream t)
1000+-- any p t = S.any p (stream t)
921{-# INLINE any #-}
1001{-# INLINE any #-}
922
1002
923-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
1003-- | /O(n)/ 'all' @p@ @t@ determines whether all characters in the
924-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
1004-- 'Text' @t@ satisfy the predicate @p@. Subject to fusion.
925all :: (Char -> Bool) -> Text -> Bool
1005all :: (Char -> Bool) -> Text -> Bool
1006+all = coerce JSS.all
926−all p t = S.all p (stream t)
1007+-- all p t = S.all p (stream t)
927{-# INLINE all #-}
1008{-# INLINE all #-}
928
1009
929-- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which
1010-- | /O(n)/ 'maximum' returns the maximum value from a 'Text', which
930-- must be non-empty. Subject to fusion.
1011-- must be non-empty. Subject to fusion.
931maximum :: Text -> Char
1012maximum :: Text -> Char
1013+maximum = coerce JSS.maximum
932−maximum t = S.maximum (stream t)
1014+-- maximum t = S.maximum (stream t)
933{-# INLINE maximum #-}
1015{-# INLINE maximum #-}
934
1016
935-- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which
1017-- | /O(n)/ 'minimum' returns the minimum value from a 'Text', which
936-- must be non-empty. Subject to fusion.
1018-- must be non-empty. Subject to fusion.
937minimum :: Text -> Char
1019minimum :: Text -> Char
1020+minimum = coerce JSS.minimum
938−minimum t = S.minimum (stream t)
1021+-- minimum t = S.minimum (stream t)
939{-# INLINE minimum #-}
1022{-# INLINE minimum #-}
940
1023
941-- -----------------------------------------------------------------------------
1024-- -----------------------------------------------------------------------------
@@ -951,8 +1034,9 @@ minimum t = S.minimum (stream t)
951--
1034--
952-- > last (scanl f z xs) == foldl f z xs.
1035-- > last (scanl f z xs) == foldl f z xs.
953scanl :: (Char -> Char -> Char) -> Char -> Text -> Text
1036scanl :: (Char -> Char -> Char) -> Char -> Text -> Text
1037+scanl = coerce JSS.scanl
954−scanl f z t = unstream (S.scanl g z (stream t))
1038+-- scanl f z t = unstream (S.scanl g z (stream t))
955− where g a b = safe (f a b)
1039+-- where g a b = safe (f a b)
956{-# INLINE scanl #-}
1040{-# INLINE scanl #-}
957
1041
958-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
1042-- | /O(n)/ 'scanl1' is a variant of 'scanl' that has no starting
@@ -961,8 +1045,9 @@ scanl f z t = unstream (S.scanl g z (stream t))
961--
1045--
962-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
1046-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
963scanl1 :: (Char -> Char -> Char) -> Text -> Text
1047scanl1 :: (Char -> Char -> Char) -> Text -> Text
1048+scanl1 = coerce JSS.scanl1
964−scanl1 f t | null t = empty
1049+-- scanl1 f t | null t = empty
965− | otherwise = scanl f (unsafeHead t) (unsafeTail t)
1050+-- | otherwise = scanl f (unsafeHead t) (unsafeTail t)
966{-# INLINE scanl1 #-}
1051{-# INLINE scanl1 #-}
967
1052
968-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
1053-- | /O(n)/ 'scanr' is the right-to-left dual of 'scanl'. Performs
@@ -970,16 +1055,18 @@ scanl1 f t | null t = empty
970--
1055--
971-- > scanr f v == reverse . scanl (flip f) v . reverse
1056-- > scanr f v == reverse . scanl (flip f) v . reverse
972scanr :: (Char -> Char -> Char) -> Char -> Text -> Text
1057scanr :: (Char -> Char -> Char) -> Char -> Text -> Text
1058+scanr = coerce JSS.scanr
973−scanr f z = S.reverse . S.reverseScanr g z . reverseStream
1059+-- scanr f z = S.reverse . S.reverseScanr g z . reverseStream
974− where g a b = safe (f a b)
1060+-- where g a b = safe (f a b)
975{-# INLINE scanr #-}
1061{-# INLINE scanr #-}
976
1062
977-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
1063-- | /O(n)/ 'scanr1' is a variant of 'scanr' that has no starting
978-- value argument. Subject to fusion. Performs replacement on
1064-- value argument. Subject to fusion. Performs replacement on
979-- invalid scalar values.
1065-- invalid scalar values.
980scanr1 :: (Char -> Char -> Char) -> Text -> Text
1066scanr1 :: (Char -> Char -> Char) -> Text -> Text
1067+scanr1 = coerce JSS.scanr1
981−scanr1 f t | null t = empty
1068+-- scanr1 f t | null t = empty
982− | otherwise = scanr f (last t) (init t)
1069+-- | otherwise = scanr f (last t) (init t)
983{-# INLINE scanr1 #-}
1070{-# INLINE scanr1 #-}
984
1071
985-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
1072-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
@@ -987,8 +1074,11 @@ scanr1 f t | null t = empty
987-- parameter from left to right, and returns a final 'Text'. Performs
1074-- parameter from left to right, and returns a final 'Text'. Performs
988-- replacement on invalid scalar values.
1075-- replacement on invalid scalar values.
989mapAccumL :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
1076mapAccumL :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
1077+mapAccumL f z0 (Text a) =
1078+ let (a', t) = JSS.mapAccumL f z0 a
1079+ in (a', Text t)
990−mapAccumL f z0 = S.mapAccumL g z0 . stream
1080+-- mapAccumL f z0 = S.mapAccumL g z0 . stream
991− where g a b = second safe (f a b)
1081+-- where g a b = second safe (f a b)
992{-# INLINE mapAccumL #-}
1082{-# INLINE mapAccumL #-}
993
1083
994-- | The 'mapAccumR' function behaves like a combination of 'map' and
1084-- | The 'mapAccumR' function behaves like a combination of 'map' and
@@ -998,8 +1088,11 @@ mapAccumL f z0 = S.mapAccumL g z0 . stream
998-- 'Text'.
1088-- 'Text'.
999-- Performs replacement on invalid scalar values.
1089-- Performs replacement on invalid scalar values.
1000mapAccumR :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
1090mapAccumR :: (a -> Char -> (a,Char)) -> a -> Text -> (a, Text)
1091+mapAccumR f z0 (Text a) =
1092+ let (a', t) = JSS.mapAccumR f z0 a
1093+ in (a', Text t)
1001−mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
1094+-- mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
1002− where g a b = second safe (f a b)
1095+-- where g a b = second safe (f a b)
1003{-# INLINE mapAccumR #-}
1096{-# INLINE mapAccumR #-}
1004
1097
1005-- -----------------------------------------------------------------------------
1098-- -----------------------------------------------------------------------------
@@ -1008,20 +1101,21 @@ mapAccumR f z0 = second reverse . S.mapAccumL g z0 . reverseStream
1008-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'Text' consisting of the input
1101-- | /O(n*m)/ 'replicate' @n@ @t@ is a 'Text' consisting of the input
1009-- @t@ repeated @n@ times.
1102-- @t@ repeated @n@ times.
1010replicate :: Int -> Text -> Text
1103replicate :: Int -> Text -> Text
1104+replicate = coerce JSS.replicate
1011−replicate n t@(Text a o l)
1105+-- replicate n t@(Text a o l)
1012− | n <= 0 || l <= 0 = empty
1106+-- | n <= 0 || l <= 0 = empty
1013− | n == 1 = t
1107+-- | n == 1 = t
1014− | isSingleton t = replicateChar n (unsafeHead t)
1108+-- | isSingleton t = replicateChar n (unsafeHead t)
1015− | otherwise = Text (A.run x) 0 len
1109+-- | otherwise = Text (A.run x) 0 len
1016− where
1110+-- where
1017− len = l `mul` n
1111+-- len = l `mul` n
1018− x :: ST s (A.MArray s)
1112+-- x :: ST s (A.MArray s)
1019− x = do
1113+-- x = do
1020− arr <- A.new len
1114+-- arr <- A.new len
1021− let loop !d !i | i >= n = return arr
1115+-- let loop !d !i | i >= n = return arr
1022− | otherwise = let m = d + l
1116+-- | otherwise = let m = d + l
1023− in A.copyI arr d a o m >> loop m (i+1)
1117+-- in A.copyI arr d a o m >> loop m (i+1)
1024− loop 0 0
1118+-- loop 0 0
1025{-# INLINE [1] replicate #-}
1119{-# INLINE [1] replicate #-}
1026
1120
1027{-# RULES
1121{-# RULES
@@ -1032,8 +1126,19 @@ replicate n t@(Text a o l)
1032-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the
1126-- | /O(n)/ 'replicateChar' @n@ @c@ is a 'Text' of length @n@ with @c@ the
1033-- value of every element. Subject to fusion.
1127-- value of every element. Subject to fusion.
1034replicateChar :: Int -> Char -> Text
1128replicateChar :: Int -> Char -> Text
1129+#ifndef __GHCJS__
1035replicateChar n c = unstream (S.replicateCharI n (safe c))
1130replicateChar n c = unstream (S.replicateCharI n (safe c))
1036{-# INLINE replicateChar #-}
1131{-# INLINE replicateChar #-}
1132+#else
1133+replicateChar n c = Text $ js_replicateChar n c
1134+{-# INLINE [1] replicateChar #-}
1135+{-# RULES
1136+"JSSTRING replicateChar -> fused" [~1] forall n c.
1137+ replicateChar n c = unstream (S.replicateCharI n (safe c))
1138+"JSSTRING replicateChar -> unfused" [1] forall n c.
1139+ unstream (S.replicateCharI n (safe c)) = replicateChar n c
1140+ #-}
1141+#endif
1037
1142
1038-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
1143-- | /O(n)/, where @n@ is the length of the result. The 'unfoldr'
1039-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
1144-- function is analogous to the List 'L.unfoldr'. 'unfoldr' builds a
@@ -1043,7 +1148,8 @@ replicateChar n c = unstream (S.replicateCharI n (safe c))
1043-- string, and @b@ is the seed value for further production. Subject
1148-- string, and @b@ is the seed value for further production. Subject
1044-- to fusion. Performs replacement on invalid scalar values.
1149-- to fusion. Performs replacement on invalid scalar values.
1045unfoldr :: (a -> Maybe (Char,a)) -> a -> Text
1150unfoldr :: (a -> Maybe (Char,a)) -> a -> Text
1151+unfoldr f a = Text $ JSS.unfoldr f a
1046−unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
1152+-- unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
1047{-# INLINE unfoldr #-}
1153{-# INLINE unfoldr #-}
1048
1154
1049-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Text' from a seed
1155-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a 'Text' from a seed
@@ -1053,7 +1159,8 @@ unfoldr f s = unstream (S.unfoldr (firstf safe . f) s)
1053-- correct, otherwise its performance is similar to 'unfoldr'. Subject
1159-- correct, otherwise its performance is similar to 'unfoldr'. Subject
1054-- to fusion. Performs replacement on invalid scalar values.
1160-- to fusion. Performs replacement on invalid scalar values.
1055unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Text
1161unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Text
1162+unfoldrN n f a0 = Text $ JSS.unfoldrN n f a0
1056−unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
1163+-- unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
1057{-# INLINE unfoldrN #-}
1164{-# INLINE unfoldrN #-}
1058
1165
1059-- -----------------------------------------------------------------------------
1166-- -----------------------------------------------------------------------------
@@ -1063,18 +1170,19 @@ unfoldrN n f s = unstream (S.unfoldrN n (firstf safe . f) s)
1063-- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than
1170-- 'Text' of length @n@, or the 'Text' itself if @n@ is greater than
1064-- the length of the Text. Subject to fusion.
1171-- the length of the Text. Subject to fusion.
1065take :: Int -> Text -> Text
1172take :: Int -> Text -> Text
1173+take = coerce JSS.take
1066−take n t@(Text arr off len)
1174+-- take n t@(Text arr off len)
1067− | n <= 0 = empty
1175+-- | n <= 0 = empty
1068− | n >= len = t
1176+-- | n >= len = t
1069− | otherwise = text arr off (iterN n t)
1177+-- | otherwise = text arr off (iterN n t)
1070{-# INLINE [1] take #-}
1178{-# INLINE [1] take #-}
1071
1179
1072−iterN :: Int -> Text -> Int
1180+-- iterN :: Int -> Text -> Int
1073−iterN n t@(Text _arr _off len) = loop 0 0
1181+-- iterN n t@(Text _arr _off len) = loop 0 0
1074− where loop !i !cnt
1182+-- where loop !i !cnt
1075− | i >= len || cnt >= n = i
1183+-- | i >= len || cnt >= n = i
1076− | otherwise = loop (i+d) (cnt+1)
1184+-- | otherwise = loop (i+d) (cnt+1)
1077− where d = iter_ t i
1185+-- where d = iter_ t i
1078
1186
1079{-# RULES
1187{-# RULES
1080"TEXT take -> fused" [~1] forall n t.
1188"TEXT take -> fused" [~1] forall n t.
@@ -1090,29 +1198,31 @@ iterN n t@(Text _arr _off len) = loop 0 0
1090--
1198--
1091-- > takeEnd 3 "foobar" == "bar"
1199-- > takeEnd 3 "foobar" == "bar"
1092takeEnd :: Int -> Text -> Text
1200takeEnd :: Int -> Text -> Text
1201+takeEnd = coerce JSS.takeEnd
1093−takeEnd n t@(Text arr off len)
1202+-- takeEnd n t@(Text arr off len)
1094− | n <= 0 = empty
1203+-- | n <= 0 = empty
1095− | n >= len = t
1204+-- | n >= len = t
1096− | otherwise = text arr (off+i) (len-i)
1205+-- | otherwise = text arr (off+i) (len-i)
1097− where i = iterNEnd n t
1206+-- where i = iterNEnd n t
1098−
1207+
1099−iterNEnd :: Int -> Text -> Int
1208+-- iterNEnd :: Int -> Text -> Int
1100−iterNEnd n t@(Text _arr _off len) = loop (len-1) n
1209+-- iterNEnd n t@(Text _arr _off len) = loop (len-1) n
1101− where loop i !m
1210+-- where loop i !m
1102− | i <= 0 = 0
1211+-- | i <= 0 = 0
1103− | m <= 1 = i
1212+-- | m <= 1 = i
1104− | otherwise = loop (i+d) (m-1)
1213+-- | otherwise = loop (i+d) (m-1)
1105− where d = reverseIter_ t i
1214+-- where d = reverseIter_ t i
1106
1215
1107-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
1216-- | /O(n)/ 'drop' @n@, applied to a 'Text', returns the suffix of the
1108-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
1217-- 'Text' after the first @n@ characters, or the empty 'Text' if @n@
1109-- is greater than the length of the 'Text'. Subject to fusion.
1218-- is greater than the length of the 'Text'. Subject to fusion.
1110drop :: Int -> Text -> Text
1219drop :: Int -> Text -> Text
1220+drop = coerce JSS.drop
1111−drop n t@(Text arr off len)
1221+-- drop n t@(Text arr off len)
1112− | n <= 0 = t
1222+-- | n <= 0 = t
1113− | n >= len = empty
1223+-- | n >= len = empty
1114− | otherwise = text arr (off+i) (len-i)
1224+-- | otherwise = text arr (off+i) (len-i)
1115− where i = iterN n t
1225+-- where i = iterN n t
1116{-# INLINE [1] drop #-}
1226{-# INLINE [1] drop #-}
1117
1227
1118{-# RULES
1228{-# RULES
@@ -1129,20 +1239,22 @@ drop n t@(Text arr off len)
1129--
1239--
1130-- > dropEnd 3 "foobar" == "foo"
1240-- > dropEnd 3 "foobar" == "foo"
1131dropEnd :: Int -> Text -> Text
1241dropEnd :: Int -> Text -> Text
1242+dropEnd = coerce JSS.dropEnd
1132−dropEnd n t@(Text arr off len)
1243+-- dropEnd n t@(Text arr off len)
1133− | n <= 0 = t
1244+-- | n <= 0 = t
1134− | n >= len = empty
1245+-- | n >= len = empty
1135− | otherwise = text arr off (iterNEnd n t)
1246+-- | otherwise = text arr off (iterNEnd n t)
1136
1247
1137-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
1248-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
1138-- returns the longest prefix (possibly empty) of elements that
1249-- returns the longest prefix (possibly empty) of elements that
1139-- satisfy @p@. Subject to fusion.
1250-- satisfy @p@. Subject to fusion.
1140takeWhile :: (Char -> Bool) -> Text -> Text
1251takeWhile :: (Char -> Bool) -> Text -> Text
1252+takeWhile = coerce JSS.takeWhile
1141−takeWhile p t@(Text arr off len) = loop 0
1253+-- takeWhile p t@(Text arr off len) = loop 0
1142− where loop !i | i >= len = t
1254+-- where loop !i | i >= len = t
1143− | p c = loop (i+d)
1255+-- | p c = loop (i+d)
1144− | otherwise = text arr off i
1256+-- | otherwise = text arr off i
1145− where Iter c d = iter t i
1257+-- where Iter c d = iter t i
1146{-# INLINE [1] takeWhile #-}
1258{-# INLINE [1] takeWhile #-}
1147
1259
1148{-# RULES
1260{-# RULES
@@ -1159,11 +1271,20 @@ takeWhile p t@(Text arr off len) = loop 0
1159--
1271--
1160-- > takeWhileEnd (=='o') "foo" == "oo"
1272-- > takeWhileEnd (=='o') "foo" == "oo"
1161takeWhileEnd :: (Char -> Bool) -> Text -> Text
1273takeWhileEnd :: (Char -> Bool) -> Text -> Text
1274+#ifndef __GHCJS__
1162takeWhileEnd p t@(Text arr off len) = loop (len-1) len
1275takeWhileEnd p t@(Text arr off len) = loop (len-1) len
1163 where loop !i !l | l <= 0 = t
1276 where loop !i !l | l <= 0 = t
1164 | p c = loop (i+d) (l+d)
1277 | p c = loop (i+d) (l+d)
1165 | otherwise = text arr (off+l) (len-l)
1278 | otherwise = text arr (off+l) (len-l)
1166 where (c,d) = reverseIter t i
1279 where (c,d) = reverseIter t i
1280+#else
1281+takeWhileEnd p t@(Text jst) = loop (len-1) len
1282+ where loop !i !l | l <= 0 = t
1283+ | p c = loop (i+d) (l+d)
1284+ | otherwise = Text $ js_substr1 l jst
1285+ where (c,d) = reverseIter t i
1286+ len = length t
1287+#endif
1167{-# INLINE [1] takeWhileEnd #-}
1288{-# INLINE [1] takeWhileEnd #-}
1168
1289
1169{-# RULES
1290{-# RULES
@@ -1176,11 +1297,12 @@ takeWhileEnd p t@(Text arr off len) = loop (len-1) len
1176-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
1297-- | /O(n)/ 'dropWhile' @p@ @t@ returns the suffix remaining after
1177-- 'takeWhile' @p@ @t@. Subject to fusion.
1298-- 'takeWhile' @p@ @t@. Subject to fusion.
1178dropWhile :: (Char -> Bool) -> Text -> Text
1299dropWhile :: (Char -> Bool) -> Text -> Text
1300+dropWhile = coerce JSS.dropWhile
1179−dropWhile p t@(Text arr off len) = loop 0 0
1301+-- dropWhile p t@(Text arr off len) = loop 0 0
1180− where loop !i !l | l >= len = empty
1302+-- where loop !i !l | l >= len = empty
1181− | p c = loop (i+d) (l+d)
1303+-- | p c = loop (i+d) (l+d)
1182− | otherwise = Text arr (off+i) (len-l)
1304+-- | otherwise = Text arr (off+i) (len-l)
1183− where Iter c d = iter t i
1305+
1184{-# INLINE [1] dropWhile #-}
1306{-# INLINE [1] dropWhile #-}
1185
1307
1186{-# RULES
1308{-# RULES
@@ -1198,11 +1320,12 @@ dropWhile p t@(Text arr off len) = loop 0 0
1198--
1320--
1199-- > dropWhileEnd (=='.') "foo..." == "foo"
1321-- > dropWhileEnd (=='.') "foo..." == "foo"
1200dropWhileEnd :: (Char -> Bool) -> Text -> Text
1322dropWhileEnd :: (Char -> Bool) -> Text -> Text
1323+dropWhileEnd = coerce JSS.dropWhileEnd
1201−dropWhileEnd p t@(Text arr off len) = loop (len-1) len
1324+-- dropWhileEnd p t@(Text arr off len) = loop (len-1) len
1202− where loop !i !l | l <= 0 = empty
1325+-- where loop !i !l | l <= 0 = empty
1203− | p c = loop (i+d) (l+d)
1326+-- | p c = loop (i+d) (l+d)
1204− | otherwise = Text arr off l
1327+-- | otherwise = Text arr off l
1205− where (c,d) = reverseIter t i
1328+-- where (c,d) = reverseIter t i
1206{-# INLINE [1] dropWhileEnd #-}
1329{-# INLINE [1] dropWhileEnd #-}
1207
1330
1208{-# RULES
1331{-# RULES
@@ -1245,45 +1368,49 @@ strip = dropAround isSpace
1245-- prefix of @t@ of length @n@, and whose second is the remainder of
1368-- prefix of @t@ of length @n@, and whose second is the remainder of
1246-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
1369-- the string. It is equivalent to @('take' n t, 'drop' n t)@.
1247splitAt :: Int -> Text -> (Text, Text)
1370splitAt :: Int -> Text -> (Text, Text)
1371+splitAt = coerce JSS.splitAt
1248−splitAt n t@(Text arr off len)
1372+-- splitAt n t@(Text arr off len)
1249− | n <= 0 = (empty, t)
1373+-- | n <= 0 = (empty, t)
1250− | n >= len = (t, empty)
1374+-- | n >= len = (t, empty)
1251− | otherwise = let k = iterN n t
1375+-- | otherwise = let k = iterN n t
1252− in (text arr off k, text arr (off+k) (len-k))
1376+-- in (text arr off k, text arr (off+k) (len-k))
1253
1377
1254-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
1378-- | /O(n)/ 'span', applied to a predicate @p@ and text @t@, returns
1255-- a pair whose first element is the longest prefix (possibly empty)
1379-- a pair whose first element is the longest prefix (possibly empty)
1256-- of @t@ of elements that satisfy @p@, and whose second is the
1380-- of @t@ of elements that satisfy @p@, and whose second is the
1257-- remainder of the list.
1381-- remainder of the list.
1258span :: (Char -> Bool) -> Text -> (Text, Text)
1382span :: (Char -> Bool) -> Text -> (Text, Text)
1383+span = coerce JSS.span
1259−span p t = case span_ p t of
1384+-- span p t = case span_ p t of
1260− (# hd,tl #) -> (hd,tl)
1385+-- (# hd,tl #) -> (hd,tl)
1261{-# INLINE span #-}
1386{-# INLINE span #-}
1262
1387
1263-- | /O(n)/ 'break' is like 'span', but the prefix returned is
1388-- | /O(n)/ 'break' is like 'span', but the prefix returned is
1264-- over elements that fail the predicate @p@.
1389-- over elements that fail the predicate @p@.
1265break :: (Char -> Bool) -> Text -> (Text, Text)
1390break :: (Char -> Bool) -> Text -> (Text, Text)
1391+break = coerce JSS.break
1266−break p = span (not . p)
1392+-- break p = span (not . p)
1267{-# INLINE break #-}
1393{-# INLINE break #-}
1268
1394
1269-- | /O(n)/ Group characters in a string according to a predicate.
1395-- | /O(n)/ Group characters in a string according to a predicate.
1270groupBy :: (Char -> Char -> Bool) -> Text -> [Text]
1396groupBy :: (Char -> Char -> Bool) -> Text -> [Text]
1397+groupBy = coerce JSS.groupBy
1271−groupBy p = loop
1398+-- groupBy p = loop
1272− where
1399+-- where
1273− loop t@(Text arr off len)
1400+-- loop t@(Text arr off len)
1274− | null t = []
1401+-- | null t = []
1275− | otherwise = text arr off n : loop (text arr (off+n) (len-n))
1402+-- | otherwise = text arr off n : loop (text arr (off+n) (len-n))
1276− where Iter c d = iter t 0
1403+-- where Iter c d = iter t 0
1277− n = d + findAIndexOrEnd (not . p c) (Text arr (off+d) (len-d))
1404+-- n = d + findAIndexOrEnd (not . p c) (Text arr (off+d) (len-d))
1278
1405
1279-- | Returns the /array/ index (in units of 'Word16') at which a
1406-- | Returns the /array/ index (in units of 'Word16') at which a
1280-- character may be found. This is /not/ the same as the logical
1407-- character may be found. This is /not/ the same as the logical
1281-- index returned by e.g. 'findIndex'.
1408-- index returned by e.g. 'findIndex'.
1282−findAIndexOrEnd :: (Char -> Bool) -> Text -> Int
1409+-- findAIndexOrEnd :: (Char -> Bool) -> Text -> Int
1283−findAIndexOrEnd q t@(Text _arr _off len) = go 0
1410+-- findAIndexOrEnd q t@(Text _arr _off len) = go 0
1284− where go !i | i >= len || q c = i
1411+-- where go !i | i >= len || q c = i
1285− | otherwise = go (i+d)
1412+-- | otherwise = go (i+d)
1286− where Iter c d = iter t i
1413+-- where Iter c d = iter t i
1287
1414
1288-- | /O(n)/ Group characters in a string by equality.
1415-- | /O(n)/ Group characters in a string by equality.
1289group :: Text -> [Text]
1416group :: Text -> [Text]
@@ -1292,15 +1419,17 @@ group = groupBy (==)
1292-- | /O(n)/ Return all initial segments of the given 'Text', shortest
1419-- | /O(n)/ Return all initial segments of the given 'Text', shortest
1293-- first.
1420-- first.
1294inits :: Text -> [Text]
1421inits :: Text -> [Text]
1422+inits = coerce JSS.inits
1295−inits t@(Text arr off len) = loop 0
1423+-- inits t@(Text arr off len) = loop 0
1296− where loop i | i >= len = [t]
1424+-- where loop i | i >= len = [t]
1297− | otherwise = Text arr off i : loop (i + iter_ t i)
1425+-- | otherwise = Text arr off i : loop (i + iter_ t i)
1298
1426
1299-- | /O(n)/ Return all final segments of the given 'Text', longest
1427-- | /O(n)/ Return all final segments of the given 'Text', longest
1300-- first.
1428-- first.
1301tails :: Text -> [Text]
1429tails :: Text -> [Text]
1430+tails = coerce JSS.tails
1302−tails t | null t = [empty]
1431+-- tails t | null t = [empty]
1303− | otherwise = t : tails (unsafeTail t)
1432+-- | otherwise = t : tails (unsafeTail t)
1304
1433
1305-- $split
1434-- $split
1306--
1435--
@@ -1333,13 +1462,14 @@ splitOn :: Text
1333 -> Text
1462 -> Text
1334 -- ^ Input text.
1463 -- ^ Input text.
1335 -> [Text]
1464 -> [Text]
1465+splitOn = coerce JSS.splitOn
1336−splitOn pat@(Text _ _ l) src@(Text arr off len)
1466+-- splitOn pat@(Text _ _ l) src@(Text arr off len)
1337− | l <= 0 = emptyError "splitOn"
1467+-- | l <= 0 = emptyError "splitOn"
1338− | isSingleton pat = split (== unsafeHead pat) src
1468+-- | isSingleton pat = split (== unsafeHead pat) src
1339− | otherwise = go 0 (indices pat src)
1469+-- | otherwise = go 0 (indices pat src)
1340− where
1470+-- where
1341− go !s (x:xs) = text arr (s+off) (x-s) : go (x+l) xs
1471+-- go !s (x:xs) = text arr (s+off) (x-s) : go (x+l) xs
1342− go s _ = [text arr (s+off) (len-s)]
1472+-- go s _ = [text arr (s+off) (len-s)]
1343{-# INLINE [1] splitOn #-}
1473{-# INLINE [1] splitOn #-}
1344
1474
1345{-# RULES
1475{-# RULES
@@ -1355,11 +1485,12 @@ splitOn pat@(Text _ _ l) src@(Text arr off len)
1355-- > split (=='a') "aabbaca" == ["","","bb","c",""]
1485-- > split (=='a') "aabbaca" == ["","","bb","c",""]
1356-- > split (=='a') "" == [""]
1486-- > split (=='a') "" == [""]
1357split :: (Char -> Bool) -> Text -> [Text]
1487split :: (Char -> Bool) -> Text -> [Text]
1488+split = coerce JSS.split
1358−split _ t@(Text _off _arr 0) = [t]
1489+-- split _ t@(Text _off _arr 0) = [t]
1359−split p t = loop t
1490+-- split p t = loop t
1360− where loop s | null s' = [l]
1491+-- where loop s | null s' = [l]
1361− | otherwise = l : loop (unsafeTail s')
1492+-- | otherwise = l : loop (unsafeTail s')
1362− where (# l, s' #) = span_ (not . p) s
1493+-- where (# l, s' #) = span_ (not . p) s
1363{-# INLINE split #-}
1494{-# INLINE split #-}
1364
1495
1365-- | /O(n)/ Splits a 'Text' into components of length @k@. The last
1496-- | /O(n)/ Splits a 'Text' into components of length @k@. The last
@@ -1369,11 +1500,12 @@ split p t = loop t
1369-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1500-- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"]
1370-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1501-- > chunksOf 4 "haskell.org" == ["hask","ell.","org"]
1371chunksOf :: Int -> Text -> [Text]
1502chunksOf :: Int -> Text -> [Text]
1372−chunksOf k = go
1503+chunksOf = coerce JSS.chunksOf
1504+-- chunksOf k = go
1373− where
1505+-- where
1374− go t = case splitAt k t of
1506+-- go t = case splitAt k t of
1375− (a,b) | null a -> []
1507+-- (a,b) | null a -> []
1376− | otherwise -> a : go b
1508+-- | otherwise -> a : go b
1377{-# INLINE chunksOf #-}
1509{-# INLINE chunksOf #-}
1378
1510
1379-- ----------------------------------------------------------------------------
1511-- ----------------------------------------------------------------------------
@@ -1386,7 +1518,8 @@ chunksOf k = go
1386-- returns the first element matching the predicate, or 'Nothing' if
1518-- returns the first element matching the predicate, or 'Nothing' if
1387-- there is no such element.
1519-- there is no such element.
1388find :: (Char -> Bool) -> Text -> Maybe Char
1520find :: (Char -> Bool) -> Text -> Maybe Char
1521+find = coerce JSS.find
1389−find p t = S.findBy p (stream t)
1522+-- find p t = S.findBy p (stream t)
1390{-# INLINE find #-}
1523{-# INLINE find #-}
1391
1524
1392-- | /O(n)/ The 'partition' function takes a predicate and a 'Text',
1525-- | /O(n)/ The 'partition' function takes a predicate and a 'Text',
@@ -1395,14 +1528,16 @@ find p t = S.findBy p (stream t)
1395--
1528--
1396-- > partition p t == (filter p t, filter (not . p) t)
1529-- > partition p t == (filter p t, filter (not . p) t)
1397partition :: (Char -> Bool) -> Text -> (Text, Text)
1530partition :: (Char -> Bool) -> Text -> (Text, Text)
1531+partition = coerce JSS.partition
1398−partition p t = (filter p t, filter (not . p) t)
1532+-- partition p t = (filter p t, filter (not . p) t)
1399{-# INLINE partition #-}
1533{-# INLINE partition #-}
1400
1534
1401-- | /O(n)/ 'filter', applied to a predicate and a 'Text',
1535-- | /O(n)/ 'filter', applied to a predicate and a 'Text',
1402-- returns a 'Text' containing those characters that satisfy the
1536-- returns a 'Text' containing those characters that satisfy the
1403-- predicate.
1537-- predicate.
1404filter :: (Char -> Bool) -> Text -> Text
1538filter :: (Char -> Bool) -> Text -> Text
1539+filter = coerce JSS.filter
1405−filter p t = unstream (S.filter p (stream t))
1540+-- filter p t = unstream (S.filter p (stream t))
1406{-# INLINE filter #-}
1541{-# INLINE filter #-}
1407
1542
1408-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1543-- | /O(n+m)/ Find the first instance of @needle@ (which must be
@@ -1427,11 +1562,12 @@ filter p t = unstream (S.filter p (stream t))
1427-- In (unlikely) bad cases, this function's time complexity degrades
1562-- In (unlikely) bad cases, this function's time complexity degrades
1428-- towards /O(n*m)/.
1563-- towards /O(n*m)/.
1429breakOn :: Text -> Text -> (Text, Text)
1564breakOn :: Text -> Text -> (Text, Text)
1565+breakOn = coerce JSS.breakOn
1430−breakOn pat src@(Text arr off len)
1566+-- breakOn pat src@(Text arr off len)
1431− | null pat = emptyError "breakOn"
1567+-- | null pat = emptyError "breakOn"
1432− | otherwise = case indices pat src of
1568+-- | otherwise = case indices pat src of
1433− [] -> (src, empty)
1569+-- [] -> (src, empty)
1434− (x:_) -> (text arr off x, text arr (off+x) (len-x))
1570+-- (x:_) -> (text arr off x, text arr (off+x) (len-x))
1435{-# INLINE breakOn #-}
1571{-# INLINE breakOn #-}
1436
1572
1437-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
1573-- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the
@@ -1443,8 +1579,9 @@ breakOn pat src@(Text arr off len)
1443--
1579--
1444-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
1580-- > breakOnEnd "::" "a::b::c" ==> ("a::b::", "c")
1445breakOnEnd :: Text -> Text -> (Text, Text)
1581breakOnEnd :: Text -> Text -> (Text, Text)
1582+breakOnEnd = coerce JSS.breakOnEnd
1446−breakOnEnd pat src = (reverse b, reverse a)
1583+-- breakOnEnd pat src = (reverse b, reverse a)
1447− where (a,b) = breakOn (reverse pat) (reverse src)
1584+-- where (a,b) = breakOn (reverse pat) (reverse src)
1448{-# INLINE breakOnEnd #-}
1585{-# INLINE breakOnEnd #-}
1449
1586
1450-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
1587-- | /O(n+m)/ Find all non-overlapping instances of @needle@ in
@@ -1468,12 +1605,13 @@ breakOnEnd pat src = (reverse b, reverse a)
1468breakOnAll :: Text -- ^ @needle@ to search for
1605breakOnAll :: Text -- ^ @needle@ to search for
1469 -> Text -- ^ @haystack@ in which to search
1606 -> Text -- ^ @haystack@ in which to search
1470 -> [(Text, Text)]
1607 -> [(Text, Text)]
1608+breakOnAll = coerce JSS.breakOnAll
1471−breakOnAll pat src@(Text arr off slen)
1609+-- breakOnAll pat src@(Text arr off slen)
1472− | null pat = emptyError "breakOnAll"
1610+-- | null pat = emptyError "breakOnAll"
1473− | otherwise = L.map step (indices pat src)
1611+-- | otherwise = L.map step (indices pat src)
1474− where
1612+-- where
1475− step x = (chunk 0 x, chunk x (slen-x))
1613+-- step x = (chunk 0 x, chunk x (slen-x))
1476− chunk !n !l = text arr (n+off) l
1614+-- chunk !n !l = text arr (n+off) l
1477{-# INLINE breakOnAll #-}
1615{-# INLINE breakOnAll #-}
1478
1616
1479-------------------------------------------------------------------------------
1617-------------------------------------------------------------------------------
@@ -1497,14 +1635,16 @@ breakOnAll pat src@(Text arr off slen)
1497
1635
1498-- | /O(n)/ 'Text' index (subscript) operator, starting from 0.
1636-- | /O(n)/ 'Text' index (subscript) operator, starting from 0.
1499index :: Text -> Int -> Char
1637index :: Text -> Int -> Char
1638+index = coerce JSS.index
1500−index t n = S.index (stream t) n
1639+-- index t n = S.index (stream t) n
1501{-# INLINE index #-}
1640{-# INLINE index #-}
1502
1641
1503-- | /O(n)/ The 'findIndex' function takes a predicate and a 'Text'
1642-- | /O(n)/ The 'findIndex' function takes a predicate and a 'Text'
1504-- and returns the index of the first element in the 'Text' satisfying
1643-- and returns the index of the first element in the 'Text' satisfying
1505-- the predicate. Subject to fusion.
1644-- the predicate. Subject to fusion.
1506findIndex :: (Char -> Bool) -> Text -> Maybe Int
1645findIndex :: (Char -> Bool) -> Text -> Maybe Int
1646+findIndex = coerce JSS.findIndex
1507−findIndex p t = S.findIndex p (stream t)
1647+-- findIndex p t = S.findIndex p (stream t)
1508{-# INLINE findIndex #-}
1648{-# INLINE findIndex #-}
1509
1649
1510-- | /O(n+m)/ The 'count' function returns the number of times the
1650-- | /O(n+m)/ The 'count' function returns the number of times the
@@ -1514,10 +1654,11 @@ findIndex p t = S.findIndex p (stream t)
1514-- In (unlikely) bad cases, this function's time complexity degrades
1654-- In (unlikely) bad cases, this function's time complexity degrades
1515-- towards /O(n*m)/.
1655-- towards /O(n*m)/.
1516count :: Text -> Text -> Int
1656count :: Text -> Text -> Int
1657+count = coerce JSS.count
1517−count pat src
1658+-- count pat src
1518− | null pat = emptyError "count"
1659+-- | null pat = emptyError "count"
1519− | isSingleton pat = countChar (unsafeHead pat) src
1660+-- | isSingleton pat = countChar (unsafeHead pat) src
1520− | otherwise = L.length (indices pat src)
1661+-- | otherwise = L.length (indices pat src)
1521{-# INLINE [1] count #-}
1662{-# INLINE [1] count #-}
1522
1663
1523{-# RULES
1664{-# RULES
@@ -1539,42 +1680,46 @@ countChar c t = S.countChar c (stream t)
1539-- excess elements of the longer 'Text' are discarded. This is
1680-- excess elements of the longer 'Text' are discarded. This is
1540-- equivalent to a pair of 'unpack' operations.
1681-- equivalent to a pair of 'unpack' operations.
1541zip :: Text -> Text -> [(Char,Char)]
1682zip :: Text -> Text -> [(Char,Char)]
1683+zip = coerce JSS.zip
1542−zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1684+-- zip a b = S.unstreamList $ S.zipWith (,) (stream a) (stream b)
1543{-# INLINE zip #-}
1685{-# INLINE zip #-}
1544
1686
1545-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1687-- | /O(n)/ 'zipWith' generalises 'zip' by zipping with the function
1546-- given as the first argument, instead of a tupling function.
1688-- given as the first argument, instead of a tupling function.
1547-- Performs replacement on invalid scalar values.
1689-- Performs replacement on invalid scalar values.
1548zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
1690zipWith :: (Char -> Char -> Char) -> Text -> Text -> Text
1691+zipWith = coerce JSS.zipWith
1549−zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
1692+-- zipWith f t1 t2 = unstream (S.zipWith g (stream t1) (stream t2))
1550− where g a b = safe (f a b)
1693+-- where g a b = safe (f a b)
1551{-# INLINE zipWith #-}
1694{-# INLINE zipWith #-}
1552
1695
1553-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's
1696-- | /O(n)/ Breaks a 'Text' up into a list of words, delimited by 'Char's
1554-- representing white space.
1697-- representing white space.
1555words :: Text -> [Text]
1698words :: Text -> [Text]
1699+words = coerce JSS.words
1556−words t@(Text arr off len) = loop 0 0
1700+-- words t@(Text arr off len) = loop 0 0
1557− where
1701+-- where
1558− loop !start !n
1702+-- loop !start !n
1559− | n >= len = if start == n
1703+-- | n >= len = if start == n
1560− then []
1704+-- then []
1561− else [Text arr (start+off) (n-start)]
1705+-- else [Text arr (start+off) (n-start)]
1562− | isSpace c =
1706+-- | isSpace c =
1563− if start == n
1707+-- if start == n
1564− then loop (start+1) (start+1)
1708+-- then loop (start+1) (start+1)
1565− else Text arr (start+off) (n-start) : loop (n+d) (n+d)
1709+-- else Text arr (start+off) (n-start) : loop (n+d) (n+d)
1566− | otherwise = loop start (n+d)
1710+-- | otherwise = loop start (n+d)
1567− where Iter c d = iter t n
1711+-- where Iter c d = iter t n
1568{-# INLINE words #-}
1712{-# INLINE words #-}
1569
1713
1570-- | /O(n)/ Breaks a 'Text' up into a list of 'Text's at
1714-- | /O(n)/ Breaks a 'Text' up into a list of 'Text's at
1571-- newline 'Char's. The resulting strings do not contain newlines.
1715-- newline 'Char's. The resulting strings do not contain newlines.
1572lines :: Text -> [Text]
1716lines :: Text -> [Text]
1717+lines = coerce JSS.lines
1573−lines ps | null ps = []
1718+-- lines ps | null ps = []
1574− | otherwise = h : if null t
1719+-- | otherwise = h : if null t
1575− then []
1720+-- then []
1576− else lines (unsafeTail t)
1721+-- else lines (unsafeTail t)
1577− where (# h,t #) = span_ (/= '\n') ps
1722+-- where (# h,t #) = span_ (/= '\n') ps
1578{-# INLINE lines #-}
1723{-# INLINE lines #-}
1579
1724
1580{-
1725{-
@@ -1602,34 +1747,40 @@ lines' ps | null ps = []
1602-- | /O(n)/ Joins lines, after appending a terminating newline to
1747-- | /O(n)/ Joins lines, after appending a terminating newline to
1603-- each.
1748-- each.
1604unlines :: [Text] -> Text
1749unlines :: [Text] -> Text
1750+unlines = coerce JSS.unlines
1605−unlines = concat . L.map (`snoc` '\n')
1751+-- unlines = concat . L.map (`snoc` '\n')
1606{-# INLINE unlines #-}
1752{-# INLINE unlines #-}
1607
1753
1608-- | /O(n)/ Joins words using single space characters.
1754-- | /O(n)/ Joins words using single space characters.
1609unwords :: [Text] -> Text
1755unwords :: [Text] -> Text
1756+unwords = coerce JSS.unwords
1610−unwords = intercalate (singleton ' ')
1757+-- unwords = intercalate (singleton ' ')
1611{-# INLINE unwords #-}
1758{-# INLINE unwords #-}
1612
1759
1613-- | /O(n)/ The 'isPrefixOf' function takes two 'Text's and returns
1760-- | /O(n)/ The 'isPrefixOf' function takes two 'Text's and returns
1614-- 'True' iff the first is a prefix of the second. Subject to fusion.
1761-- 'True' iff the first is a prefix of the second. Subject to fusion.
1615isPrefixOf :: Text -> Text -> Bool
1762isPrefixOf :: Text -> Text -> Bool
1763+isPrefixOf = coerce JSS.isPrefixOf
1616−isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
1764+-- isPrefixOf a@(Text _ _ alen) b@(Text _ _ blen) =
1617− alen <= blen && S.isPrefixOf (stream a) (stream b)
1765+-- alen <= blen && S.isPrefixOf (stream a) (stream b)
1618{-# INLINE [1] isPrefixOf #-}
1766{-# INLINE [1] isPrefixOf #-}
1619
1767
1620{-# RULES
1768{-# RULES
1621"TEXT isPrefixOf -> fused" [~1] forall s t.
1769"TEXT isPrefixOf -> fused" [~1] forall s t.
1622 isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1770 isPrefixOf s t = S.isPrefixOf (stream s) (stream t)
1771+"JSSTRING isPrefixOf -> unfused" [1] forall x y.
1772+ S.isPrefixOf (stream x) (stream y) = isPrefixOf x y
1623 #-}
1773 #-}
1624
1774
1625-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns
1775-- | /O(n)/ The 'isSuffixOf' function takes two 'Text's and returns
1626-- 'True' iff the first is a suffix of the second.
1776-- 'True' iff the first is a suffix of the second.
1627isSuffixOf :: Text -> Text -> Bool
1777isSuffixOf :: Text -> Text -> Bool
1778+isSuffixOf = coerce JSS.isSuffixOf
1628−isSuffixOf a@(Text _aarr _aoff alen) b@(Text barr boff blen) =
1779+-- isSuffixOf a@(Text _aarr _aoff alen) b@(Text barr boff blen) =
1629− d >= 0 && a == b'
1780+-- d >= 0 && a == b'
1630− where d = blen - alen
1781+-- where d = blen - alen
1631− b' | d == 0 = b
1782+-- b' | d == 0 = b
1632− | otherwise = Text barr (boff+d) alen
1783+-- | otherwise = Text barr (boff+d) alen
1633{-# INLINE isSuffixOf #-}
1784{-# INLINE isSuffixOf #-}
1634
1785
1635-- | /O(n+m)/ The 'isInfixOf' function takes two 'Text's and returns
1786-- | /O(n+m)/ The 'isInfixOf' function takes two 'Text's and returns
@@ -1639,10 +1790,11 @@ isSuffixOf a@(Text _aarr _aoff alen) b@(Text barr boff blen) =
1639-- In (unlikely) bad cases, this function's time complexity degrades
1790-- In (unlikely) bad cases, this function's time complexity degrades
1640-- towards /O(n*m)/.
1791-- towards /O(n*m)/.
1641isInfixOf :: Text -> Text -> Bool
1792isInfixOf :: Text -> Text -> Bool
1793+isInfixOf = coerce JSS.isInfixOf
1642−isInfixOf needle haystack
1794+-- isInfixOf needle haystack
1643− | null needle = True
1795+-- | null needle = True
1644− | isSingleton needle = S.elem (unsafeHead needle) . S.stream $ haystack
1796+-- | isSingleton needle = S.elem (unsafeHead needle) . S.stream $ haystack
1645− | otherwise = not . L.null . indices needle $ haystack
1797+-- | otherwise = not . L.null . indices needle $ haystack
1646{-# INLINE [1] isInfixOf #-}
1798{-# INLINE [1] isInfixOf #-}
1647
1799
1648{-# RULES
1800{-# RULES
@@ -1672,9 +1824,10 @@ isInfixOf needle haystack
1672-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1824-- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf
1673-- > fnordLength _ = -1
1825-- > fnordLength _ = -1
1674stripPrefix :: Text -> Text -> Maybe Text
1826stripPrefix :: Text -> Text -> Maybe Text
1827+stripPrefix = coerce JSS.stripPrefix
1675−stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1828+-- stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1676− | p `isPrefixOf` t = Just $! text arr (off+plen) (len-plen)
1829+-- | p `isPrefixOf` t = Just $! text arr (off+plen) (len-plen)
1677− | otherwise = Nothing
1830+-- | otherwise = Nothing
1678
1831
1679-- | /O(n)/ Find the longest non-empty common prefix of two strings
1832-- | /O(n)/ Find the longest non-empty common prefix of two strings
1680-- and return it, along with the suffixes of each string at which they
1833-- and return it, along with the suffixes of each string at which they
@@ -1689,15 +1842,16 @@ stripPrefix p@(Text _arr _off plen) t@(Text arr off len)
1689-- > commonPrefixes "veeble" "fetzer" == Nothing
1842-- > commonPrefixes "veeble" "fetzer" == Nothing
1690-- > commonPrefixes "" "baz" == Nothing
1843-- > commonPrefixes "" "baz" == Nothing
1691commonPrefixes :: Text -> Text -> Maybe (Text,Text,Text)
1844commonPrefixes :: Text -> Text -> Maybe (Text,Text,Text)
1845+commonPrefixes = coerce JSS.commonPrefixes
1692−commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
1846+-- commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
1693− where
1847+-- where
1694− go !i !j | i < len0 && j < len1 && a == b = go (i+d0) (j+d1)
1848+-- go !i !j | i < len0 && j < len1 && a == b = go (i+d0) (j+d1)
1695− | i > 0 = Just (Text arr0 off0 i,
1849+-- | i > 0 = Just (Text arr0 off0 i,
1696− text arr0 (off0+i) (len0-i),
1850+-- text arr0 (off0+i) (len0-i),
1697− text arr1 (off1+j) (len1-j))
1851+-- text arr1 (off1+j) (len1-j))
1698− | otherwise = Nothing
1852+-- | otherwise = Nothing
1699− where Iter a d0 = iter t0 i
1853+-- where Iter a d0 = iter t0 i
1700− Iter b d1 = iter t1 j
1854+-- Iter b d1 = iter t1 j
1701
1855
1702-- | /O(n)/ Return the prefix of the second string if its suffix
1856-- | /O(n)/ Return the prefix of the second string if its suffix
1703-- matches the entire first string.
1857-- matches the entire first string.
@@ -1718,21 +1872,22 @@ commonPrefixes t0@(Text arr0 off0 len0) t1@(Text arr1 off1 len1) = go 0 0
1718-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1872-- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre
1719-- > quuxLength _ = -1
1873-- > quuxLength _ = -1
1720stripSuffix :: Text -> Text -> Maybe Text
1874stripSuffix :: Text -> Text -> Maybe Text
1875+stripSuffix = coerce JSS.stripSuffix
1721−stripSuffix p@(Text _arr _off plen) t@(Text arr off len)
1876+-- stripSuffix p@(Text _arr _off plen) t@(Text arr off len)
1722− | p `isSuffixOf` t = Just $! text arr off (len-plen)
1877+-- | p `isSuffixOf` t = Just $! text arr off (len-plen)
1723− | otherwise = Nothing
1878+-- | otherwise = Nothing
1724−
1879+
1725−-- | Add a list of non-negative numbers. Errors out on overflow.
1880+-- -- | Add a list of non-negative numbers. Errors out on overflow.
1726−sumP :: String -> [Int] -> Int
1881+-- sumP :: String -> [Int] -> Int
1727−sumP fun = go 0
1882+-- sumP fun = go 0
1728− where go !a (x:xs)
1883+-- where go !a (x:xs)
1729− | ax >= 0 = go ax xs
1884+-- | ax >= 0 = go ax xs
1730− | otherwise = overflowError fun
1885+-- | otherwise = overflowError fun
1731− where ax = a + x
1886+-- where ax = a + x
1732− go a _ = a
1887+-- go a _ = a
1733−
1888+
1734−emptyError :: String -> a
1889+-- emptyError :: String -> a
1735−emptyError fun = P.error $ "Data.Text." ++ fun ++ ": empty input"
1890+-- emptyError fun = P.error $ "Data.Text." ++ fun ++ ": empty input"
1736
1891
1737overflowError :: String -> a
1892overflowError :: String -> a
1738overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
1893overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
@@ -1746,10 +1901,14 @@ overflowError fun = P.error $ "Data.Text." ++ fun ++ ": size overflow"
1746-- copy \"breaks the link\" to the original array, allowing it to be
1901-- copy \"breaks the link\" to the original array, allowing it to be
1747-- garbage collected if there are no other live references to it.
1902-- garbage collected if there are no other live references to it.
1748copy :: Text -> Text
1903copy :: Text -> Text
1904+copy = P.id -- TODO
1749−copy (Text arr off len) = Text (A.run go) 0 len
1905+-- copy (Text arr off len) = Text (A.run go) 0 len
1750− where
1906+-- where
1751− go :: ST s (A.MArray s)
1907+-- go :: ST s (A.MArray s)
1752− go = do
1908+-- go = do
1753− marr <- A.new len
1909+-- marr <- A.new len
1754− A.copyI marr 0 arr off len
1910+
1755− return marr
1911+foreign import javascript unsafe
1912+ "h$jsstringReplicateChar" js_replicateChar :: Int -> Char -> JSString
1913+foreign import javascript unsafe
1914+ "$2.substr($1)" js_substr1 :: Int -> JSString -> JSString
Data/Text/Encoding.hs+28
@@ -3,6 +3,7 @@
3#if __GLASGOW_HASKELL__ >= 702
3#if __GLASGOW_HASKELL__ >= 702
4{-# LANGUAGE Trustworthy #-}
4{-# LANGUAGE Trustworthy #-}
5#endif
5#endif
6+{-# LANGUAGE UnboxedTuples #-}
6-- |
7-- |
7-- Module : Data.Text.Encoding
8-- Module : Data.Text.Encoding
8-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,
9-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan,
@@ -76,7 +77,9 @@ import Data.Text.Internal (Text(..), safe, text)
76import Data.Text.Internal.Private (runText)
77import Data.Text.Internal.Private (runText)
77import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
78import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
78import Data.Text.Internal.Unsafe.Shift (shiftR)
79import Data.Text.Internal.Unsafe.Shift (shiftR)
80+#ifndef __GHCJS__
79import Data.Text.Show ()
81import Data.Text.Show ()
82+#endif
80import Data.Text.Unsafe (unsafeDupablePerformIO)
83import Data.Text.Unsafe (unsafeDupablePerformIO)
81import Data.Word (Word8, Word32)
84import Data.Word (Word8, Word32)
82import Foreign.C.Types (CSize(..))
85import Foreign.C.Types (CSize(..))
@@ -95,6 +98,12 @@ import qualified Data.Text.Internal.Encoding.Utf16 as U16
95import qualified Data.Text.Internal.Fusion as F
98import qualified Data.Text.Internal.Fusion as F
96
99
97#include "text_cbits.h"
100#include "text_cbits.h"
101+#ifdef __GHCJS__
102+import GHC.Exts (Int(..), Int#)
103+import Data.ByteString (ByteString)
104+import GHCJS.Buffer
105+import Data.JSString (JSString)
106+#endif
98
107
99-- $strict
108-- $strict
100--
109--
@@ -326,9 +335,18 @@ encodeUtf8BuilderEscaped be =
326 where
335 where
327 bound = max 4 $ BP.sizeBound be
336 bound = max 4 $ BP.sizeBound be
328
337
338+#ifndef __GHCJS__
329 mkBuildstep (Text arr off len) !k =
339 mkBuildstep (Text arr off len) !k =
340+#else
341+ mkBuildstep (Text t) !k =
342+#endif
330 outerLoop off
343 outerLoop off
331 where
344 where
345+#ifdef __GHCJS__
346+ off = 0
347+ (arr, len) = let (# ba, len' #) = js_fromString t
348+ in (A.Array ba, I# len')
349+#endif
332 iend = off + len
350 iend = off + len
333
351
334 outerLoop !i0 !br@(B.BufferRange op0 ope)
352 outerLoop !i0 !br@(B.BufferRange op0 ope)
@@ -370,6 +388,7 @@ encodeUtf8BuilderEscaped be =
370
388
371-- | Encode text using UTF-8 encoding.
389-- | Encode text using UTF-8 encoding.
372encodeUtf8 :: Text -> ByteString
390encodeUtf8 :: Text -> ByteString
391+#ifndef __GHCJS__
373encodeUtf8 (Text arr off len)
392encodeUtf8 (Text arr off len)
374 | len == 0 = B.empty
393 | len == 0 = B.empty
375 | otherwise = unsafeDupablePerformIO $ do
394 | otherwise = unsafeDupablePerformIO $ do
@@ -386,6 +405,10 @@ encodeUtf8 (Text arr off len)
386 withForeignPtr fp' $ \ptr' -> do
405 withForeignPtr fp' $ \ptr' -> do
387 memcpy ptr' ptr (fromIntegral utf8len)
406 memcpy ptr' ptr (fromIntegral utf8len)
388 return (PS fp' 0 utf8len)
407 return (PS fp' 0 utf8len)
408+#else
409+encodeUtf8 (Text txt) = toByteString 0 (Just (byteLength buf - 1)) buf
410+ where buf = js_encodeUtf8 txt
411+#endif
389
412
390-- | Decode text from little endian UTF-16 encoding.
413-- | Decode text from little endian UTF-16 encoding.
391decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
414decodeUtf16LEWith :: OnDecodeError -> ByteString -> Text
@@ -475,5 +498,10 @@ foreign import ccall unsafe "_hs_text_decode_utf8_state" c_decode_utf8_with_stat
475foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
498foreign import ccall unsafe "_hs_text_decode_latin1" c_decode_latin1
476 :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
499 :: MutableByteArray# s -> Ptr Word8 -> Ptr Word8 -> IO ()
477
500
501+#ifndef __GHCJS__
478foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
502foreign import ccall unsafe "_hs_text_encode_utf8" c_encode_utf8
479 :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()
503 :: Ptr (Ptr Word8) -> ByteArray# -> CSize -> CSize -> IO ()
504+#else
505+foreign import javascript unsafe "h$textFromString" js_fromString :: JSString -> (# ByteArray#, Int# #)
506+foreign import javascript unsafe "h$encodeUtf8($1)" js_encodeUtf8 :: JSString -> Buffer
507+#endif
Data/Text/IO.hs+16
@@ -185,7 +185,11 @@ hPutStr h t = do
185 | otherwise -> writeBlocksRaw h buf str
185 | otherwise -> writeBlocksRaw h buf str
186
186
187hPutChars :: Handle -> Stream Char -> IO ()
187hPutChars :: Handle -> Stream Char -> IO ()
188+#ifndef __GHCJS__
188hPutChars h (Stream next0 s0 _len) = loop s0
189hPutChars h (Stream next0 s0 _len) = loop s0
190+#else
191+hPutChars h (Stream next0 s0) = loop s0
192+#endif
189 where
193 where
190 loop !s = case next0 s of
194 loop !s = case next0 s of
191 Done -> return ()
195 Done -> return ()
@@ -203,7 +207,11 @@ hPutChars h (Stream next0 s0 _len) = loop s0
203-- handling gave a few more percent on top.
207-- handling gave a few more percent on top.
204
208
205writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO ()
209writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO ()
210+#ifndef __GHCJS__
206writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0
211writeLines 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
207 where
215 where
208 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
216 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
209 where
217 where
@@ -223,7 +231,11 @@ writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0
223 commit = commitBuffer h raw len
231 commit = commitBuffer h raw len
224
232
225writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
233writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
234+#ifndef __GHCJS__
226writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
235writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
236+#else
237+writeBlocksCRLF h buf0 (Stream next0 s0) = outer s0 buf0
238+#endif
227 where
239 where
228 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
240 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
229 where
241 where
@@ -239,7 +251,11 @@ writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
239 commit = commitBuffer h raw len
251 commit = commitBuffer h raw len
240
252
241writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
253writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
254+#ifndef __GHCJS__
242writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
255writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
256+#else
257+writeBlocksRaw h buf0 (Stream next0 s0) = outer s0 buf0
258+#endif
243 where
259 where
244 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
260 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
245 where
261 where
Data/Text/Internal.hs+47−125
@@ -1,127 +1,66 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, UnboxedTuples, MagicHash,
2−{-# OPTIONS_HADDOCK not-home #-}
2+ BangPatterns, ForeignFunctionInterface, JavaScriptFFI, GeneralizedNewtypeDeriving #-}
3−
3+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes,
4−-- |
4+ GHCForeignImportPrim, MagicHash, FlexibleInstances #-}
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−
27module Data.Text.Internal
5module Data.Text.Internal
28− (
6+ ( module Data.Text.Internal
29− -- * Types
30− -- $internals
31− Text(..)
32− -- * Construction
33− , text
34− , textP
35− -- * Safety
36− , safe
7+ , JSS.safe
37− -- * Code that must be here for accessibility
38− , empty
39− , empty_
40− -- * Utilities
41− , firstf
8+ , JSS.firstf
42− -- * Checked multiplication
43− , mul
44− , mul32
45− , mul64
46− -- * Debugging
47− , showText
48− ) where
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
49
24
50−#if defined(ASSERTS)
51−import Control.Exception (assert)
52−#endif
53import Data.Bits
25import Data.Bits
54import Data.Int (Int32, Int64)
26import Data.Int (Int32, Int64)
55−import Data.Text.Internal.Unsafe.Char (ord)
27+-- import Data.Text.Internal.Unsafe.Char (ord)
56import Data.Typeable (Typeable)
28import Data.Typeable (Typeable)
29+import GHC.Exts (ByteArray#, Char(..), ord#, andI#, (/=#), isTrue#, (==#), Int(..), Int#, isTrue#)
57−import qualified Data.Text.Array as A
30+-- import qualified Data.Text.Array as A
31+import GHCJS.Marshal.Pure
32+import GHCJS.Marshal
33+import qualified GHC.CString as GHC
58
34
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)
65
35
66−-- | Smart constructor.
36+newtype Text = Text JSString
67−text_ :: A.Array -> Int -> Int -> Text
37+ deriving ( Show, Eq, Ord, IsString, Monoid, Read, Data
68−text_ arr off len =
38+ , PToJSVal, PFromJSVal, FromJSVal, ToJSVal
69−#if defined(ASSERTS)
39+ )
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_ #-}
79
40
80−-- | /O(1)/ The empty 'Text'.
81empty :: Text
41empty :: Text
82−empty = Text A.empty 0 0
42+empty = Text JSS.empty
83{-# INLINE [1] empty #-}
43{-# INLINE [1] empty #-}
84
44
85−-- | A non-inlined version of 'empty'.
86empty_ :: Text
45empty_ :: Text
87−empty_ = Text A.empty 0 0
46+empty_ = Text JSS.empty
88{-# NOINLINE empty_ #-}
47{-# NOINLINE empty_ #-}
89
48
49+foreign import javascript unsafe
50+ "String.fromCharCode.apply(null, $1['u8'])"
51+ js_decodeBytes :: ByteArray# -> JSString
52+
53+foreign import javascript unsafe
54+ "h$textToString"
55+ js_textToString :: ByteArray# -> Int# -> Int# -> JSString
56+
90-- | Construct a 'Text' without invisibly pinning its byte array in
57-- | Construct a 'Text' without invisibly pinning its byte array in
91-- memory if its length has dwindled to zero.
58-- memory if its length has dwindled to zero.
92text :: A.Array -> Int -> Int -> Text
59text :: A.Array -> Int -> Int -> Text
93−text arr off len | len == 0 = empty
60+-- text arr off len | len == 0 = empty
94− | otherwise = text_ arr off len
61+-- | otherwise = text_ arr off len
95−{-# INLINE text #-}
62+text (A.Array ba) (I# off#) (I# len#) | isTrue# (len# ==# 0#) = empty
96−
63+ | otherwise = Text $ js_textToString ba off# len#
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
125
64
126-- | Checked multiplication. Calls 'error' if the result would
65-- | Checked multiplication. Calls 'error' if the result would
127-- overflow.
66-- overflow.
@@ -168,21 +107,4 @@ mul32 a b = case fromIntegral a * fromIntegral b of
168{-# INLINE mul32 #-}
107{-# INLINE mul32 #-}
169infixl 7 `mul32`
108infixl 7 `mul32`
170
109
171−-- $internals
110+--------------------------------------
172−--
173−-- Internally, the 'Text' type is represented as an array of 'Word16'
174−-- UTF-16 code units. The offset and length fields in the constructor
175−-- are in these units, /not/ units of 'Char'.
176−--
177−-- Invariants that all functions must maintain:
178−--
179−-- * Since the 'Text' type uses UTF-16 internally, it cannot represent
180−-- characters in the reserved surrogate code point range U+D800 to
181−-- U+DFFF. To maintain this invariant, the 'safe' function maps
182−-- 'Char' values in this range to the replacement character (U+FFFD,
183−-- \'&#xfffd;\').
184−--
185−-- * A leading (or \"high\") surrogate code unit (0xD800–0xDBFF) must
186−-- always be followed by a trailing (or \"low\") surrogate code unit
187−-- (0xDC00-0xDFFF). A trailing surrogate code unit must always be
188−-- preceded by a leading surrogate code unit.
Data/Text/Internal/Builder.hs+47−5
@@ -1,4 +1,6 @@
1{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
1{-# LANGUAGE BangPatterns, CPP, Rank2Types #-}
2+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, UnboxedTuples,
3+ MagicHash #-}
2{-# OPTIONS_HADDOCK not-home #-}
4{-# OPTIONS_HADDOCK not-home #-}
3
5
4-----------------------------------------------------------------------------
6-----------------------------------------------------------------------------
@@ -73,6 +75,8 @@ import qualified Data.Text as S
73import qualified Data.Text.Array as A
75import qualified Data.Text.Array as A
74import qualified Data.Text.Lazy as L
76import qualified Data.Text.Lazy as L
75
77
78+import Data.JSString (JSString)
79+import GHC.Exts (ByteArray#, Int#, Int(I#))
76------------------------------------------------------------------------
80------------------------------------------------------------------------
77
81
78-- | A @Builder@ is an efficient way to build lazy @Text@ values.
82-- | A @Builder@ is an efficient way to build lazy @Text@ values.
@@ -164,10 +168,17 @@ copyLimit = 128
164-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
168-- * @'toLazyText' ('fromText' t) = 'L.fromChunks' [t]@
165--
169--
166fromText :: S.Text -> Builder
170fromText :: S.Text -> Builder
167−fromText t@(Text arr off l)
171+fromText t@(Text t')
168 | S.null t = empty
172 | S.null t = empty
169 | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
173 | l <= copyLimit = writeN l $ \marr o -> A.copyI marr o arr off (l+o)
170 | otherwise = flush `append` mapBuilder (t :)
174 | 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 :)
171{-# INLINE [1] fromText #-}
182{-# INLINE [1] fromText #-}
172
183
173{-# RULES
184{-# RULES
@@ -182,10 +193,10 @@ fromText t@(Text arr off l)
182fromString :: String -> Builder
193fromString :: String -> Builder
183fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
194fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
184 let loop !marr !o !u !l [] = k (Buffer marr o u l)
195 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)
186 | l <= 1 = do
197 | l <= 1 = do
187 arr <- A.unsafeFreeze marr
198 arr <- A.unsafeFreeze marr
188− let !t = Text arr o u
199+ let !t = Text $ js_toString (A.aBA arr) o# u#
189 marr' <- A.new chunkSize
200 marr' <- A.new chunkSize
190 ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
201 ts <- inlineInterleaveST (loop marr' 0 0 chunkSize s)
191 return $ t : ts
202 return $ t : ts
@@ -195,6 +206,21 @@ fromString str = Builder $ \k (Buffer p0 o0 u0 l0) ->
195 in loop p0 o0 u0 l0 str
206 in loop p0 o0 u0 l0 str
196 where
207 where
197 chunkSize = smallChunkSize
208 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
198{-# INLINE fromString #-}
224{-# INLINE fromString #-}
199
225
200-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
226-- | /O(1)./ A @Builder@ taking a lazy @Text@, satisfying
@@ -234,16 +260,24 @@ toLazyTextWith chunkSize m = L.fromChunks (runST $
234-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
260-- | /O(1)./ Pop the strict @Text@ we have constructed so far, if any,
235-- yielding a new chunk in the result lazy @Text@.
261-- yielding a new chunk in the result lazy @Text@.
236flush :: Builder
262flush :: 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) ->
238 if u == 0
264 if u == 0
239 then k buf
265 then k buf
240 else do arr <- A.unsafeFreeze p
266 else do arr <- A.unsafeFreeze p
241 let !b = Buffer p (o+u) 0 l
267 let !b = Buffer p (o+u) 0 l
242− !t = Text arr o u
268+ !t = Text $ js_toString (A.aBA arr) o# u#
243 ts <- inlineInterleaveST (k b)
269 ts <- inlineInterleaveST (k b)
244 return $! t : ts
270 return $! t : ts
245{-# INLINE [1] flush #-}
271{-# INLINE [1] flush #-}
246-- defer inlining so that flush/flush rule may fire.
272-- 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
247
281
248------------------------------------------------------------------------
282------------------------------------------------------------------------
249
283
@@ -327,3 +361,11 @@ append' (Builder f) (Builder g) = Builder (f . g)
327 append flush flush = flush
361 append flush flush = flush
328
362
329 #-}
363 #-}
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
55import Data.Text.Unsafe (unsafeDupablePerformIO)
55import Data.Text.Unsafe (unsafeDupablePerformIO)
56
56
57streamASCII :: ByteString -> Stream Char
57streamASCII :: ByteString -> Stream Char
58−streamASCII bs = Stream next 0 (maxSize l)
58+streamASCII bs = Stream next 0 -- (maxSize l)
59 where
59 where
60 l = B.length bs
60 l = B.length bs
61 {-# INLINE next #-}
61 {-# INLINE next #-}
@@ -70,7 +70,7 @@ streamASCII bs = Stream next 0 (maxSize l)
70-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8
70-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8
71-- encoding.
71-- encoding.
72streamUtf8 :: OnDecodeError -> ByteString -> Stream Char
72streamUtf8 :: OnDecodeError -> ByteString -> Stream Char
73−streamUtf8 onErr bs = Stream next 0 (maxSize l)
73+streamUtf8 onErr bs = Stream next 0 -- (maxSize l)
74 where
74 where
75 l = B.length bs
75 l = B.length bs
76 next i
76 next i
@@ -91,7 +91,7 @@ streamUtf8 onErr bs = Stream next 0 (maxSize l)
91-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
91-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
92-- endian UTF-16 encoding.
92-- endian UTF-16 encoding.
93streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char
93streamUtf16LE :: 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))
95 where
95 where
96 l = B.length bs
96 l = B.length bs
97 {-# INLINE next #-}
97 {-# INLINE next #-}
@@ -109,7 +109,7 @@ streamUtf16LE onErr bs = Stream next 0 (maxSize (l `shiftR` 1))
109-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
109-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
110-- endian UTF-16 encoding.
110-- endian UTF-16 encoding.
111streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char
111streamUtf16BE :: 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))
113 where
113 where
114 l = B.length bs
114 l = B.length bs
115 {-# INLINE next #-}
115 {-# INLINE next #-}
@@ -127,7 +127,7 @@ streamUtf16BE onErr bs = Stream next 0 (maxSize (l `shiftR` 1))
127-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
127-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
128-- endian UTF-32 encoding.
128-- endian UTF-32 encoding.
129streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char
129streamUtf32BE :: 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))
131 where
131 where
132 l = B.length bs
132 l = B.length bs
133 {-# INLINE next #-}
133 {-# INLINE next #-}
@@ -147,7 +147,7 @@ streamUtf32BE onErr bs = Stream next 0 (maxSize (l `shiftR` 2))
147-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
147-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
148-- endian UTF-32 encoding.
148-- endian UTF-32 encoding.
149streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char
149streamUtf32LE :: 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))
151 where
151 where
152 l = B.length bs
152 l = B.length bs
153 {-# INLINE next #-}
153 {-# INLINE next #-}
@@ -166,8 +166,10 @@ streamUtf32LE onErr bs = Stream next 0 (maxSize (l `shiftR` 2))
166
166
167-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
167-- | /O(n)/ Convert a 'Stream' 'Word8' to a 'ByteString'.
168unstream :: Stream Word8 -> ByteString
168unstream :: Stream Word8 -> ByteString
169−unstream (Stream next s0 len) = unsafeDupablePerformIO $ do
169+-- unstream (Stream next s0 len) = unsafeDupablePerformIO $ do
170+unstream (Stream next s0) = unsafeDupablePerformIO $ do
170− let mlen = upperBound 4 len
171+ -- let mlen = upperBound 4 len
172+ let mlen = 4
171 mallocByteString mlen >>= loop mlen 0 s0
173 mallocByteString mlen >>= loop mlen 0 s0
172 where
174 where
173 loop !n !off !s fp = case next s of
175 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)
37import Data.Word (Word8)
37import Data.Word (Word8)
38
38
39restreamUtf16BE :: Stream Char -> Stream Word8
39restreamUtf16BE :: 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)
41 where
42 where
42 next (RS0 s) = case next0 s of
43 next (RS0 s) = case next0 s of
43 Done -> Done
44 Done -> Done
@@ -61,7 +62,8 @@ restreamUtf16BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
61{-# INLINE restreamUtf16BE #-}
62{-# INLINE restreamUtf16BE #-}
62
63
63restreamUtf16LE :: Stream Char -> Stream Word8
64restreamUtf16LE :: 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)
65 where
67 where
66 next (RS0 s) = case next0 s of
68 next (RS0 s) = case next0 s of
67 Done -> Done
69 Done -> Done
@@ -85,7 +87,8 @@ restreamUtf16LE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
85{-# INLINE restreamUtf16LE #-}
87{-# INLINE restreamUtf16LE #-}
86
88
87restreamUtf32BE :: Stream Char -> Stream Word8
89restreamUtf32BE :: 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)
89 where
92 where
90 next (RS0 s) = case next0 s of
93 next (RS0 s) = case next0 s of
91 Done -> Done
94 Done -> Done
@@ -104,7 +107,8 @@ restreamUtf32BE (Stream next0 s0 len) = Stream next (RS0 s0) (len * 2)
104{-# INLINE restreamUtf32BE #-}
107{-# INLINE restreamUtf32BE #-}
105
108
106restreamUtf32LE :: Stream Char -> Stream Word8
109restreamUtf32LE :: 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)
108 where
112 where
109 next (RS0 s) = case next0 s of
113 next (RS0 s) = case next0 s of
110 Done -> Done
114 Done -> Done
Data/Text/Internal/Fusion.hs+40−166
@@ -28,217 +28,91 @@ module Data.Text.Internal.Fusion
28 , unstream
28 , unstream
29 , reverseStream
29 , reverseStream
30
30
31− , length
31+ , Data.Text.Internal.Fusion.length
32
32
33 -- * Transformations
33 -- * Transformations
34− , reverse
34+ , Data.Text.Internal.Fusion.reverse
35
35
36 -- * Construction
36 -- * Construction
37 -- ** Scans
37 -- ** Scans
38 , reverseScanr
38 , reverseScanr
39
39
40 -- ** Accumulating maps
40 -- ** Accumulating maps
41− , mapAccumL
41+ , Data.Text.Internal.Fusion.mapAccumL
42
42
43 -- ** Generation and unfolding
43 -- ** Generation and unfolding
44 , unfoldrN
44 , unfoldrN
45
45
46 -- * Indexing
46 -- * Indexing
47− , index
47+ , Data.Text.Internal.Fusion.index
48− , findIndex
48+ , Data.Text.Internal.Fusion.findIndex
49 , countChar
49 , countChar
50 ) where
50 ) where
51
51
52−import Prelude (Bool(..), Char, Maybe(..), Monad(..), Int,
52+import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))
53− Num(..), Ord(..), ($), (&&),
53+
54− fromIntegral, otherwise)
54+import Prelude hiding (length, reverse)
55−import Data.Bits ((.&.))
55+import Data.Char
56+
56−import Data.Text.Internal (Text(..))
57+import Data.JSString.Internal.Type (JSString(..))
57−import Data.Text.Internal.Private (runText)
58+import qualified Data.JSString.Internal.Type as I
58−import Data.Text.Internal.Unsafe.Char (ord, unsafeChr, unsafeWrite)
59−import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
59+import Data.JSString.Internal.Fusion.Types
60−import qualified Data.Text.Array as A
61−import qualified Data.Text.Internal.Fusion.Common as S
60+import qualified Data.JSString.Internal.Fusion.Common as S
62−import Data.Text.Internal.Fusion.Types
61+
62+import System.IO.Unsafe
63+
64+import GHCJS.Prim
65+
66+import Data.Coerce
63−import Data.Text.Internal.Fusion.Size
67+import Data.Text.Internal
64−import qualified Data.Text.Internal as I
68+import qualified Data.JSString.Internal.Fusion as JSS
65−import qualified Data.Text.Internal.Encoding.Utf16 as U16
69+import Data.JSString.Internal.Fusion.Types (Stream(..))
66
70
67default(Int)
71default(Int)
68
72
69−-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
70stream :: Text -> Stream Char
73stream :: Text -> Stream Char
71−stream (Text arr off len) = Stream next off (betweenSize (len `shiftR` 1) len)
74+stream = coerce JSS.stream
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 #-}
75{-# INLINE [0] stream #-}
82
76
83−-- | /O(n)/ Convert a 'Text' into a 'Stream Char', but iterate
84−-- backwards.
85reverseStream :: Text -> Stream Char
77reverseStream :: Text -> Stream Char
86−reverseStream (Text arr off len) = Stream next (off+len-1) (betweenSize (len `shiftR` 1) len)
78+reverseStream = coerce JSS.reverseStream
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 #-}
79{-# INLINE [0] reverseStream #-}
97
80
98−-- | /O(n)/ Convert a 'Stream Char' into a 'Text'.
99unstream :: Stream Char -> Text
81unstream :: Stream Char -> Text
100−unstream (Stream next0 s0 len) = runText $ \done -> do
82+unstream = coerce JSS.unstream
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 #-}
83{-# INLINE [0] unstream #-}
131{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
84{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
132
85
133−
134−-- ----------------------------------------------------------------------------
135−-- * Basic stream functions
136−
137length :: Stream Char -> Int
86length :: Stream Char -> Int
138−length = S.lengthI
87+length = JSS.length
139−{-# INLINE[0] length #-}
88+{-# INLINE [0] length #-}
140
89
141−-- | /O(n)/ Reverse the characters of a string.
142reverse :: Stream Char -> Text
90reverse :: Stream Char -> Text
143−reverse (Stream next s len0)
91+reverse = coerce JSS.reverse
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 #-}
92{-# INLINE [0] reverse #-}
175
93
176−-- | /O(n)/ Perform the equivalent of 'scanr' over a list, only with
177−-- the input and result reversed.
178reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
94reverseScanr :: (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
95+reverseScanr = JSS.reverseScanr
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 #-}
96{-# INLINE reverseScanr #-}
189
97
190−-- | /O(n)/ Like 'unfoldr', 'unfoldrN' builds a stream from a seed
98+mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, Text)
191−-- value. However, the length of the result is limited by the
99+mapAccumL f z0 st =
192−-- first argument to 'unfoldrN'. This function is more efficient than
100+ let (a, t) = JSS.mapAccumL f z0 st
193−-- 'unfoldr' when the length of the result is known.
101+ in (a, Text t)
102+{-# INLINE [0] mapAccumL #-}
103+
194unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
104unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
195−unfoldrN n = S.unfoldrNI n
105+unfoldrN = JSS.unfoldrN
196{-# INLINE [0] unfoldrN #-}
106{-# INLINE [0] unfoldrN #-}
197
107
198−-------------------------------------------------------------------------------
199−-- ** Indexing streams
200−
201−-- | /O(n)/ stream index (subscript) operator, starting from 0.
202index :: Stream Char -> Int -> Char
108index :: Stream Char -> Int -> Char
203−index = S.indexI
109+index = JSS.index
204{-# INLINE [0] index #-}
110{-# INLINE [0] index #-}
205
111
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.
209findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
112findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
210−findIndex = S.findIndexI
113+findIndex = JSS.findIndex
211{-# INLINE [0] findIndex #-}
114{-# INLINE [0] findIndex #-}
212
115
213−-- | /O(n)/ The 'count' function returns the number of times the query
214−-- element appears in the given stream.
215countChar :: Char -> Stream Char -> Int
116countChar :: Char -> Stream Char -> Int
216−countChar = S.countCharI
117+countChar = JSS.countChar
217{-# INLINE [0] countChar #-}
118{-# INLINE [0] countChar #-}
218−
219−-- | /O(n)/ Like a combination of 'map' and 'foldl''. Applies a
220−-- function to each element of a 'Text', passing an accumulating
221−-- parameter from left to right, and returns a final 'Text'.
222−mapAccumL :: (a -> Char -> (a,Char)) -> a -> Stream Char -> (a, Text)
223−mapAccumL f z0 (Stream next0 s0 len) = (nz, I.text na 0 nl)
224− where
225− (na,(nz,nl)) = A.run2 (A.new mlen >>= \arr -> outer arr mlen z0 s0 0)
226− where mlen = upperBound 4 len
227− outer arr top = loop
228− where
229− loop !z !s !i =
230− case next0 s of
231− Done -> return (arr, (z,i))
232− Skip s' -> loop z s' i
233− Yield x s'
234− | j >= top -> {-# SCC "mapAccumL/resize" #-} do
235− let top' = (top + 1) `shiftL` 1
236− arr' <- A.new top'
237− A.copyM arr' 0 arr 0 top
238− outer arr' top' z s i
239− | otherwise -> do d <- unsafeWrite arr i c
240− loop z' s' (i+d)
241− where (z',c) = f z x
242− j | ord c < 0x10000 = i
243− | otherwise = i + 1
244−{-# INLINE [0] mapAccumL #-}
Data/Text/Internal/Fusion/Common.hs+968−922
@@ -14,925 +14,971 @@
14--
14--
15-- Common stream fusion functionality for text.
15-- Common stream fusion functionality for text.
16
16
17−module Data.Text.Internal.Fusion.Common
17+module Data.Text.Internal.Fusion.Common (module Data.JSString.Internal.Fusion.Common) where
18− (
18+import Data.JSString.Internal.Fusion.Common
19− -- * Creation and elimination
19+-- module Data.Text.Internal.Fusion.Common
20− singleton
20+-- (
21− , streamList
21+-- -- * Creation and elimination
22− , unstreamList
22+-- singleton
23− , streamCString#
23+-- , streamList
24−
24+-- , unstreamList
25− -- * Basic interface
25+-- , streamCString#
26− , cons
26+
27− , snoc
27+-- -- * Basic interface
28− , append
28+-- , cons
29− , head
29+-- , snoc
30− , uncons
30+-- , append
31− , last
31+-- , head
32− , tail
32+-- , uncons
33− , init
33+-- , last
34− , null
34+-- , tail
35− , lengthI
35+-- , init
36− , compareLengthI
36+-- , null
37− , isSingleton
37+-- , lengthI
38−
38+-- , compareLengthI
39− -- * Transformations
39+-- , isSingleton
40− , map
40+
41− , intercalate
41+-- -- * Transformations
42− , intersperse
42+-- , map
43−
43+-- , intercalate
44− -- ** Case conversion
44+-- , intersperse
45− -- $case
45+
46− , toCaseFold
46+-- -- ** Case conversion
47− , toLower
47+-- -- $case
48− , toTitle
48+-- , toCaseFold
49− , toUpper
49+-- , toLower
50−
50+-- , toTitle
51− -- ** Justification
51+-- , toUpper
52− , justifyLeftI
52+
53−
53+-- -- ** Justification
54− -- * Folds
54+-- , justifyLeftI
55− , foldl
55+
56− , foldl'
56+-- -- * Folds
57− , foldl1
57+-- , foldl
58− , foldl1'
58+-- , foldl'
59− , foldr
59+-- , foldl1
60− , foldr1
60+-- , foldl1'
61−
61+-- , foldr
62− -- ** Special folds
62+-- , foldr1
63− , concat
63+
64− , concatMap
64+-- -- ** Special folds
65− , any
65+-- , concat
66− , all
66+-- , concatMap
67− , maximum
67+-- , any
68− , minimum
68+-- , all
69−
69+-- , maximum
70− -- * Construction
70+-- , minimum
71− -- ** Scans
71+
72− , scanl
72+-- -- * Construction
73−
73+-- -- ** Scans
74− -- ** Generation and unfolding
74+-- , scanl
75− , replicateCharI
75+
76− , replicateI
76+-- -- ** Generation and unfolding
77− , unfoldr
77+-- , replicateCharI
78− , unfoldrNI
78+-- , replicateI
79−
79+-- , unfoldr
80− -- * Substrings
80+-- , unfoldrNI
81− -- ** Breaking strings
81+
82− , take
82+-- -- * Substrings
83− , drop
83+-- -- ** Breaking strings
84− , takeWhile
84+-- , take
85− , dropWhile
85+-- , drop
86−
86+-- , takeWhile
87− -- * Predicates
87+-- , dropWhile
88− , isPrefixOf
88+
89−
89+-- -- * Predicates
90− -- * Searching
90+-- , isPrefixOf
91− , elem
91+
92− , filter
92+-- -- * Searching
93−
93+-- , elem
94− -- * Indexing
94+-- , filter
95− , findBy
95+
96− , indexI
96+-- -- * Indexing
97− , findIndexI
97+-- , findBy
98− , countCharI
98+-- , indexI
99−
99+-- , findIndexI
100− -- * Zipping and unzipping
100+-- , countCharI
101− , zipWith
101+
102− ) where
102+-- -- * Zipping and unzipping
103−
103+-- , zipWith
104−import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),
104+-- ) where
105− Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++),
105+
106− (&&), fromIntegral, otherwise)
106+-- import Prelude (Bool(..), Char, Eq(..), Int, Integral, Maybe(..),
107−import qualified Data.List as L
107+-- Ord(..), Ordering(..), String, (.), ($), (+), (-), (*), (++),
108−import qualified Prelude as P
108+-- (&&), fromIntegral, otherwise)
109−import Data.Bits (shiftL)
109+-- import qualified Data.List as L
110−import Data.Char (isLetter)
110+-- import qualified Prelude as P
111−import Data.Int (Int64)
111+-- import Data.Bits (shiftL)
112−import Data.Text.Internal.Fusion.Types
112+-- import Data.Char (isLetter)
113−import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping,
113+-- import Data.Int (Int64)
114− upperMapping)
114+-- import Data.Text.Internal.Fusion.Types
115−import Data.Text.Internal.Fusion.Size
115+-- import Data.Text.Internal.Fusion.CaseMapping (foldMapping, lowerMapping, titleMapping,
116−import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)
116+-- upperMapping)
117−import GHC.Types (Char(..), Int(..))
117+-- import Data.Text.Internal.Fusion.Size
118−
118+-- import GHC.Prim (Addr#, chr#, indexCharOffAddr#, ord#)
119−singleton :: Char -> Stream Char
119+-- import GHC.Types (Char(..), Int(..))
120−singleton c = Stream next False 1
120+
121− where next False = Yield c True
121+-- singleton :: Char -> Stream Char
122− next True = Done
122+-- singleton c = Stream next False -- 1
123−{-# INLINE [0] singleton #-}
123+-- where next False = Yield c True
124−
124+-- next True = Done
125−streamList :: [a] -> Stream a
125+-- {-# INLINE [0] singleton #-}
126−{-# INLINE [0] streamList #-}
126+
127−streamList s = Stream next s unknownSize
127+-- streamList :: [a] -> Stream a
128− where next [] = Done
128+-- {-# INLINE [0] streamList #-}
129− next (x:xs) = Yield x xs
129+-- streamList s = Stream next s -- unknownSize
130−
130+-- where next [] = Done
131−unstreamList :: Stream a -> [a]
131+-- next (x:xs) = Yield x xs
132−unstreamList (Stream next s0 _len) = unfold s0
132+
133− where unfold !s = case next s of
133+-- unstreamList :: Stream a -> [a]
134− Done -> []
134+-- -- unstreamList (Stream next s0 _len) = unfold s0
135− Skip s' -> unfold s'
135+-- unstreamList (Stream next s0) = unfold s0
136− Yield x s' -> x : unfold s'
136+-- where unfold !s = case next s of
137−{-# INLINE [0] unstreamList #-}
137+-- Done -> []
138−
138+-- Skip s' -> unfold s'
139−{-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}
139+-- Yield x s' -> x : unfold s'
140−
140+-- {-# INLINE [0] unstreamList #-}
141−-- | Stream the UTF-8-like packed encoding used by GHC to represent
141+
142−-- constant strings in generated code.
142+-- {-# RULES "STREAM streamList/unstreamList fusion" forall s. streamList (unstreamList s) = s #-}
143−--
143+
144−-- This encoding uses the byte sequence "\xc0\x80" to represent NUL,
144+-- -- | Stream the UTF-8-like packed encoding used by GHC to represent
145−-- and the string is NUL-terminated.
145+-- -- constant strings in generated code.
146−streamCString# :: Addr# -> Stream Char
146+-- --
147−streamCString# addr = Stream step 0 unknownSize
147+-- -- This encoding uses the byte sequence "\xc0\x80" to represent NUL,
148− where
148+-- -- and the string is NUL-terminated.
149− step !i
149+-- streamCString# :: Addr# -> Stream Char
150− | b == 0 = Done
150+-- streamCString# addr = Stream step 0 -- unknownSize
151− | b <= 0x7f = Yield (C# b#) (i+1)
151+-- where
152− | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1
152+-- step !i
153− in Yield c (i+2)
153+-- | b == 0 = Done
154− | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) +
154+-- | b <= 0x7f = Yield (C# b#) (i+1)
155− (next 1 `shiftL` 6) +
155+-- | b <= 0xdf = let !c = chr $ ((b-0xc0) `shiftL` 6) + next 1
156− next 2
156+-- in Yield c (i+2)
157− in Yield c (i+3)
157+-- | b <= 0xef = let !c = chr $ ((b-0xe0) `shiftL` 12) +
158− | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) +
158+-- (next 1 `shiftL` 6) +
159− (next 1 `shiftL` 12) +
159+-- next 2
160− (next 2 `shiftL` 6) +
160+-- in Yield c (i+3)
161− next 3
161+-- | otherwise = let !c = chr $ ((b-0xf0) `shiftL` 18) +
162− in Yield c (i+4)
162+-- (next 1 `shiftL` 12) +
163− where b = I# (ord# b#)
163+-- (next 2 `shiftL` 6) +
164− next n = I# (ord# (at# (i+n))) - 0x80
164+-- next 3
165− !b# = at# i
165+-- in Yield c (i+4)
166− at# (I# i#) = indexCharOffAddr# addr i#
166+-- where b = I# (ord# b#)
167− chr (I# i#) = C# (chr# i#)
167+-- next n = I# (ord# (at# (i+n))) - 0x80
168−{-# INLINE [0] streamCString# #-}
168+-- !b# = at# i
169−
169+-- at# (I# i#) = indexCharOffAddr# addr i#
170−-- ----------------------------------------------------------------------------
170+-- chr (I# i#) = C# (chr# i#)
171−-- * Basic stream functions
171+-- {-# INLINE [0] streamCString# #-}
172−
172+
173−data C s = C0 !s
173+-- -- ----------------------------------------------------------------------------
174− | C1 !s
174+-- -- * Basic stream functions
175−
175+
176−-- | /O(n)/ Adds a character to the front of a Stream Char.
176+-- data C s = C0 !s
177−cons :: Char -> Stream Char -> Stream Char
177+-- | C1 !s
178−cons !w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
178+
179− where
179+-- -- | /O(n)/ Adds a character to the front of a Stream Char.
180− next (C1 s) = Yield w (C0 s)
180+-- cons :: Char -> Stream Char -> Stream Char
181− next (C0 s) = case next0 s of
181+-- -- cons !w (Stream next0 s0 len) = Stream next (C1 s0) (len+1)
182− Done -> Done
182+-- cons !w (Stream next0 s0) = Stream next (C1 s0) -- (len+1)
183− Skip s' -> Skip (C0 s')
183+-- where
184− Yield x s' -> Yield x (C0 s')
184+-- next (C1 s) = Yield w (C0 s)
185−{-# INLINE [0] cons #-}
185+-- next (C0 s) = case next0 s of
186−
186+-- Done -> Done
187−data Snoc a = N
187+-- Skip s' -> Skip (C0 s')
188− | J !a
188+-- Yield x s' -> Yield x (C0 s')
189−
189+-- {-# INLINE [0] cons #-}
190−-- | /O(n)/ Adds a character to the end of a stream.
190+
191−snoc :: Stream Char -> Char -> Stream Char
191+-- data Snoc a = N
192−snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)
192+-- | J !a
193− where
193+
194− next (J xs) = case next0 xs of
194+-- -- | /O(n)/ Adds a character to the end of a stream.
195− Done -> Yield w N
195+-- snoc :: Stream Char -> Char -> Stream Char
196− Skip xs' -> Skip (J xs')
196+-- -- snoc (Stream next0 xs0 len) w = Stream next (J xs0) (len+1)
197− Yield x xs' -> Yield x (J xs')
197+-- snoc (Stream next0 xs0) w = Stream next (J xs0) -- (len+1)
198− next N = Done
198+-- where
199−{-# INLINE [0] snoc #-}
199+-- next (J xs) = case next0 xs of
200−
200+-- Done -> Yield w N
201−data E l r = L !l
201+-- Skip xs' -> Skip (J xs')
202− | R !r
202+-- Yield x xs' -> Yield x (J xs')
203−
203+-- next N = Done
204−-- | /O(n)/ Appends one Stream to the other.
204+-- {-# INLINE [0] snoc #-}
205−append :: Stream Char -> Stream Char -> Stream Char
205+
206−append (Stream next0 s01 len1) (Stream next1 s02 len2) =
206+-- data E l r = L !l
207− Stream next (L s01) (len1 + len2)
207+-- | R !r
208− where
208+
209− next (L s1) = case next0 s1 of
209+-- -- | /O(n)/ Appends one Stream to the other.
210− Done -> Skip (R s02)
210+-- append :: Stream Char -> Stream Char -> Stream Char
211− Skip s1' -> Skip (L s1')
211+-- -- append (Stream next0 s01 len1) (Stream next1 s02 len2) =
212− Yield x s1' -> Yield x (L s1')
212+-- -- Stream next (L s01) (len1 + len2)
213− next (R s2) = case next1 s2 of
213+-- append (Stream next0 s01) (Stream next1 s02) =
214− Done -> Done
214+-- Stream next (L s01)
215− Skip s2' -> Skip (R s2')
215+-- where
216− Yield x s2' -> Yield x (R s2')
216+-- next (L s1) = case next0 s1 of
217−{-# INLINE [0] append #-}
217+-- Done -> Skip (R s02)
218−
218+-- Skip s1' -> Skip (L s1')
219−-- | /O(1)/ Returns the first character of a Text, which must be non-empty.
219+-- Yield x s1' -> Yield x (L s1')
220−-- Subject to array fusion.
220+-- next (R s2) = case next1 s2 of
221−head :: Stream Char -> Char
221+-- Done -> Done
222−head (Stream next s0 _len) = loop_head s0
222+-- Skip s2' -> Skip (R s2')
223− where
223+-- Yield x s2' -> Yield x (R s2')
224− loop_head !s = case next s of
224+-- {-# INLINE [0] append #-}
225− Yield x _ -> x
225+
226− Skip s' -> loop_head s'
226+-- -- | /O(1)/ Returns the first character of a Text, which must be non-empty.
227− Done -> head_empty
227+-- -- Subject to array fusion.
228−{-# INLINE [0] head #-}
228+-- head :: Stream Char -> Char
229−
229+-- -- head (Stream next s0 _len) = loop_head s0
230−head_empty :: a
230+-- head (Stream next s0) = loop_head s0
231−head_empty = streamError "head" "Empty stream"
231+-- where
232−{-# NOINLINE head_empty #-}
232+-- loop_head !s = case next s of
233−
233+-- Yield x _ -> x
234−-- | /O(1)/ Returns the first character and remainder of a 'Stream
234+-- Skip s' -> loop_head s'
235−-- Char', or 'Nothing' if empty. Subject to array fusion.
235+-- Done -> head_empty
236−uncons :: Stream Char -> Maybe (Char, Stream Char)
236+-- {-# INLINE [0] head #-}
237−uncons (Stream next s0 len) = loop_uncons s0
237+
238− where
238+-- head_empty :: a
239− loop_uncons !s = case next s of
239+-- head_empty = streamError "head" "Empty stream"
240− Yield x s1 -> Just (x, Stream next s1 (len-1))
240+-- {-# NOINLINE head_empty #-}
241− Skip s' -> loop_uncons s'
241+
242− Done -> Nothing
242+-- -- | /O(1)/ Returns the first character and remainder of a 'Stream
243−{-# INLINE [0] uncons #-}
243+-- -- Char', or 'Nothing' if empty. Subject to array fusion.
244−
244+-- uncons :: Stream Char -> Maybe (Char, Stream Char)
245−-- | /O(n)/ Returns the last character of a 'Stream Char', which must
245+-- -- uncons (Stream next s0 len) = loop_uncons s0
246−-- be non-empty.
246+-- uncons (Stream next s0) = loop_uncons s0
247−last :: Stream Char -> Char
247+-- where
248−last (Stream next s0 _len) = loop0_last s0
248+-- loop_uncons !s = case next s of
249− where
249+-- Yield x s1 -> Just (x, Stream next s1)
250− loop0_last !s = case next s of
250+-- Skip s' -> loop_uncons s'
251− Done -> emptyError "last"
251+-- Done -> Nothing
252− Skip s' -> loop0_last s'
252+-- {-# INLINE [0] uncons #-}
253− Yield x s' -> loop_last x s'
253+
254− loop_last !x !s = case next s of
254+-- -- | /O(n)/ Returns the last character of a 'Stream Char', which must
255− Done -> x
255+-- -- be non-empty.
256− Skip s' -> loop_last x s'
256+-- last :: Stream Char -> Char
257− Yield x' s' -> loop_last x' s'
257+-- -- last (Stream next s0 _len) = loop0_last s0
258−{-# INLINE[0] last #-}
258+-- last (Stream next s0) = loop0_last s0
259−
259+-- where
260−-- | /O(1)/ Returns all characters after the head of a Stream Char, which must
260+-- loop0_last !s = case next s of
261−-- be non-empty.
261+-- Done -> emptyError "last"
262−tail :: Stream Char -> Stream Char
262+-- Skip s' -> loop0_last s'
263−tail (Stream next0 s0 len) = Stream next (C0 s0) (len-1)
263+-- Yield x s' -> loop_last x s'
264− where
264+-- loop_last !x !s = case next s of
265− next (C0 s) = case next0 s of
265+-- Done -> x
266− Done -> emptyError "tail"
266+-- Skip s' -> loop_last x s'
267− Skip s' -> Skip (C0 s')
267+-- Yield x' s' -> loop_last x' s'
268− Yield _ s' -> Skip (C1 s')
268+-- {-# INLINE[0] last #-}
269− next (C1 s) = case next0 s of
269+
270− Done -> Done
270+-- -- | /O(1)/ Returns all characters after the head of a Stream Char, which must
271− Skip s' -> Skip (C1 s')
271+-- -- be non-empty.
272− Yield x s' -> Yield x (C1 s')
272+-- tail :: Stream Char -> Stream Char
273−{-# INLINE [0] tail #-}
273+-- -- tail (Stream next0 s0 len) = Stream next (C0 s0) (len-1)
274−
274+-- tail (Stream next0 s0) = Stream next (C0 s0) -- (len-1)
275−data Init s = Init0 !s
275+-- where
276− | Init1 {-# UNPACK #-} !Char !s
276+-- next (C0 s) = case next0 s of
277−
277+-- Done -> emptyError "tail"
278−-- | /O(1)/ Returns all but the last character of a Stream Char, which
278+-- Skip s' -> Skip (C0 s')
279−-- must be non-empty.
279+-- Yield _ s' -> Skip (C1 s')
280−init :: Stream Char -> Stream Char
280+-- next (C1 s) = case next0 s of
281−init (Stream next0 s0 len) = Stream next (Init0 s0) (len-1)
281+-- Done -> Done
282− where
282+-- Skip s' -> Skip (C1 s')
283− next (Init0 s) = case next0 s of
283+-- Yield x s' -> Yield x (C1 s')
284− Done -> emptyError "init"
284+-- {-# INLINE [0] tail #-}
285− Skip s' -> Skip (Init0 s')
285+
286− Yield x s' -> Skip (Init1 x s')
286+-- data Init s = Init0 !s
287− next (Init1 x s) = case next0 s of
287+-- | Init1 {-# UNPACK #-} !Char !s
288− Done -> Done
288+
289− Skip s' -> Skip (Init1 x s')
289+-- -- | /O(1)/ Returns all but the last character of a Stream Char, which
290− Yield x' s' -> Yield x (Init1 x' s')
290+-- -- must be non-empty.
291−{-# INLINE [0] init #-}
291+-- init :: Stream Char -> Stream Char
292−
292+-- -- init (Stream next0 s0 len) = Stream next (Init0 s0) (len-1)
293−-- | /O(1)/ Tests whether a Stream Char is empty or not.
293+-- init (Stream next0 s0) = Stream next (Init0 s0) -- (len-1)
294−null :: Stream Char -> Bool
294+-- where
295−null (Stream next s0 _len) = loop_null s0
295+-- next (Init0 s) = case next0 s of
296− where
296+-- Done -> emptyError "init"
297− loop_null !s = case next s of
297+-- Skip s' -> Skip (Init0 s')
298− Done -> True
298+-- Yield x s' -> Skip (Init1 x s')
299− Yield _ _ -> False
299+-- next (Init1 x s) = case next0 s of
300− Skip s' -> loop_null s'
300+-- Done -> Done
301−{-# INLINE[0] null #-}
301+-- Skip s' -> Skip (Init1 x s')
302−
302+-- Yield x' s' -> Yield x (Init1 x' s')
303−-- | /O(n)/ Returns the number of characters in a string.
303+-- {-# INLINE [0] init #-}
304−lengthI :: Integral a => Stream Char -> a
304+
305−lengthI (Stream next s0 _len) = loop_length 0 s0
305+-- -- | /O(1)/ Tests whether a Stream Char is empty or not.
306− where
306+-- null :: Stream Char -> Bool
307− loop_length !z s = case next s of
307+-- -- null (Stream next s0 _len) = loop_null s0
308− Done -> z
308+-- null (Stream next s0) = loop_null s0
309− Skip s' -> loop_length z s'
309+-- where
310− Yield _ s' -> loop_length (z + 1) s'
310+-- loop_null !s = case next s of
311−{-# INLINE[0] lengthI #-}
311+-- Done -> True
312−
312+-- Yield _ _ -> False
313−-- | /O(n)/ Compares the count of characters in a string to a number.
313+-- Skip s' -> loop_null s'
314−-- Subject to fusion.
314+-- {-# INLINE[0] null #-}
315−--
315+
316−-- This function gives the same answer as comparing against the result
316+-- -- | /O(n)/ Returns the number of characters in a string.
317−-- of 'lengthI', but can short circuit if the count of characters is
317+-- lengthI :: Integral a => Stream Char -> a
318−-- greater than the number or if the stream can't possibly be as long
318+-- -- lengthI (Stream next s0 _len) = loop_length 0 s0
319−-- as the number supplied, and hence be more efficient.
319+-- lengthI (Stream next s0) = loop_length 0 s0
320−compareLengthI :: Integral a => Stream Char -> a -> Ordering
320+-- where
321−compareLengthI (Stream next s0 len) n =
321+-- loop_length !z s = case next s of
322− case compareSize len (fromIntegral n) of
322+-- Done -> z
323− Just o -> o
323+-- Skip s' -> loop_length z s'
324− Nothing -> loop_cmp 0 s0
324+-- Yield _ s' -> loop_length (z + 1) s'
325− where
325+-- {-# INLINE[0] lengthI #-}
326− loop_cmp !z s = case next s of
326+
327− Done -> compare z n
327+-- -- | /O(n)/ Compares the count of characters in a string to a number.
328− Skip s' -> loop_cmp z s'
328+-- -- Subject to fusion.
329− Yield _ s' | z > n -> GT
329+-- --
330− | otherwise -> loop_cmp (z + 1) s'
330+-- -- This function gives the same answer as comparing against the result
331−{-# INLINE[0] compareLengthI #-}
331+-- -- of 'lengthI', but can short circuit if the count of characters is
332−
332+-- -- greater than the number or if the stream can't possibly be as long
333−-- | /O(n)/ Indicate whether a string contains exactly one element.
333+-- -- as the number supplied, and hence be more efficient.
334−isSingleton :: Stream Char -> Bool
334+-- compareLengthI :: Integral a => Stream Char -> a -> Ordering
335−isSingleton (Stream next s0 _len) = loop 0 s0
335+-- -- compareLengthI (Stream next s0 len) n =
336− where
336+-- compareLengthI (Stream next s0) n =
337− loop !z s = case next s of
337+-- -- case compareSize len (fromIntegral n) of
338− Done -> z == (1::Int)
338+-- -- Just o -> o
339− Skip s' -> loop z s'
339+-- -- Nothing -> loop_cmp 0 s0
340− Yield _ s'
340+-- loop_cmp 0 s0
341− | z >= 1 -> False
341+-- where
342− | otherwise -> loop (z+1) s'
342+-- loop_cmp !z s = case next s of
343−{-# INLINE[0] isSingleton #-}
343+-- Done -> compare z n
344−
344+-- Skip s' -> loop_cmp z s'
345−-- ----------------------------------------------------------------------------
345+-- Yield _ s' | z > n -> GT
346−-- * Stream transformations
346+-- | otherwise -> loop_cmp (z + 1) s'
347−
347+-- {-# INLINE[0] compareLengthI #-}
348−-- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@
348+
349−-- to each element of @xs@.
349+-- -- | /O(n)/ Indicate whether a string contains exactly one element.
350−map :: (Char -> Char) -> Stream Char -> Stream Char
350+-- isSingleton :: Stream Char -> Bool
351−map f (Stream next0 s0 len) = Stream next s0 len
351+-- -- isSingleton (Stream next s0 _len) = loop 0 s0
352− where
352+-- isSingleton (Stream next s0) = loop 0 s0
353− next !s = case next0 s of
353+-- where
354− Done -> Done
354+-- loop !z s = case next s of
355− Skip s' -> Skip s'
355+-- Done -> z == (1::Int)
356− Yield x s' -> Yield (f x) s'
356+-- Skip s' -> loop z s'
357−{-# INLINE [0] map #-}
357+-- Yield _ s'
358−
358+-- | z >= 1 -> False
359−{-#
359+-- | otherwise -> loop (z+1) s'
360− RULES "STREAM map/map fusion" forall f g s.
360+-- {-# INLINE[0] isSingleton #-}
361− map f (map g s) = map (\x -> f (g x)) s
361+
362− #-}
362+-- -- ----------------------------------------------------------------------------
363−
363+-- -- * Stream transformations
364−data I s = I1 !s
364+
365− | I2 !s {-# UNPACK #-} !Char
365+-- -- | /O(n)/ 'map' @f @xs is the Stream Char obtained by applying @f@
366− | I3 !s
366+-- -- to each element of @xs@.
367−
367+-- map :: (Char -> Char) -> Stream Char -> Stream Char
368−-- | /O(n)/ Take a character and place it between each of the
368+-- -- map f (Stream next0 s0 len) = Stream next s0 len
369−-- characters of a 'Stream Char'.
369+-- map f (Stream next0 s0) = Stream next s0 -- len
370−intersperse :: Char -> Stream Char -> Stream Char
370+-- where
371−intersperse c (Stream next0 s0 len) = Stream next (I1 s0) len
371+-- next !s = case next0 s of
372− where
372+-- Done -> Done
373− next (I1 s) = case next0 s of
373+-- Skip s' -> Skip s'
374− Done -> Done
374+-- Yield x s' -> Yield (f x) s'
375− Skip s' -> Skip (I1 s')
375+-- {-# INLINE [0] map #-}
376− Yield x s' -> Skip (I2 s' x)
376+
377− next (I2 s x) = Yield x (I3 s)
377+-- {-#
378− next (I3 s) = case next0 s of
378+-- RULES "STREAM map/map fusion" forall f g s.
379− Done -> Done
379+-- map f (map g s) = map (\x -> f (g x)) s
380− Skip s' -> Skip (I3 s')
380+-- #-}
381− Yield x s' -> Yield c (I2 s' x)
381+
382−{-# INLINE [0] intersperse #-}
382+-- data I s = I1 !s
383−
383+-- | I2 !s {-# UNPACK #-} !Char
384−-- ----------------------------------------------------------------------------
384+-- | I3 !s
385−-- ** Case conversions (folds)
385+
386−
386+-- -- | /O(n)/ Take a character and place it between each of the
387−-- $case
387+-- -- characters of a 'Stream Char'.
388−--
388+-- intersperse :: Char -> Stream Char -> Stream Char
389−-- With Unicode text, it is incorrect to use combinators like @map
389+-- intersperse c (Stream next0 s0) = Stream next (I1 s0) -- len
390−-- toUpper@ to case convert each character of a string individually.
390+-- -- intersperse c (Stream next0 s0 len) = Stream next (I1 s0) len
391−-- Instead, use the whole-string case conversion functions from this
391+-- where
392−-- module. For correctness in different writing systems, these
392+-- next (I1 s) = case next0 s of
393−-- functions may map one input character to two or three output
393+-- Done -> Done
394−-- characters.
394+-- Skip s' -> Skip (I1 s')
395−
395+-- Yield x s' -> Skip (I2 s' x)
396−caseConvert :: (forall s. Char -> s -> Step (CC s) Char)
396+-- next (I2 s x) = Yield x (I3 s)
397− -> Stream Char -> Stream Char
397+-- next (I3 s) = case next0 s of
398−caseConvert remap (Stream next0 s0 len) = Stream next (CC s0 '\0' '\0') len
398+-- Done -> Done
399− where
399+-- Skip s' -> Skip (I3 s')
400− next (CC s '\0' _) =
400+-- Yield x s' -> Yield c (I2 s' x)
401− case next0 s of
401+-- {-# INLINE [0] intersperse #-}
402− Done -> Done
402+
403− Skip s' -> Skip (CC s' '\0' '\0')
403+-- -- ----------------------------------------------------------------------------
404− Yield c s' -> remap c s'
404+-- -- ** Case conversions (folds)
405− next (CC s a b) = Yield a (CC s b '\0')
405+
406−
406+-- -- $case
407−-- | /O(n)/ Convert a string to folded case. This function is mainly
407+-- --
408−-- useful for performing caseless (or case insensitive) string
408+-- -- With Unicode text, it is incorrect to use combinators like @map
409−-- comparisons.
409+-- -- toUpper@ to case convert each character of a string individually.
410−--
410+-- -- Instead, use the whole-string case conversion functions from this
411−-- A string @x@ is a caseless match for a string @y@ if and only if:
411+-- -- module. For correctness in different writing systems, these
412−--
412+-- -- functions may map one input character to two or three output
413−-- @toCaseFold x == toCaseFold y@
413+-- -- characters.
414−--
414+
415−-- The result string may be longer than the input string, and may
415+-- caseConvert :: (forall s. Char -> s -> Step (CC s) Char)
416−-- differ from applying 'toLower' to the input string. For instance,
416+-- -> Stream Char -> Stream Char
417−-- the Armenian small ligature men now (U+FB13) is case folded to the
417+-- -- caseConvert remap (Stream next0 s0 len) = Stream next (CC s0 '\0' '\0') len
418−-- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is
418+-- caseConvert remap (Stream next0 s0) = Stream next (CC s0 '\0' '\0') -- len
419−-- case folded to the Greek small letter letter mu (U+03BC) instead of
419+-- where
420−-- itself.
420+-- next (CC s '\0' _) =
421−toCaseFold :: Stream Char -> Stream Char
421+-- case next0 s of
422−toCaseFold = caseConvert foldMapping
422+-- Done -> Done
423−{-# INLINE [0] toCaseFold #-}
423+-- Skip s' -> Skip (CC s' '\0' '\0')
424−
424+-- Yield c s' -> remap c s'
425−-- | /O(n)/ Convert a string to upper case, using simple case
425+-- next (CC s a b) = Yield a (CC s b '\0')
426−-- conversion. The result string may be longer than the input string.
426+
427−-- For instance, the German eszett (U+00DF) maps to the two-letter
427+-- -- | /O(n)/ Convert a string to folded case. This function is mainly
428−-- sequence SS.
428+-- -- useful for performing caseless (or case insensitive) string
429−toUpper :: Stream Char -> Stream Char
429+-- -- comparisons.
430−toUpper = caseConvert upperMapping
430+-- --
431−{-# INLINE [0] toUpper #-}
431+-- -- A string @x@ is a caseless match for a string @y@ if and only if:
432−
432+-- --
433−-- | /O(n)/ Convert a string to lower case, using simple case
433+-- -- @toCaseFold x == toCaseFold y@
434−-- conversion. The result string may be longer than the input string.
434+-- --
435−-- For instance, the Latin capital letter I with dot above (U+0130)
435+-- -- The result string may be longer than the input string, and may
436−-- maps to the sequence Latin small letter i (U+0069) followed by
436+-- -- differ from applying 'toLower' to the input string. For instance,
437−-- combining dot above (U+0307).
437+-- -- the Armenian small ligature men now (U+FB13) is case folded to the
438−toLower :: Stream Char -> Stream Char
438+-- -- bigram men now (U+0574 U+0576), while the micro sign (U+00B5) is
439−toLower = caseConvert lowerMapping
439+-- -- case folded to the Greek small letter letter mu (U+03BC) instead of
440−{-# INLINE [0] toLower #-}
440+-- -- itself.
441−
441+-- toCaseFold :: Stream Char -> Stream Char
442−-- | /O(n)/ Convert a string to title case, using simple case
442+-- toCaseFold = caseConvert foldMapping
443−-- conversion.
443+-- {-# INLINE [0] toCaseFold #-}
444−--
444+
445−-- The first letter of the input is converted to title case, as is
445+-- -- | /O(n)/ Convert a string to upper case, using simple case
446−-- every subsequent letter that immediately follows a non-letter.
446+-- -- conversion. The result string may be longer than the input string.
447−-- Every letter that immediately follows another letter is converted
447+-- -- For instance, the German eszett (U+00DF) maps to the two-letter
448−-- to lower case.
448+-- -- sequence SS.
449−--
449+-- toUpper :: Stream Char -> Stream Char
450−-- The result string may be longer than the input string. For example,
450+-- toUpper = caseConvert upperMapping
451−-- the Latin small ligature &#xfb02; (U+FB02) is converted to the
451+-- {-# INLINE [0] toUpper #-}
452−-- sequence Latin capital letter F (U+0046) followed by Latin small
452+
453−-- letter l (U+006C).
453+-- -- | /O(n)/ Convert a string to lower case, using simple case
454−--
454+-- -- conversion. The result string may be longer than the input string.
455−-- /Note/: this function does not take language or culture specific
455+-- -- For instance, the Latin capital letter I with dot above (U+0130)
456−-- rules into account. For instance, in English, different style
456+-- -- maps to the sequence Latin small letter i (U+0069) followed by
457−-- guides disagree on whether the book name \"The Hill of the Red
457+-- -- combining dot above (U+0307).
458−-- Fox\" is correctly title cased&#x2014;but this function will
458+-- toLower :: Stream Char -> Stream Char
459−-- capitalize /every/ word.
459+-- toLower = caseConvert lowerMapping
460−toTitle :: Stream Char -> Stream Char
460+-- {-# INLINE [0] toLower #-}
461−toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') len
461+
462− where
462+-- -- | /O(n)/ Convert a string to title case, using simple case
463− next (CC (letter :*: s) '\0' _) =
463+-- -- conversion.
464− case next0 s of
464+-- --
465− Done -> Done
465+-- -- The first letter of the input is converted to title case, as is
466− Skip s' -> Skip (CC (letter :*: s') '\0' '\0')
466+-- -- every subsequent letter that immediately follows a non-letter.
467− Yield c s'
467+-- -- Every letter that immediately follows another letter is converted
468− | letter' -> if letter
468+-- -- to lower case.
469− then lowerMapping c (letter' :*: s')
469+-- --
470− else titleMapping c (letter' :*: s')
470+-- -- The result string may be longer than the input string. For example,
471− | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0')
471+-- -- the Latin small ligature &#xfb02; (U+FB02) is converted to the
472− where letter' = isLetter c
472+-- -- sequence Latin capital letter F (U+0046) followed by Latin small
473− next (CC s a b) = Yield a (CC s b '\0')
473+-- -- letter l (U+006C).
474−{-# INLINE [0] toTitle #-}
474+-- --
475−
475+-- -- /Note/: this function does not take language or culture specific
476−data Justify i s = Just1 !i !s
476+-- -- rules into account. For instance, in English, different style
477− | Just2 !i !s
477+-- -- guides disagree on whether the book name \"The Hill of the Red
478−
478+-- -- Fox\" is correctly title cased&#x2014;but this function will
479−justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char
479+-- -- capitalize /every/ word.
480−justifyLeftI k c (Stream next0 s0 len) =
480+-- toTitle :: Stream Char -> Stream Char
481− Stream next (Just1 0 s0) (larger (fromIntegral k) len)
481+-- -- toTitle (Stream next0 s0 len) = Stream next (CC (False :*: s0) '\0' '\0') len
482− where
482+-- toTitle (Stream next0 s0) = Stream next (CC (False :*: s0) '\0' '\0') -- len
483− next (Just1 n s) =
483+-- where
484− case next0 s of
484+-- next (CC (letter :*: s) '\0' _) =
485− Done -> next (Just2 n s)
485+-- case next0 s of
486− Skip s' -> Skip (Just1 n s')
486+-- Done -> Done
487− Yield x s' -> Yield x (Just1 (n+1) s')
487+-- Skip s' -> Skip (CC (letter :*: s') '\0' '\0')
488− next (Just2 n s)
488+-- Yield c s'
489− | n < k = Yield c (Just2 (n+1) s)
489+-- | letter' -> if letter
490− | otherwise = Done
490+-- then lowerMapping c (letter' :*: s')
491− {-# INLINE next #-}
491+-- else titleMapping c (letter' :*: s')
492−{-# INLINE [0] justifyLeftI #-}
492+-- | otherwise -> Yield c (CC (letter' :*: s') '\0' '\0')
493−
493+-- where letter' = isLetter c
494−-- ----------------------------------------------------------------------------
494+-- next (CC s a b) = Yield a (CC s b '\0')
495−-- * Reducing Streams (folds)
495+-- {-# INLINE [0] toTitle #-}
496−
496+
497−-- | foldl, applied to a binary operator, a starting value (typically the
497+-- data Justify i s = Just1 !i !s
498−-- left-identity of the operator), and a Stream, reduces the Stream using the
498+-- | Just2 !i !s
499−-- binary operator, from left to right.
499+
500−foldl :: (b -> Char -> b) -> b -> Stream Char -> b
500+-- justifyLeftI :: Integral a => a -> Char -> Stream Char -> Stream Char
501−foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0
501+-- -- justifyLeftI k c (Stream next0 s0 len) =
502− where
502+-- justifyLeftI k c (Stream next0 s0) =
503− loop_foldl z !s = case next s of
503+-- Stream next (Just1 0 s0) -- (larger (fromIntegral k) len)
504− Done -> z
504+-- where
505− Skip s' -> loop_foldl z s'
505+-- next (Just1 n s) =
506− Yield x s' -> loop_foldl (f z x) s'
506+-- case next0 s of
507−{-# INLINE [0] foldl #-}
507+-- Done -> next (Just2 n s)
508−
508+-- Skip s' -> Skip (Just1 n s')
509−-- | A strict version of foldl.
509+-- Yield x s' -> Yield x (Just1 (n+1) s')
510−foldl' :: (b -> Char -> b) -> b -> Stream Char -> b
510+-- next (Just2 n s)
511−foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0
511+-- | n < k = Yield c (Just2 (n+1) s)
512− where
512+-- | otherwise = Done
513− loop_foldl' !z !s = case next s of
513+-- {-# INLINE next #-}
514− Done -> z
514+-- {-# INLINE [0] justifyLeftI #-}
515− Skip s' -> loop_foldl' z s'
515+
516− Yield x s' -> loop_foldl' (f z x) s'
516+-- -- ----------------------------------------------------------------------------
517−{-# INLINE [0] foldl' #-}
517+-- -- * Reducing Streams (folds)
518−
518+
519−-- | foldl1 is a variant of foldl that has no starting value argument,
519+-- -- | foldl, applied to a binary operator, a starting value (typically the
520−-- and thus must be applied to non-empty Streams.
520+-- -- left-identity of the operator), and a Stream, reduces the Stream using the
521−foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char
521+-- -- binary operator, from left to right.
522−foldl1 f (Stream next s0 _len) = loop0_foldl1 s0
522+-- foldl :: (b -> Char -> b) -> b -> Stream Char -> b
523− where
523+-- -- foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0
524− loop0_foldl1 !s = case next s of
524+-- foldl f z0 (Stream next s0) = loop_foldl z0 s0
525− Skip s' -> loop0_foldl1 s'
525+-- where
526− Yield x s' -> loop_foldl1 x s'
526+-- loop_foldl z !s = case next s of
527− Done -> emptyError "foldl1"
527+-- Done -> z
528− loop_foldl1 z !s = case next s of
528+-- Skip s' -> loop_foldl z s'
529− Done -> z
529+-- Yield x s' -> loop_foldl (f z x) s'
530− Skip s' -> loop_foldl1 z s'
530+-- {-# INLINE [0] foldl #-}
531− Yield x s' -> loop_foldl1 (f z x) s'
531+
532−{-# INLINE [0] foldl1 #-}
532+-- -- | A strict version of foldl.
533−
533+-- foldl' :: (b -> Char -> b) -> b -> Stream Char -> b
534−-- | A strict version of foldl1.
534+-- -- foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0
535−foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char
535+-- foldl' f z0 (Stream next s0) = loop_foldl' z0 s0
536−foldl1' f (Stream next s0 _len) = loop0_foldl1' s0
536+-- where
537− where
537+-- loop_foldl' !z !s = case next s of
538− loop0_foldl1' !s = case next s of
538+-- Done -> z
539− Skip s' -> loop0_foldl1' s'
539+-- Skip s' -> loop_foldl' z s'
540− Yield x s' -> loop_foldl1' x s'
540+-- Yield x s' -> loop_foldl' (f z x) s'
541− Done -> emptyError "foldl1"
541+-- {-# INLINE [0] foldl' #-}
542− loop_foldl1' !z !s = case next s of
542+
543− Done -> z
543+-- -- | foldl1 is a variant of foldl that has no starting value argument,
544− Skip s' -> loop_foldl1' z s'
544+-- -- and thus must be applied to non-empty Streams.
545− Yield x s' -> loop_foldl1' (f z x) s'
545+-- foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char
546−{-# INLINE [0] foldl1' #-}
546+-- -- foldl1 f (Stream next s0 _len) = loop0_foldl1 s0
547−
547+-- foldl1 f (Stream next s0) = loop0_foldl1 s0
548−-- | 'foldr', applied to a binary operator, a starting value (typically the
548+-- where
549−-- right-identity of the operator), and a stream, reduces the stream using the
549+-- loop0_foldl1 !s = case next s of
550−-- binary operator, from right to left.
550+-- Skip s' -> loop0_foldl1 s'
551−foldr :: (Char -> b -> b) -> b -> Stream Char -> b
551+-- Yield x s' -> loop_foldl1 x s'
552−foldr f z (Stream next s0 _len) = loop_foldr s0
552+-- Done -> emptyError "foldl1"
553− where
553+-- loop_foldl1 z !s = case next s of
554− loop_foldr !s = case next s of
554+-- Done -> z
555− Done -> z
555+-- Skip s' -> loop_foldl1 z s'
556− Skip s' -> loop_foldr s'
556+-- Yield x s' -> loop_foldl1 (f z x) s'
557− Yield x s' -> f x (loop_foldr s')
557+-- {-# INLINE [0] foldl1 #-}
558−{-# INLINE [0] foldr #-}
558+
559−
559+-- -- | A strict version of foldl1.
560−-- | foldr1 is a variant of 'foldr' that has no starting value argument,
560+-- foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char
561−-- and thus must be applied to non-empty streams.
561+-- -- foldl1' f (Stream next s0 _len) = loop0_foldl1' s0
562−-- Subject to array fusion.
562+-- foldl1' f (Stream next s0) = loop0_foldl1' s0
563−foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char
563+-- where
564−foldr1 f (Stream next s0 _len) = loop0_foldr1 s0
564+-- loop0_foldl1' !s = case next s of
565− where
565+-- Skip s' -> loop0_foldl1' s'
566− loop0_foldr1 !s = case next s of
566+-- Yield x s' -> loop_foldl1' x s'
567− Done -> emptyError "foldr1"
567+-- Done -> emptyError "foldl1"
568− Skip s' -> loop0_foldr1 s'
568+-- loop_foldl1' !z !s = case next s of
569− Yield x s' -> loop_foldr1 x s'
569+-- Done -> z
570−
570+-- Skip s' -> loop_foldl1' z s'
571− loop_foldr1 x !s = case next s of
571+-- Yield x s' -> loop_foldl1' (f z x) s'
572− Done -> x
572+-- {-# INLINE [0] foldl1' #-}
573− Skip s' -> loop_foldr1 x s'
573+
574− Yield x' s' -> f x (loop_foldr1 x' s')
574+-- -- | 'foldr', applied to a binary operator, a starting value (typically the
575−{-# INLINE [0] foldr1 #-}
575+-- -- right-identity of the operator), and a stream, reduces the stream using the
576−
576+-- -- binary operator, from right to left.
577−intercalate :: Stream Char -> [Stream Char] -> Stream Char
577+-- foldr :: (Char -> b -> b) -> b -> Stream Char -> b
578−intercalate s = concat . (L.intersperse s)
578+-- -- foldr f z (Stream next s0 _len) = loop_foldr s0
579−{-# INLINE [0] intercalate #-}
579+-- foldr f z (Stream next s0) = loop_foldr s0
580−
580+-- where
581−-- ----------------------------------------------------------------------------
581+-- loop_foldr !s = case next s of
582−-- ** Special folds
582+-- Done -> z
583−
583+-- Skip s' -> loop_foldr s'
584−-- | /O(n)/ Concatenate a list of streams. Subject to array fusion.
584+-- Yield x s' -> f x (loop_foldr s')
585−concat :: [Stream Char] -> Stream Char
585+-- {-# INLINE [0] foldr #-}
586−concat = L.foldr append empty
586+
587−{-# INLINE [0] concat #-}
587+-- -- | foldr1 is a variant of 'foldr' that has no starting value argument,
588−
588+-- -- and thus must be applied to non-empty streams.
589−-- | Map a function over a stream that results in a stream and concatenate the
589+-- -- Subject to array fusion.
590−-- results.
590+-- foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char
591−concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char
591+-- -- foldr1 f (Stream next s0 _len) = loop0_foldr1 s0
592−concatMap f = foldr (append . f) empty
592+-- foldr1 f (Stream next s0) = loop0_foldr1 s0
593−{-# INLINE [0] concatMap #-}
593+-- where
594−
594+-- loop0_foldr1 !s = case next s of
595−-- | /O(n)/ any @p @xs determines if any character in the stream
595+-- Done -> emptyError "foldr1"
596−-- @xs@ satisfies the predicate @p@.
596+-- Skip s' -> loop0_foldr1 s'
597−any :: (Char -> Bool) -> Stream Char -> Bool
597+-- Yield x s' -> loop_foldr1 x s'
598−any p (Stream next0 s0 _len) = loop_any s0
598+
599− where
599+-- loop_foldr1 x !s = case next s of
600− loop_any !s = case next0 s of
600+-- Done -> x
601− Done -> False
601+-- Skip s' -> loop_foldr1 x s'
602− Skip s' -> loop_any s'
602+-- Yield x' s' -> f x (loop_foldr1 x' s')
603− Yield x s' | p x -> True
603+-- {-# INLINE [0] foldr1 #-}
604− | otherwise -> loop_any s'
604+
605−{-# INLINE [0] any #-}
605+-- intercalate :: Stream Char -> [Stream Char] -> Stream Char
606−
606+-- intercalate s = concat . (L.intersperse s)
607−-- | /O(n)/ all @p @xs determines if all characters in the 'Text'
607+-- {-# INLINE [0] intercalate #-}
608−-- @xs@ satisfy the predicate @p@.
608+
609−all :: (Char -> Bool) -> Stream Char -> Bool
609+-- -- ----------------------------------------------------------------------------
610−all p (Stream next0 s0 _len) = loop_all s0
610+-- -- ** Special folds
611− where
611+
612− loop_all !s = case next0 s of
612+-- -- | /O(n)/ Concatenate a list of streams. Subject to array fusion.
613− Done -> True
613+-- concat :: [Stream Char] -> Stream Char
614− Skip s' -> loop_all s'
614+-- concat = L.foldr append empty
615− Yield x s' | p x -> loop_all s'
615+-- {-# INLINE [0] concat #-}
616− | otherwise -> False
616+
617−{-# INLINE [0] all #-}
617+-- -- | Map a function over a stream that results in a stream and concatenate the
618−
618+-- -- results.
619−-- | /O(n)/ maximum returns the maximum value from a stream, which must be
619+-- concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char
620−-- non-empty.
620+-- concatMap f = foldr (append . f) empty
621−maximum :: Stream Char -> Char
621+-- {-# INLINE [0] concatMap #-}
622−maximum (Stream next0 s0 _len) = loop0_maximum s0
622+
623− where
623+-- -- | /O(n)/ any @p @xs determines if any character in the stream
624− loop0_maximum !s = case next0 s of
624+-- -- @xs@ satisfies the predicate @p@.
625− Done -> emptyError "maximum"
625+-- any :: (Char -> Bool) -> Stream Char -> Bool
626− Skip s' -> loop0_maximum s'
626+-- -- any p (Stream next0 s0 _len) = loop_any s0
627− Yield x s' -> loop_maximum x s'
627+-- any p (Stream next0 s0) = loop_any s0
628− loop_maximum !z !s = case next0 s of
628+-- where
629− Done -> z
629+-- loop_any !s = case next0 s of
630− Skip s' -> loop_maximum z s'
630+-- Done -> False
631− Yield x s'
631+-- Skip s' -> loop_any s'
632− | x > z -> loop_maximum x s'
632+-- Yield x s' | p x -> True
633− | otherwise -> loop_maximum z s'
633+-- | otherwise -> loop_any s'
634−{-# INLINE [0] maximum #-}
634+-- {-# INLINE [0] any #-}
635−
635+
636−-- | /O(n)/ minimum returns the minimum value from a 'Text', which must be
636+-- -- | /O(n)/ all @p @xs determines if all characters in the 'Text'
637−-- non-empty.
637+-- -- @xs@ satisfy the predicate @p@.
638−minimum :: Stream Char -> Char
638+-- all :: (Char -> Bool) -> Stream Char -> Bool
639−minimum (Stream next0 s0 _len) = loop0_minimum s0
639+-- -- all p (Stream next0 s0 _len) = loop_all s0
640− where
640+-- all p (Stream next0 s0) = loop_all s0
641− loop0_minimum !s = case next0 s of
641+-- where
642− Done -> emptyError "minimum"
642+-- loop_all !s = case next0 s of
643− Skip s' -> loop0_minimum s'
643+-- Done -> True
644− Yield x s' -> loop_minimum x s'
644+-- Skip s' -> loop_all s'
645− loop_minimum !z !s = case next0 s of
645+-- Yield x s' | p x -> loop_all s'
646− Done -> z
646+-- | otherwise -> False
647− Skip s' -> loop_minimum z s'
647+-- {-# INLINE [0] all #-}
648− Yield x s'
648+
649− | x < z -> loop_minimum x s'
649+-- -- | /O(n)/ maximum returns the maximum value from a stream, which must be
650− | otherwise -> loop_minimum z s'
650+-- -- non-empty.
651−{-# INLINE [0] minimum #-}
651+-- maximum :: Stream Char -> Char
652−
652+-- -- maximum (Stream next0 s0 _len) = loop0_maximum s0
653−-- -----------------------------------------------------------------------------
653+-- maximum (Stream next0 s0) = loop0_maximum s0
654−-- * Building streams
654+-- where
655−
655+-- loop0_maximum !s = case next0 s of
656−scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
656+-- Done -> emptyError "maximum"
657−scanl f z0 (Stream next0 s0 len) = Stream next (Scan1 z0 s0) (len+1) -- HINT maybe too low
657+-- Skip s' -> loop0_maximum s'
658− where
658+-- Yield x s' -> loop_maximum x s'
659− {-# INLINE next #-}
659+-- loop_maximum !z !s = case next0 s of
660− next (Scan1 z s) = Yield z (Scan2 z s)
660+-- Done -> z
661− next (Scan2 z s) = case next0 s of
661+-- Skip s' -> loop_maximum z s'
662− Yield x s' -> let !x' = f z x
662+-- Yield x s'
663− in Yield x' (Scan2 x' s')
663+-- | x > z -> loop_maximum x s'
664− Skip s' -> Skip (Scan2 z s')
664+-- | otherwise -> loop_maximum z s'
665− Done -> Done
665+-- {-# INLINE [0] maximum #-}
666−{-# INLINE [0] scanl #-}
666+
667−
667+-- -- | /O(n)/ minimum returns the minimum value from a 'Text', which must be
668−-- -----------------------------------------------------------------------------
668+-- -- non-empty.
669−-- ** Generating and unfolding streams
669+-- minimum :: Stream Char -> Char
670−
670+-- -- minimum (Stream next0 s0 _len) = loop0_minimum s0
671−replicateCharI :: Integral a => a -> Char -> Stream Char
671+-- minimum (Stream next0 s0) = loop0_minimum s0
672−replicateCharI !n !c
672+-- where
673− | n < 0 = empty
673+-- loop0_minimum !s = case next0 s of
674− | otherwise = Stream next 0 (fromIntegral n) -- HINT maybe too low
674+-- Done -> emptyError "minimum"
675− where
675+-- Skip s' -> loop0_minimum s'
676− next !i | i >= n = Done
676+-- Yield x s' -> loop_minimum x s'
677− | otherwise = Yield c (i + 1)
677+-- loop_minimum !z !s = case next0 s of
678−{-# INLINE [0] replicateCharI #-}
678+-- Done -> z
679−
679+-- Skip s' -> loop_minimum z s'
680−data RI s = RI !s {-# UNPACK #-} !Int64
680+-- Yield x s'
681−
681+-- | x < z -> loop_minimum x s'
682−replicateI :: Int64 -> Stream Char -> Stream Char
682+-- | otherwise -> loop_minimum z s'
683−replicateI n (Stream next0 s0 len) =
683+-- {-# INLINE [0] minimum #-}
684− Stream next (RI s0 0) (fromIntegral (max 0 n) * len)
684+
685− where
685+-- -- -----------------------------------------------------------------------------
686− next (RI s k)
686+-- -- * Building streams
687− | k >= n = Done
687+
688− | otherwise = case next0 s of
688+-- scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
689− Done -> Skip (RI s0 (k+1))
689+-- -- scanl f z0 (Stream next0 s0 len) = Stream next (Scan1 z0 s0) (len+1) -- HINT maybe too low
690− Skip s' -> Skip (RI s' k)
690+-- scanl f z0 (Stream next0 s0) = Stream next (Scan1 z0 s0) -- (len+1) -- HINT maybe too low
691− Yield x s' -> Yield x (RI s' k)
691+-- where
692−{-# INLINE [0] replicateI #-}
692+-- {-# INLINE next #-}
693−
693+-- next (Scan1 z s) = Yield z (Scan2 z s)
694−-- | /O(n)/, where @n@ is the length of the result. The unfoldr function
694+-- next (Scan2 z s) = case next0 s of
695−-- is analogous to the List 'unfoldr'. unfoldr builds a stream
695+-- Yield x s' -> let !x' = f z x
696−-- from a seed value. The function takes the element and returns
696+-- in Yield x' (Scan2 x' s')
697−-- Nothing if it is done producing the stream or returns Just
697+-- Skip s' -> Skip (Scan2 z s')
698−-- (a,b), in which case, a is the next Char in the string, and b is
698+-- Done -> Done
699−-- the seed value for further production.
699+-- {-# INLINE [0] scanl #-}
700−unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char
700+
701−unfoldr f s0 = Stream next s0 1 -- HINT maybe too low
701+-- -- -----------------------------------------------------------------------------
702− where
702+-- -- ** Generating and unfolding streams
703− {-# INLINE next #-}
703+
704− next !s = case f s of
704+-- replicateCharI :: Integral a => a -> Char -> Stream Char
705− Nothing -> Done
705+-- replicateCharI n c
706− Just (w, s') -> Yield w s'
706+-- | n < 0 = empty
707−{-# INLINE [0] unfoldr #-}
707+-- | otherwise = Stream next 0 -- (fromIntegral n) -- HINT maybe too low
708−
708+-- where
709−-- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed
709+-- next i | i >= n = Done
710−-- value. However, the length of the result is limited by the
710+-- | otherwise = Yield c (i + 1)
711−-- first argument to 'unfoldrNI'. This function is more efficient than
711+-- {-# INLINE [0] replicateCharI #-}
712−-- 'unfoldr' when the length of the result is known.
712+
713−unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char
713+-- data RI s = RI !s {-# UNPACK #-} !Int64
714−unfoldrNI n f s0 | n < 0 = empty
714+
715− | otherwise = Stream next (0 :*: s0) (fromIntegral (n*2)) -- HINT maybe too high
715+-- replicateI :: Int64 -> Stream Char -> Stream Char
716− where
716+-- -- replicateI n (Stream next0 s0 len) =
717− {-# INLINE next #-}
717+-- replicateI n (Stream next0 s0) =
718− next (z :*: s) = case f s of
718+-- Stream next (RI s0 0) -- (fromIntegral (max 0 n) * len)
719− Nothing -> Done
719+-- where
720− Just (w, s') | z >= n -> Done
720+-- next (RI s k)
721− | otherwise -> Yield w ((z + 1) :*: s')
721+-- | k >= n = Done
722−{-# INLINE unfoldrNI #-}
722+-- | otherwise = case next0 s of
723−
723+-- Done -> Skip (RI s0 (k+1))
724−-------------------------------------------------------------------------------
724+-- Skip s' -> Skip (RI s' k)
725−-- * Substreams
725+-- Yield x s' -> Yield x (RI s' k)
726−
726+-- {-# INLINE [0] replicateI #-}
727−-- | /O(n)/ take n, applied to a stream, returns the prefix of the
727+
728−-- stream of length @n@, or the stream itself if @n@ is greater than the
728+-- -- | /O(n)/, where @n@ is the length of the result. The unfoldr function
729−-- length of the stream.
729+-- -- is analogous to the List 'unfoldr'. unfoldr builds a stream
730−take :: Integral a => a -> Stream Char -> Stream Char
730+-- -- from a seed value. The function takes the element and returns
731−take n0 (Stream next0 s0 len) =
731+-- -- Nothing if it is done producing the stream or returns Just
732− Stream next (n0 :*: s0) (smaller len (fromIntegral (max 0 n0)))
732+-- -- (a,b), in which case, a is the next Char in the string, and b is
733− where
733+-- -- the seed value for further production.
734− {-# INLINE next #-}
734+-- unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char
735− next (n :*: s) | n <= 0 = Done
735+-- unfoldr f s0 = Stream next s0 -- 1 -- HINT maybe too low
736− | otherwise = case next0 s of
736+-- where
737− Done -> Done
737+-- {-# INLINE next #-}
738− Skip s' -> Skip (n :*: s')
738+-- next !s = case f s of
739− Yield x s' -> Yield x ((n-1) :*: s')
739+-- Nothing -> Done
740−{-# INLINE [0] take #-}
740+-- Just (w, s') -> Yield w s'
741−
741+-- {-# INLINE [0] unfoldr #-}
742−data Drop a s = NS !s
742+
743− | JS !a !s
743+-- -- | /O(n)/ Like 'unfoldr', 'unfoldrNI' builds a stream from a seed
744−
744+-- -- value. However, the length of the result is limited by the
745−-- | /O(n)/ drop n, applied to a stream, returns the suffix of the
745+-- -- first argument to 'unfoldrNI'. This function is more efficient than
746−-- stream after the first @n@ characters, or the empty stream if @n@
746+-- -- 'unfoldr' when the length of the result is known.
747−-- is greater than the length of the stream.
747+-- unfoldrNI :: Integral a => a -> (b -> Maybe (Char,b)) -> b -> Stream Char
748−drop :: Integral a => a -> Stream Char -> Stream Char
748+-- unfoldrNI n f s0 | n < 0 = empty
749−drop n0 (Stream next0 s0 len) =
749+-- | otherwise = Stream next (0 :*: s0) -- (fromIntegral (n*2)) -- HINT maybe too high
750− Stream next (JS n0 s0) (len - fromIntegral (max 0 n0))
750+-- where
751− where
751+-- {-# INLINE next #-}
752− {-# INLINE next #-}
752+-- next (z :*: s) = case f s of
753− next (JS n s)
753+-- Nothing -> Done
754− | n <= 0 = Skip (NS s)
754+-- Just (w, s') | z >= n -> Done
755− | otherwise = case next0 s of
755+-- | otherwise -> Yield w ((z + 1) :*: s')
756− Done -> Done
756+-- {-# INLINE unfoldrNI #-}
757− Skip s' -> Skip (JS n s')
757+
758− Yield _ s' -> Skip (JS (n-1) s')
758+-- -------------------------------------------------------------------------------
759− next (NS s) = case next0 s of
759+-- -- * Substreams
760− Done -> Done
760+
761− Skip s' -> Skip (NS s')
761+-- -- | /O(n)/ take n, applied to a stream, returns the prefix of the
762− Yield x s' -> Yield x (NS s')
762+-- -- stream of length @n@, or the stream itself if @n@ is greater than the
763−{-# INLINE [0] drop #-}
763+-- -- length of the stream.
764−
764+-- take :: Integral a => a -> Stream Char -> Stream Char
765−-- | takeWhile, applied to a predicate @p@ and a stream, returns the
765+-- take n0 (Stream next0 s0) =
766−-- longest prefix (possibly empty) of elements that satisfy p.
766+-- -- take n0 (Stream next0 s0 len) =
767−takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char
767+-- Stream next (n0 :*: s0) -- (smaller len (fromIntegral (max 0 n0)))
768−takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
768+-- where
769− where
769+-- {-# INLINE next #-}
770− {-# INLINE next #-}
770+-- next (n :*: s) | n <= 0 = Done
771− next !s = case next0 s of
771+-- | otherwise = case next0 s of
772− Done -> Done
772+-- Done -> Done
773− Skip s' -> Skip s'
773+-- Skip s' -> Skip (n :*: s')
774− Yield x s' | p x -> Yield x s'
774+-- Yield x s' -> Yield x ((n-1) :*: s')
775− | otherwise -> Done
775+-- {-# INLINE [0] take #-}
776−{-# INLINE [0] takeWhile #-}
776+
777−
777+-- data Drop a s = NS !s
778−-- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
778+-- | JS !a !s
779−dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
779+
780−dropWhile p (Stream next0 s0 len) = Stream next (L s0) len -- HINT maybe too high
780+-- -- | /O(n)/ drop n, applied to a stream, returns the suffix of the
781− where
781+-- -- stream after the first @n@ characters, or the empty stream if @n@
782− {-# INLINE next #-}
782+-- -- is greater than the length of the stream.
783− next (L s) = case next0 s of
783+-- drop :: Integral a => a -> Stream Char -> Stream Char
784− Done -> Done
784+-- -- drop n0 (Stream next0 s0 len) =
785− Skip s' -> Skip (L s')
785+-- drop n0 (Stream next0 s0) =
786− Yield x s' | p x -> Skip (L s')
786+-- Stream next (JS n0 s0) -- (len - fromIntegral (max 0 n0))
787− | otherwise -> Yield x (R s')
787+-- where
788− next (R s) = case next0 s of
788+-- {-# INLINE next #-}
789− Done -> Done
789+-- next (JS n s)
790− Skip s' -> Skip (R s')
790+-- | n <= 0 = Skip (NS s)
791− Yield x s' -> Yield x (R s')
791+-- | otherwise = case next0 s of
792−{-# INLINE [0] dropWhile #-}
792+-- Done -> Done
793−
793+-- Skip s' -> Skip (JS n s')
794−-- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns
794+-- Yield _ s' -> Skip (JS (n-1) s')
795−-- 'True' iff the first is a prefix of the second.
795+-- next (NS s) = case next0 s of
796−isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool
796+-- Done -> Done
797−isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
797+-- Skip s' -> Skip (NS s')
798− where
798+-- Yield x s' -> Yield x (NS s')
799− loop Done _ = True
799+-- {-# INLINE [0] drop #-}
800− loop _ Done = False
800+
801− loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
801+-- -- | takeWhile, applied to a predicate @p@ and a stream, returns the
802− loop (Skip s1') x2 = loop (next1 s1') x2
802+-- -- longest prefix (possibly empty) of elements that satisfy p.
803− loop x1 (Skip s2') = loop x1 (next2 s2')
803+-- takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char
804− loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
804+-- -- takeWhile p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
805− loop (next1 s1') (next2 s2')
805+-- takeWhile p (Stream next0 s0) = Stream next s0 -- len -- HINT maybe too high
806−{-# INLINE [0] isPrefixOf #-}
806+-- where
807−
807+-- {-# INLINE next #-}
808−-- ----------------------------------------------------------------------------
808+-- next !s = case next0 s of
809−-- * Searching
809+-- Done -> Done
810−
810+-- Skip s' -> Skip s'
811−-------------------------------------------------------------------------------
811+-- Yield x s' | p x -> Yield x s'
812−-- ** Searching by equality
812+-- | otherwise -> Done
813−
813+-- {-# INLINE [0] takeWhile #-}
814−-- | /O(n)/ elem is the stream membership predicate.
814+
815−elem :: Char -> Stream Char -> Bool
815+-- -- | dropWhile @p @xs returns the suffix remaining after takeWhile @p @xs.
816−elem w (Stream next s0 _len) = loop_elem s0
816+-- dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
817− where
817+-- -- dropWhile p (Stream next0 s0 len) = Stream next (L s0) len -- HINT maybe too high
818− loop_elem !s = case next s of
818+-- dropWhile p (Stream next0 s0) = Stream next (L s0) -- len -- HINT maybe too high
819− Done -> False
819+-- where
820− Skip s' -> loop_elem s'
820+-- {-# INLINE next #-}
821− Yield x s' | x == w -> True
821+-- next (L s) = case next0 s of
822− | otherwise -> loop_elem s'
822+-- Done -> Done
823−{-# INLINE [0] elem #-}
823+-- Skip s' -> Skip (L s')
824−
824+-- Yield x s' | p x -> Skip (L s')
825−-------------------------------------------------------------------------------
825+-- | otherwise -> Yield x (R s')
826−-- ** Searching with a predicate
826+-- next (R s) = case next0 s of
827−
827+-- Done -> Done
828−-- | /O(n)/ The 'findBy' function takes a predicate and a stream,
828+-- Skip s' -> Skip (R s')
829−-- and returns the first element in matching the predicate, or 'Nothing'
829+-- Yield x s' -> Yield x (R s')
830−-- if there is no such element.
830+-- {-# INLINE [0] dropWhile #-}
831−
831+
832−findBy :: (Char -> Bool) -> Stream Char -> Maybe Char
832+-- -- | /O(n)/ The 'isPrefixOf' function takes two 'Stream's and returns
833−findBy p (Stream next s0 _len) = loop_find s0
833+-- -- 'True' iff the first is a prefix of the second.
834− where
834+-- isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool
835− loop_find !s = case next s of
835+-- -- isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
836− Done -> Nothing
836+-- isPrefixOf (Stream next1 s1) (Stream next2 s2) = loop (next1 s1) (next2 s2)
837− Skip s' -> loop_find s'
837+-- where
838− Yield x s' | p x -> Just x
838+-- loop Done _ = True
839− | otherwise -> loop_find s'
839+-- loop _ Done = False
840−{-# INLINE [0] findBy #-}
840+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
841−
841+-- loop (Skip s1') x2 = loop (next1 s1') x2
842−-- | /O(n)/ Stream index (subscript) operator, starting from 0.
842+-- loop x1 (Skip s2') = loop x1 (next2 s2')
843−indexI :: Integral a => Stream Char -> a -> Char
843+-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
844−indexI (Stream next s0 _len) n0
844+-- loop (next1 s1') (next2 s2')
845− | n0 < 0 = streamError "index" "Negative index"
845+-- {-# INLINE [0] isPrefixOf #-}
846− | otherwise = loop_index n0 s0
846+
847− where
847+-- -- ----------------------------------------------------------------------------
848− loop_index !n !s = case next s of
848+-- -- * Searching
849− Done -> streamError "index" "Index too large"
849+
850− Skip s' -> loop_index n s'
850+-- -------------------------------------------------------------------------------
851− Yield x s' | n == 0 -> x
851+-- -- ** Searching by equality
852− | otherwise -> loop_index (n-1) s'
852+
853−{-# INLINE [0] indexI #-}
853+-- -- | /O(n)/ elem is the stream membership predicate.
854−
854+-- elem :: Char -> Stream Char -> Bool
855−-- | /O(n)/ 'filter', applied to a predicate and a stream,
855+-- -- elem w (Stream next s0 _len) = loop_elem s0
856−-- returns a stream containing those characters that satisfy the
856+-- elem w (Stream next s0) = loop_elem s0
857−-- predicate.
857+-- where
858−filter :: (Char -> Bool) -> Stream Char -> Stream Char
858+-- loop_elem !s = case next s of
859−filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
859+-- Done -> False
860− where
860+-- Skip s' -> loop_elem s'
861− next !s = case next0 s of
861+-- Yield x s' | x == w -> True
862− Done -> Done
862+-- | otherwise -> loop_elem s'
863− Skip s' -> Skip s'
863+-- {-# INLINE [0] elem #-}
864− Yield x s' | p x -> Yield x s'
864+
865− | otherwise -> Skip s'
865+-- -------------------------------------------------------------------------------
866−{-# INLINE [0] filter #-}
866+-- -- ** Searching with a predicate
867−
867+
868−{-# RULES
868+-- -- | /O(n)/ The 'findBy' function takes a predicate and a stream,
869− "STREAM filter/filter fusion" forall p q s.
869+-- -- and returns the first element in matching the predicate, or 'Nothing'
870− filter p (filter q s) = filter (\x -> q x && p x) s
870+-- -- if there is no such element.
871− #-}
871+
872−
872+-- findBy :: (Char -> Bool) -> Stream Char -> Maybe Char
873−-- | The 'findIndexI' function takes a predicate and a stream and
873+-- -- findBy p (Stream next s0 _len) = loop_find s0
874−-- returns the index of the first element in the stream satisfying the
874+-- findBy p (Stream next s0) = loop_find s0
875−-- predicate.
875+-- where
876−findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a
876+-- loop_find !s = case next s of
877−findIndexI p s = case findIndicesI p s of
877+-- Done -> Nothing
878− (i:_) -> Just i
878+-- Skip s' -> loop_find s'
879− _ -> Nothing
879+-- Yield x s' | p x -> Just x
880−{-# INLINE [0] findIndexI #-}
880+-- | otherwise -> loop_find s'
881−
881+-- {-# INLINE [0] findBy #-}
882−-- | The 'findIndicesI' function takes a predicate and a stream and
882+
883−-- returns all indices of the elements in the stream satisfying the
883+-- -- | /O(n)/ Stream index (subscript) operator, starting from 0.
884−-- predicate.
884+-- indexI :: Integral a => Stream Char -> a -> Char
885−findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a]
885+-- -- indexI (Stream next s0 _len) n0
886−findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0
886+-- indexI (Stream next s0) n0
887− where
887+-- | n0 < 0 = streamError "index" "Negative index"
888− loop_findIndex !i !s = case next s of
888+-- | otherwise = loop_index n0 s0
889− Done -> []
889+-- where
890− Skip s' -> loop_findIndex i s' -- hmm. not caught by QC
890+-- loop_index !n !s = case next s of
891− Yield x s' | p x -> i : loop_findIndex (i+1) s'
891+-- Done -> streamError "index" "Index too large"
892− | otherwise -> loop_findIndex (i+1) s'
892+-- Skip s' -> loop_index n s'
893−{-# INLINE [0] findIndicesI #-}
893+-- Yield x s' | n == 0 -> x
894−
894+-- | otherwise -> loop_index (n-1) s'
895−-------------------------------------------------------------------------------
895+-- {-# INLINE [0] indexI #-}
896−-- * Zipping
896+
897−
897+-- -- | /O(n)/ 'filter', applied to a predicate and a stream,
898−-- | Strict triple.
898+-- -- returns a stream containing those characters that satisfy the
899−data Zip a b m = Z1 !a !b
899+-- -- predicate.
900− | Z2 !a !b !m
900+-- filter :: (Char -> Bool) -> Stream Char -> Stream Char
901−
901+-- -- filter p (Stream next0 s0 len) = Stream next s0 len -- HINT maybe too high
902−-- | zipWith generalises 'zip' by zipping with the function given as
902+-- filter p (Stream next0 s0) = Stream next s0 -- len -- HINT maybe too high
903−-- the first argument, instead of a tupling function.
903+-- where
904−zipWith :: (a -> a -> b) -> Stream a -> Stream a -> Stream b
904+-- next !s = case next0 s of
905−zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) =
905+-- Done -> Done
906− Stream next (Z1 sa0 sb0) (smaller len1 len2)
906+-- Skip s' -> Skip s'
907− where
907+-- Yield x s' | p x -> Yield x s'
908− next (Z1 sa sb) = case next0 sa of
908+-- | otherwise -> Skip s'
909− Done -> Done
909+-- {-# INLINE [0] filter #-}
910− Skip sa' -> Skip (Z1 sa' sb)
910+
911− Yield a sa' -> Skip (Z2 sa' sb a)
911+-- {-# RULES
912−
912+-- "STREAM filter/filter fusion" forall p q s.
913− next (Z2 sa' sb a) = case next1 sb of
913+-- filter p (filter q s) = filter (\x -> q x && p x) s
914− Done -> Done
914+-- #-}
915− Skip sb' -> Skip (Z2 sa' sb' a)
915+
916− Yield b sb' -> Yield (f a b) (Z1 sa' sb')
916+-- -- | The 'findIndexI' function takes a predicate and a stream and
917−{-# INLINE [0] zipWith #-}
917+-- -- returns the index of the first element in the stream satisfying the
918−
918+-- -- predicate.
919−-- | /O(n)/ The 'countCharI' function returns the number of times the
919+-- findIndexI :: Integral a => (Char -> Bool) -> Stream Char -> Maybe a
920−-- query element appears in the given stream.
920+-- findIndexI p s = case findIndicesI p s of
921−countCharI :: Integral a => Char -> Stream Char -> a
921+-- (i:_) -> Just i
922−countCharI a (Stream next s0 _len) = loop 0 s0
922+-- _ -> Nothing
923− where
923+-- {-# INLINE [0] findIndexI #-}
924− loop !i !s = case next s of
924+
925− Done -> i
925+-- -- | The 'findIndicesI' function takes a predicate and a stream and
926− Skip s' -> loop i s'
926+-- -- returns all indices of the elements in the stream satisfying the
927− Yield x s' | a == x -> loop (i+1) s'
927+-- -- predicate.
928− | otherwise -> loop i s'
928+-- findIndicesI :: Integral a => (Char -> Bool) -> Stream Char -> [a]
929−{-# INLINE [0] countCharI #-}
929+-- -- findIndicesI p (Stream next s0 _len) = loop_findIndex 0 s0
930−
930+-- findIndicesI p (Stream next s0) = loop_findIndex 0 s0
931−streamError :: String -> String -> a
931+-- where
932−streamError func msg = P.error $ "Data.Text.Internal.Fusion.Common." ++ func ++ ": " ++ msg
932+-- loop_findIndex !i !s = case next s of
933−
933+-- Done -> []
934−emptyError :: String -> a
934+-- Skip s' -> loop_findIndex i s' -- hmm. not caught by QC
935−emptyError func = internalError func "Empty input"
935+-- Yield x s' | p x -> i : loop_findIndex (i+1) s'
936−
936+-- | otherwise -> loop_findIndex (i+1) s'
937−internalError :: String -> a
937+-- {-# INLINE [0] findIndicesI #-}
938−internalError func = streamError func "Internal error"
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 @@
19
19
20module Data.Text.Internal.Fusion.Types
20module Data.Text.Internal.Fusion.Types
21 (
21 (
22− CC(..)
22+ -- CC(..)
23− , PairS(..)
23+ -- , PairS(..)
24− , Scan(..)
24+ -- , Scan(..)
25− , RS(..)
25+ -- , RS(..)
26− , Step(..)
26+ -- , Step(..)
27− , Stream(..)
27+ -- , Stream(..)
28− , empty
28+ -- , empty
29+ module Data.JSString.Internal.Fusion.Types
29 ) where
30 ) where
30
31
31−import Data.Text.Internal.Fusion.Size
32+-- import Data.Text.Internal.Fusion.Size
32−import Data.Word (Word8)
33+-- import Data.Word (Word8)
33−
34+
35+import Data.JSString.Internal.Fusion.Types
36+
34−-- | Specialised tuple for case conversion.
37+-- -- | Specialised tuple for case conversion.
35−data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
38+-- data CC s = CC !s {-# UNPACK #-} !Char {-# UNPACK #-} !Char
36−
39+
37−-- | Restreaming state.
40+-- -- | Restreaming state.
38−data RS s
41+-- data RS s
39− = RS0 !s
42+-- = RS0 !s
40− | RS1 !s {-# UNPACK #-} !Word8
43+-- | RS1 !s {-# UNPACK #-} !Word8
41− | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
44+-- | RS2 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
42− | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
45+-- | RS3 !s {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
43−
46+
44−-- | Strict pair.
47+-- -- | Strict pair.
45−data PairS a b = !a :*: !b
48+-- data PairS a b = !a :*: !b
46− -- deriving (Eq, Ord, Show)
49+-- -- deriving (Eq, Ord, Show)
47−infixl 2 :*:
50+-- infixl 2 :*:
48−
51+
49−-- | An intermediate result in a scan.
52+-- -- | An intermediate result in a scan.
50−data Scan s = Scan1 {-# UNPACK #-} !Char !s
53+-- data Scan s = Scan1 {-# UNPACK #-} !Char !s
51− | Scan2 {-# UNPACK #-} !Char !s
54+-- | Scan2 {-# UNPACK #-} !Char !s
52−
55+
53−-- | Intermediate result in a processing pipeline.
56+-- -- | Intermediate result in a processing pipeline.
54−data Step s a = Done
57+-- data Step s a = Done
55− | Skip !s
58+-- | Skip !s
56− | Yield !a !s
59+-- | Yield !a !s
57−
60+
58−{-
61+-- {-
59−instance (Show a) => Show (Step s a)
62+-- instance (Show a) => Show (Step s a)
60− where show Done = "Done"
63+-- where show Done = "Done"
61− show (Skip _) = "Skip"
64+-- show (Skip _) = "Skip"
62− show (Yield x _) = "Yield " ++ show x
65+-- show (Yield x _) = "Yield " ++ show x
63−-}
66+-- -}
64−
67+
65−instance (Eq a) => Eq (Stream a) where
68+-- instance (Eq a) => Eq (Stream a) where
66− (==) = eq
69+-- (==) = eq
67−
70+
68−instance (Ord a) => Ord (Stream a) where
71+-- instance (Ord a) => Ord (Stream a) where
69− compare = cmp
72+-- compare = cmp
70−
73+
71−-- The length hint in a Stream has two roles. If its value is zero,
74+-- -- 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
75+-- -- 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
76+-- -- as a hint: it should usually be accurate, so we use it when
74−-- unstreaming to decide what size array to allocate. However, the
77+-- -- unstreaming to decide what size array to allocate. However, the
75−-- unstreaming functions must be able to cope with the hint being too
78+-- -- unstreaming functions must be able to cope with the hint being too
76−-- small or too large.
79+-- -- small or too large.
77−--
80+-- --
78−-- The size hint tries to track the UTF-16 code points in a stream,
81+-- -- 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
82+-- -- but often counts the number of characters instead. It can easily
80−-- undercount if, for instance, a transformed stream contains astral
83+-- -- undercount if, for instance, a transformed stream contains astral
81−-- plane characters (those above 0x10000).
84+-- -- plane characters (those above 0x10000).
82−
85+
83−data Stream a =
86+-- data Stream a =
84− forall s. Stream
87+-- forall s. Stream
85− (s -> Step s a) -- stepper function
88+-- (s -> Step s a) -- stepper function
86− !s -- current state
89+-- !s -- current state
87− !Size -- size hint
90+-- !Size -- size hint
88−
91+
89−-- | /O(n)/ Determines if two streams are equal.
92+-- -- | /O(n)/ Determines if two streams are equal.
90−eq :: (Eq a) => Stream a -> Stream a -> Bool
93+-- eq :: (Eq a) => Stream a -> Stream a -> Bool
91−eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
94+-- eq (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
92− where
95+-- where
93− loop Done Done = True
96+-- loop Done Done = True
94− loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
97+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
95− loop (Skip s1') x2 = loop (next1 s1') x2
98+-- loop (Skip s1') x2 = loop (next1 s1') x2
96− loop x1 (Skip s2') = loop x1 (next2 s2')
99+-- loop x1 (Skip s2') = loop x1 (next2 s2')
97− loop Done _ = False
100+-- loop Done _ = False
98− loop _ Done = False
101+-- loop _ Done = False
99− loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
102+-- loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
100− loop (next1 s1') (next2 s2')
103+-- loop (next1 s1') (next2 s2')
101−{-# INLINE [0] eq #-}
104+-- {-# INLINE [0] eq #-}
102−
105+
103−cmp :: (Ord a) => Stream a -> Stream a -> Ordering
106+-- cmp :: (Ord a) => Stream a -> Stream a -> Ordering
104−cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
107+-- cmp (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
105− where
108+-- where
106− loop Done Done = EQ
109+-- loop Done Done = EQ
107− loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
110+-- loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
108− loop (Skip s1') x2 = loop (next1 s1') x2
111+-- loop (Skip s1') x2 = loop (next1 s1') x2
109− loop x1 (Skip s2') = loop x1 (next2 s2')
112+-- loop x1 (Skip s2') = loop x1 (next2 s2')
110− loop Done _ = LT
113+-- loop Done _ = LT
111− loop _ Done = GT
114+-- loop _ Done = GT
112− loop (Yield x1 s1') (Yield x2 s2') =
115+-- loop (Yield x1 s1') (Yield x2 s2') =
113− case compare x1 x2 of
116+-- case compare x1 x2 of
114− EQ -> loop (next1 s1') (next2 s2')
117+-- EQ -> loop (next1 s1') (next2 s2')
115− other -> other
118+-- other -> other
116−{-# INLINE [0] cmp #-}
119+-- {-# INLINE [0] cmp #-}
117−
120+
118−-- | The empty stream.
121+-- -- | The empty stream.
119−empty :: Stream a
122+-- empty :: Stream a
120−empty = Stream next () 0
123+-- empty = Stream next () 0
121− where next _ = Done
124+-- where next _ = Done
122−{-# INLINE [0] empty #-}
125+-- {-# INLINE [0] empty #-}
Data/Text/Internal/IO.hs+8
@@ -95,7 +95,11 @@ unpack !buf !r !w
95 | r >= w = return T.empty
95 | r >= w = return T.empty
96 | otherwise = withRawBuffer buf go
96 | otherwise = withRawBuffer buf go
97 where
97 where
98+#ifndef __GHCJS__
98 go pbuf = return $! unstream (Stream next r (exactSize (w-r)))
99 go pbuf = return $! unstream (Stream next r (exactSize (w-r)))
100+#else
101+ go pbuf = return $! unstream (Stream next r)
102+#endif
99 where
103 where
100 next !i | i >= w = Done
104 next !i | i >= w = Done
101 | otherwise = Yield (ix i) (i+1)
105 | otherwise = Yield (ix i) (i+1)
@@ -108,7 +112,11 @@ unpack_nl !buf !r !w
108 | otherwise = withRawBuffer buf $ go
112 | otherwise = withRawBuffer buf $ go
109 where
113 where
110 go pbuf = do
114 go pbuf = do
115+#ifndef __GHCJS__
111 let !t = unstream (Stream next r (maxSize (w-r)))
116 let !t = unstream (Stream next r (maxSize (w-r)))
117+#else
118+ let !t = unstream (Stream next r)
119+#endif
112 w' = w - 1
120 w' = w - 1
113 return $ if ix w' == '\r'
121 return $ if ix w' == '\r'
114 then (t,w')
122 then (t,w')
Data/Text/Internal/Lazy.hs+20−1
@@ -1,4 +1,4 @@
1−{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
1+{-# LANGUAGE BangPatterns, DeriveDataTypeable, CPP #-}
2{-# OPTIONS_HADDOCK not-home #-}
2{-# OPTIONS_HADDOCK not-home #-}
3
3
4-- |
4-- |
@@ -44,6 +44,10 @@ import Data.Typeable (Typeable)
44import Foreign.Storable (sizeOf)
44import Foreign.Storable (sizeOf)
45import qualified Data.Text.Internal as T
45import qualified Data.Text.Internal as T
46
46
47+#ifdef __GHCJS__
48+import qualified Data.Text as TT
49+#endif
50+
47data Text = Empty
51data Text = Empty
48 | Chunk {-# UNPACK #-} !T.Text Text
52 | Chunk {-# UNPACK #-} !T.Text Text
49 deriving (Typeable)
53 deriving (Typeable)
@@ -57,16 +61,26 @@ data Text = Empty
57-- | Check the invariant strictly.
61-- | Check the invariant strictly.
58strictInvariant :: Text -> Bool
62strictInvariant :: Text -> Bool
59strictInvariant Empty = True
63strictInvariant Empty = True
64+#ifndef __GHCJS__
60strictInvariant x@(Chunk (T.Text _ _ len) cs)
65strictInvariant x@(Chunk (T.Text _ _ len) cs)
61 | len > 0 = strictInvariant cs
66 | len > 0 = strictInvariant cs
67+#else
68+strictInvariant x@(Chunk t cs)
69+ | TT.length t > 0 = strictInvariant cs
70+#endif
62 | otherwise = error $ "Data.Text.Lazy: invariant violation: "
71 | otherwise = error $ "Data.Text.Lazy: invariant violation: "
63 ++ showStructure x
72 ++ showStructure x
64
73
65-- | Check the invariant lazily.
74-- | Check the invariant lazily.
66lazyInvariant :: Text -> Text
75lazyInvariant :: Text -> Text
67lazyInvariant Empty = Empty
76lazyInvariant Empty = Empty
77+#ifndef __GHCJS__
68lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)
78lazyInvariant x@(Chunk c@(T.Text _ _ len) cs)
69 | len > 0 = Chunk c (lazyInvariant cs)
79 | len > 0 = Chunk c (lazyInvariant cs)
80+#else
81+lazyInvariant x@(Chunk c cs)
82+ | TT.length c > 0 = Chunk c (lazyInvariant cs)
83+#endif
70 | otherwise = error $ "Data.Text.Lazy: invariant violation: "
84 | otherwise = error $ "Data.Text.Lazy: invariant violation: "
71 ++ showStructure x
85 ++ showStructure x
72
86
@@ -80,8 +94,13 @@ showStructure (Chunk t ts) =
80-- | Smart constructor for 'Chunk'. Guarantees the data type invariant.
94-- | Smart constructor for 'Chunk'. Guarantees the data type invariant.
81chunk :: T.Text -> Text -> Text
95chunk :: T.Text -> Text -> Text
82{-# INLINE chunk #-}
96{-# INLINE chunk #-}
97+#ifndef __GHCJS__
83chunk t@(T.Text _ _ len) ts | len == 0 = ts
98chunk t@(T.Text _ _ len) ts | len == 0 = ts
84 | otherwise = Chunk t ts
99 | otherwise = Chunk t ts
100+#else
101+chunk t ts | TT.null t = ts
102+ | otherwise = Chunk t ts
103+#endif
85
104
86-- | Smart constructor for 'Empty'.
105-- | Smart constructor for 'Empty'.
87empty :: Text
106empty :: Text
Data/Text/Internal/Lazy/Encoding/Fusion.hs+26
@@ -38,7 +38,9 @@ import qualified Data.ByteString.Unsafe as B
38import Data.Text.Internal.Encoding.Fusion.Common
38import Data.Text.Internal.Encoding.Fusion.Common
39import Data.Text.Encoding.Error
39import Data.Text.Encoding.Error
40import Data.Text.Internal.Fusion (Step(..), Stream(..))
40import Data.Text.Internal.Fusion (Step(..), Stream(..))
41+#ifndef __GHCJS__
41import Data.Text.Internal.Fusion.Size
42import Data.Text.Internal.Fusion.Size
43+#endif
42import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
44import Data.Text.Internal.Unsafe.Char (unsafeChr, unsafeChr8, unsafeChr32)
43import Data.Text.Internal.Unsafe.Shift (shiftL)
45import Data.Text.Internal.Unsafe.Shift (shiftL)
44import Data.Word (Word8, Word16, Word32)
46import Data.Word (Word8, Word16, Word32)
@@ -65,7 +67,11 @@ data T = T !ByteString !S {-# UNPACK #-} !Int
65-- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using
67-- | /O(n)/ Convert a lazy 'ByteString' into a 'Stream Char', using
66-- UTF-8 encoding.
68-- UTF-8 encoding.
67streamUtf8 :: OnDecodeError -> ByteString -> Stream Char
69streamUtf8 :: OnDecodeError -> ByteString -> Stream Char
70+#ifndef __GHCJS__
68streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize
71streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize
72+#else
73+streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
74+#endif
69 where
75 where
70 next (T bs@(Chunk ps _) S0 i)
76 next (T bs@(Chunk ps _) S0 i)
71 | i < len && U8.validate1 a =
77 | i < len && U8.validate1 a =
@@ -107,7 +113,11 @@ streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize
107-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
113-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
108-- endian UTF-16 encoding.
114-- endian UTF-16 encoding.
109streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char
115streamUtf16LE :: OnDecodeError -> ByteString -> Stream Char
116+#ifndef __GHCJS__
110streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
117streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
118+#else
119+streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
120+#endif
111 where
121 where
112 next (T bs@(Chunk ps _) S0 i)
122 next (T bs@(Chunk ps _) S0 i)
113 | i + 1 < len && U16.validate1 x1 =
123 | i + 1 < len && U16.validate1 x1 =
@@ -147,7 +157,11 @@ streamUtf16LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
147-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
157-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
148-- endian UTF-16 encoding.
158-- endian UTF-16 encoding.
149streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char
159streamUtf16BE :: OnDecodeError -> ByteString -> Stream Char
160+#ifndef __GHCJS__
150streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
161streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
162+#else
163+streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
164+#endif
151 where
165 where
152 next (T bs@(Chunk ps _) S0 i)
166 next (T bs@(Chunk ps _) S0 i)
153 | i + 1 < len && U16.validate1 x1 =
167 | i + 1 < len && U16.validate1 x1 =
@@ -187,7 +201,11 @@ streamUtf16BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
187-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
201-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using big
188-- endian UTF-32 encoding.
202-- endian UTF-32 encoding.
189streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char
203streamUtf32BE :: OnDecodeError -> ByteString -> Stream Char
204+#ifndef __GHCJS__
190streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
205streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
206+#else
207+streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
208+#endif
191 where
209 where
192 next (T bs@(Chunk ps _) S0 i)
210 next (T bs@(Chunk ps _) S0 i)
193 | i + 3 < len && U32.validate x =
211 | i + 3 < len && U32.validate x =
@@ -231,7 +249,11 @@ streamUtf32BE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
231-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
249-- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using little
232-- endian UTF-32 encoding.
250-- endian UTF-32 encoding.
233streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char
251streamUtf32LE :: OnDecodeError -> ByteString -> Stream Char
252+#ifndef __GHCJS__
234streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
253streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
254+#else
255+streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) -- unknownSize
256+#endif
235 where
257 where
236 next (T bs@(Chunk ps _) S0 i)
258 next (T bs@(Chunk ps _) S0 i)
237 | i + 3 < len && U32.validate x =
259 | i + 3 < len && U32.validate x =
@@ -274,7 +296,11 @@ streamUtf32LE onErr bs0 = Stream next (T bs0 S0 0) unknownSize
274
296
275-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.
297-- | /O(n)/ Convert a 'Stream' 'Word8' to a lazy 'ByteString'.
276unstreamChunks :: Int -> Stream Word8 -> ByteString
298unstreamChunks :: Int -> Stream Word8 -> ByteString
299+#ifndef __GHCJS__
277unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
300unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
301+#else
302+unstreamChunks chunkSize (Stream next s0) = chunk s0 4
303+#endif
278 where chunk s1 len1 = unsafeDupablePerformIO $ do
304 where chunk s1 len1 = unsafeDupablePerformIO $ do
279 let len = max 4 (min len1 chunkSize)
305 let len = max 4 (min len1 chunkSize)
280 mallocByteString len >>= loop len 0 s1
306 mallocByteString len >>= loop len 0 s1
Data/Text/Internal/Lazy/Fusion.hs+62
@@ -1,4 +1,10 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+#ifdef __GHCJS__
4+{-# LANGUAGE ForeignFunctionInterface #-}
5+{-# LANGUAGE MagicHash #-}
6+{-# LANGUAGE UnliftedFFITypes #-}
7+#endif
2-- |
8-- |
3-- Module : Data.Text.Lazy.Fusion
9-- Module : Data.Text.Lazy.Fusion
4-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
10-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
@@ -29,7 +35,14 @@ import Prelude hiding (length)
29import qualified Data.Text.Internal.Fusion.Common as S
35import qualified Data.Text.Internal.Fusion.Common as S
30import Control.Monad.ST (runST)
36import Control.Monad.ST (runST)
31import Data.Text.Internal.Fusion.Types
37import Data.Text.Internal.Fusion.Types
38+#ifndef __GHCJS__
32import Data.Text.Internal.Fusion.Size (isEmpty, unknownSize)
39import Data.Text.Internal.Fusion.Size (isEmpty, unknownSize)
40+#else
41+import Data.JSString (JSString)
42+import qualified Data.JSString as JSS
43+import GHC.Base (Int(..))
44+import GHC.Exts (ByteArray#, Int#)
45+#endif
33import Data.Text.Internal.Lazy
46import Data.Text.Internal.Lazy
34import qualified Data.Text.Internal as I
47import qualified Data.Text.Internal as I
35import qualified Data.Text.Array as A
48import qualified Data.Text.Array as A
@@ -42,6 +55,7 @@ default(Int64)
42
55
43-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
56-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
44stream :: Text -> Stream Char
57stream :: Text -> Stream Char
58+#ifndef __GHCJS__
45stream text = Stream next (text :*: 0) unknownSize
59stream text = Stream next (text :*: 0) unknownSize
46 where
60 where
47 next (Empty :*: _) = Done
61 next (Empty :*: _) = Done
@@ -49,11 +63,22 @@ stream text = Stream next (text :*: 0) unknownSize
49 | i >= len = next (ts :*: 0)
63 | i >= len = next (ts :*: 0)
50 | otherwise = Yield c (txt :*: i+d)
64 | otherwise = Yield c (txt :*: i+d)
51 where Iter c d = iter t i
65 where Iter c d = iter t i
66+#else
67+stream text = Stream next (text :*: 0) -- unknownSize
68+ where
69+ next (Empty :*: _) = Done
70+ next (txt@(Chunk t@(I.Text jst) ts) :*: i)
71+ | i >= JSS.length jst = next (ts :*: 0)
72+ | otherwise = Yield c (txt :*: i+d)
73+ where Iter c d = iter t i
74+#endif
52{-# INLINE [0] stream #-}
75{-# INLINE [0] stream #-}
53
76
77+-- TODO
54-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given
78-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using the given
55-- chunk size.
79-- chunk size.
56unstreamChunks :: Int -> Stream Char -> Text
80unstreamChunks :: Int -> Stream Char -> Text
81+#ifndef __GHCJS__
57unstreamChunks !chunkSize (Stream next s0 len0)
82unstreamChunks !chunkSize (Stream next s0 len0)
58 | isEmpty len0 = Empty
83 | isEmpty len0 = Empty
59 | otherwise = outer s0
84 | otherwise = outer s0
@@ -84,6 +109,36 @@ unstreamChunks !chunkSize (Stream next s0 len0)
84 finish marr len s' = do
109 finish marr len s' = do
85 arr <- A.unsafeFreeze marr
110 arr <- A.unsafeFreeze marr
86 return (I.Text arr 0 len `Chunk` outer s')
111 return (I.Text arr 0 len `Chunk` outer s')
112+#else
113+unstreamChunks !chunkSize (Stream next s0) = outer s0
114+ where
115+ outer so = {-# SCC "unstreamChunks/outer" #-}
116+ case next so of
117+ Done -> Empty
118+ Skip s' -> outer s'
119+ Yield x s' -> runST $ do
120+ a <- A.new unknownLength
121+ unsafeWrite a 0 x >>= inner a unknownLength s'
122+ where unknownLength = 4
123+ where
124+ inner marr !len s !i
125+ | i + 1 >= chunkSize = finish marr i s
126+ | i + 1 >= len = {-# SCC "unstreamChunks/resize" #-} do
127+ let newLen = min (len `shiftL` 1) chunkSize
128+ marr' <- A.new newLen
129+ A.copyM marr' 0 marr 0 len
130+ inner marr' newLen s i
131+ | otherwise =
132+ {-# SCC "unstreamChunks/inner" #-}
133+ case next s of
134+ Done -> finish marr i s
135+ Skip s' -> inner marr len s' i
136+ Yield x s' -> do d <- unsafeWrite marr i x
137+ inner marr len s' (i+d)
138+ finish marr (I# len#) s' = do
139+ arr <- A.unsafeFreeze marr
140+ return (I.Text (js_toString (A.aBA arr) 0# len#) `Chunk` outer s')
141+#endif
87{-# INLINE [0] unstreamChunks #-}
142{-# INLINE [0] unstreamChunks #-}
88
143
89-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using
144-- | /O(n)/ Convert a 'Stream Char' into a 'Text', using
@@ -118,3 +173,10 @@ index = S.indexI
118countChar :: Char -> Stream Char -> Int64
173countChar :: Char -> Stream Char -> Int64
119countChar = S.countCharI
174countChar = S.countCharI
120{-# INLINE [0] countChar #-}
175{-# INLINE [0] countChar #-}
176+
177+#ifdef __GHCJS__
178+foreign import javascript unsafe
179+ "h$textToString"
180+ js_toString :: ByteArray# -> Int# -> Int# -> JSString
181+#endif
182+
Data/Text/Internal/Lazy/Search.hs+55−11
@@ -1,4 +1,7 @@
1{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
1{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2+{-# LANGUAGE ForeignFunctionInterface, UnliftedFFITypes, JavaScriptFFI,
3+ UnboxedTuples, DeriveDataTypeable, GHCForeignImportPrim,
4+ MagicHash, FlexibleInstances, BangPatterns, Rank2Types, CPP #-}
2
5
3-- |
6-- |
4-- Module : Data.Text.Lazy.Search
7-- Module : Data.Text.Lazy.Search
@@ -31,6 +34,17 @@ import Data.Text.Internal.Lazy (Text(..), foldlChunks)
31import Data.Bits ((.|.), (.&.))
34import Data.Bits ((.|.), (.&.))
32import Data.Text.Internal.Unsafe.Shift (shiftL)
35import Data.Text.Internal.Unsafe.Shift (shiftL)
33
36
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+
34-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
48-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
35-- @needle@ within @haystack@.
49-- @needle@ within @haystack@.
36--
50--
@@ -47,8 +61,10 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
47 | nlen == 1 = indicesOne (nindex 0) 0 k ks
61 | nlen == 1 = indicesOne (nindex 0) 0 k ks
48 | otherwise = advance k ks 0 0
62 | otherwise = advance k ks 0 0
49 where
63 where
50− advance x@(T.Text _ _ l) xs = scan
64+ -- advance x@(T.Text _ _ l) xs = scan
65+ advance x xs = scan
51 where
66 where
67+ l = TT.length x
52 scan !g !i
68 scan !g !i
53 | i >= m = case xs of
69 | i >= m = case xs of
54 Empty -> []
70 Empty -> []
@@ -72,11 +88,23 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
72 nlast = nlen - 1
88 nlast = nlen - 1
73 nindex = index n ns
89 nindex = index n ns
74 z = foldlChunks fin 0 needle
90 z = foldlChunks fin 0 needle
91+ where
92+ -- fin _ (T.Text farr foff flen) =
93+ fin _ t =
94+ let foff = 0
95+ (farr, flen) =
96+ let (# ba, len #) = fromString t
97+ in (A.Array ba, I# len)
75− where fin _ (T.Text farr foff flen) = A.unsafeIndex farr (foff+flen-1)
98+ in A.unsafeIndex farr (foff+flen-1)
76 (mask :: Word64) :*: skip = buildTable n ns 0 0 0 (nlen-2)
99 (mask :: Word64) :*: skip = buildTable n ns 0 0 0 (nlen-2)
77 swizzle w = 1 `shiftL` (fromIntegral w .&. 0x3f)
100 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
79 where
103 where
104+ xoff = 0
105+ (xarr, xlen) =
106+ let (# ba, len #) = fromString t
107+ in (A.Array ba, I# len)
80 go !(g::Int64) !i !msk !skp
108 go !(g::Int64) !i !msk !skp
81 | i >= xlast = case xs of
109 | i >= xlast = case xs of
82 Empty -> (msk .|. swizzle z) :*: skp
110 Empty -> (msk .|. swizzle z) :*: skp
@@ -91,17 +119,22 @@ indices needle@(Chunk n ns) _haystack@(Chunk k ks)
91 -- given offset would fail.
119 -- given offset would fail.
92 lackingHay q = go 0
120 lackingHay q = go 0
93 where
121 where
94− go p (T.Text _ _ l) ps = p' < q && case ps of
122+ -- go p (T.Text _ _ l) ps = p' < q && case ps of
123+ go p t ps = p' < q && case ps of
95− Empty -> True
124+ Empty -> True
96− Chunk r rs -> go p' r rs
125+ Chunk r rs -> go p' r rs
126+ where
127+ l = TT.length t
97− where p' = p + fromIntegral l
128+ p' = p + fromIntegral l
129+
98indices _ _ = []
130indices _ _ = []
99
131
100-- | Fast index into a partly unpacked 'Text'. We take into account
132-- | Fast index into a partly unpacked 'Text'. We take into account
101-- the possibility that the caller might try to access one element
133-- the possibility that the caller might try to access one element
102-- past the end.
134-- past the end.
103index :: T.Text -> Text -> Int64 -> Word16
135index :: 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
105 | j < len = A.unsafeIndex arr (off+j)
138 | j < len = A.unsafeIndex arr (off+j)
106 | otherwise = case xs of
139 | otherwise = case xs of
107 Empty
140 Empty
@@ -110,14 +143,24 @@ index (T.Text arr off len) xs !i
110 -- should never happen, due to lackingHay above
143 -- should never happen, due to lackingHay above
111 | otherwise -> emptyError "index"
144 | otherwise -> emptyError "index"
112 Chunk c cs -> index c cs (i-fromIntegral len)
145 Chunk c cs -> index c cs (i-fromIntegral len)
146+ where
113− where j = fromIntegral i
147+ j = fromIntegral i
148+ off = 0
149+ (arr, len) =
150+ let (# ba, len' #) = fromString t
151+ in (A.Array ba, I# len')
114
152
115-- | A variant of 'indices' that scans linearly for a single 'Word16'.
153-- | A variant of 'indices' that scans linearly for a single 'Word16'.
116indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64]
154indicesOne :: Word16 -> Int64 -> T.Text -> Text -> [Int64]
117indicesOne c = chunk
155indicesOne c = chunk
118 where
156 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
120 where
159 where
160+ ooff = 0
161+ (oarr, olen) =
162+ let (# ba, len #) = fromString t
163+ in (A.Array ba, I# len)
121 go h | h >= olen = case os of
164 go h | h >= olen = case os of
122 Empty -> []
165 Empty -> []
123 Chunk y ys -> chunk (i+fromIntegral olen) y ys
166 Chunk y ys -> chunk (i+fromIntegral olen) y ys
@@ -128,7 +171,8 @@ indicesOne c = chunk
128-- | The number of 'Word16' values in a 'Text'.
171-- | The number of 'Word16' values in a 'Text'.
129wordLength :: Text -> Int64
172wordLength :: Text -> Int64
130wordLength = foldlChunks sumLength 0
173wordLength = foldlChunks sumLength 0
174+ where sumLength i t = i + fromIntegral (TT.length t)
131− where sumLength i (T.Text _ _ l) = i + fromIntegral l
175+ -- where sumLength i (T.Text _ _ l) = i + fromIntegral l
132
176
133emptyError :: String -> a
177emptyError :: String -> a
134emptyError fun = error ("Data.Text.Lazy.Search." ++ fun ++ ": empty input")
178emptyError 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 #-}
2
2
3-- |
3-- |
4-- Module : Data.Text.Internal.Private
4-- Module : Data.Text.Internal.Private
@@ -19,8 +19,12 @@ import Control.Monad.ST (ST, runST)
19import Data.Text.Internal (Text(..), text)
19import Data.Text.Internal (Text(..), text)
20import Data.Text.Unsafe (Iter(..), iter)
20import Data.Text.Unsafe (Iter(..), iter)
21import qualified Data.Text.Array as A
21import qualified Data.Text.Array as A
22+#ifdef __GHCJS__
23+import qualified Data.JSString as JSS
24+#endif
22
25
23span_ :: (Char -> Bool) -> Text -> (# Text, Text #)
26span_ :: (Char -> Bool) -> Text -> (# Text, Text #)
27+#ifndef __GHCJS__
24span_ p t@(Text arr off len) = (# hd,tl #)
28span_ p t@(Text arr off len) = (# hd,tl #)
25 where hd = text arr off k
29 where hd = text arr off k
26 tl = text arr (off+k) (len-k)
30 tl = text arr (off+k) (len-k)
@@ -28,6 +32,9 @@ span_ p t@(Text arr off len) = (# hd,tl #)
28 loop !i | i < len && p c = loop (i+d)
32 loop !i | i < len && p c = loop (i+d)
29 | otherwise = i
33 | otherwise = i
30 where Iter c d = iter t i
34 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
31{-# INLINE span_ #-}
38{-# INLINE span_ #-}
32
39
33runText :: (forall s. (A.MArray s -> Int -> ST s Text) -> ST s Text) -> Text
40runText :: (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(..))
37import Data.Bits ((.|.), (.&.))
37import Data.Bits ((.|.), (.&.))
38import Data.Text.Internal.Unsafe.Shift (shiftL)
38import Data.Text.Internal.Unsafe.Shift (shiftL)
39
39
40+import qualified Data.JSString.Internal.Search as JSS
41+
40data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
42data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
41
43
42-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
44-- | /O(n+m)/ Find the offsets of all non-overlapping indices of
@@ -49,41 +51,42 @@ data T = {-# UNPACK #-} !Word64 :* {-# UNPACK #-} !Int
49indices :: Text -- ^ Substring to search for (@needle@)
51indices :: Text -- ^ Substring to search for (@needle@)
50 -> Text -- ^ Text to search in (@haystack@)
52 -> Text -- ^ Text to search in (@haystack@)
51 -> [Int]
53 -> [Int]
54+indices = coerce JSS.indices
52−indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
55+-- indices _needle@(Text narr noff nlen) _haystack@(Text harr hoff hlen)
53− | nlen == 1 = scanOne (nindex 0)
56+-- | nlen == 1 = scanOne (nindex 0)
54− | nlen <= 0 || ldiff < 0 = []
57+-- | nlen <= 0 || ldiff < 0 = []
55− | otherwise = scan 0
58+-- | otherwise = scan 0
56− where
59+-- where
57− ldiff = hlen - nlen
60+-- ldiff = hlen - nlen
58− nlast = nlen - 1
61+-- nlast = nlen - 1
59− z = nindex nlast
62+-- z = nindex nlast
60− nindex k = A.unsafeIndex narr (noff+k)
63+-- nindex k = A.unsafeIndex narr (noff+k)
61− hindex k = A.unsafeIndex harr (hoff+k)
64+-- hindex k = A.unsafeIndex harr (hoff+k)
62− hindex' k | k == hlen = 0
65+-- hindex' k | k == hlen = 0
63− | otherwise = A.unsafeIndex harr (hoff+k)
66+-- | otherwise = A.unsafeIndex harr (hoff+k)
64− buildTable !i !msk !skp
67+-- buildTable !i !msk !skp
65− | i >= nlast = (msk .|. swizzle z) :* skp
68+-- | i >= nlast = (msk .|. swizzle z) :* skp
66− | otherwise = buildTable (i+1) (msk .|. swizzle c) skp'
69+-- | otherwise = buildTable (i+1) (msk .|. swizzle c) skp'
67− where c = nindex i
70+-- where c = nindex i
68− skp' | c == z = nlen - i - 2
71+-- skp' | c == z = nlen - i - 2
69− | otherwise = skp
72+-- | otherwise = skp
70− swizzle k = 1 `shiftL` (fromIntegral k .&. 0x3f)
73+-- swizzle k = 1 `shiftL` (fromIntegral k .&. 0x3f)
71− scan !i
74+-- scan !i
72− | i > ldiff = []
75+-- | i > ldiff = []
73− | c == z && candidateMatch 0 = i : scan (i + nlen)
76+-- | c == z && candidateMatch 0 = i : scan (i + nlen)
74− | otherwise = scan (i + delta)
77+-- | otherwise = scan (i + delta)
75− where c = hindex (i + nlast)
78+-- where c = hindex (i + nlast)
76− candidateMatch !j
79+-- candidateMatch !j
77− | j >= nlast = True
80+-- | j >= nlast = True
78− | hindex (i+j) /= nindex j = False
81+-- | hindex (i+j) /= nindex j = False
79− | otherwise = candidateMatch (j+1)
82+-- | otherwise = candidateMatch (j+1)
80− delta | nextInPattern = nlen + 1
83+-- delta | nextInPattern = nlen + 1
81− | c == z = skip + 1
84+-- | c == z = skip + 1
82− | otherwise = 1
85+-- | otherwise = 1
83− where nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0
86+-- where nextInPattern = mask .&. swizzle (hindex' (i+nlen)) == 0
84− !(mask :* skip) = buildTable 0 0 (nlen-2)
87+-- !(mask :* skip) = buildTable 0 0 (nlen-2)
85− scanOne c = loop 0
88+-- scanOne c = loop 0
86− where loop !i | i >= hlen = []
89+-- where loop !i | i >= hlen = []
87− | hindex i == c = i : loop (i+1)
90+-- | hindex i == c = i : loop (i+1)
88− | otherwise = loop (i+1)
91+-- | otherwise = loop (i+1)
89{-# INLINE indices #-}
92{-# INLINE indices #-}
Data/Text/Lazy.hs+49−1
@@ -6,7 +6,9 @@
6#if __GLASGOW_HASKELL__ >= 708
6#if __GLASGOW_HASKELL__ >= 708
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8#endif
8#endif
9−
9+#ifdef __GHCJS__
10+{-# LANGUAGE ForeignFunctionInterface #-}
11+#endif
10-- |
12-- |
11-- Module : Data.Text.Lazy
13-- Module : Data.Text.Lazy
12-- Copyright : (c) 2009, 2010, 2012 Bryan O'Sullivan
14-- Copyright : (c) 2009, 2010, 2012 Bryan O'Sullivan
@@ -244,6 +246,9 @@ import GHC.Prim (Addr#)
244#if MIN_VERSION_base(4,7,0)
246#if MIN_VERSION_base(4,7,0)
245import Text.Printf (PrintfArg, formatArg, formatString)
247import Text.Printf (PrintfArg, formatArg, formatString)
246#endif
248#endif
249+#ifdef __GHCJS__
250+import Data.JSString (JSString)
251+#endif
247
252
248-- $fusion
253-- $fusion
249--
254--
@@ -324,6 +329,7 @@ compareText Empty _ = LT
324compareText _ Empty = GT
329compareText _ Empty = GT
325compareText (Chunk a0 as) (Chunk b0 bs) = outer a0 b0
330compareText (Chunk a0 as) (Chunk b0 bs) = outer a0 b0
326 where
331 where
332+#ifndef __GHCJS__
327 outer ta@(T.Text arrA offA lenA) tb@(T.Text arrB offB lenB) = go 0 0
333 outer ta@(T.Text arrA offA lenA) tb@(T.Text arrB offB lenB) = go 0 0
328 where
334 where
329 go !i !j
335 go !i !j
@@ -334,6 +340,20 @@ compareText (Chunk a0 as) (Chunk b0 bs) = outer a0 b0
334 | otherwise = go (i+di) (j+dj)
340 | otherwise = go (i+di) (j+dj)
335 where T.Iter a di = T.iter ta i
341 where T.Iter a di = T.iter ta i
336 T.Iter b dj = T.iter tb j
342 T.Iter b dj = T.iter tb j
343+#else
344+ outer ta@(T.Text jsa) tb@(T.Text jsb) = go 0 0
345+ where
346+ go !i !j
347+ | i >= lenA = compareText as (chunk (T.Text (js_substr1 j jsb)) bs)
348+ | j >= lenB = compareText (chunk (T.Text (js_substr1 i jsa)) as) bs
349+ | a < b = LT
350+ | a > b = GT
351+ | otherwise = go (i+di) (j+dj)
352+ where T.Iter a di = T.iter ta i
353+ T.Iter b dj = T.iter tb j
354+ lenA = T.length ta
355+ lenB = T.length tb
356+#endif
337
357
338instance Show Text where
358instance Show Text where
339 showsPrec p ps r = showsPrec p (unpack ps) r
359 showsPrec p ps r = showsPrec p (unpack ps) r
@@ -1119,11 +1139,20 @@ dropWords i t0
1119 | otherwise = drop' i t0
1139 | otherwise = drop' i t0
1120 where drop' 0 ts = ts
1140 where drop' 0 ts = ts
1121 drop' _ Empty = Empty
1141 drop' _ Empty = Empty
1142+#ifndef __GHCJS__
1122 drop' n (Chunk (T.Text arr off len) ts)
1143 drop' n (Chunk (T.Text arr off len) ts)
1123 | n < len' = chunk (text arr (off+n') (len-n')) ts
1144 | n < len' = chunk (text arr (off+n') (len-n')) ts
1124 | otherwise = drop' (n - len') ts
1145 | otherwise = drop' (n - len') ts
1125 where len' = fromIntegral len
1146 where len' = fromIntegral len
1126 n' = fromIntegral n
1147 n' = fromIntegral n
1148+#else
1149+ drop' n (Chunk t@(T.Text jst) ts)
1150+ | n < len' = chunk (T.Text $ js_substr1 n' jst) ts
1151+ | otherwise = drop' (n - len') ts
1152+ where len' = fromIntegral len
1153+ len = T.length t
1154+ n' = fromIntegral n
1155+#endif
1127
1156
1128-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
1157-- | /O(n)/ 'takeWhile', applied to a predicate @p@ and a 'Text',
1129-- returns the longest prefix (possibly empty) of elements that
1158-- returns the longest prefix (possibly empty) of elements that
@@ -1244,12 +1273,22 @@ splitAt = loop
1244-- values, and whose second is the remainder of the string.
1273-- values, and whose second is the remainder of the string.
1245splitAtWord :: Int64 -> Text -> PairS Text Text
1274splitAtWord :: Int64 -> Text -> PairS Text Text
1246splitAtWord _ Empty = empty :*: empty
1275splitAtWord _ Empty = empty :*: empty
1276+#ifndef __GHCJS__
1247splitAtWord x (Chunk c@(T.Text arr off len) cs)
1277splitAtWord x (Chunk c@(T.Text arr off len) cs)
1248 | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
1278 | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
1249 in Chunk c h :*: t
1279 in Chunk c h :*: t
1250 | otherwise = chunk (text arr off y) empty :*:
1280 | otherwise = chunk (text arr off y) empty :*:
1251 chunk (text arr (off+y) (len-y)) cs
1281 chunk (text arr (off+y) (len-y)) cs
1252 where y = fromIntegral x
1282 where y = fromIntegral x
1283+#else
1284+splitAtWord x (Chunk c@(T.Text jst) cs)
1285+ | y >= len = let h :*: t = splitAtWord (x-fromIntegral len) cs
1286+ in Chunk c h :*: t
1287+ | otherwise = chunk (T.Text (js_substr 0 (y-1) jst)) empty :*:
1288+ chunk (T.Text (js_substr1 y jst)) cs
1289+ where y = fromIntegral x
1290+ len = T.length c
1291+#endif
1253
1292
1254-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1293-- | /O(n+m)/ Find the first instance of @needle@ (which must be
1255-- non-'null') in @haystack@. The first element of the returned tuple
1294-- non-'null') in @haystack@. The first element of the returned tuple
@@ -1429,7 +1468,11 @@ splitOn pat src
1429 go _ [] cs = [cs]
1468 go _ [] cs = [cs]
1430 go !i (x:xs) cs = let h :*: t = splitAtWord (x-i) cs
1469 go !i (x:xs) cs = let h :*: t = splitAtWord (x-i) cs
1431 in h : go (x+l) xs (dropWords l t)
1470 in h : go (x+l) xs (dropWords l t)
1471+#ifndef __GHCJS__
1432 l = foldlChunks (\a (T.Text _ _ b) -> a + fromIntegral b) 0 pat
1472 l = foldlChunks (\a (T.Text _ _ b) -> a + fromIntegral b) 0 pat
1473+#else
1474+ l = foldlChunks (\a t -> a + fromIntegral (T.length t)) 0 pat
1475+#endif
1433{-# INLINE [1] splitOn #-}
1476{-# INLINE [1] splitOn #-}
1434
1477
1435{-# RULES
1478{-# RULES
@@ -1693,3 +1736,8 @@ emptyError fun = P.error ("Data.Text.Lazy." ++ fun ++ ": empty input")
1693
1736
1694impossibleError :: String -> a
1737impossibleError :: String -> a
1695impossibleError fun = P.error ("Data.Text.Lazy." ++ fun ++ ": impossible case")
1738impossibleError fun = P.error ("Data.Text.Lazy." ++ fun ++ ": impossible case")
1739+
1740+#ifdef __GHCJS__
1741+foreign import javascript unsafe "$2.substr($1)" js_substr1 :: Exts.Int -> JSString -> JSString
1742+foreign import javascript unsafe "$3.substr($1,$2)" js_substr :: Exts.Int -> Exts.Int -> JSString -> JSString
1743+#endif
Data/Text/Lazy/Builder/Int.hs+9−259
@@ -1,262 +1,12 @@
1−{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, ScopedTypeVariables,
1+module Data.Text.Lazy.Builder.Int where
2− UnboxedTuples #-}
3−#if __GLASGOW_HASKELL__ >= 702
4−{-# LANGUAGE Trustworthy #-}
5−#endif
6
2
7−-- Module: Data.Text.Lazy.Builder.Int
3+import Data.Text.Lazy (Text)
8−-- Copyright: (c) 2013 Bryan O'Sullivan
4+import qualified Data.Text.Lazy as L
9−-- (c) 2011 MailRank, Inc.
5+import qualified Data.Text as T
10−-- License: BSD-style
6+import qualified Data.JSString.Int as JSS
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
7+import Data.Text.Lazy.Builder
18− (
19− decimal
20− , hexadecimal
21− ) where
22−
23−import Data.Int (Int8, Int16, Int32, Int64)
24−import Data.Monoid (mempty)
8+import Data.Monoid
25−import qualified Data.ByteString.Unsafe as B
26−import Data.Text.Internal.Builder.Functions ((<>), i2d)
27−import Data.Text.Internal.Builder
28−import Data.Text.Internal.Builder.Int.Digits (digits)
29−import Data.Text.Array
30−import Data.Word (Word, Word8, Word16, Word32, Word64)
31−import GHC.Base (quotInt, remInt)
32−import GHC.Num (quotRemInteger)
33−import GHC.Types (Int(..))
34−import Control.Monad.ST
35−
36−#ifdef __GLASGOW_HASKELL__
37−# if defined(INTEGER_GMP)
38−import GHC.Integer.GMP.Internals (Integer(S#))
39−# elif defined(INTEGER_SIMPLE)
40−import GHC.Integer
41−# else
42−# error "You need to use either GMP or integer-simple."
43−# endif
44−#endif
45−
46−#if defined(INTEGER_GMP) || defined(INTEGER_SIMPLE)
47−# define PAIR(a,b) (# a,b #)
48−#else
49−# define PAIR(a,b) (a,b)
50−#endif
51
9
52decimal :: Integral a => a -> Builder
10decimal :: Integral a => a -> Builder
53−{-# RULES "decimal/Int8" decimal = boundedDecimal :: Int8 -> Builder #-}
11+-- decimal n = L.fromChunks [T.Text $ JSS.decimal n]
54−{-# RULES "decimal/Int" decimal = boundedDecimal :: Int -> Builder #-}
12+decimal _ = mempty
55−{-# RULES "decimal/Int16" decimal = boundedDecimal :: Int16 -> Builder #-}
56−{-# RULES "decimal/Int32" decimal = boundedDecimal :: Int32 -> Builder #-}
57−{-# RULES "decimal/Int64" decimal = boundedDecimal :: Int64 -> Builder #-}
58−{-# RULES "decimal/Word" decimal = positive :: Data.Word.Word -> Builder #-}
59−{-# RULES "decimal/Word8" decimal = positive :: Word8 -> Builder #-}
60−{-# RULES "decimal/Word16" decimal = positive :: Word16 -> Builder #-}
61−{-# RULES "decimal/Word32" decimal = positive :: Word32 -> Builder #-}
62−{-# RULES "decimal/Word64" decimal = positive :: Word64 -> Builder #-}
63−{-# RULES "decimal/Integer" decimal = integer 10 :: Integer -> Builder #-}
64−decimal i = decimal' (<= -128) i
65−{-# NOINLINE decimal #-}
66−
67−boundedDecimal :: (Integral a, Bounded a) => a -> Builder
68−{-# SPECIALIZE boundedDecimal :: Int -> Builder #-}
69−{-# SPECIALIZE boundedDecimal :: Int8 -> Builder #-}
70−{-# SPECIALIZE boundedDecimal :: Int16 -> Builder #-}
71−{-# SPECIALIZE boundedDecimal :: Int32 -> Builder #-}
72−{-# SPECIALIZE boundedDecimal :: Int64 -> Builder #-}
73−boundedDecimal i = decimal' (== minBound) i
74−
75−decimal' :: (Integral a) => (a -> Bool) -> a -> Builder
76−{-# INLINE decimal' #-}
77−decimal' p i
78− | i < 0 = if p i
79− then let (q, r) = i `quotRem` 10
80− qq = -q
81− !n = countDigits qq
82− in writeN (n + 2) $ \marr off -> do
83− unsafeWrite marr off minus
84− posDecimal marr (off+1) n qq
85− unsafeWrite marr (off+n+1) (i2w (-r))
86− else let j = -i
87− !n = countDigits j
88− in writeN (n + 1) $ \marr off ->
89− unsafeWrite marr off minus >> posDecimal marr (off+1) n j
90− | otherwise = positive i
91−
92−positive :: (Integral a) => a -> Builder
93−{-# SPECIALIZE positive :: Int -> Builder #-}
94−{-# SPECIALIZE positive :: Int8 -> Builder #-}
95−{-# SPECIALIZE positive :: Int16 -> Builder #-}
96−{-# SPECIALIZE positive :: Int32 -> Builder #-}
97−{-# SPECIALIZE positive :: Int64 -> Builder #-}
98−{-# SPECIALIZE positive :: Word -> Builder #-}
99−{-# SPECIALIZE positive :: Word8 -> Builder #-}
100−{-# SPECIALIZE positive :: Word16 -> Builder #-}
101−{-# SPECIALIZE positive :: Word32 -> Builder #-}
102−{-# SPECIALIZE positive :: Word64 -> Builder #-}
103−positive i
104− | i < 10 = writeN 1 $ \marr off -> unsafeWrite marr off (i2w i)
105− | otherwise = let !n = countDigits i
106− in writeN n $ \marr off -> posDecimal marr off n i
107−
108−posDecimal :: (Integral a) =>
109− forall s. MArray s -> Int -> Int -> a -> ST s ()
110−{-# INLINE posDecimal #-}
111−posDecimal marr off0 ds v0 = go (off0 + ds - 1) v0
112− where go off v
113− | v >= 100 = do
114− let (q, r) = v `quotRem` 100
115− write2 off r
116− go (off - 2) q
117− | v < 10 = unsafeWrite marr off (i2w v)
118− | otherwise = write2 off v
119− write2 off i0 = do
120− let i = fromIntegral i0; j = i + i
121− unsafeWrite marr off $ get (j + 1)
122− unsafeWrite marr (off - 1) $ get j
123− get = fromIntegral . B.unsafeIndex digits
124−
125−minus, zero :: Word16
126−{-# INLINE minus #-}
127−{-# INLINE zero #-}
128−minus = 45
129−zero = 48
130−
131−i2w :: (Integral a) => a -> Word16
132−{-# INLINE i2w #-}
133−i2w v = zero + fromIntegral v
134−
135−countDigits :: (Integral a) => a -> Int
136−{-# INLINE countDigits #-}
137−countDigits v0
138− | fromIntegral v64 == v0 = go 1 v64
139− | otherwise = goBig 1 (fromIntegral v0)
140− where v64 = fromIntegral v0
141− goBig !k (v :: Integer)
142− | v > big = goBig (k + 19) (v `quot` big)
143− | otherwise = go k (fromIntegral v)
144− big = 10000000000000000000
145− go !k (v :: Word64)
146− | v < 10 = k
147− | v < 100 = k + 1
148− | v < 1000 = k + 2
149− | v < 1000000000000 =
150− k + if v < 100000000
151− then if v < 1000000
152− then if v < 10000
153− then 3
154− else 4 + fin v 100000
155− else 6 + fin v 10000000
156− else if v < 10000000000
157− then 8 + fin v 1000000000
158− else 10 + fin v 100000000000
159− | otherwise = go (k + 12) (v `quot` 1000000000000)
160− fin v n = if v >= n then 1 else 0
161−
162−hexadecimal :: Integral a => a -> Builder
163−{-# SPECIALIZE hexadecimal :: Int -> Builder #-}
164−{-# SPECIALIZE hexadecimal :: Int8 -> Builder #-}
165−{-# SPECIALIZE hexadecimal :: Int16 -> Builder #-}
166−{-# SPECIALIZE hexadecimal :: Int32 -> Builder #-}
167−{-# SPECIALIZE hexadecimal :: Int64 -> Builder #-}
168−{-# SPECIALIZE hexadecimal :: Word -> Builder #-}
169−{-# SPECIALIZE hexadecimal :: Word8 -> Builder #-}
170−{-# SPECIALIZE hexadecimal :: Word16 -> Builder #-}
171−{-# SPECIALIZE hexadecimal :: Word32 -> Builder #-}
172−{-# SPECIALIZE hexadecimal :: Word64 -> Builder #-}
173−{-# RULES "hexadecimal/Integer"
174− hexadecimal = hexInteger :: Integer -> Builder #-}
175−hexadecimal i
176− | i < 0 = error hexErrMsg
177− | otherwise = go i
178− where
179− go n | n < 16 = hexDigit n
180− | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16)
181−{-# NOINLINE[0] hexadecimal #-}
182−
183−hexInteger :: Integer -> Builder
184−hexInteger i
185− | i < 0 = error hexErrMsg
186− | otherwise = integer 16 i
187−
188−hexErrMsg :: String
189−hexErrMsg = "Data.Text.Lazy.Builder.Int.hexadecimal: applied to negative number"
190−
191−hexDigit :: Integral a => a -> Builder
192−hexDigit n
193− | n <= 9 = singleton $! i2d (fromIntegral n)
194− | otherwise = singleton $! toEnum (fromIntegral n + 87)
195−{-# INLINE hexDigit #-}
196−
197−data T = T !Integer !Int
198−
199−integer :: Int -> Integer -> Builder
200−#ifdef INTEGER_GMP
201−integer 10 (S# i#) = decimal (I# i#)
202−integer 16 (S# i#) = hexadecimal (I# i#)
203−#endif
204−integer base i
205− | i < 0 = singleton '-' <> go (-i)
206− | otherwise = go i
207− where
208− go n | n < maxInt = int (fromInteger n)
209− | otherwise = putH (splitf (maxInt * maxInt) n)
210−
211− splitf p n
212− | p > n = [n]
213− | otherwise = splith p (splitf (p*p) n)
214−
215− splith p (n:ns) = case n `quotRemInteger` p of
216− PAIR(q,r) | q > 0 -> q : r : splitb p ns
217− | otherwise -> r : splitb p ns
218− splith _ _ = error "splith: the impossible happened."
219−
220− splitb p (n:ns) = case n `quotRemInteger` p of
221− PAIR(q,r) -> q : r : splitb p ns
222− splitb _ _ = []
223−
224− T maxInt10 maxDigits10 =
225− until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)
226− where mi = fromIntegral (maxBound :: Int)
227− T maxInt16 maxDigits16 =
228− until ((>mi) . (*16) . fstT) (\(T n d) -> T (n*16) (d+1)) (T 16 1)
229− where mi = fromIntegral (maxBound :: Int)
230−
231− fstT (T a _) = a
232−
233− maxInt | base == 10 = maxInt10
234− | otherwise = maxInt16
235− maxDigits | base == 10 = maxDigits10
236− | otherwise = maxDigits16
237−
238− putH (n:ns) = case n `quotRemInteger` maxInt of
239− PAIR(x,y)
240− | q > 0 -> int q <> pblock r <> putB ns
241− | otherwise -> int r <> putB ns
242− where q = fromInteger x
243− r = fromInteger y
244− putH _ = error "putH: the impossible happened"
245−
246− putB (n:ns) = case n `quotRemInteger` maxInt of
247− PAIR(x,y) -> pblock q <> pblock r <> putB ns
248− where q = fromInteger x
249− r = fromInteger y
250− putB _ = Data.Monoid.mempty
251−
252− int :: Int -> Builder
253− int x | base == 10 = decimal x
254− | otherwise = hexadecimal x
255−
256− pblock = loop maxDigits
257− where
258− loop !d !n
259− | d == 1 = hexDigit n
260− | otherwise = loop (d-1) q <> hexDigit r
261− where q = n `quotInt` base
262− r = n `remInt` base
Data/Text/Lazy/Builder/RealFloat.hs+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
1+module Data.Text.Lazy.Builder.RealFloat (FPFormat(..)) where
14− (
15− FPFormat(..)
16− , realFloat
17− , formatRealFloat
18− ) where
19−
20−import Data.Array.Base (unsafeAt)
21−import Data.Array.IArray
22−import Data.Text.Internal.Builder.Functions ((<>), i2d)
23−import Data.Text.Lazy.Builder.Int (decimal)
24−import Data.Text.Internal.Builder.RealFloat.Functions (roundTo)
25−import Data.Text.Lazy.Builder
26−import qualified Data.Text as T
27
2
28-- | Control the rendering of floating point numbers.
3-- | Control the rendering of floating point numbers.
29data FPFormat = Exponent
4data FPFormat = Exponent
@@ -33,210 +8,4 @@ data FPFormat = Exponent
33 | Generic
8 | Generic
34 -- ^ Use decimal notation for values between @0.1@ and
9 -- ^ Use decimal notation for values between @0.1@ and
35 -- @9,999,999@, and scientific notation otherwise.
10 -- @9,999,999@, and scientific notation otherwise.
36− deriving (Enum, Read, Show)
11+ deriving (Enum, Read, Show)
37−
38−-- | Show a signed 'RealFloat' value to full precision,
39−-- using standard decimal notation for arguments whose absolute value lies
40−-- between @0.1@ and @9,999,999@, and scientific notation otherwise.
41−realFloat :: (RealFloat a) => a -> Builder
42−{-# SPECIALIZE realFloat :: Float -> Builder #-}
43−{-# SPECIALIZE realFloat :: Double -> Builder #-}
44−realFloat x = formatRealFloat Generic Nothing x
45−
46−formatRealFloat :: (RealFloat a) =>
47− FPFormat
48− -> Maybe Int -- ^ Number of decimal places to render.
49− -> a
50− -> Builder
51−{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Float -> Builder #-}
52−{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Double -> Builder #-}
53−formatRealFloat fmt decs x
54− | isNaN x = "NaN"
55− | isInfinite x = if x < 0 then "-Infinity" else "Infinity"
56− | x < 0 || isNegativeZero x = singleton '-' <> doFmt fmt (floatToDigits (-x))
57− | otherwise = doFmt fmt (floatToDigits x)
58− where
59− doFmt format (is, e) =
60− let ds = map i2d is in
61− case format of
62− Generic ->
63− doFmt (if e < 0 || e > 7 then Exponent else Fixed)
64− (is,e)
65− Exponent ->
66− case decs of
67− Nothing ->
68− let show_e' = decimal (e-1) in
69− case ds of
70− "0" -> "0.0e0"
71− [d] -> singleton d <> ".0e" <> show_e'
72− (d:ds') -> singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> show_e'
73− [] -> error "formatRealFloat/doFmt/Exponent: []"
74− Just dec ->
75− let dec' = max dec 1 in
76− case is of
77− [0] -> "0." <> fromText (T.replicate dec' "0") <> "e0"
78− _ ->
79− let
80− (ei,is') = roundTo (dec'+1) is
81− (d:ds') = map i2d (if ei > 0 then init is' else is')
82− in
83− singleton d <> singleton '.' <> fromString ds' <> singleton 'e' <> decimal (e-1+ei)
84− Fixed ->
85− let
86− mk0 ls = case ls of { "" -> "0" ; _ -> fromString ls}
87− in
88− case decs of
89− Nothing
90− | e <= 0 -> "0." <> fromText (T.replicate (-e) "0") <> fromString ds
91− | otherwise ->
92− let
93− f 0 s rs = mk0 (reverse s) <> singleton '.' <> mk0 rs
94− f n s "" = f (n-1) ('0':s) ""
95− f n s (r:rs) = f (n-1) (r:s) rs
96− in
97− f e "" ds
98− Just dec ->
99− let dec' = max dec 0 in
100− if e >= 0 then
101− let
102− (ei,is') = roundTo (dec' + e) is
103− (ls,rs) = splitAt (e+ei) (map i2d is')
104− in
105− mk0 ls <> (if null rs then "" else singleton '.' <> fromString rs)
106− else
107− let
108− (ei,is') = roundTo dec' (replicate (-e) 0 ++ is)
109− d:ds' = map i2d (if ei > 0 then is' else 0:is')
110− in
111− singleton d <> (if null ds' then "" else singleton '.' <> fromString ds')
112−
113−
114−-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
115−-- by R.G. Burger and R.K. Dybvig in PLDI 96.
116−-- This version uses a much slower logarithm estimator. It should be improved.
117−
118−-- | 'floatToDigits' takes a base and a non-negative 'RealFloat' number,
119−-- and returns a list of digits and an exponent.
120−-- In particular, if @x>=0@, and
121−--
122−-- > floatToDigits base x = ([d1,d2,...,dn], e)
123−--
124−-- then
125−--
126−-- (1) @n >= 1@
127−--
128−-- (2) @x = 0.d1d2...dn * (base**e)@
129−--
130−-- (3) @0 <= di <= base-1@
131−
132−floatToDigits :: (RealFloat a) => a -> ([Int], Int)
133−{-# SPECIALIZE floatToDigits :: Float -> ([Int], Int) #-}
134−{-# SPECIALIZE floatToDigits :: Double -> ([Int], Int) #-}
135−floatToDigits 0 = ([0], 0)
136−floatToDigits x =
137− let
138− (f0, e0) = decodeFloat x
139− (minExp0, _) = floatRange x
140− p = floatDigits x
141− b = floatRadix x
142− minExp = minExp0 - p -- the real minimum exponent
143− -- Haskell requires that f be adjusted so denormalized numbers
144− -- will have an impossibly low exponent. Adjust for this.
145− (f, e) =
146− let n = minExp - e0 in
147− if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0)
148− (r, s, mUp, mDn) =
149− if e >= 0 then
150− let be = expt b e in
151− if f == expt b (p-1) then
152− (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig
153− else
154− (f*be*2, 2, be, be)
155− else
156− if e > minExp && f == expt b (p-1) then
157− (f*b*2, expt b (-e+1)*2, b, 1)
158− else
159− (f*2, expt b (-e)*2, 1, 1)
160− k :: Int
161− k =
162− let
163− k0 :: Int
164− k0 =
165− if b == 2 then
166− -- logBase 10 2 is very slightly larger than 8651/28738
167− -- (about 5.3558e-10), so if log x >= 0, the approximation
168− -- k1 is too small, hence we add one and need one fixup step less.
169− -- If log x < 0, the approximation errs rather on the high side.
170− -- That is usually more than compensated for by ignoring the
171− -- fractional part of logBase 2 x, but when x is a power of 1/2
172− -- or slightly larger and the exponent is a multiple of the
173− -- denominator of the rational approximation to logBase 10 2,
174− -- k1 is larger than logBase 10 x. If k1 > 1 + logBase 10 x,
175− -- we get a leading zero-digit we don't want.
176− -- With the approximation 3/10, this happened for
177− -- 0.5^1030, 0.5^1040, ..., 0.5^1070 and values close above.
178− -- The approximation 8651/28738 guarantees k1 < 1 + logBase 10 x
179− -- for IEEE-ish floating point types with exponent fields
180− -- <= 17 bits and mantissae of several thousand bits, earlier
181− -- convergents to logBase 10 2 would fail for long double.
182− -- Using quot instead of div is a little faster and requires
183− -- fewer fixup steps for negative lx.
184− let lx = p - 1 + e0
185− k1 = (lx * 8651) `quot` 28738
186− in if lx >= 0 then k1 + 1 else k1
187− else
188− -- f :: Integer, log :: Float -> Float,
189− -- ceiling :: Float -> Int
190− ceiling ((log (fromInteger (f+1) :: Float) +
191− fromIntegral e * log (fromInteger b)) /
192− log 10)
193−--WAS: fromInt e * log (fromInteger b))
194−
195− fixup n =
196− if n >= 0 then
197− if r + mUp <= expt 10 n * s then n else fixup (n+1)
198− else
199− if expt 10 (-n) * (r + mUp) <= s then n else fixup (n+1)
200− in
201− fixup k0
202−
203− gen ds rn sN mUpN mDnN =
204− let
205− (dn, rn') = (rn * 10) `quotRem` sN
206− mUpN' = mUpN * 10
207− mDnN' = mDnN * 10
208− in
209− case (rn' < mDnN', rn' + mUpN' > sN) of
210− (True, False) -> dn : ds
211− (False, True) -> dn+1 : ds
212− (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
213− (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
214−
215− rds =
216− if k >= 0 then
217− gen [] r (s * expt 10 k) mUp mDn
218− else
219− let bk = expt 10 (-k) in
220− gen [] (r * bk) s (mUp * bk) (mDn * bk)
221− in
222− (map fromIntegral (reverse rds), k)
223−
224−-- Exponentiation with a cache for the most common numbers.
225−minExpt, maxExpt :: Int
226−minExpt = 0
227−maxExpt = 1100
228−
229−expt :: Integer -> Int -> Integer
230−expt base n
231− | base == 2 && n >= minExpt && n <= maxExpt = expts `unsafeAt` n
232− | base == 10 && n <= maxExpt10 = expts10 `unsafeAt` n
233− | otherwise = base^n
234−
235−expts :: Array Int Integer
236−expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
237−
238−maxExpt10 :: Int
239−maxExpt10 = 324
240−
241−expts10 :: Array Int Integer
242−expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]]
Data/Text/Unsafe.hs+87
@@ -1,4 +1,7 @@
1{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
1{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
2+#ifdef __GHCJS__
3+{-# LANGUAGE JavaScriptFFI, ForeignFunctionInterface, UnliftedFFITypes #-}
4+#endif
2-- |
5-- |
3-- Module : Data.Text.Unsafe
6-- Module : Data.Text.Unsafe
4-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
7-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
@@ -32,31 +35,47 @@ import Control.Exception (assert)
32import Data.Text.Internal.Encoding.Utf16 (chr2)
35import Data.Text.Internal.Encoding.Utf16 (chr2)
33import Data.Text.Internal (Text(..))
36import Data.Text.Internal (Text(..))
34import Data.Text.Internal.Unsafe (inlineInterleaveST, inlinePerformIO)
37import 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
35import Data.Text.Internal.Unsafe.Char (unsafeChr)
45import Data.Text.Internal.Unsafe.Char (unsafeChr)
36import qualified Data.Text.Array as A
46import qualified Data.Text.Array as A
47+#endif
37import GHC.IO (unsafeDupablePerformIO)
48import GHC.IO (unsafeDupablePerformIO)
38
49
39-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
50-- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
40-- omits the check for the empty case, so there is an obligation on
51-- omits the check for the empty case, so there is an obligation on
41-- the programmer to provide a proof that the 'Text' is non-empty.
52-- the programmer to provide a proof that the 'Text' is non-empty.
42unsafeHead :: Text -> Char
53unsafeHead :: Text -> Char
54+#ifndef __GHCJS__
43unsafeHead (Text arr off _len)
55unsafeHead (Text arr off _len)
44 | m < 0xD800 || m > 0xDBFF = unsafeChr m
56 | m < 0xD800 || m > 0xDBFF = unsafeChr m
45 | otherwise = chr2 m n
57 | otherwise = chr2 m n
46 where m = A.unsafeIndex arr off
58 where m = A.unsafeIndex arr off
47 n = A.unsafeIndex arr (off+1)
59 n = A.unsafeIndex arr (off+1)
60+#else
61+unsafeHead = coerce JSS.rawHead
62+#endif
48{-# INLINE unsafeHead #-}
63{-# INLINE unsafeHead #-}
49
64
50-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeTail'
65-- | /O(1)/ A variant of 'tail' for non-empty 'Text'. 'unsafeTail'
51-- omits the check for the empty case, so there is an obligation on
66-- omits the check for the empty case, so there is an obligation on
52-- the programmer to provide a proof that the 'Text' is non-empty.
67-- the programmer to provide a proof that the 'Text' is non-empty.
53unsafeTail :: Text -> Text
68unsafeTail :: Text -> Text
69+#ifndef __GHCJS__
54unsafeTail t@(Text arr off len) =
70unsafeTail t@(Text arr off len) =
55#if defined(ASSERTS)
71#if defined(ASSERTS)
56 assert (d <= len) $
72 assert (d <= len) $
57#endif
73#endif
58 Text arr (off+d) (len-d)
74 Text arr (off+d) (len-d)
59 where d = iter_ t 0
75 where d = iter_ t 0
76+#else
77+unsafeTail = coerce JSS.rawTail
78+#endif
60{-# INLINE unsafeTail #-}
79{-# INLINE unsafeTail #-}
61
80
62data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
81data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
@@ -65,6 +84,7 @@ data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
65-- array, returning the current character and the delta to add to give
84-- array, returning the current character and the delta to add to give
66-- the next offset to iterate at.
85-- the next offset to iterate at.
67iter :: Text -> Int -> Iter
86iter :: Text -> Int -> Iter
87+#ifndef __GHCJS__
68iter (Text arr off _len) i
88iter (Text arr off _len) i
69 | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1
89 | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1
70 | otherwise = Iter (chr2 m n) 2
90 | otherwise = Iter (chr2 m n) 2
@@ -72,20 +92,40 @@ iter (Text arr off _len) i
72 n = A.unsafeIndex arr k
92 n = A.unsafeIndex arr k
73 j = off + i
93 j = off + i
74 k = j + 1
94 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
75{-# INLINE iter #-}
107{-# INLINE iter #-}
76
108
77-- | /O(1)/ Iterate one step through a UTF-16 array, returning the
109-- | /O(1)/ Iterate one step through a UTF-16 array, returning the
78-- delta to add to give the next offset to iterate at.
110-- delta to add to give the next offset to iterate at.
79iter_ :: Text -> Int -> Int
111iter_ :: Text -> Int -> Int
112+#ifndef __GHCJS__
80iter_ (Text arr off _len) i | m < 0xD800 || m > 0xDBFF = 1
113iter_ (Text arr off _len) i | m < 0xD800 || m > 0xDBFF = 1
81 | otherwise = 2
114 | otherwise = 2
82 where m = A.unsafeIndex arr (off+i)
115 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
83{-# INLINE iter_ #-}
122{-# INLINE iter_ #-}
84
123
85-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
124-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
86-- returning the current character and the delta to add (i.e. a
125-- returning the current character and the delta to add (i.e. a
87-- negative number) to give the next offset to iterate at.
126-- negative number) to give the next offset to iterate at.
88reverseIter :: Text -> Int -> (Char,Int)
127reverseIter :: Text -> Int -> (Char,Int)
128+#ifndef __GHCJS__
89reverseIter (Text arr off _len) i
129reverseIter (Text arr off _len) i
90 | m < 0xDC00 || m > 0xDFFF = (unsafeChr m, -1)
130 | m < 0xDC00 || m > 0xDFFF = (unsafeChr m, -1)
91 | otherwise = (chr2 n m, -2)
131 | otherwise = (chr2 n m, -2)
@@ -93,31 +133,78 @@ reverseIter (Text arr off _len) i
93 n = A.unsafeIndex arr k
133 n = A.unsafeIndex arr k
94 j = off + i
134 j = off + i
95 k = j - 1
135 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
96{-# INLINE reverseIter #-}
148{-# INLINE reverseIter #-}
97
149
98-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
150-- | /O(1)/ Iterate one step backwards through a UTF-16 array,
99-- returning the delta to add (i.e. a negative number) to give the
151-- returning the delta to add (i.e. a negative number) to give the
100-- next offset to iterate at.
152-- next offset to iterate at.
101reverseIter_ :: Text -> Int -> Int
153reverseIter_ :: Text -> Int -> Int
154+#ifndef __GHCJS__
102reverseIter_ (Text arr off _len) i
155reverseIter_ (Text arr off _len) i
103 | m < 0xDC00 || m > 0xDFFF = -1
156 | m < 0xDC00 || m > 0xDFFF = -1
104 | otherwise = -2
157 | otherwise = -2
105 where m = A.unsafeIndex arr (off+i)
158 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
106{-# INLINE reverseIter_ #-}
167{-# INLINE reverseIter_ #-}
107
168
108-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This
169-- | /O(1)/ Return the length of a 'Text' in units of 'Word16'. This
109-- is useful for sizing a target array appropriately before using
170-- is useful for sizing a target array appropriately before using
110-- 'unsafeCopyToPtr'.
171-- 'unsafeCopyToPtr'.
111lengthWord16 :: Text -> Int
172lengthWord16 :: Text -> Int
173+#ifndef __GHCJS__
112lengthWord16 (Text _arr _off len) = len
174lengthWord16 (Text _arr _off len) = len
175+#else
176+lengthWord16 (Text t) = js_length t
177+#endif
113{-# INLINE lengthWord16 #-}
178{-# INLINE lengthWord16 #-}
114
179
115-- | /O(1)/ Unchecked take of 'k' 'Word16's from the front of a 'Text'.
180-- | /O(1)/ Unchecked take of 'k' 'Word16's from the front of a 'Text'.
116takeWord16 :: Int -> Text -> Text
181takeWord16 :: Int -> Text -> Text
182+#ifndef __GHCJS__
117takeWord16 k (Text arr off _len) = Text arr off k
183takeWord16 k (Text arr off _len) = Text arr off k
184+#else
185+takeWord16 k (Text txt) = Text $ js_take k txt
186+#endif
118{-# INLINE takeWord16 #-}
187{-# INLINE takeWord16 #-}
119
188
120-- | /O(1)/ Unchecked drop of 'k' 'Word16's from the front of a 'Text'.
189-- | /O(1)/ Unchecked drop of 'k' 'Word16's from the front of a 'Text'.
121dropWord16 :: Int -> Text -> Text
190dropWord16 :: Int -> Text -> Text
191+#ifndef __GHCJS__
122dropWord16 k (Text arr off len) = Text arr (off+k) (len-k)
192dropWord16 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
123{-# INLINE dropWord16 #-}
196{-# 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+64−59
@@ -88,13 +88,13 @@ library
88 Data.Text.Array
88 Data.Text.Array
89 Data.Text.Encoding
89 Data.Text.Encoding
90 Data.Text.Encoding.Error
90 Data.Text.Encoding.Error
91− Data.Text.Foreign
91+ -- Data.Text.Foreign
92 Data.Text.IO
92 Data.Text.IO
93 Data.Text.Internal
93 Data.Text.Internal
94 Data.Text.Internal.Builder
94 Data.Text.Internal.Builder
95− Data.Text.Internal.Builder.Functions
95+ -- Data.Text.Internal.Builder.Functions
96− Data.Text.Internal.Builder.Int.Digits
96+ -- Data.Text.Internal.Builder.Int.Digits
97− Data.Text.Internal.Builder.RealFloat.Functions
97+ -- Data.Text.Internal.Builder.RealFloat.Functions
98 Data.Text.Internal.Encoding.Fusion
98 Data.Text.Internal.Encoding.Fusion
99 Data.Text.Internal.Encoding.Fusion.Common
99 Data.Text.Internal.Encoding.Fusion.Common
100 Data.Text.Internal.Encoding.Utf16
100 Data.Text.Internal.Encoding.Utf16
@@ -106,14 +106,14 @@ library
106 Data.Text.Internal.Fusion.Common
106 Data.Text.Internal.Fusion.Common
107 Data.Text.Internal.Fusion.Size
107 Data.Text.Internal.Fusion.Size
108 Data.Text.Internal.Fusion.Types
108 Data.Text.Internal.Fusion.Types
109− Data.Text.Internal.IO
109+ -- Data.Text.Internal.IO
110 Data.Text.Internal.Lazy
110 Data.Text.Internal.Lazy
111− Data.Text.Internal.Lazy.Encoding.Fusion
111+ -- Data.Text.Internal.Lazy.Encoding.Fusion
112 Data.Text.Internal.Lazy.Fusion
112 Data.Text.Internal.Lazy.Fusion
113 Data.Text.Internal.Lazy.Search
113 Data.Text.Internal.Lazy.Search
114 Data.Text.Internal.Private
114 Data.Text.Internal.Private
115 Data.Text.Internal.Read
115 Data.Text.Internal.Read
116− Data.Text.Internal.Search
116+ -- Data.Text.Internal.Search
117 Data.Text.Internal.Unsafe
117 Data.Text.Internal.Unsafe
118 Data.Text.Internal.Unsafe.Char
118 Data.Text.Internal.Unsafe.Char
119 Data.Text.Internal.Unsafe.Shift
119 Data.Text.Internal.Unsafe.Shift
@@ -124,18 +124,23 @@ library
124 Data.Text.Lazy.Encoding
124 Data.Text.Lazy.Encoding
125 Data.Text.Lazy.IO
125 Data.Text.Lazy.IO
126 Data.Text.Lazy.Internal
126 Data.Text.Lazy.Internal
127− Data.Text.Lazy.Read
127+ -- Data.Text.Lazy.Read
128 Data.Text.Read
128 Data.Text.Read
129 Data.Text.Unsafe
129 Data.Text.Unsafe
130
130
131+ -- moved from ghcjs-base
132+ -- reflex-dom depends in it
133+ Data.JSString.Text
131− other-modules:
134+ -- other-modules:
132− Data.Text.Show
135+ -- Data.Text.Show
133
136
134 build-depends:
137 build-depends:
135− array >= 0.3,
138+ -- array >= 0.3,
136 base >= 4.2 && < 5,
139 base >= 4.2 && < 5,
137 binary,
140 binary,
138 deepseq >= 1.1.0.0,
141 deepseq >= 1.1.0.0,
142+ ghcjs-base,
143+ ghcjs-prim,
139 ghc-prim >= 0.2
144 ghc-prim >= 0.2
140
145
141 if flag(bytestring-builder)
146 if flag(bytestring-builder)
@@ -158,51 +163,51 @@ library
158 cpp-options: -DINTEGER_GMP
163 cpp-options: -DINTEGER_GMP
159 build-depends: integer-gmp >= 0.2
164 build-depends: integer-gmp >= 0.2
160
165
161−test-suite tests
166+-- test-suite tests
162− type: exitcode-stdio-1.0
167+-- type: exitcode-stdio-1.0
163− hs-source-dirs: tests .
168+-- hs-source-dirs: tests .
164− main-is: Tests.hs
169+-- main-is: Tests.hs
165− c-sources: cbits/cbits.c
170+-- c-sources: cbits/cbits.c
166− include-dirs: include
171+-- include-dirs: include
167−
172+
168− ghc-options:
173+-- ghc-options:
169− -Wall -threaded -O0 -rtsopts
174+-- -Wall -threaded -O0 -rtsopts
170−
175+
171− cpp-options:
176+-- cpp-options:
172− -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE
177+-- -DASSERTS -DHAVE_DEEPSEQ -DTEST_SUITE
173−
178+
174− build-depends:
179+-- build-depends:
175− HUnit >= 1.2,
180+-- HUnit >= 1.2,
176− QuickCheck >= 2.7,
181+-- QuickCheck >= 2.7,
177− array,
182+-- array,
178− base,
183+-- base,
179− binary,
184+-- binary,
180− deepseq,
185+-- deepseq,
181− directory,
186+-- directory,
182− ghc-prim,
187+-- ghc-prim,
183− quickcheck-unicode,
188+-- quickcheck-unicode,
184− random,
189+-- random,
185− test-framework >= 0.4,
190+-- test-framework >= 0.4,
186− test-framework-hunit >= 0.2,
191+-- test-framework-hunit >= 0.2,
187− test-framework-quickcheck2 >= 0.2
192+-- test-framework-quickcheck2 >= 0.2
188−
193+
189− if flag(bytestring-builder)
194+-- if flag(bytestring-builder)
190− build-depends: bytestring >= 0.9 && < 0.10.4,
195+-- build-depends: bytestring >= 0.9 && < 0.10.4,
191− bytestring-builder >= 0.10.4
196+-- bytestring-builder >= 0.10.4
192− else
197+-- else
193− build-depends: bytestring >= 0.10.4
198+-- build-depends: bytestring >= 0.10.4
194−
199+
195− if flag(integer-simple)
200+-- if flag(integer-simple)
196− cpp-options: -DINTEGER_SIMPLE
201+-- cpp-options: -DINTEGER_SIMPLE
197− build-depends: integer-simple >= 0.1 && < 0.5
202+-- build-depends: integer-simple >= 0.1 && < 0.5
198− else
203+-- else
199− cpp-options: -DINTEGER_GMP
204+-- cpp-options: -DINTEGER_GMP
200− build-depends: integer-gmp >= 0.2
205+-- build-depends: integer-gmp >= 0.2
201−
206+
202−source-repository head
207+-- source-repository head
203− type: git
208+-- type: git
204− location: https://github.com/bos/text
209+-- location: https://github.com/bos/text
205−
210+
206−source-repository head
211+-- source-repository head
207− type: mercurial
212+-- type: mercurial
208− location: https://bitbucket.org/bos/text
213+-- location: https://bitbucket.org/bos/text