module Data.Text.Fusion
(
Stream(..)
, Step(..)
, stream
, unstream
, reverseStream
, empty
, cons
, snoc
, append
, uncons
, head
, tail
, last
, init
, null
, length
, eq
, map
, intercalate
, intersperse
, reverse
, foldl
, foldl'
, foldl1
, foldl1'
, foldr
, foldr1
, concat
, concatMap
, any
, all
, maximum
, minimum
, scanl
, reverseScanr
, mapAccumL
, replicate
, unfoldr
, unfoldrN
, take
, drop
, takeWhile
, dropWhile
, isPrefixOf
, elem
, filter
, find
, index
, findIndex
, findIndices
, findIndexOrEnd
, elemIndex
, elemIndices
, count
, zipWith
) where
import Prelude (Bool(..), Char, Either(..), Eq(..), Maybe(..), Monad(..),
Num(..), Ord(..), String, ($), (++), (.), (&&),
fromIntegral, otherwise)
import Control.Monad (liftM2)
import Control.Monad.ST (runST)
import qualified Data.List as L
import GHC.Exts (Int(..), (+#))
import Data.Bits ((.&.), shiftR)
import Data.Char (ord)
import Data.Text.Internal (Text(..))
import Data.Text.UnsafeChar (unsafeChr, unsafeWrite, unsafeWriteRev)
import qualified Data.Text.Array as A
import qualified Data.Text.Internal as I
import qualified Data.Text.Encoding.Utf16 as U16
import qualified Prelude as P
default(Int)
infixl 2 :!:
data PairS a b = !a :!: !b
data Switch = S1 | S2
data Stream a =
forall s. Stream
(s -> Step s a)
!s
!Int
data Step s a = Done
| Skip !s
| Yield !a !s
stream :: Text -> Stream Char
stream (Text arr off len) = Stream next off len
where
end = off+len
next !i
| i >= end = Done
| n >= 0xD800 && n <= 0xDBFF = Yield (U16.chr2 n n2) (i + 2)
| otherwise = Yield (unsafeChr n) (i + 1)
where
n = A.unsafeIndex arr i
n2 = A.unsafeIndex arr (i + 1)
reverseStream :: Text -> Stream Char
reverseStream (Text arr off len) = Stream next (off+len1) len
where
next !i
| i < off = Done
| n >= 0xDC00 && n <= 0xDFFF = Yield (U16.chr2 n2 n) (i 2)
| otherwise = Yield (unsafeChr n) (i 1)
where
n = A.unsafeIndex arr i
n2 = A.unsafeIndex arr (i 1)
unstream :: Stream Char -> Text
unstream (Stream next0 s0 len)
| len == 0 = I.empty
| otherwise = Text (P.fst a) 0 (P.snd a)
where
a = runST (A.unsafeNew len >>= (\arr -> loop arr len s0 0))
loop arr !top !s !i
| i + 1 >= top = case next0 s of
Done -> liftM2 (,) (A.unsafeFreeze arr) (return i)
_ -> do
arr' <- A.unsafeNew (top*2)
A.copy arr arr' >> loop arr' (top*2) s i
| otherwise = case next0 s of
Done -> liftM2 (,) (A.unsafeFreeze arr) (return i)
Skip s' -> loop arr top s' i
Yield x s' -> unsafeWrite arr i x >>= loop arr top s'
empty :: Stream Char
empty = Stream next () 0
where next _ = Done
eq :: Ord a => Stream a -> Stream a -> Bool
eq (Stream next1 s1 _) (Stream next2 s2 _) = cmp (next1 s1) (next2 s2)
where
cmp Done Done = True
cmp Done _ = False
cmp _ Done = False
cmp (Skip s1') (Skip s2') = cmp (next1 s1') (next2 s2')
cmp (Skip s1') x2 = cmp (next1 s1') x2
cmp x1 (Skip s2') = cmp x1 (next2 s2')
cmp (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
cmp (next1 s1') (next2 s2')
streamError :: String -> String -> a
streamError func msg = P.error $ "Data.Text.Fusion." ++ func ++ ": " ++ msg
internalError :: String -> a
internalError func = streamError func "Internal error"
emptyError :: String -> a
emptyError func = internalError func "Empty input"
cons :: Char -> Stream Char -> Stream Char
cons w (Stream next0 s0 len) = Stream next (S2 :!: s0) (len+2)
where
next (S2 :!: s) = Yield w (S1 :!: s)
next (S1 :!: s) = case next0 s of
Done -> Done
Skip s' -> Skip (S1 :!: s')
Yield x s' -> Yield x (S1 :!: s')
snoc :: Stream Char -> Char -> Stream Char
snoc (Stream next0 xs0 len) w = Stream next (Just xs0) (len+2)
where
next (Just xs) = case next0 xs of
Done -> Yield w Nothing
Skip xs' -> Skip (Just xs')
Yield x xs' -> Yield x (Just xs')
next Nothing = Done
append :: Stream Char -> Stream Char -> Stream Char
append (Stream next0 s01 len1) (Stream next1 s02 len2) =
Stream next (Left s01) (len1 + len2)
where
next (Left s1) = case next0 s1 of
Done -> Skip (Right s02)
Skip s1' -> Skip (Left s1')
Yield x s1' -> Yield x (Left s1')
next (Right s2) = case next1 s2 of
Done -> Done
Skip s2' -> Skip (Right s2')
Yield x s2' -> Yield x (Right s2')
head :: Stream Char -> Char
head (Stream next s0 _len) = loop_head s0
where
loop_head !s = case next s of
Yield x _ -> x
Skip s' -> loop_head s'
Done -> streamError "head" "Empty stream"
uncons :: Stream Char -> Maybe (Char, Stream Char)
uncons (Stream next s0 len) = loop_uncons s0
where
loop_uncons !s = case next s of
Yield x s1 -> Just (x, Stream next s1 (len1))
Skip s' -> loop_uncons s'
Done -> Nothing
last :: Stream Char -> Char
last (Stream next s0 _len) = loop0_last s0
where
loop0_last !s = case next s of
Done -> emptyError "last"
Skip s' -> loop0_last s'
Yield x s' -> loop_last x s'
loop_last !x !s = case next s of
Done -> x
Skip s' -> loop_last x s'
Yield x' s' -> loop_last x' s'
tail :: Stream Char -> Stream Char
tail (Stream next0 s0 len) = Stream next (False :!: s0) (len1)
where
next (False :!: s) = case next0 s of
Done -> emptyError "tail"
Skip s' -> Skip (False :!: s')
Yield _ s' -> Skip (True :!: s')
next (True :!: s) = case next0 s of
Done -> Done
Skip s' -> Skip (True :!: s')
Yield x s' -> Yield x (True :!: s')
init :: Stream Char -> Stream Char
init (Stream next0 s0 len) = Stream next (Nothing :!: s0) (len1)
where
next (Nothing :!: s) = case next0 s of
Done -> emptyError "init"
Skip s' -> Skip (Nothing :!: s')
Yield x s' -> Skip (Just x :!: s')
next (Just x :!: s) = case next0 s of
Done -> Done
Skip s' -> Skip (Just x :!: s')
Yield x' s' -> Yield x (Just x' :!: s')
null :: Stream Char -> Bool
null (Stream next s0 _len) = loop_null s0
where
loop_null !s = case next s of
Done -> True
Yield _ _ -> False
Skip s' -> loop_null s'
length :: Stream Char -> Int
length (Stream next s0 _len) = loop_length 0# s0
where
loop_length z# s = case next s of
Done -> (I# z#)
Skip s' -> loop_length z# s'
Yield _ s' -> loop_length (z# +# 1#) s'
map :: (Char -> Char) -> Stream Char -> Stream Char
map f (Stream next0 s0 len) = Stream next s0 len
where
next !s = case next0 s of
Done -> Done
Skip s' -> Skip s'
Yield x s' -> Yield (f x) s'
intersperse :: Char -> Stream Char -> Stream Char
intersperse c (Stream next0 s0 len) = Stream next (s0 :!: Nothing :!: S1) len
where
next (s :!: Nothing :!: S1) = case next0 s of
Done -> Done
Skip s' -> Skip (s' :!: Nothing :!: S1)
Yield x s' -> Skip (s' :!: Just x :!: S1)
next (s :!: Just x :!: S1) = Yield x (s :!: Nothing :!: S2)
next (s :!: Nothing :!: S2) = case next0 s of
Done -> Done
Skip s' -> Skip (s' :!: Nothing :!: S2)
Yield x s' -> Yield c (s' :!: Just x :!: S1)
next _ = internalError "intersperse"
reverse :: Stream Char -> Text
reverse (Stream next s len0)
| len0 == 0 = I.empty
| otherwise = Text arr off' len'
where
len0' = max len0 4
(arr, (off', len')) = A.run2 (A.unsafeNew len0 >>= loop s (len0'1) len0')
loop !s0 !i !len marr =
case next s0 of
Done -> return (marr, (j, lenj))
where j = i + 1
Skip s1 -> loop s1 i len marr
Yield x s1 | i < least -> do
let newLen = len * 2
marr' <- A.unsafeNew newLen
A.unsafeCopy marr 0 marr' (newLenlen) len
write s1 (len+i) newLen marr'
| otherwise -> write s1 i len marr
where n = ord x
least | n < 0x10000 = 0
| otherwise = 1
m = n 0x10000
lo = fromIntegral $ (m `shiftR` 10) + 0xD800
hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00
write s i len marr
| n < 0x10000 = do
A.unsafeWrite marr i (fromIntegral n)
loop s (i1) len marr
| otherwise = do
A.unsafeWrite marr (i1) lo
A.unsafeWrite marr i hi
loop s (i2) len marr
foldl :: (b -> Char -> b) -> b -> Stream Char -> b
foldl f z0 (Stream next s0 _len) = loop_foldl z0 s0
where
loop_foldl z !s = case next s of
Done -> z
Skip s' -> loop_foldl z s'
Yield x s' -> loop_foldl (f z x) s'
foldl' :: (b -> Char -> b) -> b -> Stream Char -> b
foldl' f z0 (Stream next s0 _len) = loop_foldl' z0 s0
where
loop_foldl' !z !s = case next s of
Done -> z
Skip s' -> loop_foldl' z s'
Yield x s' -> loop_foldl' (f z x) s'
foldl1 :: (Char -> Char -> Char) -> Stream Char -> Char
foldl1 f (Stream next s0 _len) = loop0_foldl1 s0
where
loop0_foldl1 !s = case next s of
Skip s' -> loop0_foldl1 s'
Yield x s' -> loop_foldl1 x s'
Done -> emptyError "foldl1"
loop_foldl1 z !s = case next s of
Done -> z
Skip s' -> loop_foldl1 z s'
Yield x s' -> loop_foldl1 (f z x) s'
foldl1' :: (Char -> Char -> Char) -> Stream Char -> Char
foldl1' f (Stream next s0 _len) = loop0_foldl1' s0
where
loop0_foldl1' !s = case next s of
Skip s' -> loop0_foldl1' s'
Yield x s' -> loop_foldl1' x s'
Done -> emptyError "foldl1"
loop_foldl1' !z !s = case next s of
Done -> z
Skip s' -> loop_foldl1' z s'
Yield x s' -> loop_foldl1' (f z x) s'
foldr :: (Char -> b -> b) -> b -> Stream Char -> b
foldr f z (Stream next s0 _len) = loop_foldr s0
where
loop_foldr !s = case next s of
Done -> z
Skip s' -> loop_foldr s'
Yield x s' -> f x (loop_foldr s')
foldr1 :: (Char -> Char -> Char) -> Stream Char -> Char
foldr1 f (Stream next s0 _len) = loop0_foldr1 s0
where
loop0_foldr1 !s = case next s of
Done -> emptyError "foldr1"
Skip s' -> loop0_foldr1 s'
Yield x s' -> loop_foldr1 x s'
loop_foldr1 x !s = case next s of
Done -> x
Skip s' -> loop_foldr1 x s'
Yield x' s' -> f x (loop_foldr1 x' s')
intercalate :: Stream Char -> [Stream Char] -> Stream Char
intercalate s = concat . (L.intersperse s)
concat :: [Stream Char] -> Stream Char
concat = L.foldr append (Stream next Done 0)
where
next Done = Done
next _ = internalError "concat"
concatMap :: (Char -> Stream Char) -> Stream Char -> Stream Char
concatMap f = foldr (append . f) empty
any :: (Char -> Bool) -> Stream Char -> Bool
any p (Stream next0 s0 _len) = loop_any s0
where
loop_any !s = case next0 s of
Done -> False
Skip s' -> loop_any s'
Yield x s' | p x -> True
| otherwise -> loop_any s'
all :: (Char -> Bool) -> Stream Char -> Bool
all p (Stream next0 s0 _len) = loop_all s0
where
loop_all !s = case next0 s of
Done -> True
Skip s' -> loop_all s'
Yield x s' | p x -> loop_all s'
| otherwise -> False
maximum :: Stream Char -> Char
maximum (Stream next0 s0 _len) = loop0_maximum s0
where
loop0_maximum !s = case next0 s of
Done -> emptyError "maximum"
Skip s' -> loop0_maximum s'
Yield x s' -> loop_maximum x s'
loop_maximum !z !s = case next0 s of
Done -> z
Skip s' -> loop_maximum z s'
Yield x s'
| x > z -> loop_maximum x s'
| otherwise -> loop_maximum z s'
minimum :: Stream Char -> Char
minimum (Stream next0 s0 _len) = loop0_minimum s0
where
loop0_minimum !s = case next0 s of
Done -> emptyError "minimum"
Skip s' -> loop0_minimum s'
Yield x s' -> loop_minimum x s'
loop_minimum !z !s = case next0 s of
Done -> z
Skip s' -> loop_minimum z s'
Yield x s'
| x < z -> loop_minimum x s'
| otherwise -> loop_minimum z s'
scanl :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
scanl f z0 (Stream next0 s0 len) = Stream next (S1 :!: z0 :!: s0) (len+1)
where
next (S1 :!: z :!: s) = Yield z (S2 :!: z :!: s)
next (S2 :!: z :!: s) = case next0 s of
Yield x s' -> let !x' = f z x
in Yield x' (S2 :!: x' :!: s')
Skip s' -> Skip (S2 :!: z :!: s')
Done -> Done
reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
reverseScanr f z0 (Stream next0 s0 len) = Stream next (S1 :!: z0 :!: s0) (len+1)
where
next (S1 :!: z :!: s) = Yield z (S2 :!: z :!: s)
next (S2 :!: z :!: s) = case next0 s of
Yield x s' -> let !x' = f x z
in Yield x' (S2 :!: x' :!: s')
Skip s' -> Skip (S2 :!: z :!: s')
Done -> Done
mapAccumL :: (a -> b -> (a,b)) -> a -> Stream b -> Stream b
mapAccumL f z0 (Stream next0 s0 len) = Stream next (s0 :!: z0) len
where
next (s :!: z) = case next0 s of
Yield x s' -> let (z',y) = f z x
in Yield y (s' :!: z')
Skip s' -> Skip (s' :!: z)
Done -> Done
replicate :: Int -> Char -> Stream Char
replicate n c
| n < 0 = empty
| otherwise = Stream next 0 n
where
next i | i >= n = Done
| otherwise = Yield c (i + 1)
unfoldr :: (a -> Maybe (Char,a)) -> a -> Stream Char
unfoldr f s0 = Stream next s0 1
where
next !s = case f s of
Nothing -> Done
Just (w, s') -> Yield w s'
unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
unfoldrN n f s0 | n < 0 = empty
| otherwise = Stream next (0 :!: s0) (n*2)
where
next (z :!: s) = case f s of
Nothing -> Done
Just (w, s') | z >= n -> Done
| otherwise -> Yield w ((z + 1) :!: s')
take :: Int -> Stream Char -> Stream Char
take n0 (Stream next0 s0 len) = Stream next (n0 :!: s0) len
where
next (n :!: s) | n <= 0 = Done
| otherwise = case next0 s of
Done -> Done
Skip s' -> Skip (n :!: s')
Yield x s' -> Yield x ((n1) :!: s')
drop :: Int -> Stream Char -> Stream Char
drop n0 (Stream next0 s0 len) = Stream next (Just ((max 0 n0)) :!: s0) (len n0)
where
next (Just !n :!: s)
| n == 0 = Skip (Nothing :!: s)
| otherwise = case next0 s of
Done -> Done
Skip s' -> Skip (Just n :!: s')
Yield _ s' -> Skip (Just (n1) :!: s')
next (Nothing :!: s) = case next0 s of
Done -> Done
Skip s' -> Skip (Nothing :!: s')
Yield x s' -> Yield x (Nothing :!: s')
takeWhile :: (Char -> Bool) -> Stream Char -> Stream Char
takeWhile p (Stream next0 s0 len) = Stream next s0 len
where
next !s = case next0 s of
Done -> Done
Skip s' -> Skip s'
Yield x s' | p x -> Yield x s'
| otherwise -> Done
dropWhile :: (Char -> Bool) -> Stream Char -> Stream Char
dropWhile p (Stream next0 s0 len) = Stream next (S1 :!: s0) len
where
next (S1 :!: s) = case next0 s of
Done -> Done
Skip s' -> Skip (S1 :!: s')
Yield x s' | p x -> Skip (S1 :!: s')
| otherwise -> Yield x (S2 :!: s')
next (S2 :!: s) = case next0 s of
Done -> Done
Skip s' -> Skip (S2 :!: s')
Yield x s' -> Yield x (S2 :!: s')
isPrefixOf :: (Eq a) => Stream a -> Stream a -> Bool
isPrefixOf (Stream next1 s1 _) (Stream next2 s2 _) = loop (next1 s1) (next2 s2)
where
loop Done _ = True
loop _ Done = False
loop (Skip s1') (Skip s2') = loop (next1 s1') (next2 s2')
loop (Skip s1') x2 = loop (next1 s1') x2
loop x1 (Skip s2') = loop x1 (next2 s2')
loop (Yield x1 s1') (Yield x2 s2') = x1 == x2 &&
loop (next1 s1') (next2 s2')
elem :: Char -> Stream Char -> Bool
elem w (Stream next s0 _len) = loop_elem s0
where
loop_elem !s = case next s of
Done -> False
Skip s' -> loop_elem s'
Yield x s' | x == w -> True
| otherwise -> loop_elem s'
find :: (Char -> Bool) -> Stream Char -> Maybe Char
find p (Stream next s0 _len) = loop_find s0
where
loop_find !s = case next s of
Done -> Nothing
Skip s' -> loop_find s'
Yield x s' | p x -> Just x
| otherwise -> loop_find s'
filter :: (Char -> Bool) -> Stream Char -> Stream Char
filter p (Stream next0 s0 len) = Stream next s0 len
where
next !s = case next0 s of
Done -> Done
Skip s' -> Skip s'
Yield x s' | p x -> Yield x s'
| otherwise -> Skip s'
index :: Stream Char -> Int -> Char
index (Stream next s0 _len) n0
| n0 < 0 = streamError "index" "Negative index"
| otherwise = loop_index n0 s0
where
loop_index !n !s = case next s of
Done -> streamError "index" "Index too large"
Skip s' -> loop_index n s'
Yield x s' | n == 0 -> x
| otherwise -> loop_index (n1) s'
findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
findIndex p s = case findIndices p s of
(i:_) -> Just i
_ -> Nothing
findIndices :: (Char -> Bool) -> Stream Char -> [Int]
findIndices p (Stream next s0 _len) = loop_findIndex 0 s0
where
loop_findIndex !i !s = case next s of
Done -> []
Skip s' -> loop_findIndex i s'
Yield x s' | p x -> i : loop_findIndex (i+1) s'
| otherwise -> loop_findIndex (i+1) s'
findIndexOrEnd :: (Char -> Bool) -> Stream Char -> Int
findIndexOrEnd p (Stream next s0 _len) = loop_findIndex 0 s0
where
loop_findIndex !i !s = case next s of
Done -> i
Skip s' -> loop_findIndex i s'
Yield x s' | p x -> i
| otherwise -> loop_findIndex (i+1) s'
elemIndex :: Char -> Stream Char -> Maybe Int
elemIndex a s = case elemIndices a s of
(i:_) -> Just i
_ -> Nothing
elemIndices :: Char -> Stream Char -> [Int]
elemIndices a (Stream next s0 _len) = loop 0 s0
where
loop !i !s = case next s of
Done -> []
Skip s' -> loop i s'
Yield x s' | a == x -> i : loop (i+1) s'
| otherwise -> loop (i+1) s'
count :: Char -> Stream Char -> Int
count a (Stream next s0 _len) = loop 0 s0
where
loop !i !s = case next s of
Done -> i
Skip s' -> loop i s'
Yield x s' | a == x -> loop (i+1) s'
| otherwise -> loop i s'
zipWith :: (Char -> Char -> Char) -> Stream Char -> Stream Char -> Stream Char
zipWith f (Stream next0 sa0 len1) (Stream next1 sb0 len2) = Stream next (sa0 :!: sb0 :!: Nothing) (min len1 len2)
where
next (sa :!: sb :!: Nothing) = case next0 sa of
Done -> Done
Skip sa' -> Skip (sa' :!: sb :!: Nothing)
Yield a sa' -> Skip (sa' :!: sb :!: Just a)
next (sa' :!: sb :!: Just a) = case next1 sb of
Done -> Done
Skip sb' -> Skip (sa' :!: sb' :!: Just a)
Yield b sb' -> Yield (f a b) (sa' :!: sb' :!: Nothing)