{-# LANGUAGE BangPatterns, MagicHash, ForeignFunctionInterface, JavaScriptFFI,
UnliftedFFITypes
#-}
module Data.JSString.Internal.Fusion (
Stream(..)
, Step(..)
, stream
, unstream
, reverseStream
, length
, reverse
, reverseScanr
, mapAccumL
, unfoldrN
, index
, findIndex
, countChar
) where
import GHC.Exts (Char(..), Int(..), chr#, Int#, isTrue#, (-#), (+#), (>=#))
import Prelude hiding (length, reverse)
import Data.Char
import Data.JSString.Internal.Type (JSString(..))
import qualified Data.JSString.Internal.Type as I
import Data.JSString.Internal.Fusion.Types
import qualified Data.JSString.Internal.Fusion.Common as S
import System.IO.Unsafe
import GHCJS.Prim
default (Int)
stream :: JSString -> Stream Char
stream x =
let next i = case js_index i x of
-1# -> Done
ch -> let !i' = i + if isTrue# (ch >=# 0x10000#)
then 2
else 1
in Yield (C# (chr# ch)) i'
in Stream next 0
{-# INLINE [0] stream #-}
reverseStream :: JSString -> Stream Char
reverseStream x =
let l = js_length x
{-# INLINE next #-}
next i = case js_indexR i x of
-1# -> Done
ch -> let !i' = i - if isTrue# (ch >=# 0x10000#)
then 2
else 1
in Yield (C# (chr# ch)) i'
in Stream next (I# (l -# 1#))
{-# INLINE [0] reverseStream #-}
unstream :: Stream Char -> JSString
unstream (Stream next s) = runJSString $ \done ->
let go !s0 = case next s0 of
Done -> done I.empty
Skip s1 -> go s1
Yield x s1 -> js_newSingletonArray x >>= loop 1 s1
loop !i !s0 a = case next s0 of
Done -> js_packString a >>= done
Skip s1 -> loop i s1 a
Yield x s1 -> js_writeArray x i a >> loop (i+1) s1 a
in go s
{-# INLINE [0] unstream #-}
{-# RULES "STREAM stream/unstream fusion" forall s. stream (unstream s) = s #-}
runJSString :: ((a -> IO a) -> IO a) -> a
runJSString f = unsafePerformIO (f pure)
length :: Stream Char -> Int
length = S.lengthI
{-# INLINE[0] length #-}
reverse :: Stream Char -> JSString
reverse (Stream next s) = runJSString $ \done ->
let go !s0 = case next s0 of
Done -> done I.empty
Skip s1 -> go s1
Yield x s1 -> js_newSingletonArray x >>= loop 1 s1
loop !i !s0 a = case next s0 of
Done -> js_packReverse a >>= done
Skip s1 -> loop i s1 a
Yield x s1 -> js_writeArray x i a >> loop (i+1) s1 a
in go s
{-# INLINE [0] reverse #-}
reverseScanr :: (Char -> Char -> Char) -> Char -> Stream Char -> Stream Char
reverseScanr f z0 (Stream next0 s0) = Stream next (S1 :*: z0 :*: s0)
where
{-# INLINE next #-}
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
{-# INLINE reverseScanr #-}
unfoldrN :: Int -> (a -> Maybe (Char,a)) -> a -> Stream Char
unfoldrN n = S.unfoldrNI n
{-# INLINE [0] unfoldrN #-}
index :: Stream Char -> Int -> Char
index = S.indexI
{-# INLINE [0] index #-}
findIndex :: (Char -> Bool) -> Stream Char -> Maybe Int
findIndex = S.findIndexI
{-# INLINE [0] findIndex #-}
countChar :: Char -> Stream Char -> Int
countChar = S.countCharI
{-# INLINE [0] countChar #-}
mapAccumL :: (a -> Char -> (a, Char)) -> a -> Stream Char -> (a, JSString)
mapAccumL f z0 (Stream next s0) = runJSString $ \done ->
let go !s1 = case next s1 of
Done -> done (z0, I.empty)
Skip s2 -> go s2
Yield ch s2 -> let (z1, ch1) = f z0 ch
in js_newSingletonArray ch1 >>= loop 1 s2 z1
loop !i !s1 !z1 a = case next s1 of
Done -> js_packString a >>= \s -> done (z1, s)
Skip s2 -> loop i s2 z1 a
Yield ch1 s2 -> let (z2, ch2) = f z1 ch1
in js_writeArray ch2 i a >> loop (i+1) s2 z2 a
in go s0
{-# INLINE [0] mapAccumL #-}
foreign import javascript unsafe
"h$jsstringIndex" js_index :: Int -> JSString -> Int#
foreign import javascript unsafe
"h$jsstringIndexR" js_indexR :: Int -> JSString -> Int#
foreign import javascript unsafe
"$1.length" js_length :: JSString -> Int#
foreign import javascript unsafe
"$r = [$1];" js_newSingletonArray :: Char -> IO JSVal
foreign import javascript unsafe
"$3[$2] = $1;" js_writeArray :: Char -> Int -> JSVal -> IO ()
foreign import javascript unsafe
"h$jsstringPackArray" js_packString :: JSVal -> IO JSString
foreign import javascript unsafe
"h$jsstringPackArrayReverse" js_packReverse :: JSVal -> IO JSString