diff --git a/Data/JSString.hs b/Data/JSString.hs --- a/Data/JSString.hs +++ b/Data/JSString.hs @@ -167,8 +167,8 @@ import Unsafe.Coerce -import GHCJS.Prim (JSVal) -import qualified GHCJS.Prim as Prim +import GHC.JS.Prim (JSVal) +import qualified GHC.JS.Prim as Prim import Data.JSString.Internal.Type import Data.JSString.Internal.Fusion (stream, unstream) @@ -300,11 +300,13 @@ unstream (S.map safe (S.streamList [a])) = singleton a #-} +#ifdef MIN_VERSION_ghcjs_prim #if MIN_VERSION_ghcjs_prim(0,1,1) {-# RULES "JSSTRING literal prim" [0] forall a. unpackCString# a = JSString (Prim.unsafeUnpackJSStringUtf8# a) #-} #endif +#endif -- | /O(1)/ Convert a character into a 'JSString'. Subject to fusion. -- Performs replacement on invalid scalar values. @@ -1813,16 +1815,16 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "h$jsstringPack($1)" js_pack :: Exts.Any -> JSString + "h$jsstringPack" js_pack :: Exts.Any -> JSString foreign import javascript unsafe - "$1===''" js_null :: JSString -> Bool + "((x) => { return x === ''; })" js_null :: JSString -> Bool foreign import javascript unsafe - "$1===null" js_isNull :: JSVal -> Bool + "((x) => { return x === null; })" js_isNull :: JSVal -> Bool foreign import javascript unsafe - "$1===$2" js_eq :: JSString -> JSString -> Bool + "((x,y) => { return x === y; })" js_eq :: JSString -> JSString -> Bool foreign import javascript unsafe -- "h$jsstringAppend" js_append :: JSString -> JSString -> JSString -- debug - "$1+$2" js_append :: JSString -> JSString -> JSString + "((x,y) => { return x + y; })" js_append :: JSString -> JSString -> JSString foreign import javascript unsafe "h$jsstringCompare" js_compare :: JSString -> JSString -> Int# -- "($1<$2)?-1:(($1>$2)?1:0)" js_compare :: JSString -> JSString -> Int# @@ -1839,15 +1841,15 @@ foreign import javascript unsafe "h$jsstringUnsnoc" js_unsnoc :: JSString -> (# Int#, JSString #) foreign import javascript unsafe - "$3.substr($1,$2)" js_substr :: Int# -> Int# -> JSString -> JSString + "((x,y,z) => { return z.substr(x,y); })" js_substr :: Int# -> Int# -> JSString -> JSString foreign import javascript unsafe - "$2.substr($1)" js_substr1 :: Int# -> JSString -> JSString + "((x,y) => { return y.substr(x); })" js_substr1 :: Int# -> JSString -> JSString foreign import javascript unsafe - "$3.substring($1,$2)" js_substring :: Int# -> Int# -> JSString -> JSString + "((x,y,z) => { return z.substring(x,y); })" js_substring :: Int# -> Int# -> JSString -> JSString foreign import javascript unsafe - "$1.length" js_length :: JSString -> Int# + "((x) => { return x.length; })" js_length :: JSString -> Int# foreign import javascript unsafe - "(($2.charCodeAt($1)|1023)===0xDBFF)?2:1" js_charWidthAt + "((x,y) => { return ((y.charCodeAt(x)|1023)===0xDBFF)?2:1; })" js_charWidthAt :: Int# -> JSString -> Int# foreign import javascript unsafe "h$jsstringIndex" js_index :: Int# -> JSString -> Int# @@ -1949,7 +1951,7 @@ foreign import javascript unsafe "h$jsstringReplicateChar" js_replicateChar :: Int -> Char -> JSString foreign import javascript unsafe - "var l=$1.length; $r=l==1||(l==2&&($1.charCodeAt(0)|1023)==0xDFFF);" + "((x) => { var l = x.length; return l==1 || (l==2 && (x.charCodeAt(0)|1023) == 0xDFFF); })" js_isSingleton :: JSString -> Bool foreign import javascript unsafe "h$jsstringIntersperse" @@ -1958,6 +1960,6 @@ "h$jsstringIntercalate" js_intercalate :: JSString -> Exts.Any {- [JSString] -} -> JSString foreign import javascript unsafe - "$1.toUpperCase()" js_toUpper :: JSString -> JSString + "((x) => { return x.toUpperCase(); })" js_toUpper :: JSString -> JSString foreign import javascript unsafe - "$1.toLowerCase()" js_toLower :: JSString -> JSString + "((x) => { return x.toLowerCase(); })" js_toLower :: JSString -> JSString diff --git a/Data/JSString/Int.hs b/Data/JSString/Int.hs --- a/Data/JSString/Int.hs +++ b/Data/JSString/Int.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE LambdaCase #-} module Data.JSString.Int ( decimal @@ -16,14 +17,11 @@ import GHC.Int import GHC.Word -import GHC.Exts ( ByteArray# - , Int(..), Int#, Int64# - , Word(..), Word#, Word64# - , (<#), (<=#), isTrue# ) - -import GHC.Integer.GMP.Internals +import GHC.Exts hiding (Any) +import GHC.Num.Integer +import GHC.Num.Natural import Unsafe.Coerce -import GHCJS.Prim +import GHC.JS.Prim decimal :: Integral a => a -> JSString decimal i = decimal' i @@ -38,7 +36,9 @@ {-# RULES "decimal/Word32" decimal = decimalW32 :: Word32 -> JSString #-} {-# RULES "decimal/Word64" decimal = decimalW64 :: Word64 -> JSString #-} {-# RULES "decimal/Integer" decimal = decimalInteger :: Integer -> JSString #-} +{-# RULES "decimal/Natural" decimal = decimalNatural :: Natural -> JSString #-} {-# SPECIALIZE decimal :: Integer -> JSString #-} +{-# SPECIALIZE decimal :: Natural -> JSString #-} {-# SPECIALIZE decimal :: Int -> JSString #-} {-# SPECIALIZE decimal :: Int8 -> JSString #-} {-# SPECIALIZE decimal :: Int16 -> JSString #-} @@ -56,15 +56,15 @@ {-# INLINE decimalI #-} decimalI8 :: Int8 -> JSString -decimalI8 (I8# x) = js_decI x +decimalI8 (I8# x) = js_decI (int8ToInt# x) {-# INLINE decimalI8 #-} decimalI16 :: Int16 -> JSString -decimalI16 (I16# x) = js_decI x +decimalI16 (I16# x) = js_decI (int16ToInt# x) {-# INLINE decimalI16 #-} decimalI32 :: Int32 -> JSString -decimalI32 (I32# x) = js_decI x +decimalI32 (I32# x) = js_decI (int32ToInt# x) {-# INLINE decimalI32 #-} decimalI64 :: Int64 -> JSString @@ -72,11 +72,11 @@ {-# INLINE decimalI64 #-} decimalW8 :: Word8 -> JSString -decimalW8 (W8# x) = js_decW x +decimalW8 (W8# x) = js_decW (word8ToWord# x) {-# INLINE decimalW8 #-} decimalW16 :: Word16 -> JSString -decimalW16 (W16# x) = js_decW x +decimalW16 (W16# x) = js_decW (word16ToWord# x) {-# INLINE decimalW16 #-} decimalW32 :: Word32 -> JSString @@ -88,16 +88,25 @@ {-# INLINE decimalW64 #-} decimalW :: Word -> JSString -decimalW (W# x) = js_decW32 x +decimalW (W# x) = js_decW x {-# INLINE decimalW #-} -- hack warning, we should really expose J# somehow data MyI = MyS Int# | MyJ Int# ByteArray# decimalInteger :: Integer -> JSString -decimalInteger !i = js_decInteger (unsafeCoerce i) +decimalInteger = \case + IS x -> js_decI x + IP x -> js_decBigNat True x + IN x -> js_decBigNat False x {-# INLINE decimalInteger #-} +decimalNatural :: Natural -> JSString +decimalNatural = \case + NS x -> js_decW x + NB x -> js_decBigNat True x +{-# INLINE decimalNatural #-} + decimal' :: Integral a => a -> JSString decimal' i = decimalInteger (toInteger i) {-# NOINLINE decimal' #-} @@ -130,7 +139,9 @@ {-# RULES "hexadecimal/Word32" hexadecimal = hexW32 :: Word32 -> JSString #-} {-# RULES "hexadecimal/Word64" hexadecimal = hexW64 :: Word64 -> JSString #-} {-# RULES "hexadecimal/Integer" hexadecimal = hexInteger :: Integer -> JSString #-} +{-# RULES "hexadecimal/Natural" hexadecimal = hexNatural :: Natural -> JSString #-} {-# SPECIALIZE hexadecimal :: Integer -> JSString #-} +{-# SPECIALIZE hexadecimal :: Natural -> JSString #-} {-# SPECIALIZE hexadecimal :: Int -> JSString #-} {-# SPECIALIZE hexadecimal :: Int8 -> JSString #-} {-# SPECIALIZE hexadecimal :: Int16 -> JSString #-} @@ -150,55 +161,48 @@ {-# NOINLINE hexadecimal' #-} hexInteger :: Integer -> JSString -hexInteger !i - | i < 0 = error hexErrMsg - | otherwise = js_hexInteger (unsafeCoerce i) +hexInteger = \case + IS x -> js_hexI x + IP x -> js_hexBigNat True x + IN x -> js_hexBigNat False x {-# INLINE hexInteger #-} +hexNatural :: Natural -> JSString +hexNatural = \case + NS x -> js_hexW x + NB x -> js_hexBigNat True x +{-# INLINE hexNatural #-} + hexI :: Int -> JSString -hexI (I# x) = if isTrue# (x <# 0#) - then error hexErrMsg - else js_hexI x +hexI (I# x) = js_hexI x {-# INLINE hexI #-} hexI8 :: Int8 -> JSString -hexI8 (I8# x) = - if isTrue# (x <# 0#) - then error hexErrMsg - else js_hexI x +hexI8 (I8# x) = js_hexI (int8ToInt# x) {-# INLINE hexI8 #-} hexI16 :: Int16 -> JSString -hexI16 (I16# x) = - if isTrue# (x <# 0#) - then error hexErrMsg - else js_hexI x +hexI16 (I16# x) = js_hexI (int16ToInt# x) {-# INLINE hexI16 #-} hexI32 :: Int32 -> JSString -hexI32 (I32# x) = - if isTrue# (x <# 0#) - then error hexErrMsg - else js_hexI x +hexI32 (I32# x) = js_hexI (int32ToInt# x) {-# INLINE hexI32 #-} hexI64 :: Int64 -> JSString -hexI64 i@(I64# x) = - if i < 0 - then error hexErrMsg - else js_hexI64 x +hexI64 i@(I64# x) = js_hexI64 x {-# INLINE hexI64 #-} hexW :: Word -> JSString -hexW (W# x) = js_hexW32 x +hexW (W# x) = js_hexW x {-# INLINE hexW #-} hexW8 :: Word8 -> JSString -hexW8 (W8# x) = js_hexW x +hexW8 (W8# x) = js_hexW (word8ToWord# x) {-# INLINE hexW8 #-} hexW16 :: Word16 -> JSString -hexW16 (W16# x) = js_hexW x +hexW16 (W16# x) = js_hexW (word16ToWord# x) {-# INLINE hexW16 #-} hexW32 :: Word32 -> JSString @@ -215,50 +219,50 @@ -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "''+$1" + "((x) => { return '' + x; })" js_decI :: Int# -> JSString foreign import javascript unsafe "h$jsstringDecI64" js_decI64 :: Int64# -> JSString foreign import javascript unsafe - "''+$1" + "((x) => { return '' + x; })" js_decW :: Word# -> JSString foreign import javascript unsafe - "''+(($1>=0)?$1:($1+4294967296))" - js_decW32 :: Word# -> JSString + "((x) => { return '' + x; })" + js_decW32 :: Word32# -> JSString foreign import javascript unsafe - "h$jsstringDecW64($1_1, $1_2)" + "h$jsstringDecW64" js_decW64 :: Word64# -> JSString foreign import javascript unsafe - "h$jsstringDecInteger($1)" - js_decInteger :: Any -> JSString + "h$jsstringDecBigNat" + js_decBigNat :: Bool -> ByteArray# -> JSString -- these are expected to be only applied to nonnegative integers foreign import javascript unsafe - "$1.toString(16)" + "((x) => { return x.toString(16); })" js_hexI :: Int# -> JSString foreign import javascript unsafe "h$jsstringHexI64" js_hexI64 :: Int64# -> JSString foreign import javascript unsafe - "$1.toString(16)" + "((x) => { return x.toString(16); })" js_hexW :: Word# -> JSString foreign import javascript unsafe - "(($1>=0)?$1:($1+4294967296)).toString(16)" - js_hexW32 :: Word# -> JSString + "((x) => { return x.toString(16); })" + js_hexW32 :: Word32# -> JSString foreign import javascript unsafe - "h$jsstringHexW64($1_1, $1_2)" + "h$jsstringHexW64" js_hexW64 :: Word64# -> JSString foreign import javascript unsafe - "h$jsstringHexInteger($1)" - js_hexInteger :: Any -> JSString + "h$jsstringHexBigNat" + js_hexBigNat :: Bool -> ByteArray# -> JSString foreign import javascript unsafe - "'-'+$1+(-$2)" + "((x,y) => { return '-'+x+(-y); })" js_minusDigit :: JSString -> Int# -> JSString foreign import javascript unsafe - "'-'+$1" + "((x) => { return '-'+x; })" js_minus :: JSString -> JSString -- diff --git a/Data/JSString/Internal/Fusion.hs b/Data/JSString/Internal/Fusion.hs --- a/Data/JSString/Internal/Fusion.hs +++ b/Data/JSString/Internal/Fusion.hs @@ -43,7 +43,7 @@ import System.IO.Unsafe -import GHCJS.Prim +import GHC.JS.Prim default (Int) @@ -183,11 +183,11 @@ foreign import javascript unsafe "h$jsstringIndexR" js_indexR :: Int -> JSString -> Int# foreign import javascript unsafe - "$1.length" js_length :: JSString -> Int# + "((x) => { return x.length; })" js_length :: JSString -> Int# foreign import javascript unsafe - "$r = [$1];" js_newSingletonArray :: Char -> IO JSVal + "((x) => { return [x]; })" js_newSingletonArray :: Char -> IO JSVal foreign import javascript unsafe - "$3[$2] = $1;" js_writeArray :: Char -> Int -> JSVal -> IO () + "((x,y,z) => { z[y] = x; })" js_writeArray :: Char -> Int -> JSVal -> IO () foreign import javascript unsafe "h$jsstringPackArray" js_packString :: JSVal -> IO JSString foreign import javascript unsafe diff --git a/Data/JSString/Internal/Search.hs b/Data/JSString/Internal/Search.hs --- a/Data/JSString/Internal/Search.hs +++ b/Data/JSString/Internal/Search.hs @@ -9,14 +9,13 @@ import GHC.Exts (Int#, (+#), Int(..)) import Data.JSString --- returns uncorrected offsets in the String indices :: JSString -> JSString -> [Int] -indices needle haystack = go 0# +indices needle haystack = go 0# 0# where - go i = case js_indexOf needle i haystack of - -1# -> [] - n -> I# n : go (n +# 1#) + go n i = case js_indexOf needle n i haystack of + (# -1#, _ #) -> [] + (# n' , i' #) -> I# n' : go (n' +# 1#) (i' +# 1#) foreign import javascript unsafe - "$3.indexOf($1,$2)" - js_indexOf :: JSString -> Int# -> JSString -> Int# + "h$jsstringIndices" + js_indexOf :: JSString -> Int# -> Int# -> JSString -> (# Int#, Int# #) diff --git a/Data/JSString/Internal/Type.hs b/Data/JSString/Internal/Type.hs --- a/Data/JSString/Internal/Type.hs +++ b/Data/JSString/Internal/Type.hs @@ -36,7 +36,7 @@ import Data.Typeable (Typeable) import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#) -import GHCJS.Prim (JSVal) +import GHC.JS.Prim (JSVal) import GHCJS.Internal.Types @@ -47,7 +47,7 @@ instance NFData JSString where rnf !x = () foreign import javascript unsafe - "$r = '';" js_empty :: JSString + "(() => { return ''; })" js_empty :: JSString -- | /O(1)/ The empty 'JSString'. empty :: JSString diff --git a/Data/JSString/Raw.hs b/Data/JSString/Raw.hs --- a/Data/JSString/Raw.hs +++ b/Data/JSString/Raw.hs @@ -25,7 +25,7 @@ , (+#), (-#), (>=#), (<#) , isTrue#, chr#) import qualified GHC.Exts as Exts -import GHCJS.Prim (JSVal) +import GHC.JS.Prim (JSVal) import Unsafe.Coerce @@ -127,25 +127,25 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1===''" js_null :: JSString -> Bool + "((x) => { return x===''; })" js_null :: JSString -> Bool foreign import javascript unsafe - "$1.length" js_length :: JSString -> Int# + "((x) => { return x.length; })" js_length :: JSString -> Int# foreign import javascript unsafe - "$3.substr($1,$2)" js_substr :: Int# -> Int# -> JSString -> JSString + "((x,y,z) => { return z.substr(x,y); })" js_substr :: Int# -> Int# -> JSString -> JSString foreign import javascript unsafe - "$2.substr($1)" js_substr1 :: Int# -> JSString -> JSString + "((x,y) => { return y.substr(x); })" js_substr1 :: Int# -> JSString -> JSString foreign import javascript unsafe - "$3.slice($1,$2)" js_slice :: Int# -> Int# -> JSString -> JSString + "((x,y,z) => { return z.slice(x,y); })" js_slice :: Int# -> Int# -> JSString -> JSString foreign import javascript unsafe - "$2.slice($1)" js_slice1 :: Int# -> JSString -> JSString + "((x,y) => { return y.slice(x); })" js_slice1 :: Int# -> JSString -> JSString foreign import javascript unsafe - "$3.indexOf($1,$2)" js_indexOf :: JSString -> Int# -> JSString -> Int# + "((x,y,z) => { return z.indexOf(x,y); })" js_indexOf :: JSString -> Int# -> JSString -> Int# foreign import javascript unsafe - "$2.indexOf($1)" js_indexOf1 :: JSString -> JSString -> Int# + "((x,y) => { return y.indexOf(x); })" js_indexOf1 :: JSString -> JSString -> Int# foreign import javascript unsafe - "$2.charCodeAt($1)" js_charCodeAt :: Int# -> JSString -> Int# + "((x,y) => { return y.charCodeAt(x); })" js_charCodeAt :: Int# -> JSString -> Int# foreign import javascript unsafe - "$2.codePointAt($1)" js_codePointAt :: Int# -> JSString -> Int# + "((x,y) => { return y.codePointAt(x); })" js_codePointAt :: Int# -> JSString -> Int# foreign import javascript unsafe "$hsRawChunksOf" js_rawChunksOf :: Int# -> JSString -> Exts.Any -- [JSString] foreign import javascript unsafe diff --git a/Data/JSString/Read.hs b/Data/JSString/Read.hs --- a/Data/JSString/Read.hs +++ b/Data/JSString/Read.hs @@ -150,9 +150,9 @@ -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "$r = $1===null;" js_isNull :: JSVal -> Bool + "((x) => { return x===null; })" js_isNull :: JSVal -> Bool foreign import javascript unsafe - "$r=$1;" js_toHeapObject :: JSVal -> Any + "((x) => { return x; })" js_toHeapObject :: JSVal -> Any foreign import javascript unsafe "h$jsstringReadInteger" js_readInteger :: JSString -> JSVal foreign import javascript unsafe diff --git a/Data/JSString/RealFloat.hs b/Data/JSString/RealFloat.hs --- a/Data/JSString/RealFloat.hs +++ b/Data/JSString/RealFloat.hs @@ -26,8 +26,6 @@ realFloat = error "Data.JSString.RealFloat.realFloat not yet implemented" {-# RULES "realFloat/Double" realFloat = genericDouble #-} {-# RULES "realFoat/Float" realFloat = genericFloat #-} -{-# SPECIALIZE realFloat :: Double -> JSString #-} -{-# SPECIALIZE realFloat :: Float -> JSString #-} {-# NOINLINE realFloat #-} formatRealFloat :: (RealFloat a) @@ -38,8 +36,6 @@ formatRealFloat = error "Data.JSString.RealFloat.formatRealFloat not yet implemented" {-# RULES "formatRealFloat/Double" formatRealFloat = formatDouble #-} {-# RULES "formatRealFloat/Float" formatRealFloat = formatFloat #-} -{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Double -> JSString #-} -{-# SPECIALIZE formatRealFloat :: FPFormat -> Maybe Int -> Float -> JSString #-} {-# NOINLINE formatRealFloat #-} genericDouble :: Double -> JSString @@ -85,15 +81,15 @@ js_floatToFixed :: Int# -> Float# -> JSString foreign import javascript unsafe - "h$jsstringDoubleToExponent($1,$2)" + "h$jsstringDoubleToExponent" js_doubleToExponent :: Int# -> Double# -> JSString foreign import javascript unsafe - "h$jsstringDoubleToExponent($1,$2)" + "h$jsstringDoubleToExponent" js_floatToExponent :: Int# -> Float# -> JSString foreign import javascript unsafe - "h$jsstringDoubleGeneric($1,$2)" + "h$jsstringDoubleGeneric" js_doubleGeneric :: Int# -> Double# -> JSString foreign import javascript unsafe - "h$jsstringDoubleGeneric($1,$2)" + "h$jsstringDoubleGeneric" js_floatGeneric :: Int# -> Float# -> JSString diff --git a/Data/JSString/RegExp.hs b/Data/JSString/RegExp.hs --- a/Data/JSString/RegExp.hs +++ b/Data/JSString/RegExp.hs @@ -18,7 +18,7 @@ , execNext ) where -import GHCJS.Prim +import GHC.JS.Prim import GHC.Exts (Any, Int#, Int(..)) import Unsafe.Coerce (unsafeCoerce) @@ -94,9 +94,9 @@ -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "new RegExp($1,$2)" js_createRE :: JSString -> JSString -> RegExp + "((x,y) => { return new RegExp(x,y); })" js_createRE :: JSString -> JSString -> RegExp foreign import javascript unsafe - "$2.test($1)" js_test :: JSString -> RegExp -> Bool + "((x,y) => { return y.test(x); })" js_test :: JSString -> RegExp -> Bool foreign import javascript unsafe "h$jsstringExecRE" js_exec :: Int# -> JSString -> RegExp -> (# Int#, JSString, Any {- [JSString] -} #) @@ -105,9 +105,9 @@ foreign import javascript unsafe "h$jsstringSplitRE" js_split :: Int# -> JSString -> RegExp -> Any -- [JSString] foreign import javascript unsafe - "$1.multiline" js_isMultiline :: RegExp -> Bool + "((x) => { return x.multiline; })" js_isMultiline :: RegExp -> Bool foreign import javascript unsafe - "$1.ignoreCase" js_isIgnoreCase :: RegExp -> Bool + "((x) => { return x.ignoreCase; })" js_isIgnoreCase :: RegExp -> Bool foreign import javascript unsafe - "$1.pattern" js_pattern :: RegExp -> JSString + "((x) => { return x.pattern; })" js_pattern :: RegExp -> JSString diff --git a/Data/JSString/Text.hs b/Data/JSString/Text.hs --- a/Data/JSString/Text.hs +++ b/Data/JSString/Text.hs @@ -15,7 +15,7 @@ , lazyTextFromJSVal ) where -import GHCJS.Prim +import GHC.JS.Prim import GHC.Exts (ByteArray#, Int(..), Int#, Any) @@ -31,7 +31,7 @@ import Unsafe.Coerce textToJSString :: T.Text -> JSString -textToJSString (T.Text (A.Array ba) (I# offset) (I# length)) = +textToJSString (T.Text (A.ByteArray ba) (I# offset) (I# length)) = js_toString ba offset length {-# INLINE textToJSString #-} @@ -39,7 +39,7 @@ textFromJSString j = case js_fromString j of (# _ , 0# #) -> T.empty - (# ba, length #) -> T.Text (A.Array ba) 0 (I# length) + (# ba, length #) -> T.Text (A.ByteArray ba) 0 (I# length) {-# INLINE textFromJSString #-} lazyTextToJSString :: TL.Text -> JSString @@ -54,7 +54,7 @@ textFromJSVal :: JSVal -> T.Text textFromJSVal j = case js_fromString' j of (# _, 0# #) -> T.empty - (# ba, length #) -> T.Text (A.Array ba) 0 (I# length) + (# ba, length #) -> T.Text (A.ByteArray ba) 0 (I# length) {-# INLINE textFromJSVal #-} -- | returns the empty Text if not a string @@ -65,7 +65,7 @@ -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "h$textToString($1,$2,$3)" + "h$textToString" js_toString :: ByteArray# -> Int# -> Int# -> JSString foreign import javascript unsafe "h$textFromString" diff --git a/GHCJS/Buffer.hs b/GHCJS/Buffer.hs --- a/GHCJS/Buffer.hs +++ b/GHCJS/Buffer.hs @@ -41,7 +41,7 @@ import GHC.Exts (ByteArray#, MutableByteArray#, Addr#, Ptr(..), Any) import GHCJS.Buffer.Types -import GHCJS.Prim +import GHC.JS.Prim import GHCJS.Internal.Types import Data.Int @@ -146,13 +146,14 @@ -- as a reference for the purpose of determining when that finalizer -- should run. fromByteString :: ByteString -> (Buffer, Int, Int) -fromByteString (BS.PS fp off len) = +fromByteString (BS.BS fp len) = -- not super happy with this. What if the bytestring's foreign ptr -- has a nontrivial finalizer attached to it? I don't think there's -- a way to do that without someone else messing with the PS constructor -- directly though. let !(Ptr addr) = unsafeForeignPtrToPtr fp - in (js_fromAddr addr, off, len) + (ptr, off) = js_fromAddr addr + in (ptr, off, len) {-# INLINE fromByteString #-} -- | Wrap a 'Buffer' into a 'ByteString' using the given offset @@ -194,35 +195,35 @@ "h$wrapBuffer($1.buf.slice($1.u8.byteOffset, $1.len))" js_clone :: SomeBuffer any1 -> IO (SomeBuffer any2) foreign import javascript unsafe - "$1.len" js_byteLength :: SomeBuffer any -> Int + "((x) => { return x.len; })" js_byteLength :: SomeBuffer any -> Int foreign import javascript unsafe - "$1.buf" js_getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any + "((x) => { return x.buf; })" js_getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any foreign import javascript unsafe - "$1.i3" js_getInt32Array :: SomeBuffer any -> I.SomeInt32Array any + "((x) => { return x.i3; })" js_getInt32Array :: SomeBuffer any -> I.SomeInt32Array any foreign import javascript unsafe - "$1.u8" js_getUint8Array :: SomeBuffer any -> I.SomeUint8Array any + "((x) => { return x.u8; })" js_getUint8Array :: SomeBuffer any -> I.SomeUint8Array any foreign import javascript unsafe - "$1.u1" js_getUint16Array :: SomeBuffer any -> I.SomeUint16Array any + "((x) => { return x.u1; })" js_getUint16Array :: SomeBuffer any -> I.SomeUint16Array any foreign import javascript unsafe - "$1.f3" js_getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any + "((x) => { return x.f3; })" js_getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any foreign import javascript unsafe - "$1.f6" js_getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any + "((x) => { return x.f6; })" js_getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any foreign import javascript unsafe - "$1.dv" js_getDataView :: SomeBuffer any -> SomeDataView any + "((x) => { return x.dv; })" js_getDataView :: SomeBuffer any -> SomeDataView any -- ---------------------------------------------------------------------------- -- these things have the same representation (modulo boxing), -- conversion is free foreign import javascript unsafe - "$r = $1;" js_toByteArray :: SomeBuffer any -> ByteArray# + "((x) => { return x; })" js_toByteArray :: SomeBuffer any -> ByteArray# foreign import javascript unsafe - "$r = $1;" js_fromByteArray :: ByteArray# -> JSVal + "((x) => { return x; })" js_fromByteArray :: ByteArray# -> JSVal foreign import javascript unsafe - "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSVal + "((x) => { return x; })" js_fromMutableByteArray :: MutableByteArray# s -> JSVal foreign import javascript unsafe - "$r = $1;" js_toMutableByteArray :: JSVal -> MutableByteArray# s + "((x) => { return x; })" js_toMutableByteArray :: JSVal -> MutableByteArray# s foreign import javascript unsafe - "$r1 = $1; $r2 = 0;" js_toAddr :: SomeBuffer any -> Addr# + "h$toAddr" js_toAddr :: SomeBuffer any -> Addr# foreign import javascript unsafe - "$r = $1;" js_fromAddr :: Addr# -> SomeBuffer any + "h$fromAddr" js_fromAddr :: Addr# -> (SomeBuffer any, Int) diff --git a/GHCJS/Concurrent.hs b/GHCJS/Concurrent.hs --- a/GHCJS/Concurrent.hs +++ b/GHCJS/Concurrent.hs @@ -33,7 +33,8 @@ , synchronously ) where -import GHCJS.Prim +import GHC.JS.Prim +import GHC.JS.Foreign.Callback (OnBlocked(..)) import Control.Applicative import Control.Concurrent @@ -49,18 +50,6 @@ import Unsafe.Coerce {- | - The runtime tries to run synchronous threads to completion. Sometimes it's - not possible to continue running a thread, for example when the thread - tries to take an empty 'MVar'. The runtime can then either throw a - 'WouldBlockException', aborting the blocking action, or continue the - thread asynchronously. - -} - -data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked - | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked - deriving (Data, Typeable, Enum, Show, Eq, Ord) - -{- | Run the action without the scheduler preempting the thread. When a blocking action is encountered, the thread is still suspended and will continue without preemption when it's woken up again. @@ -118,15 +107,13 @@ -- ---------------------------------------------------------------------------- -foreign import javascript unsafe "h$syncThreadState($1)" +foreign import javascript unsafe "h$syncThreadState" js_syncThreadState :: ThreadId# -> IO Int foreign import javascript unsafe - "$r = h$currentThread.noPreemption;\ - \h$currentThread.noPreemption = $1;" + "((x) => { var r = h$currentThread.noPreemption; h$currentThread.noPreemption = x; return r; })" js_setNoPreemption :: Bool -> IO Bool; foreign import javascript unsafe - "$r = h$currentThread.isSynchronous;\ - \h$currentThread.isSynchronous = $1;" + "((x) => { var r = h$currentThread.isSynchronous; h$currentThread.isSynchronous = x; return r; })" js_setSynchronous :: Bool -> IO Bool diff --git a/GHCJS/Foreign/Callback.hs b/GHCJS/Foreign/Callback.hs deleted file mode 100644 --- a/GHCJS/Foreign/Callback.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes, - GHCForeignImportPrim, DeriveDataTypeable, GHCForeignImportPrim #-} -module GHCJS.Foreign.Callback - ( Callback - , OnBlocked(..) - , releaseCallback - -- * asynchronous callbacks - , asyncCallback - , asyncCallback1 - , asyncCallback2 - , asyncCallback3 - -- * synchronous callbacks - , syncCallback - , syncCallback1 - , syncCallback2 - , syncCallback3 - -- * synchronous callbacks that return a value - , syncCallback' - , syncCallback1' - , syncCallback2' - , syncCallback3' - ) where - -import GHCJS.Concurrent -import GHCJS.Marshal -import GHCJS.Marshal.Pure -import GHCJS.Foreign.Callback.Internal -import GHCJS.Prim -import GHCJS.Types - -import qualified GHC.Exts as Exts - -import Data.Typeable - -import Unsafe.Coerce - -{- | - When you create a callback, the Haskell runtime stores a reference to - the exported IO action or function. This means that all data referenced by the - exported value stays in memory, even if nothing outside the Haskell runtime - holds a reference to to callback. - - Use 'releaseCallback' to free the reference. Subsequent calls from JavaScript - to the callback will result in an exception. - -} -releaseCallback :: Callback a -> IO () -releaseCallback x = js_release x - -{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous - thread when called. - - Call 'releaseCallback' when done with the callback, freeing memory referenced - by the IO action. - -} -syncCallback :: OnBlocked -- ^ what to do when the thread blocks - -> IO () -- ^ the Haskell action - -> IO (Callback (IO ())) -- ^ the callback -syncCallback onBlocked x = js_syncCallback (onBlocked == ContinueAsync) (unsafeCoerce x) - - -{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous - thread when called. The callback takes one argument that it passes as a JSVal value to - the Haskell function. - - Call 'releaseCallback' when done with the callback, freeing data referenced - by the function. - -} -syncCallback1 :: OnBlocked -- ^ what to do when the thread blocks - -> (JSVal -> IO ()) -- ^ the Haskell function - -> IO (Callback (JSVal -> IO ())) -- ^ the callback -syncCallback1 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 1 (unsafeCoerce x) - - -{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous - thread when called. The callback takes two arguments that it passes as JSVal values to - the Haskell function. - - Call 'releaseCallback' when done with the callback, freeing data referenced - by the function. - -} -syncCallback2 :: OnBlocked -- ^ what to do when the thread blocks - -> (JSVal -> JSVal -> IO ()) -- ^ the Haskell function - -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback -syncCallback2 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 2 (unsafeCoerce x) - -{- | Make a callback (JavaScript function) that runs the supplied IO function in a synchronous - thread when called. The callback takes three arguments that it passes as JSVal values to - the Haskell function. - - Call 'releaseCallback' when done with the callback, freeing data referenced - by the function. - -} -syncCallback3 :: OnBlocked -- ^ what to do when the thread blocks - -> (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function - -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback -syncCallback3 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 3 (unsafeCoerce x) - -{- | Make a callback (JavaScript function) that runs the supplied IO action in a synchronous - thread when called. - - Call 'releaseCallback' when done with the callback, freeing memory referenced - by the IO action. - -} -syncCallback' :: IO JSVal - -> IO (Callback (IO JSVal)) -syncCallback' x = js_syncCallbackReturn (unsafeCoerce x) - -syncCallback1' :: (JSVal -> IO JSVal) - -> IO (Callback (JSVal -> IO JSVal)) -syncCallback1' x = js_syncCallbackApplyReturn 1 (unsafeCoerce x) - -syncCallback2' :: (JSVal -> JSVal -> IO JSVal) - -> IO (Callback (JSVal -> JSVal -> IO JSVal)) -syncCallback2' x = js_syncCallbackApplyReturn 2 (unsafeCoerce x) - -syncCallback3' :: (JSVal -> JSVal -> JSVal -> IO JSVal) - -> IO (Callback (JSVal -> JSVal -> JSVal -> IO JSVal)) -syncCallback3' x = js_syncCallbackApplyReturn 3 (unsafeCoerce x) - -{- | Make a callback (JavaScript function) that runs the supplied IO action in an asynchronous - thread when called. - - Call 'releaseCallback' when done with the callback, freeing data referenced - by the IO action. - -} -asyncCallback :: IO () -- ^ the action that the callback runs - -> IO (Callback (IO ())) -- ^ the callback -asyncCallback x = js_asyncCallback (unsafeCoerce x) - -asyncCallback1 :: (JSVal -> IO ()) -- ^ the function that the callback calls - -> IO (Callback (JSVal -> IO ())) -- ^ the calback -asyncCallback1 x = js_asyncCallbackApply 1 (unsafeCoerce x) - -asyncCallback2 :: (JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls - -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback -asyncCallback2 x = js_asyncCallbackApply 2 (unsafeCoerce x) - -asyncCallback3 :: (JSVal -> JSVal -> JSVal -> IO ()) -- ^ the Haskell function that the callback calls - -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ())) -- ^ the callback -asyncCallback3 x = js_asyncCallbackApply 3 (unsafeCoerce x) - --- ---------------------------------------------------------------------------- - -foreign import javascript unsafe "h$makeCallback(h$runSync, [$1], $2)" - js_syncCallback :: Bool -> Exts.Any -> IO (Callback (IO b)) -foreign import javascript unsafe "h$makeCallback(h$run, [], $1)" - js_asyncCallback :: Exts.Any -> IO (Callback (IO b)) -foreign import javascript unsafe "h$makeCallback(h$runSyncReturn, [false], $1)" - js_syncCallbackReturn :: Exts.Any -> IO (Callback (IO JSVal)) - -foreign import javascript unsafe "h$makeCallbackApply($2, h$runSync, [$1], $3)" - js_syncCallbackApply :: Bool -> Int -> Exts.Any -> IO (Callback b) -foreign import javascript unsafe "h$makeCallbackApply($1, h$run, [], $2)" - js_asyncCallbackApply :: Int -> Exts.Any -> IO (Callback b) -foreign import javascript unsafe - "h$makeCallbackApply($1, h$runSyncReturn, [false], $2)" - js_syncCallbackApplyReturn :: Int -> Exts.Any -> IO (Callback b) - -foreign import javascript unsafe "h$release" - js_release :: Callback a -> IO () - diff --git a/GHCJS/Foreign/Callback/Internal.hs b/GHCJS/Foreign/Callback/Internal.hs deleted file mode 100644 --- a/GHCJS/Foreign/Callback/Internal.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module GHCJS.Foreign.Callback.Internal where - -import GHCJS.Types -import GHCJS.Marshal.Internal - -import Data.Typeable - -newtype Callback a = Callback JSVal deriving Typeable -instance IsJSVal (Callback a) - diff --git a/GHCJS/Foreign/Export.hs b/GHCJS/Foreign/Export.hs --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -27,7 +27,7 @@ import Unsafe.Coerce import qualified GHC.Exts as Exts -import GHCJS.Prim +import GHC.JS.Prim import GHCJS.Types newtype Export a = Export JSVal @@ -84,7 +84,7 @@ "h$derefExport" js_derefExport :: Word64 -> Word64 -> Export a -> IO JSVal foreign import javascript unsafe - "$r = $1;" js_toHeapObject :: JSVal -> IO Any + "((x) => { return x; })" js_toHeapObject :: JSVal -> IO Any foreign import javascript unsafe "h$releaseExport" js_releaseExport :: Export a -> IO () diff --git a/GHCJS/Foreign/Internal.hs b/GHCJS/Foreign/Internal.hs --- a/GHCJS/Foreign/Internal.hs +++ b/GHCJS/Foreign/Internal.hs @@ -80,7 +80,7 @@ ) where import GHCJS.Types -import qualified GHCJS.Prim as Prim +import qualified GHC.JS.Prim as Prim import GHC.Prim import GHC.Exts @@ -90,7 +90,7 @@ import Control.DeepSeq (force) import Control.Exception (evaluate, Exception) -import Foreign.ForeignPtr.Safe +import Foreign.ForeignPtr import Foreign.Ptr import Data.Primitive.ByteArray @@ -317,7 +317,7 @@ mutableByteArrayJSVal a = unsafeCoerce (MutableByteArray a) {-# INLINE mutableByteArrayJSVal #-} -foreign import javascript safe "h$wrapBuffer($3, true, $1, $2)" +foreign import javascript safe "((x,y,z) => { return h$wrapBuffer(z, true, x, y); })" js_wrapBuffer :: Int -> Int -> JSVal a -> IO (JSVal ()) {- | Convert an ArrayBuffer to a strict 'ByteString' @@ -368,15 +368,15 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$r = $1===true;" + "((x) => { return x===true; })" js_fromBool :: JSVal -> Bool foreign import javascript unsafe - "$1 ? true : false" + "((x) => { return x ? true : false; })" js_isTruthy :: JSVal -> Bool -foreign import javascript unsafe "$r = true;" js_true :: Int# -> Ref# -foreign import javascript unsafe "$r = false;" js_false :: Int# -> Ref# -foreign import javascript unsafe "$r = null;" js_null :: Int# -> Ref# -foreign import javascript unsafe "$r = undefined;" js_undefined :: Int# -> Ref# +foreign import javascript unsafe "((x) => { return true; })" js_true :: Int# -> Ref# +foreign import javascript unsafe "((x) => { return false; })" js_false :: Int# -> Ref# +foreign import javascript unsafe "((x) => { return null; })" js_null :: Int# -> Ref# +foreign import javascript unsafe "((x) => { return undefined; })" js_undefined :: Int# -> Ref# -- foreign import javascript unsafe "$r = [];" js_emptyArray :: IO (JSArray a) -- foreign import javascript unsafe "$r = {};" js_emptyObj :: IO (JSVal a) --foreign import javascript unsafe "$3[$1] = $2;" @@ -390,17 +390,17 @@ -- js_index :: Int -> JSArray a -> IO (JSVal a) --foreign import javascript unsafe "$2[$1]" -- js_unsafeIndex :: Int -> JSArray a -> IO (JSVal a) -foreign import javascript unsafe "$2[$1]" +foreign import javascript unsafe "((x,y) => { return y[x]; })" js_unsafeGetProp :: JSString -> JSVal -> IO JSVal -foreign import javascript unsafe "$3[$1] = $2" +foreign import javascript unsafe "((x,y,z) => { return z[x] = y; })" js_unsafeSetProp :: JSString -> JSVal -> JSVal -> IO () {- foreign import javascript safe "h$listProps($1)" js_listProps :: JSVal a -> IO (JSArray JSString) -} -foreign import javascript unsafe "h$jsTypeOf($1)" +foreign import javascript unsafe "h$jsTypeOf" js_jsTypeOf :: JSVal -> Int# -foreign import javascript unsafe "h$jsonTypeOf($1)" +foreign import javascript unsafe "h$jsonTypeOf" js_jsonTypeOf :: JSVal -> Int# -- foreign import javascript unsafe "h$listToArray" -- js_toArray :: Any -> IO (JSArray a) diff --git a/GHCJS/Internal/Types.hs b/GHCJS/Internal/Types.hs --- a/GHCJS/Internal/Types.hs +++ b/GHCJS/Internal/Types.hs @@ -13,7 +13,8 @@ import Control.DeepSeq -import GHCJS.Prim (JSVal) +import GHC.JS.Prim (JSVal) +import GHC.JS.Foreign.Callback (Callback) instance NFData JSVal where rnf x = x `seq` () @@ -24,6 +25,9 @@ default jsval_ :: Coercible a JSVal => a -> JSVal jsval_ = coerce {-# INLINE jsval_ #-} + +instance IsJSVal (Callback a) where + jsval_ = unsafeCoerce jsval :: IsJSVal a => a -> JSVal jsval = jsval_ diff --git a/GHCJS/Marshal.hs b/GHCJS/Marshal.hs --- a/GHCJS/Marshal.hs +++ b/GHCJS/Marshal.hs @@ -25,7 +25,6 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import qualified Data.Aeson as AE -import Data.Attoparsec.Number (Number(..)) import Data.Bits ((.&.)) import Data.Char (chr, ord) #if MIN_VERSION_aeson (2,0,0) @@ -286,13 +285,20 @@ toJSVal (a,b,c,d,e,f,g) = join $ arr7 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f <*> toJSVal g {-# INLINE toJSVal #-} -foreign import javascript unsafe "[$1]" arr1 :: JSVal -> IO JSVal -foreign import javascript unsafe "[$1,$2]" arr2 :: JSVal -> JSVal -> IO JSVal -foreign import javascript unsafe "[$1,$2,$3]" arr3 :: JSVal -> JSVal -> JSVal -> IO JSVal -foreign import javascript unsafe "[$1,$2,$3,$4]" arr4 :: JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal -foreign import javascript unsafe "[$1,$2,$3,$4,$5]" arr5 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal -foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]" arr6 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal -foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1) => { return [$1]; })" + arr1 :: JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2) => { return [$1,$2]; })" + arr2 :: JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3) => { return [$1,$2,$3]; })" + arr3 :: JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4) => { return [$1,$2,$3,$4]; })" + arr4 :: JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4,$5) => { return [$1,$2,$3,$4,$5]; })" + arr5 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6) => { return [$1,$2,$3,$4,$5,$6]; })" + arr6 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6,$7) => { return [$1,$2,$3,$4,$5,$6,$7]; })" + arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> IO JSVal toJSVal_aeson :: AE.ToJSON a => a -> IO JSVal toJSVal_aeson x = cv (AE.toJSON x) diff --git a/GHCJS/Marshal/Internal.hs b/GHCJS/Marshal/Internal.hs --- a/GHCJS/Marshal/Internal.hs +++ b/GHCJS/Marshal/Internal.hs @@ -23,7 +23,7 @@ import GHC.Generics -import qualified GHCJS.Prim as Prim +import qualified GHC.JS.Prim as Prim import qualified GHCJS.Foreign as F import GHCJS.Types diff --git a/GHCJS/Marshal/Pure.hs b/GHCJS/Marshal/Pure.hs --- a/GHCJS/Marshal/Pure.hs +++ b/GHCJS/Marshal/Pure.hs @@ -21,6 +21,8 @@ -} module GHCJS.Marshal.Pure ( PFromJSVal(..) , PToJSVal(..) + , jsvalToChar + , charToJSVal ) where import Data.Char (chr, ord) @@ -42,7 +44,7 @@ import GHC.Prim import GHCJS.Types -import qualified GHCJS.Prim as Prim +import qualified GHC.JS.Prim as Prim import GHCJS.Foreign.Internal import GHCJS.Marshal.Internal @@ -77,7 +79,7 @@ {-# INLINE pFromJSVal #-} instance PFromJSVal Int16 where pFromJSVal x = I16# (jsvalToInt16 x) {-# INLINE pFromJSVal #-} -instance PFromJSVal Int32 where pFromJSVal x = I32# (jsvalToInt x) +instance PFromJSVal Int32 where pFromJSVal x = I32# (jsvalToInt32 x) {-# INLINE pFromJSVal #-} instance PFromJSVal Word where pFromJSVal x = W# (jsvalToWord x) {-# INLINE pFromJSVal #-} @@ -85,7 +87,7 @@ {-# INLINE pFromJSVal #-} instance PFromJSVal Word16 where pFromJSVal x = W16# (jsvalToWord16 x) {-# INLINE pFromJSVal #-} -instance PFromJSVal Word32 where pFromJSVal x = W32# (jsvalToWord x) +instance PFromJSVal Word32 where pFromJSVal x = (jsvalToWord32 x) {-# INLINE pFromJSVal #-} instance PFromJSVal Float where pFromJSVal x = F# (jsvalToFloat x) {-# INLINE pFromJSVal #-} @@ -112,19 +114,19 @@ {-# INLINE pToJSVal #-} instance PToJSVal Int where pToJSVal (I# x) = intToJSVal x {-# INLINE pToJSVal #-} -instance PToJSVal Int8 where pToJSVal (I8# x) = intToJSVal x +instance PToJSVal Int8 where pToJSVal (I8# x) = intToJSVal (int8ToInt# x) {-# INLINE pToJSVal #-} -instance PToJSVal Int16 where pToJSVal (I16# x) = intToJSVal x +instance PToJSVal Int16 where pToJSVal (I16# x) = intToJSVal (int16ToInt# x) {-# INLINE pToJSVal #-} -instance PToJSVal Int32 where pToJSVal (I32# x) = intToJSVal x +instance PToJSVal Int32 where pToJSVal (I32# x) = intToJSVal (int32ToInt# x) {-# INLINE pToJSVal #-} instance PToJSVal Word where pToJSVal (W# x) = wordToJSVal x {-# INLINE pToJSVal #-} -instance PToJSVal Word8 where pToJSVal (W8# x) = wordToJSVal x +instance PToJSVal Word8 where pToJSVal (W8# x) = wordToJSVal (word8ToWord# x) {-# INLINE pToJSVal #-} -instance PToJSVal Word16 where pToJSVal (W16# x) = wordToJSVal x +instance PToJSVal Word16 where pToJSVal (W16# x) = wordToJSVal (word16ToWord# x) {-# INLINE pToJSVal #-} -instance PToJSVal Word32 where pToJSVal (W32# x) = wordToJSVal x +instance PToJSVal Word32 where pToJSVal (W32# x) = wordToJSVal (word32ToWord# x) {-# INLINE pToJSVal #-} instance PToJSVal Float where pToJSVal (F# x) = floatToJSVal x {-# INLINE pToJSVal #-} @@ -136,19 +138,21 @@ pToJSVal (Just a) = pToJSVal a {-# INLINE pToJSVal #-} -foreign import javascript unsafe "$r = $1|0;" jsvalToWord :: JSVal -> Word# -foreign import javascript unsafe "$r = $1&0xff;" jsvalToWord8 :: JSVal -> Word# -foreign import javascript unsafe "$r = $1&0xffff;" jsvalToWord16 :: JSVal -> Word# -foreign import javascript unsafe "$r = $1|0;" jsvalToInt :: JSVal -> Int# -foreign import javascript unsafe "$r = $1<<24>>24;" jsvalToInt8 :: JSVal -> Int# -foreign import javascript unsafe "$r = $1<<16>>16;" jsvalToInt16 :: JSVal -> Int# -foreign import javascript unsafe "$r = +$1;" jsvalToFloat :: JSVal -> Float# -foreign import javascript unsafe "$r = +$1;" jsvalToDouble :: JSVal -> Double# -foreign import javascript unsafe "$r = $1&0x7fffffff;" jsvalToChar :: JSVal -> Char# +foreign import javascript unsafe "((x) => { return x>>>0; })" jsvalToWord :: JSVal -> Word# +foreign import javascript unsafe "((x) => { return x&0xff; })" jsvalToWord8 :: JSVal -> Word8# +foreign import javascript unsafe "((x) => { return x&0xffff; })" jsvalToWord16 :: JSVal -> Word16# +foreign import javascript unsafe "((x) => { return x>>>0; })" jsvalToWord32 :: JSVal -> Word32 +foreign import javascript unsafe "((x) => { return x|0; })" jsvalToInt :: JSVal -> Int# +foreign import javascript unsafe "((x) => { return x<<24>>24; })" jsvalToInt8 :: JSVal -> Int8# +foreign import javascript unsafe "((x) => { return x<<16>>16; })" jsvalToInt16 :: JSVal -> Int16# +foreign import javascript unsafe "((x) => { return x|0; })" jsvalToInt32 :: JSVal -> Int32# +foreign import javascript unsafe "((x) => { return +x; })" jsvalToFloat :: JSVal -> Float# +foreign import javascript unsafe "((x) => { return +x; })" jsvalToDouble :: JSVal -> Double# +foreign import javascript unsafe "((x) => { return x&0x7fffffff; })" jsvalToChar :: JSVal -> Char# -foreign import javascript unsafe "$r = $1;" wordToJSVal :: Word# -> JSVal -foreign import javascript unsafe "$r = $1;" intToJSVal :: Int# -> JSVal -foreign import javascript unsafe "$r = $1;" doubleToJSVal :: Double# -> JSVal -foreign import javascript unsafe "$r = $1;" floatToJSVal :: Float# -> JSVal -foreign import javascript unsafe "$r = $1;" charToJSVal :: Char# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" wordToJSVal :: Word# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" intToJSVal :: Int# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" doubleToJSVal :: Double# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" floatToJSVal :: Float# -> JSVal +foreign import javascript unsafe "((x) => { return x; })" charToJSVal :: Char# -> JSVal diff --git a/GHCJS/Nullable.hs b/GHCJS/Nullable.hs --- a/GHCJS/Nullable.hs +++ b/GHCJS/Nullable.hs @@ -3,7 +3,7 @@ , maybeToNullable ) where -import GHCJS.Prim (JSVal(..)) +import GHC.JS.Prim (JSVal(..)) import GHCJS.Marshal.Pure (PToJSVal(..), PFromJSVal(..)) newtype Nullable a = Nullable JSVal diff --git a/GHCJS/Types.hs b/GHCJS/Types.hs --- a/GHCJS/Types.hs +++ b/GHCJS/Types.hs @@ -24,7 +24,7 @@ import Data.JSString.Internal.Type (JSString) import GHCJS.Internal.Types -import GHCJS.Prim +import GHC.JS.Prim import GHC.Int import GHC.Types @@ -50,13 +50,13 @@ fromPtr p = js_ptrVal p {-# INLINE fromPtr #-} -foreign import javascript unsafe "$r = null;" +foreign import javascript unsafe "((x) => { return null; })" js_nullRef :: JSVal -foreign import javascript unsafe "$r = $1_1;" +foreign import javascript unsafe "((x,y) => { return x; })" js_ptrVal :: Ptr a -> JSVal -foreign import javascript unsafe "$r1 = $1; $r2 = 0;" +foreign import javascript unsafe "((x) => { h$ret1 = 0; return x; })" js_mkPtr :: JSVal -> Ptr a -- | This is a deprecated copmatibility wrapper for the old JSRef type. diff --git a/JavaScript/Array.hs b/JavaScript/Array.hs --- a/JavaScript/Array.hs +++ b/JavaScript/Array.hs @@ -33,7 +33,7 @@ import Prelude hiding (length, drop, read, take, reverse, null) -import qualified GHCJS.Prim as Prim +import qualified GHC.JS.Prim as Prim import GHCJS.Types import JavaScript.Array.Internal (JSArray(..)) diff --git a/JavaScript/Array/Internal.hs b/JavaScript/Array/Internal.hs --- a/JavaScript/Array/Internal.hs +++ b/JavaScript/Array/Internal.hs @@ -16,7 +16,7 @@ import GHC.Exts (State#) import GHCJS.Internal.Types -import qualified GHCJS.Prim as Prim +import qualified GHC.JS.Prim as Prim import GHCJS.Types newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal @@ -140,54 +140,54 @@ -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "$r = [];" +foreign import javascript unsafe "((x) => { return []; })" js_create :: State# s -> (# State# s, SomeJSArray m #) -foreign import javascript unsafe "$1.length" +foreign import javascript unsafe "((x) => { return x.length; })" js_length :: SomeJSArray m -> State# s -> (# State# s, Int #) -foreign import javascript unsafe "$2[$1]" +foreign import javascript unsafe "((x,y) => { return y[x]; })" js_index :: Int -> SomeJSArray m -> State# s -> (# State# s, JSVal #) -foreign import javascript unsafe "$2[$1]" +foreign import javascript unsafe "((x,y) => { return y[x]; })" js_indexPure :: Int -> JSArray -> JSVal -foreign import javascript unsafe "$1.length" +foreign import javascript unsafe "((x) => { return x.length; })" js_lengthPure :: JSArray -> Int -foreign import javascript unsafe "$3[$1] = $2" +foreign import javascript unsafe "((x,y,z) => { z[x] = y; })" js_setIndex :: Int -> JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) -foreign import javascript unsafe "$3.slice($1,$2)" +foreign import javascript unsafe "((x,y,z) => { return z.slice(x,y); })" js_slice :: Int -> Int -> SomeJSArray m -> State# s -> (# State# s, SomeJSArray m1 #) -foreign import javascript unsafe "$2.slice($1)" +foreign import javascript unsafe "((x,y) => { return y.slice(x); })" js_slice1 :: Int -> SomeJSArray m -> State# s -> (# State# s, SomeJSArray m1 #) -foreign import javascript unsafe "$3.slice($1,2)" +foreign import javascript unsafe "((x,y,z) => { return z.slice(x,y); })" js_slicePure :: Int -> Int -> JSArray -> JSArray -foreign import javascript unsafe "$2.slice($1)" +foreign import javascript unsafe "((x,y) => { return y.slice(x); })" js_slice1Pure :: Int -> JSArray -> JSArray -foreign import javascript unsafe "$1.concat($2)" +foreign import javascript unsafe "((x,y) => { return x.concat(y); })" js_append :: SomeJSArray m0 -> SomeJSArray m1 -> State# s -> (# State# s, SomeJSArray m2 #) -foreign import javascript unsafe "$2.push($1)" +foreign import javascript unsafe "((x,y) => { y.push(x); })" js_push :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) -foreign import javascript unsafe "$1.pop()" +foreign import javascript unsafe "((x) => { return x.pop(); })" js_pop :: SomeJSArray m -> State# s -> (# State# s, JSVal #) -foreign import javascript unsafe "$2.unshift($1)" +foreign import javascript unsafe "((x,y) => { y.unshift(x); })" js_unshift :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) -foreign import javascript unsafe "$1.shift()" +foreign import javascript unsafe "((x) => { return x.shift(); })" js_shift :: SomeJSArray m -> State# s -> (# State# s, JSVal #) -foreign import javascript unsafe "$1.reverse()" +foreign import javascript unsafe "((x) => { return x.reverse(); })" js_reverse :: SomeJSArray m -> State# s -> (# State# s, () #) -foreign import javascript unsafe "h$toHsListJSVal($1)" +foreign import javascript unsafe "h$toHsListJSVal" js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, Exts.Any #) -foreign import javascript unsafe "h$toHsListJSVal($1)" +foreign import javascript unsafe "h$toHsListJSVal" js_fromJSArrayPure :: JSArray -> Exts.Any -- [JSVal] -foreign import javascript unsafe "h$fromHsListJSVal($1)" +foreign import javascript unsafe "h$fromHsListJSVal" js_toJSArray :: Exts.Any -> State# s -> (# State# s, SomeJSArray m #) -foreign import javascript unsafe "h$fromHsListJSVal($1)" +foreign import javascript unsafe "h$fromHsListJSVal" js_toJSArrayPure :: Exts.Any -> JSArray diff --git a/JavaScript/Cast.hs b/JavaScript/Cast.hs --- a/JavaScript/Cast.hs +++ b/JavaScript/Cast.hs @@ -5,7 +5,7 @@ , unsafeCast ) where -import GHCJS.Prim +import GHC.JS.Prim cast :: forall a. Cast a => JSVal -> Maybe a cast x | js_checkCast x (instanceRef (undefined :: a)) = Just (unsafeWrap x) @@ -23,4 +23,4 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1 instanceof $2" js_checkCast :: JSVal -> JSVal -> Bool + "((x,y) => { return x instanceof y; })" js_checkCast :: JSVal -> JSVal -> Bool diff --git a/JavaScript/JSON/Types/Generic.hs b/JavaScript/JSON/Types/Generic.hs --- a/JavaScript/JSON/Types/Generic.hs +++ b/JavaScript/JSON/Types/Generic.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, DefaultSignatures, EmptyDataDecls, FlexibleInstances, - FunctionalDependencies, KindSignatures, OverlappingInstances, + FunctionalDependencies, KindSignatures, MonoLocalBinds, ScopedTypeVariables, TypeOperators, UndecidableInstances, ViewPatterns, NamedFieldPuns, FlexibleContexts, PatternGuards, RecordWildCards, DataKinds #-} @@ -28,7 +28,7 @@ import qualified JavaScript.JSON.Types.Internal as I import qualified JavaScript.Array as JSA import qualified JavaScript.Array.ST as JSAST -import Data.Bits +import Data.Bits hiding (And) import Data.DList (DList, toList, empty) @@ -39,6 +39,7 @@ -- import Data.Text (Text, pack, unpack) import GHC.Generics +import Data.Kind {- import qualified Data.HashMap.Strict as H @@ -63,7 +64,7 @@ gToJSON _opts _ = emptyArray {-# INLINE gToJSON #-} -instance (ConsToJSON a) => GToJSON (C1 c a) where +instance {-# OVERLAPS #-} (ConsToJSON a) => GToJSON (C1 c a) where -- Constructors need to be encoded differently depending on whether they're -- a record or not. This distinction is made by 'constToJSON': gToJSON opts = consToJSON opts . unM1 @@ -265,7 +266,7 @@ ixR = ix + lenL {-# INLINE writeProduct #-} -instance (GToJSON a) => WriteProduct a where +instance {-# OVERLAPPABLE #-} (GToJSON a) => WriteProduct a where writeProduct opts mv ix _ = (\(SomeValue v) -> JSAST.write ix v mv) . gToJSON opts {-# INLINE writeProduct #-} @@ -309,7 +310,7 @@ | otherwise = typeMismatch "unit constructor (U1)" v {-# INLINE gParseJSON #-} -instance (ConsFromJSON a) => GFromJSON (C1 c a) where +instance {-# OVERLAPS #-} (ConsFromJSON a) => GFromJSON (C1 c a) where -- Constructors need to be decoded differently depending on whether they're -- a record or not. This distinction is made by consParseJSON: gParseJSON opts = fmap M1 . consParseJSON opts @@ -568,7 +569,7 @@ -------------------------------------------------------------------------------- -class IsRecord (f :: * -> *) isRecord | f -> isRecord +class IsRecord (f :: Type -> Type) isRecord | f -> isRecord instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord #if MIN_VERSION_base(4,9,0) @@ -582,7 +583,7 @@ -------------------------------------------------------------------------------- -class AllNullary (f :: * -> *) allNullary | f -> allNullary +class AllNullary (f :: Type -> Type) allNullary | f -> allNullary instance ( AllNullary a allNullaryL , AllNullary b allNullaryR @@ -609,7 +610,7 @@ newtype Tagged s b = Tagged {unTagged :: b} -newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b} +newtype Tagged2 (s :: Type -> Type) b = Tagged2 {unTagged2 :: b} -------------------------------------------------------------------------------- diff --git a/JavaScript/JSON/Types/Instances.hs b/JavaScript/JSON/Types/Instances.hs --- a/JavaScript/JSON/Types/Instances.hs +++ b/JavaScript/JSON/Types/Instances.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, - GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances, + GeneralizedNewtypeDeriving, IncoherentInstances, OverloadedStrings, UndecidableInstances, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -68,7 +68,6 @@ import Data.Scientific (Scientific) import qualified Data.Scientific as Scientific (coefficient, base10Exponent, fromFloatDigits, toRealFloat) -import Data.Attoparsec.Number (Number(..)) import Data.Fixed import Data.Hashable (Hashable(..)) import Data.Int (Int8, Int16, Int32, Int64) @@ -77,7 +76,7 @@ import Data.Ratio (Ratio, (%), numerator, denominator) import Data.Text (Text, pack, unpack) import Data.Time (UTCTime, ZonedTime(..), TimeZone(..)) -import Data.Time.Format (FormatTime, formatTime, parseTime) +import Data.Time.Format (FormatTime, formatTime, parseTimeM) import Data.Traversable (traverse) import Data.Vector (Vector) import Data.Word (Word, Word8, Word16, Word32, Word64) @@ -491,7 +490,7 @@ parseJSON = withJSString "DotNetTime" $ \t -> let (s,m) = JSS.splitAt (JSS.length t - 5) t t' = JSS.concat [s,".",m] - in case parseTime defaultTimeLocale "/Date(%s%Q)/" (JSS.unpack t') of + in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (JSS.unpack t') of Just d -> pure (DotNetTime d) _ -> fail "could not parse .NET time" {-# INLINE parseJSON #-} @@ -513,7 +512,7 @@ <|> fail "could not parse ECMA-262 ISO-8601 date" where tryFormat f = - case parseTime defaultTimeLocale f (JSS.unpack t) of + case parseTimeM True defaultTimeLocale f (JSS.unpack t) of Just d -> pure d Nothing -> empty tryFormats = foldr1 (<|>) . map tryFormat @@ -536,7 +535,7 @@ instance FromJSON UTCTime where parseJSON = withJSString "UTCTime" $ \t -> - case parseTime defaultTimeLocale "%FT%T%QZ" (JSS.unpack t) of + case parseTimeM True defaultTimeLocale "%FT%T%QZ" (JSS.unpack t) of Just d -> pure d _ -> fail "could not parse ISO-8601 date" {-# INLINE parseJSON #-} @@ -1063,15 +1062,6 @@ | isNaN d || isInfinite d = nullValue | otherwise = doubleValue (realToFrac d) {-# INLINE realFloatToJSON #-} - -scientificToNumber :: Scientific -> Number -scientificToNumber s - | e < 0 = D $ Scientific.toRealFloat s - | otherwise = I $ c * 10 ^ e - where - e = Scientific.base10Exponent s - c = Scientific.coefficient s -{-# INLINE scientificToNumber #-} parseRealFloat :: RealFloat a => String -> Value -> Parser a parseRealFloat _ (match -> Number d) = pure $ realToFrac d diff --git a/JavaScript/JSON/Types/Internal.hs b/JavaScript/JSON/Types/Internal.hs --- a/JavaScript/JSON/Types/Internal.hs +++ b/JavaScript/JSON/Types/Internal.hs @@ -8,7 +8,6 @@ ( -- * Core JSON types SomeValue(..), Value, MutableValue , SomeValue'(..), Value', MutableValue' - , MutableValue, MutableValue' , emptyArray, isEmptyArray , Pair , Object, MutableObject @@ -72,7 +71,7 @@ import qualified GHCJS.Foreign as F import GHCJS.Internal.Types import GHCJS.Types -import qualified GHCJS.Prim.Internal.Build as IB +import qualified GHC.JS.Prim.Internal.Build as IB import qualified JavaScript.Array as A import qualified JavaScript.Array.Internal as AI @@ -264,47 +263,47 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$r = [];" js_emptyArray :: Value + "(() => { return []; })" js_emptyArray :: Value foreign import javascript unsafe - "$r = {};" js_emptyObject :: Object + "(() => { return {}; })" js_emptyObject :: Object foreign import javascript unsafe - "$1.length === 0" js_isEmptyArray :: Value -> Bool + "((x) => { return x.length === 0; })" js_isEmptyArray :: Value -> Bool foreign import javascript unsafe - "$r = true;" js_trueValue :: Value + "(() => { return true; })" js_trueValue :: Value foreign import javascript unsafe - "$r = false;" js_falseValue :: Value + "(() => { return false; })" js_falseValue :: Value -- ----------------------------------------------------------------------------- -- types must be checked before using these conversions foreign import javascript unsafe - "$r = $1;" js_jsvalToDouble :: JSVal -> Double + "((x) => { return x; })" js_jsvalToDouble :: JSVal -> Double foreign import javascript unsafe - "$r = $1;" js_jsvalToBool :: JSVal -> Bool + "((x) => { return x; })" js_jsvalToBool :: JSVal -> Bool -- ----------------------------------------------------------------------------- -- various lookups foreign import javascript unsafe - "$2[$1]" + "((x,y) => { return y[x]; })" js_lookupDictPure :: JSString -> Object -> JSVal foreign import javascript unsafe - "typeof($2)==='object'?$2[$1]:undefined" + "((x,y) => { return typeof(y) === 'object' ? y[x] : undefined; })" js_lookupDictPureSafe :: JSString -> Value -> JSVal foreign import javascript unsafe - "$2[$1]" js_lookupArrayPure :: Int -> A.JSArray -> JSVal + "((x,y) => { return y[x]; })" js_lookupArrayPure :: Int -> A.JSArray -> JSVal foreign import javascript unsafe - "h$isArray($2) ? $2[$1] : undefined" + "((x,y) => { return h$isArray(y) ? y[x] : undefined; })" js_lookupArrayPureSafe :: Int -> Value -> JSVal foreign import javascript unsafe - "$r = $1;" + "((x) => { return x; })" js_doubleToJSVal :: Double -> JSVal foreign import javascript unsafe - "JSON.decode(JSON.encode($1))" + "((x) => { return JSON.decode(JSON.encode(x)); })" js_clone :: SomeValue m0 -> IO (SomeValue m1) -- ----------------------------------------------------------------------------- @@ -324,5 +323,5 @@ js_listAssocs :: SomeObject m -> Exts.State# s -> (# Exts.State# s, Exts.Any {- [(JSString, Value)] -} #) foreign import javascript unsafe - "JSON.stringify($1)" + "JSON.stringify" js_encode :: Value -> JSString diff --git a/JavaScript/Object/Internal.hs b/JavaScript/Object/Internal.hs --- a/JavaScript/Object/Internal.hs +++ b/JavaScript/Object/Internal.hs @@ -21,7 +21,7 @@ import Data.JSString import Data.Typeable -import qualified GHCJS.Prim as Prim +import qualified GHC.JS.Prim as Prim import GHCJS.Types import qualified JavaScript.Array as JA @@ -73,17 +73,17 @@ -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "$r = {};" +foreign import javascript unsafe "(() => { return {}; })" js_create :: IO Object -foreign import javascript safe "$2[$1]" +foreign import javascript safe "((x,y) => { return y[x]; })" js_getProp :: JSString -> Object -> IO JSVal -foreign import javascript unsafe "$2[$1]" +foreign import javascript unsafe "((x,y) => { return y[x]; })" js_unsafeGetProp :: JSString -> Object -> IO JSVal -foreign import javascript safe "$3[$1] = $2" +foreign import javascript safe "((x,y,z) => { z[x] = y; })" js_setProp :: JSString -> JSVal -> Object -> IO () -foreign import javascript unsafe "$3[$1] = $2" +foreign import javascript unsafe "((x,y,z) => { z[x] = y; })" js_unsafeSetProp :: JSString -> JSVal -> Object -> IO () -foreign import javascript unsafe "$1 instanceof $2" +foreign import javascript unsafe "((x,y) => { return x instanceof y; })" js_isInstanceOf :: Object -> JSVal -> Bool foreign import javascript unsafe "h$allProps" js_allProps :: Object -> IO JSArray diff --git a/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/JavaScript/TypedArray/ArrayBuffer/Internal.hs --- a/JavaScript/TypedArray/ArrayBuffer/Internal.hs +++ b/JavaScript/TypedArray/ArrayBuffer/Internal.hs @@ -38,16 +38,16 @@ -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "$1.byteLength" js_byteLength :: SomeArrayBuffer any -> Int + "((x) => { return x.byteLength; })" js_byteLength :: SomeArrayBuffer any -> Int foreign import javascript unsafe - "new ArrayBuffer($1)" js_create :: Int -> State# s -> (# State# s, JSVal #) + "((x) => { return new ArrayBuffer(x); })" js_create :: Int -> State# s -> (# State# s, JSVal #) foreign import javascript unsafe - "$2.slice($1)" js_slice1 :: Int -> JSVal -> State# s -> (# State# s, JSVal #) + "((x,y) => { return y.slice(x); })" js_slice1 :: Int -> JSVal -> State# s -> (# State# s, JSVal #) -- ---------------------------------------------------------------------------- -- immutable non-IO slice foreign import javascript unsafe - "$2.slice($1)" js_slice1_imm :: Int -> SomeArrayBuffer any -> SomeArrayBuffer any + "((x,y) => { return y.slice(x); })" js_slice1_imm :: Int -> SomeArrayBuffer any -> SomeArrayBuffer any foreign import javascript unsafe - "$3.slice($1,$2)" js_slice_imm :: Int -> Int -> SomeArrayBuffer any -> SomeArrayBuffer any + "((x,y,z) => { return z.slice(x,y); })" js_slice_imm :: Int -> Int -> SomeArrayBuffer any -> SomeArrayBuffer any diff --git a/JavaScript/TypedArray/DataView.hs b/JavaScript/TypedArray/DataView.hs --- a/JavaScript/TypedArray/DataView.hs +++ b/JavaScript/TypedArray/DataView.hs @@ -40,7 +40,7 @@ import Data.Int import Data.Word -import GHCJS.Prim +import GHC.JS.Prim import JavaScript.TypedArray.ArrayBuffer.Internal ( SomeArrayBuffer(..), ArrayBuffer, MutableArrayBuffer ) diff --git a/JavaScript/TypedArray/DataView/Internal.hs b/JavaScript/TypedArray/DataView/Internal.hs --- a/JavaScript/TypedArray/DataView/Internal.hs +++ b/JavaScript/TypedArray/DataView/Internal.hs @@ -18,7 +18,7 @@ import GHC.Exts ( State# ) -import GHCJS.Prim +import GHC.JS.Prim import GHCJS.Internal.Types import JavaScript.TypedArray.ArrayBuffer.Internal @@ -33,115 +33,115 @@ #define JSU foreign import javascript unsafe #define JSS foreign import javascript safe -JSU "new DataView($1)" +JSU "((x) => { return new DataView(x); })" js_dataView1 :: JSVal -> JSVal -JSS "new DataView($2,$1)" +JSS "((x,y) => { return new DataView(y,x); })" js_dataView2 :: Int -> JSVal -> SomeDataView m -JSU "new DataView($2,$1)" +JSU "((x,y) => { return new DataView(y,x); })" js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m -JSS "new DataView($3,$1,$2)" +JSS "((x,y,z) => { return new DataView(z,x,y); })" js_dataView :: Int -> Int -> JSVal -> SomeDataView m -JSU "new DataView($3,$1,$2)" +JSU "((x,y,z) => { return new DataView(z,x,y); })" js_unsafeDataView :: Int -> Int -> JSVal -> JSVal -JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))" +JSU "((x) => { return new DataView(x.buffer.slice(x.byteOffset, x.byteLength)); })" js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1) -- ---------------------------------------------------------------------------- -- immutable getters -JSU "$2.getInt8($1)" js_i_unsafeGetInt8 :: Int -> DataView -> Int8 -JSU "$2.getUint8($1)" js_i_unsafeGetUint8 :: Int -> DataView -> Word8 -JSU "$2.getInt16($1)" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16 -JSU "$2.getInt32($1)" js_i_unsafeGetInt32BE :: Int -> DataView -> Int -JSU "$2.getUint16($1)" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16 -JSU "$2.getUint32($1)|0" js_i_unsafeGetUint32BE :: Int -> DataView -> Word -JSU "$2.getFloat32($1)" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double -JSU "$2.getFloat64($1)" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double -JSU "$2.getInt16($1,true)" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16 -JSU "$2.getInt32($1,true)" js_i_unsafeGetInt32LE :: Int -> DataView -> Int -JSU "$2.getUint16($1,true)" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16 -JSU "$2.getUint32($1,true)|0" js_i_unsafeGetUint32LE :: Int -> DataView -> Word -JSU "$2.getFloat32($1,true)" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double -JSU "$2.getFloat64($1,true)" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double +JSU "((x,y) => { return y.getInt8(x); })" js_i_unsafeGetInt8 :: Int -> DataView -> Int8 +JSU "((x,y) => { return y.getUint8(x); })" js_i_unsafeGetUint8 :: Int -> DataView -> Word8 +JSU "((x,y) => { return y.getInt16(x); })" js_i_unsafeGetInt16BE :: Int -> DataView -> Int16 +JSU "((x,y) => { return y.getInt32(x); })" js_i_unsafeGetInt32BE :: Int -> DataView -> Int +JSU "((x,y) => { return y.getUint16(x); })" js_i_unsafeGetUint16BE :: Int -> DataView -> Word16 +JSU "((x,y) => { return y.getUint32(x)|0; })" js_i_unsafeGetUint32BE :: Int -> DataView -> Word +JSU "((x,y) => { return y.getFloat32(x); })" js_i_unsafeGetFloat32BE :: Int -> DataView -> Double +JSU "((x,y) => { return y.getFloat64(x); })" js_i_unsafeGetFloat64BE :: Int -> DataView -> Double +JSU "((x,y) => { return y.getInt16(x,true); })" js_i_unsafeGetInt16LE :: Int -> DataView -> Int16 +JSU "((x,y) => { return y.getInt32(x,true); })" js_i_unsafeGetInt32LE :: Int -> DataView -> Int +JSU "((x,y) => { return y.getUint16(x,true); })" js_i_unsafeGetUint16LE :: Int -> DataView -> Word16 +JSU "((x,y) => { return y.getUint32(x,true)|0; })" js_i_unsafeGetUint32LE :: Int -> DataView -> Word +JSU "((x,y) => { return y.getFloat32(x,true); })" js_i_unsafeGetFloat32LE :: Int -> DataView -> Double +JSU "((x,y) => { return y.getFloat64(x,true); })" js_i_unsafeGetFloat64LE :: Int -> DataView -> Double -JSS "$2.getInt8($1)" js_i_getInt8 :: Int -> DataView -> Int8 -JSS "$2.getUint8($1)" js_i_getUint8 :: Int -> DataView -> Word8 -JSS "$2.getInt16($1)" js_i_getInt16BE :: Int -> DataView -> Int16 -JSS "$2.getInt32($1)" js_i_getInt32BE :: Int -> DataView -> Int -JSS "$2.getUint16($1)" js_i_getUint16BE :: Int -> DataView -> Word16 -JSS "$2.getUint32($1)|0" js_i_getUint32BE :: Int -> DataView -> Word -JSS "$2.getFloat32($1)" js_i_getFloat32BE :: Int -> DataView -> Double -JSS "$2.getFloat64($1)" js_i_getFloat64BE :: Int -> DataView -> Double -JSS "$2.getInt16($1,true)" js_i_getInt16LE :: Int -> DataView -> Int16 -JSS "$2.getInt32($1,true)" js_i_getInt32LE :: Int -> DataView -> Int -JSS "$2.getUint16($1,true)" js_i_getUint16LE :: Int -> DataView -> Word16 -JSS "$2.getUint32($1,true)|0" js_i_getUint32LE :: Int -> DataView -> Word -JSS "$2.getFloat32($1,true)" js_i_getFloat32LE :: Int -> DataView -> Double -JSS "$2.getFloat64($1,true)" js_i_getFloat64LE :: Int -> DataView -> Double +JSS "((x,y) => { return y.getInt8(x); })" js_i_getInt8 :: Int -> DataView -> Int8 +JSS "((x,y) => { return y.getUint8(x); })" js_i_getUint8 :: Int -> DataView -> Word8 +JSS "((x,y) => { return y.getInt16(x); })" js_i_getInt16BE :: Int -> DataView -> Int16 +JSS "((x,y) => { return y.getInt32(x); })" js_i_getInt32BE :: Int -> DataView -> Int +JSS "((x,y) => { return y.getUint16(x); })" js_i_getUint16BE :: Int -> DataView -> Word16 +JSS "((x,y) => { return y.getUint32(x)|0; })" js_i_getUint32BE :: Int -> DataView -> Word +JSS "((x,y) => { return y.getFloat32(x); })" js_i_getFloat32BE :: Int -> DataView -> Double +JSS "((x,y) => { return y.getFloat64(x); })" js_i_getFloat64BE :: Int -> DataView -> Double +JSS "((x,y) => { return y.getInt16(x,true); })" js_i_getInt16LE :: Int -> DataView -> Int16 +JSS "((x,y) => { return y.getInt32(x,true); })" js_i_getInt32LE :: Int -> DataView -> Int +JSS "((x,y) => { return y.getUint16(x,true); })" js_i_getUint16LE :: Int -> DataView -> Word16 +JSS "((x,y) => { return y.getUint32(x,true)|0; })" js_i_getUint32LE :: Int -> DataView -> Word +JSS "((x,y) => { return y.getFloat32(x,true); })" js_i_getFloat32LE :: Int -> DataView -> Double +JSS "((x,y) => { return y.getFloat64(x,true); })" js_i_getFloat64LE :: Int -> DataView -> Double -- ---------------------------------------------------------------------------- -- mutable getters -JSU "$2.getInt8($1)" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #) -JSU "$2.getUint8($1)" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #) -JSU "$2.getInt16($1)" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) -JSU "$2.getInt32($1)" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) -JSU "$2.getUint16($1)" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) -JSU "$2.getUint32($1)|0" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) -JSU "$2.getFloat32($1)" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -JSU "$2.getFloat64($1)" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -JSU "$2.getInt16($1,true)" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) -JSU "$2.getInt32($1,true)" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) -JSU "$2.getUint16($1,true)" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) -JSU "$2.getUint32($1,true)|0" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) -JSU "$2.getFloat32($1,true)" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -JSU "$2.getFloat64($1,true)" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSU "((x,y) => { return y.getInt8(x); })" js_m_unsafeGetInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #) +JSU "((x,y) => { return y.getUint8(x); })" js_m_unsafeGetUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #) +JSU "((x,y) => { return y.getInt16(x); })" js_m_unsafeGetInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +JSU "((x,y) => { return y.getInt32(x); })" js_m_unsafeGetInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +JSU "((x,y) => { return y.getUint16(x); })" js_m_unsafeGetUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +JSU "((x,y) => { return y.getUint32(x)|0; })" js_m_unsafeGetUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +JSU "((x,y) => { return y.getFloat32(x); })" js_m_unsafeGetFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSU "((x,y) => { return y.getFloat64(x); })" js_m_unsafeGetFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSU "((x,y) => { return y.getInt16(x,true); })" js_m_unsafeGetInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +JSU "((x,y) => { return y.getInt32(x,true); })" js_m_unsafeGetInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +JSU "((x,y) => { return y.getUint16(x,true); })" js_m_unsafeGetUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +JSU "((x,y) => { return y.getUint32(x,true)|0; })" js_m_unsafeGetUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +JSU "((x,y) => { return y.getFloat32(x,true); })" js_m_unsafeGetFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSU "((x,y) => { return y.getFloat64(x,true); })" js_m_unsafeGetFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -JSS "$2.getInt8($1)" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #) -JSS "$2.getUint8($1)" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #) -JSS "$2.getInt16($1)" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) -JSS "$2.getInt32($1)" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) -JSS "$2.getUint16($1)" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) -JSS "$2.getUint32($1)|0" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) -JSS "$2.getFloat32($1)" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -JSS "$2.getFloat64($1)" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -JSS "$2.getInt16($1,true)" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) -JSS "$2.getInt32($1,true)" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) -JSS "$2.getUint16($1,true)" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) -JSS "$2.getUint32($1,true)|0" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) -JSS "$2.getFloat32($1,true)" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -JSS "$2.getFloat64($1,true)" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSS "((x,y) => { return y.getInt8(x); })" js_m_getInt8 :: Int -> SomeDataView m -> State# s -> (# State# s, Int8 #) +JSS "((x,y) => { return y.getUint8(x); })" js_m_getUint8 :: Int -> SomeDataView m -> State# s -> (# State# s, Word8 #) +JSS "((x,y) => { return y.getInt16(x); })" js_m_getInt16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +JSS "((x,y) => { return y.getInt32(x); })" js_m_getInt32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +JSS "((x,y) => { return y.getUint16(x); })" js_m_getUint16BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +JSS "((x,y) => { return y.getUint32(x)|0; })" js_m_getUint32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +JSS "((x,y) => { return y.getFloat32(x); })" js_m_getFloat32BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSS "((x,y) => { return y.getFloat64(x); })" js_m_getFloat64BE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSS "((x,y) => { return y.getInt16(x,true); })" js_m_getInt16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int16 #) +JSS "((x,y) => { return y.getInt32(x,true); })" js_m_getInt32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Int #) +JSS "((x,y) => { return y.getUint16(x,true); })" js_m_getUint16LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word16 #) +JSS "((x,y) => { return y.getUint32(x,true)|0; })" js_m_getUint32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Word #) +JSS "((x,y) => { return y.getFloat32(x,true); })" js_m_getFloat32LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) +JSS "((x,y) => { return y.getFloat64(x,true); })" js_m_getFloat64LE :: Int -> SomeDataView m -> State# s -> (# State# s, Double #) -- ---------------------------------------------------------------------------- -- mutable setters -JSU "$3.setInt8($1,$2)" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setUint8($1,$2)" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setInt16($1,$2)" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setInt32($1,$2)" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setUint16($1,$2)" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setUint32($1,$2)" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setFloat32($1,$2)" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setFloat64($1,$2)" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setInt16($1,$2,true)" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setInt32($1,$2,true)" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setUint16($1,$2,true)" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setUint32($1,$2,true)" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setFloat32($1,$2,true)" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) -JSU "$3.setFloat64($1,$2,true)" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setInt8(x,y); })" js_unsafeSetInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setUint8(x,y); })" js_unsafeSetUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setInt16(x,y); })" js_unsafeSetInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setInt32(x,y); })" js_unsafeSetInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setUint16(x,y); })" js_unsafeSetUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setUint32(x,y); })" js_unsafeSetUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setFloat32(x,y); })" js_unsafeSetFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setFloat64(x,y); })" js_unsafeSetFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setInt16(x,y,true); })" js_unsafeSetInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setInt32(x,y,true); })" js_unsafeSetInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setUint16(x,y,true); })" js_unsafeSetUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setUint32(x,y,true); })" js_unsafeSetUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setFloat32(x,y,true); })" js_unsafeSetFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSU "((x,y,z) => { x.setFloat64(x,y,true); })" js_unsafeSetFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setInt8($1,$2)" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setUint8($1,$2)" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setInt16($1,$2)" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setInt32($1,$2)" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setUint16($1,$2)" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setUint32($1,$2)" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setFloat32($1,$2)" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setFloat64($1,$2)" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setInt16($1,$2,true)" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setInt32($1,$2,true)" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setUint16($1,$2,true)" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setUint32($1,$2,true)" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setFloat32($1,$2,true)" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) -JSS "$3.setFloat64($1,$2,true)" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setInt8(x,y); })" js_setInt8 :: Int -> Int8 -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setUint8(x,y); })" js_setUint8 :: Int -> Word8 -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setInt16(x,y); })" js_setInt16BE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setInt32(x,y); })" js_setInt32BE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setUint16(x,y); })" js_setUint16BE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setUint32(x,y); })" js_setUint32BE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setFloat32(x,y); })" js_setFloat32BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setFloat64(x,y); })" js_setFloat64BE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setInt16(x,y,true); })" js_setInt16LE :: Int -> Int16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setInt32(x,y,true); })" js_setInt32LE :: Int -> Int -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setUint16(x,y,true); })" js_setUint16LE :: Int -> Word16 -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setUint32(x,y,true); })" js_setUint32LE :: Int -> Word -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setFloat32(x,y,true); })" js_setFloat32LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) +JSS "((x,y,z) => { x.setFloat64(x,y,true); })" js_setFloat64LE :: Int -> Double -> SomeDataView m -> State# s -> (# State# s, () #) diff --git a/JavaScript/TypedArray/DataView/ST.hs b/JavaScript/TypedArray/DataView/ST.hs --- a/JavaScript/TypedArray/DataView/ST.hs +++ b/JavaScript/TypedArray/DataView/ST.hs @@ -28,7 +28,7 @@ import GHC.ST -import GHCJS.Prim +import GHC.JS.Prim import JavaScript.TypedArray.ArrayBuffer.ST import JavaScript.TypedArray.ArrayBuffer.Internal as AI diff --git a/JavaScript/TypedArray/Internal.hs b/JavaScript/TypedArray/Internal.hs --- a/JavaScript/TypedArray/Internal.hs +++ b/JavaScript/TypedArray/Internal.hs @@ -7,6 +7,7 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} @@ -48,10 +49,10 @@ instance TypedArray IOInt8Array where index i a = IO (indexI8 i a) unsafeIndex i a = IO (unsafeIndexI8 i a) - setIndex i (I8# x) a = IO (setIndexI i x a) - unsafeSetIndex i (I8# x) a = IO (unsafeSetIndexI i x a) - indexOf s (I8# x) a = IO (indexOfI s x a) - lastIndexOf s (I8# x) a = IO (lastIndexOfI s x a) + setIndex i (I8# x) a = IO (setIndexI i (int8ToInt# x) a) + unsafeSetIndex i (I8# x) a = IO (unsafeSetIndexI i (int8ToInt# x) a) + indexOf s (I8# x) a = IO (indexOfI s (int8ToInt# x) a) + lastIndexOf s (I8# x) a = IO (lastIndexOfI s (int8ToInt# x) a) create l = IO (js_createInt8Array l) fromArray a = int8ArrayFrom a fromArrayBuffer b = undefined @@ -59,10 +60,10 @@ instance TypedArray IOInt16Array where index i a = IO (indexI16 i a) unsafeIndex i a = IO (unsafeIndexI16 i a) - setIndex i (I16# x) a = IO (setIndexI i x a) - unsafeSetIndex i (I16# x) a = IO (unsafeSetIndexI i x a) - indexOf s (I16# x) a = IO (indexOfI s x a) - lastIndexOf s (I16# x) a = IO (lastIndexOfI s x a) + setIndex i (I16# x) a = IO (setIndexI i (int16ToInt# x) a) + unsafeSetIndex i (I16# x) a = IO (unsafeSetIndexI i (int16ToInt# x) a) + indexOf s (I16# x) a = IO (indexOfI s (int16ToInt# x) a) + lastIndexOf s (I16# x) a = IO (lastIndexOfI s (int16ToInt# x) a) create l = IO (js_createInt16Array l) fromArray a = int16ArrayFrom a fromArrayBuffer b = undefined @@ -81,10 +82,10 @@ instance TypedArray IOUint8ClampedArray where index i a = IO (indexW8 i a) unsafeIndex i a = IO (unsafeIndexW8 i a) - setIndex i (W8# x) a = IO (setIndexW i x a) - unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i x a) - indexOf s (W8# x) a = IO (indexOfW s x a) - lastIndexOf s (W8# x) a = IO (lastIndexOfW s x a) + setIndex i (W8# x) a = IO (setIndexW i (word8ToWord# x) a) + unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i (word8ToWord# x) a) + indexOf s (W8# x) a = IO (indexOfW s (word8ToWord# x) a) + lastIndexOf s (W8# x) a = IO (lastIndexOfW s (word8ToWord# x) a) create l = IO (js_createUint8ClampedArray l) fromArray a = uint8ClampedArrayFrom a fromArrayBuffer b = undefined @@ -92,10 +93,10 @@ instance TypedArray IOUint8Array where index i a = IO (indexW8 i a) unsafeIndex i a = IO (unsafeIndexW8 i a) - setIndex i (W8# x) a = IO (setIndexW i x a) - unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i x a) - indexOf s (W8# x) a = IO (indexOfW s x a) - lastIndexOf s (W8# x) a = IO (lastIndexOfW s x a) + setIndex i (W8# x) a = IO (setIndexW i (word8ToWord# x) a) + unsafeSetIndex i (W8# x) a = IO (unsafeSetIndexW i (word8ToWord# x) a) + indexOf s (W8# x) a = IO (indexOfW s (word8ToWord# x) a) + lastIndexOf s (W8# x) a = IO (lastIndexOfW s (word8ToWord# x) a) create l = IO (js_createUint8Array l) fromArray a = uint8ArrayFrom a fromArrayBuffer b = undefined @@ -103,10 +104,10 @@ instance TypedArray IOUint16Array where index i a = IO (indexW16 i a) unsafeIndex i a = IO (unsafeIndexW16 i a) - setIndex i (W16# x) a = IO (setIndexW i x a) - unsafeSetIndex i (W16# x) a = IO (unsafeSetIndexW i x a) - indexOf s (W16# x) a = IO (indexOfW s x a) - lastIndexOf s (W16# x) a = IO (lastIndexOfW s x a) + setIndex i (W16# x) a = IO (setIndexW i (word16ToWord# x) a) + unsafeSetIndex i (W16# x) a = IO (unsafeSetIndexW i (word16ToWord# x) a) + indexOf s (W16# x) a = IO (indexOfW s (word16ToWord# x) a) + lastIndexOf s (W16# x) a = IO (lastIndexOfW s (word16ToWord# x) a) create l = IO (js_createUint16Array l) fromArray a = uint16ArrayFrom a fromArrayBuffer b = undefined @@ -163,11 +164,11 @@ {-# INLINE indexI #-} indexI16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int16 #) -indexI16 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I16# v #) +indexI16 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I16# (intToInt16# v) #) {-# INLINE indexI16 #-} indexI8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int8 #) -indexI8 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I8# v #) +indexI8 a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I8# (intToInt8# v) #) {-# INLINE indexI8 #-} indexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #) @@ -175,11 +176,11 @@ {-# INLINE indexW #-} indexW16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word16 #) -indexW16 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W16# v #) +indexW16 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W16# (wordToWord16# v) #) {-# INLINE indexW16 #-} indexW8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word8 #) -indexW8 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W8# v #) +indexW8 a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W8# (wordToWord8# v) #) {-# INLINE indexW8 #-} indexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) @@ -193,11 +194,11 @@ {-# INLINE unsafeIndexI #-} unsafeIndexI16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int16 #) -unsafeIndexI16 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I16# v #) +unsafeIndexI16 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I16# (intToInt16# v) #) {-# INLINE unsafeIndexI16 #-} unsafeIndexI8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int8 #) -unsafeIndexI8 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I8# v #) +unsafeIndexI8 a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I8# (intToInt8# v) #) {-# INLINE unsafeIndexI8 #-} unsafeIndexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #) @@ -205,11 +206,11 @@ {-# INLINE unsafeIndexW #-} unsafeIndexW16 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word16 #) -unsafeIndexW16 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W16# v #) +unsafeIndexW16 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W16# (wordToWord16# v) #) {-# INLINE unsafeIndexW16 #-} unsafeIndexW8 :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word8 #) -unsafeIndexW8 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W8# v #) +unsafeIndexW8 a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W8# (wordToWord8# v) #) {-# INLINE unsafeIndexW8 #-} unsafeIndexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) @@ -351,70 +352,70 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1.length" js_length :: SomeTypedArray e m -> Int + "((x) => { return x.length; })" js_length :: SomeTypedArray e m -> Int foreign import javascript unsafe - "$1.byteLength" js_byteLength :: SomeTypedArray e m -> Int + "((x) => { return x.byteLength; })" js_byteLength :: SomeTypedArray e m -> Int foreign import javascript unsafe - "$1.byteOffset" js_byteOffset :: SomeTypedArray e m -> Int + "((x) => { return x.byteOffset; })" js_byteOffset :: SomeTypedArray e m -> Int foreign import javascript unsafe - "$1.buffer" js_buffer :: SomeTypedArray e m -> SomeArrayBuffer m + "((x) => { return x.buffer; })" js_buffer :: SomeTypedArray e m -> SomeArrayBuffer m foreign import javascript unsafe - "$3.subarray($1,$2)" + "((x,y,z) => { return z.subarray(x,y); })" js_subarray :: Int -> Int -> SomeTypedArray e m -> SomeTypedArray e m foreign import javascript safe - "$3.set($1,$2)" + "((x,y,z) => { z.set(x,y); })" js_set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #) foreign import javascript unsafe - "$3.set($1,$2)" + "((x,y,z) => { z.set(x,y); })" js_unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #) foreign import javascript unsafe - "$1.BYTES_PER_ELEMENT" + "((x) => { return x.BYTES_PER_ELEMENT; })" js_elemSize :: SomeTypedArray e m -> Int -- ----------------------------------------------------------------------------- -- index foreign import javascript safe - "$2[$1]" js_indexI + "((x,y) => { return y[x]; })" js_indexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #) foreign import javascript safe - "$2[$1]" js_indexW + "((x,y) => { return y[x]; })" js_indexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #) foreign import javascript safe - "$2[$1]" js_indexD + "((x,y) => { return y[x]; })" js_indexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) foreign import javascript unsafe - "$2[$1]" js_unsafeIndexI + "((x,y) => { return y[x]; })" js_unsafeIndexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #) foreign import javascript unsafe - "$2[$1]" js_unsafeIndexW + "((x,y) => { return y[x]; })" js_unsafeIndexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #) foreign import javascript unsafe - "$2[$1]" js_unsafeIndexD + "((x,y) => { return y[x]; })" js_unsafeIndexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) -- ----------------------------------------------------------------------------- -- setIndex foreign import javascript safe - "$3[$1] = $2;" js_setIndexI + "((x,y,z) => { z[x] = y; })" js_setIndexI :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) foreign import javascript safe - "$3[$1] = $2;" js_setIndexW + "((x,y,z) => { z[x] = y; })" js_setIndexW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) foreign import javascript safe - "$3[$1] = $2;" js_setIndexD + "((x,y,z) => { z[x] = y; })" js_setIndexD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) foreign import javascript unsafe - "$3[$1] = $2;" js_unsafeSetIndexI + "((x,y,z) => { z[x] = y; })" js_unsafeSetIndexI :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) foreign import javascript unsafe - "$3[$1] = $2;" js_unsafeSetIndexW + "((x,y,z) => { z[x] = y; })" js_unsafeSetIndexW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) foreign import javascript unsafe - "$3[$1] = $2;" js_unsafeSetIndexD + "((x,y,z) => { z[x] = y; })" js_unsafeSetIndexD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) -- ------------------------------------------------------------------------------ @@ -443,94 +444,94 @@ -- create foreign import javascript unsafe - "new Int8Array($1)" + "((x) => { return new Int8Array(x); })" js_createInt8Array :: Int -> State# s -> (# State# s, SomeInt8Array m #) foreign import javascript unsafe - "new Int16Array($1)" + "((x) => { return new Int16Array(x); })" js_createInt16Array :: Int -> State# s -> (# State# s, SomeInt16Array m #) foreign import javascript unsafe - "new Int32Array($1)" + "((x) => { return new Int32Array(x); })" js_createInt32Array :: Int -> State# s -> (# State# s, SomeInt32Array m #) foreign import javascript unsafe - "new Uint8ClampedArray($1)" + "((x) => { return new Uint8ClampedArray(x); })" js_createUint8ClampedArray :: Int -> State# s -> (# State# s, SomeUint8ClampedArray m #) foreign import javascript unsafe - "new Uint8Array($1)" + "((x) => { return new Uint8Array(x); })" js_createUint8Array :: Int -> State# s -> (# State# s, SomeUint8Array m #) foreign import javascript unsafe - "new Uint16Array($1)" + "((x) => { return new Uint16Array(x); })" js_createUint16Array :: Int -> State# s -> (# State# s, SomeUint16Array m #) foreign import javascript unsafe - "new Uint32Array($1)" + "((x) => { return new Uint32Array(x); })" js_createUint32Array :: Int -> State# s -> (# State# s, SomeUint32Array m #) foreign import javascript unsafe - "new Float32Array($1)" + "((x) => { return new Float32Array(x); })" js_createFloat32Array :: Int -> State# s -> (# State# s, SomeFloat32Array m #) foreign import javascript unsafe - "new Float64Array($1)" + "((x) => { return new Float64Array(x); })" js_createFloat64Array :: Int -> State# s -> (# State# s, SomeFloat64Array m #) -- ------------------------------------------------------------------------------ -- from array foreign import javascript unsafe - "Int8Array.from($1)" + "((x) => { return Int8Array.from(x); })" js_int8ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt8Array m1) foreign import javascript unsafe - "Int16Array.from($1)" + "((x) => { return Int16Array.from(x); })" js_int16ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt16Array m1) foreign import javascript unsafe - "Int32Array.from($1)" + "((x) => { return Int32Array.from(x); })" js_int32ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt32Array m1) foreign import javascript unsafe - "Uint8ClampedArray.from($1)" + "((x) => { return Uint8ClampedArray.from(x); })" js_uint8ClampedArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8ClampedArray m1) foreign import javascript unsafe - "Uint8Array.from($1)" + "((x) => { return Uint8Array.from(x); })" js_uint8ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8Array m1) foreign import javascript unsafe - "Uint16Array.from($1)" + "((x) => { return Uint16Array.from(x); })" js_uint16ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint16Array m1) foreign import javascript unsafe - "Uint32Array.from($1)" + "((x) => { return Uint32Array.from(x); })" js_uint32ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint32Array m1) foreign import javascript unsafe - "Float32Array.from($1)" + "((x) => { return Float32Array.from(x); })" js_float32ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat32Array m1) foreign import javascript unsafe - "Float64Array.from($1)" + "((x) => { return Float64Array.from(x); })" js_float64ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat64Array m1) -- ------------------------------------------------------------------------------ -- from ArrayBuffer foreign import javascript unsafe - "new Int8Array($1)" + "((x) => { return new Int8Array(x); })" js_int8ArrayFromJSVal :: JSVal -> SomeInt8Array m foreign import javascript unsafe - "new Int16Array($1)" + "((x) => { return new Int16Array(x); })" js_int16ArrayFromJSVal :: JSVal -> SomeInt16Array m foreign import javascript unsafe - "new Int32Array($1)" + "((x) => { return new Int32Array(x); })" js_int32ArrayFromJSVal :: JSVal -> SomeInt32Array m foreign import javascript unsafe - "new Uint8ClampedArray($1)" + "((x) => { return new Uint8ClampedArray(x); })" js_uint8ClampedArrayFromJSVal :: JSVal -> SomeUint8ClampedArray m foreign import javascript unsafe - "new Uint8Array($1)" + "((x) => { return new Uint8Array(x); })" js_uint8ArrayFromJSVal :: JSVal -> SomeUint8Array m foreign import javascript unsafe - "new Uint16Array($1)" + "((x) => { return new Uint16Array(x); })" js_uint16ArrayFromJSVal :: JSVal -> SomeUint16Array m foreign import javascript unsafe - "new Uint32Array($1)" + "((x) => { return new Uint32Array(x); })" js_uint32ArrayFromJSVal :: JSVal -> SomeUint32Array m foreign import javascript unsafe - "new Float32Array($1)" + "((x) => { return new Float32Array(x); })" js_float32ArrayFromJSVal :: JSVal -> SomeFloat32Array m foreign import javascript unsafe - "new Float64Array($1)" + "((x) => { return new Float64Array(x); })" js_float64ArrayFromJSVal :: JSVal -> SomeFloat64Array m diff --git a/JavaScript/TypedArray/Internal/Types.hs b/JavaScript/TypedArray/Internal/Types.hs --- a/JavaScript/TypedArray/Internal/Types.hs +++ b/JavaScript/TypedArray/Internal/Types.hs @@ -98,7 +98,7 @@ -- ----------------------------------------------------------------------------- type family Elem x where - Elem (SomeUint8Array m) = Word8 + Elem (SomeUint8Array m) = Word8 -- SomeTypedArray Uint8Elem Elem (SomeUint8ClampedArray m) = Word8 Elem (SomeUint16Array m) = Word16 Elem (SomeUint32Array m) = Word @@ -108,13 +108,3 @@ Elem (SomeFloat32Array m) = Double Elem (SomeFloat64Array m) = Double - Elem (STUint8Array s) = Word8 - Elem (STUint8ClampedArray s) = Word8 - Elem (STUint16Array s) = Word16 - Elem (STUint32Array s) = Word - Elem (STInt8Array s) = Int8 - Elem (STInt16Array s) = Int16 - Elem (STInt32Array s) = Int - Elem (STFloat32Array s) = Double - Elem (STFloat64Array s) = Double - diff --git a/JavaScript/TypedArray/ST.hs b/JavaScript/TypedArray/ST.hs --- a/JavaScript/TypedArray/ST.hs +++ b/JavaScript/TypedArray/ST.hs @@ -24,7 +24,7 @@ import GHCJS.Types import GHCJS.Buffer.Types -import GHCJS.Prim +import GHC.JS.Prim import GHCJS.Internal.Types import qualified Data.ByteString as B @@ -53,11 +53,11 @@ instance STTypedArray s (STInt8Array s) where index i a = ST (I.indexI8 i a) unsafeIndex i a = ST (I.unsafeIndexI8 i a) - setIndex i (I8# x) a = ST (I.setIndexI i x a) - unsafeSetIndex i (I8# x) a = ST (I.unsafeSetIndexI i x a) - indexOf s (I8# x) a = ST (I.indexOfI s x a) + setIndex i (I8# x) a = ST (I.setIndexI i (int8ToInt# x) a) + unsafeSetIndex i (I8# x) a = ST (I.unsafeSetIndexI i (int8ToInt# x) a) + indexOf s (I8# x) a = ST (I.indexOfI s (int8ToInt# x) a) fromBuffer = undefined - lastIndexOf s (I8# x) a = ST (I.lastIndexOfI s x a) + lastIndexOf s (I8# x) a = ST (I.lastIndexOfI s (int8ToInt# x) a) create l = ST (I.js_createInt8Array l) -- --------------------------------------------------------------------------- diff --git a/JavaScript/Web/AnimationFrame.hs b/JavaScript/Web/AnimationFrame.hs --- a/JavaScript/Web/AnimationFrame.hs +++ b/JavaScript/Web/AnimationFrame.hs @@ -21,7 +21,7 @@ , AnimationFrameHandle ) where -import GHCJS.Foreign.Callback +import GHC.JS.Foreign.Callback import GHCJS.Marshal.Pure import GHCJS.Types @@ -62,14 +62,14 @@ -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "{ handle: null, callback: null }" +foreign import javascript unsafe "(() => { return { handle: null, callback: null }; })" js_makeAnimationFrameHandle :: IO AnimationFrameHandle -foreign import javascript unsafe "{ handle: null, callback: $1 }" +foreign import javascript unsafe "(() => { return { handle: null, callback: $1 }; })" js_makeAnimationFrameHandleCallback :: JSVal -> IO AnimationFrameHandle foreign import javascript unsafe "h$animationFrameCancel" js_cancelAnimationFrame :: AnimationFrameHandle -> IO () foreign import javascript interruptible - "$1.handle = window.requestAnimationFrame($c);" + "((x,c) => { return x.handle = window.requestAnimationFrame(c); })" js_waitForAnimationFrame :: AnimationFrameHandle -> IO Double foreign import javascript unsafe "h$animationFrameRequest" js_requestAnimationFrame :: AnimationFrameHandle -> IO () diff --git a/JavaScript/Web/Blob/Internal.hs b/JavaScript/Web/Blob/Internal.hs --- a/JavaScript/Web/Blob/Internal.hs +++ b/JavaScript/Web/Blob/Internal.hs @@ -42,14 +42,14 @@ -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "$1.size" js_size :: SomeBlob a -> Int -foreign import javascript unsafe "$1.type" js_type :: SomeBlob a -> JSString +foreign import javascript unsafe "((x) => { return x.size; })" js_size :: SomeBlob a -> Int +foreign import javascript unsafe "((x) => { return x.type; })" js_type :: SomeBlob a -> JSString -- fixme figure out if we need to support older browsers with obsolete slice -foreign import javascript unsafe "$4.slice($1,$2,$3)" +foreign import javascript unsafe "(($1,$2,$3,$4) => { return $4.slice($1,$2,$3); })" js_slice :: Int -> Int -> JSString -> SomeBlob a -> SomeBlob a -foreign import javascript unsafe "$1.isClosed" +foreign import javascript unsafe "((x) => { return x.isClosed; })" js_isClosed :: SomeBlob a -> IO Bool -foreign import javascript unsafe "$1.close();" +foreign import javascript unsafe "((x) => { return x.close(); })" js_close :: SomeBlob a -> IO () diff --git a/JavaScript/Web/Canvas.hs b/JavaScript/Web/Canvas.hs --- a/JavaScript/Web/Canvas.hs +++ b/JavaScript/Web/Canvas.hs @@ -332,102 +332,101 @@ -- ---------------------------------------------------------------------------- -foreign import javascript unsafe "$r = document.createElement('canvas');\ - \$r.width = $1;\ - \$r.height = $2;" +foreign import javascript unsafe + "((x,y) => { var r = document.createElement('canvas'); r.width = x; r.height = y; return r; })" js_create :: Int -> Int -> IO Canvas -foreign import javascript unsafe "$1.getContext('2d')" +foreign import javascript unsafe "((x) => { return x.getContext('2d'); })" js_getContext :: Canvas -> IO Context -foreign import javascript unsafe "$1.save()" +foreign import javascript unsafe "((x) => { x.save(); })" js_save :: Context -> IO () -foreign import javascript unsafe "$1.restore()" +foreign import javascript unsafe "((x) => { x.restore(); })" js_restore :: Context -> IO () -foreign import javascript unsafe "$7.transform($1,$2,$3,$4,$5,$6)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6,$7) => { $7.transform($1,$2,$3,$4,$5,$6); })" js_transform :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$7.setTransform($1,$2,$3,$4,$5,$6)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6,$7) => { $7.setTransform($1,$2,$3,$4,$5,$6); })" js_setTransform :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$3.scale($1,$2)" +foreign import javascript unsafe "((x,y,z) => { x.scale(x,y); })" js_scale :: Double -> Double -> Context -> IO () -foreign import javascript unsafe "$3.translate($1,$2)" +foreign import javascript unsafe "((x,y,z) => { x.translate(x,y); })" js_translate :: Double -> Double -> Context -> IO () -foreign import javascript unsafe "$2.rotate($1)" +foreign import javascript unsafe "((x,y) => { y.rotate(x); })" js_rotate :: Double -> Context -> IO () -foreign import javascript unsafe "$1.fill()" +foreign import javascript unsafe "((x) => { x.fill(); })" js_fill :: Context -> IO () -foreign import javascript unsafe "$2.fill($1)" +foreign import javascript unsafe "((x,y) => { y.fill(x); })" js_fill_rule :: JSString -> Context -> IO () -foreign import javascript unsafe "$1.stroke()" +foreign import javascript unsafe "((x) => { x.stroke(); })" js_stroke :: Context -> IO () -foreign import javascript unsafe "$1.beginPath()" +foreign import javascript unsafe "((x) => { x.beginPath(); })" js_beginPath :: Context -> IO () -foreign import javascript unsafe "$1.closePath()" +foreign import javascript unsafe "((x) => { x.closePath(); })" js_closePath :: Context -> IO () -foreign import javascript unsafe "$1.clip()" +foreign import javascript unsafe "((x) => { x.clip(); })" js_clip :: Context -> IO () -foreign import javascript unsafe "$3.moveTo($1,$2)" +foreign import javascript unsafe "((x,y,z) => { x.moveTo(x,y); })" js_moveTo :: Double -> Double -> Context -> IO () -foreign import javascript unsafe "$3.lineTo($1,$2)" +foreign import javascript unsafe "((x,y,z) => { x.lineTo(x,y); })" js_lineTo :: Double -> Double -> Context -> IO () -foreign import javascript unsafe "$5.quadraticCurveTo($1,$2,$3,$4)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5) => { $5.quadraticCurveTo($1,$2,$3,$4); })" js_quadraticCurveTo :: Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$7.bezierCurveTo($1,$2,$3,$4,$5,$6)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6,$7) => { $7.bezierCurveTo($1,$2,$3,$4,$5,$6); })" js_bezierCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$7.arc($1,$2,$3,$4,$5,$6)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6,$7) => { $7.arc($1,$2,$3,$4,$5,$6); })" js_arc :: Double -> Double -> Double -> Double -> Double -> Bool -> Context -> IO () -foreign import javascript unsafe "$6.arcTo($1,$2,$3,$4,$5)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6) => { $6.arcTo($1,$2,$3,$4,$5); })" js_arcTo :: Double -> Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$5.rect($1,$2,$3,$4)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5) => { $5.rect($1,$2,$3,$4); })" js_rect :: Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$3.isPointInPath($1,$2)" +foreign import javascript unsafe "((x,y,z) => { x.isPointInPath(x,y); })" js_isPointInPath :: Double -> Double -> Context -> IO () foreign import javascript unsafe - "$5.fillStyle = 'rgba(' + $1 + ',' + $2 + ',' + $3 + ',' + $4 + ')'" + "(($1,$2,$3,$4,$5) => { $5.fillStyle = 'rgba(' + $1 + ',' + $2 + ',' + $3 + ',' + $4 + ')'; })" js_fillStyle :: Int -> Int -> Int -> Double -> Context -> IO () foreign import javascript unsafe - "$5.strokeStyle = 'rgba(' + $1 + ',' + $2 + ',' + $3 + ',' + $4 + ')'" + "(($1,$2,$3,$4,$5) => { $5.strokeStyle = 'rgba(' + $1 + ',' + $2 + ',' + $3 + ',' + $4 + ')'; })" js_strokeStyle :: Int -> Int -> Int -> Double -> Context -> IO () -foreign import javascript unsafe "$2.globalAlpha = $1" +foreign import javascript unsafe "((x,y) => { y.globalAlpha = x; })" js_globalAlpha :: Double -> Context -> IO () foreign import javascript unsafe - "$2.lineJoin = $1" + "((x,y) => { y.lineJoin = x; })" js_lineJoin :: JSString -> Context -> IO () -foreign import javascript unsafe "$2.lineCap = $1" +foreign import javascript unsafe "((x,y) => { y.lineCap = x; })" js_lineCap :: JSString -> Context -> IO () -foreign import javascript unsafe "$2.miterLimit = $1" +foreign import javascript unsafe "((x,y) => { y.miterLimit = x; })" js_miterLimit :: Double -> Context -> IO () -foreign import javascript unsafe "$2.setLineDash($1)" +foreign import javascript unsafe "((x,y) => { y.setLineDash(x); })" js_setLineDash :: JSArray -> Context -> IO () -foreign import javascript unsafe "$2.lineDashOffset = $1" +foreign import javascript unsafe "((x,y) => { y.lineDashOffset = x; })" js_lineDashOffset :: Double -> Context -> IO () -foreign import javascript unsafe "$2.font = $1" +foreign import javascript unsafe "((x,y) => { y.font = x; })" js_font :: JSString -> Context -> IO () -foreign import javascript unsafe "$2.textAlign = $1" +foreign import javascript unsafe "((x,y) => { y.textAlign = x; })" js_textAlign :: JSString -> Context -> IO () -foreign import javascript unsafe "$2.textBaseline = $1" +foreign import javascript unsafe "((x,y) => { y.textBaseline = x; })" js_textBaseline :: JSString -> Context -> IO () -foreign import javascript unsafe "$2.lineWidth = $1" +foreign import javascript unsafe "((x,y) => { y.lineWidth = x; })" js_lineWidth :: Double -> Context -> IO () -foreign import javascript unsafe "$4.fillText($1,$2,$3)" +foreign import javascript unsafe "(($1,$2,$3,$4) => { $4.fillText($1,$2,$3); })" js_fillText :: JSString -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$4.strokeText($1,$2,$3)" +foreign import javascript unsafe "(($1,$2,$3,$4) => { $4.strokeText($1,$2,$3); })" js_strokeText :: JSString -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$2.measureText($1)" +foreign import javascript unsafe "((x,y) => { return y.measureText(x); })" js_measureText :: JSString -> Context -> IO Object -foreign import javascript unsafe "$5.fillRect($1,$2,$3,$4)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5) => { $5.fillRect($1,$2,$3,$4); })" js_fillRect :: Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$5.clearRect($1,$2,$3,$4)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5) => { $5.clearRect($1,$2,$3,$4); })" js_clearRect :: Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$5.strokeRect($1,$2,$3,$4)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5) => { $5.strokeRect($1,$2,$3,$4); })" js_strokeRect :: Double -> Double -> Double -> Double -> Context -> IO () -foreign import javascript unsafe "$6.drawImage($1,$2,$3,$4,$5)" +foreign import javascript unsafe "(($1,$2,$3,$4,$5,$6) => { $6.drawImage($1,$2,$3,$4,$5); })" js_drawImage :: Image -> Int -> Int -> Int -> Int -> Context -> IO () -foreign import javascript unsafe "$3.createPattern($1,$2)" +foreign import javascript unsafe "((x,y,z) => { return x.createPattern(x,y); })" js_createPattern :: Image -> JSString -> Context -> IO Pattern -foreign import javascript unsafe "$1.width" +foreign import javascript unsafe "((x) => { return x.width; })" js_width :: Canvas -> IO Int -foreign import javascript unsafe "$1.height" +foreign import javascript unsafe "((x) => { return x.height; })" js_height :: Canvas -> IO Int -foreign import javascript unsafe "$2.width = $1;" +foreign import javascript unsafe "((x,y) => { return y.width = x;; })" js_setWidth :: Int -> Canvas -> IO () -foreign import javascript unsafe "$2.height = $1;" +foreign import javascript unsafe "((x,y) => { return y.height = x;; })" js_setHeight :: Int -> Canvas -> IO () diff --git a/JavaScript/Web/Canvas/ImageData.hs b/JavaScript/Web/Canvas/ImageData.hs --- a/JavaScript/Web/Canvas/ImageData.hs +++ b/JavaScript/Web/Canvas/ImageData.hs @@ -25,9 +25,9 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1.width" js_width :: ImageData -> Int + "((x) => { return x.width; })" js_width :: ImageData -> Int foreign import javascript unsafe - "$1.height" js_height :: ImageData -> Int + "((x) => { return x.height; })" js_height :: ImageData -> Int foreign import javascript unsafe - "$1.data" js_getData :: ImageData -> Uint8ClampedArray + "((x) => { return x.data; })" js_getData :: ImageData -> Uint8ClampedArray diff --git a/JavaScript/Web/Canvas/TextMetrics.hs b/JavaScript/Web/Canvas/TextMetrics.hs --- a/JavaScript/Web/Canvas/TextMetrics.hs +++ b/JavaScript/Web/Canvas/TextMetrics.hs @@ -67,28 +67,28 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1.width" js_width :: TextMetrics -> Double + "((x) => { return x.width; })" js_width :: TextMetrics -> Double foreign import javascript unsafe - "$1.actualBoundingBoxLeft" js_actualBoundingBoxLeft :: TextMetrics -> Double + "((x) => { return x.actualBoundingBoxLeft; })" js_actualBoundingBoxLeft :: TextMetrics -> Double foreign import javascript unsafe - "$1.actualBoundingBoxRight" js_actualBoundingBoxRight :: TextMetrics -> Double + "((x) => { return x.actualBoundingBoxRight; })" js_actualBoundingBoxRight :: TextMetrics -> Double foreign import javascript unsafe - "$1.fontBoundingBoxAscent" js_fontBoundingBoxAscent :: TextMetrics -> Double + "((x) => { return x.fontBoundingBoxAscent; })" js_fontBoundingBoxAscent :: TextMetrics -> Double foreign import javascript unsafe - "$1.fontBoundingBoxDescent" js_fontBoundingBoxDescent :: TextMetrics -> Double + "((x) => { return x.fontBoundingBoxDescent; })" js_fontBoundingBoxDescent :: TextMetrics -> Double foreign import javascript unsafe - "$1.actualBoundingBoxAscent" js_actualBoundingBoxAscent :: TextMetrics -> Double + "((x) => { return x.actualBoundingBoxAscent; })" js_actualBoundingBoxAscent :: TextMetrics -> Double foreign import javascript unsafe - "$1.actualBoundingBoxDescent" js_actualBoundingBoxDescent :: TextMetrics -> Double + "((x) => { return x.actualBoundingBoxDescent; })" js_actualBoundingBoxDescent :: TextMetrics -> Double foreign import javascript unsafe - "$1.emHeightAscent" js_emHeightAscent :: TextMetrics -> Double + "((x) => { return x.emHeightAscent; })" js_emHeightAscent :: TextMetrics -> Double foreign import javascript unsafe - "$1.emHeightDescent" js_emHeightDescent :: TextMetrics -> Double + "((x) => { return x.emHeightDescent; })" js_emHeightDescent :: TextMetrics -> Double foreign import javascript unsafe - "$1.hangingBaseline" js_hangingBaseline :: TextMetrics -> Double + "((x) => { return x.hangingBaseline; })" js_hangingBaseline :: TextMetrics -> Double foreign import javascript unsafe - "$1.alphabeticBaseline" js_alphabeticBaseline :: TextMetrics -> Double + "((x) => { return x.alphabeticBaseline; })" js_alphabeticBaseline :: TextMetrics -> Double foreign import javascript unsafe - "$1.ideographicBaseline" js_ideographicBaseline :: TextMetrics -> Double + "((x) => { return x.ideographicBaseline; })" js_ideographicBaseline :: TextMetrics -> Double diff --git a/JavaScript/Web/CloseEvent.hs b/JavaScript/Web/CloseEvent.hs --- a/JavaScript/Web/CloseEvent.hs +++ b/JavaScript/Web/CloseEvent.hs @@ -25,8 +25,8 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1.code" js_getCode :: CloseEvent -> Int + "((x) => { return x.code; })" js_getCode :: CloseEvent -> Int foreign import javascript unsafe - "$1.reason" js_getReason :: CloseEvent -> JSString + "((x) => { return x.reason; })" js_getReason :: CloseEvent -> JSString foreign import javascript unsafe - "$1.wasClean" js_wasClean :: CloseEvent -> Bool + "((x) => { return x.wasClean; })" js_wasClean :: CloseEvent -> Bool diff --git a/JavaScript/Web/ErrorEvent.hs b/JavaScript/Web/ErrorEvent.hs --- a/JavaScript/Web/ErrorEvent.hs +++ b/JavaScript/Web/ErrorEvent.hs @@ -39,13 +39,13 @@ -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "$1.message" +foreign import javascript unsafe "((x) => { return x.message; })" js_getMessage :: ErrorEvent -> JSString -foreign import javascript unsafe "$1.filename" +foreign import javascript unsafe "((x) => { return x.filename; })" js_getFilename :: ErrorEvent -> JSString -foreign import javascript unsafe "$1.lineno" +foreign import javascript unsafe "((x) => { return x.lineno; })" js_getLineno :: ErrorEvent -> Int -foreign import javascript unsafe "$1.colno" +foreign import javascript unsafe "((x) => { return x.colno; })" js_getColno :: ErrorEvent -> Int -foreign import javascript unsafe "$1.error" +foreign import javascript unsafe "((x) => { return x.error; })" js_getError :: ErrorEvent -> JSVal diff --git a/JavaScript/Web/File.hs b/JavaScript/Web/File.hs --- a/JavaScript/Web/File.hs +++ b/JavaScript/Web/File.hs @@ -26,6 +26,6 @@ -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "$1.name" js_name :: File -> JSString -foreign import javascript unsafe "$1.lastModified" js_lastModified :: File -> Double +foreign import javascript unsafe "((x) => { return x.name; })" js_name :: File -> JSString +foreign import javascript unsafe "((x) => { return x.lastModified; })" js_lastModified :: File -> Double diff --git a/JavaScript/Web/Location.hs b/JavaScript/Web/Location.hs --- a/JavaScript/Web/Location.hs +++ b/JavaScript/Web/Location.hs @@ -144,29 +144,29 @@ foreign import javascript safe "window.location" js_getWindowLocation :: IO Location -foreign import javascript unsafe "$1.href" js_getHref :: Location -> IO JSString -foreign import javascript unsafe "$1.protocol" js_getProtocol :: Location -> IO JSString -foreign import javascript unsafe "$1.host" js_getHost :: Location -> IO JSString -foreign import javascript unsafe "$1.hostname" js_getHostname :: Location -> IO JSString -foreign import javascript unsafe "$1.port" js_getPort :: Location -> IO JSString -foreign import javascript unsafe "$1.pathname" js_getPathname :: Location -> IO JSString -foreign import javascript unsafe "$1.search" js_getSearch :: Location -> IO JSString -foreign import javascript unsafe "$1.hash" js_getHash :: Location -> IO JSString -foreign import javascript unsafe "$1.username" js_getUsername :: Location -> IO JSString -foreign import javascript unsafe "$1.password" js_getPassword :: Location -> IO JSString -foreign import javascript unsafe "$1.origin" js_getOrigin :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.href; })" js_getHref :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.protocol; })" js_getProtocol :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.host; })" js_getHost :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.hostname; })" js_getHostname :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.port; })" js_getPort :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.pathname; })" js_getPathname :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.search; })" js_getSearch :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.hash; })" js_getHash :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.username; })" js_getUsername :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.password; })" js_getPassword :: Location -> IO JSString +foreign import javascript unsafe "((x) => { return x.origin; })" js_getOrigin :: Location -> IO JSString -foreign import javascript safe "$2.href = $1;" js_setHref :: JSString -> Location -> IO () -foreign import javascript safe "$2.protocol = $1;" js_setProtocol :: JSString -> Location -> IO () -foreign import javascript safe "$2.host = $1;" js_setHost :: JSString -> Location -> IO () -foreign import javascript safe "$2.hostname = $1;" js_setHostname :: JSString -> Location -> IO () -foreign import javascript safe "$2.port = $1;" js_setPort :: JSString -> Location -> IO () -foreign import javascript safe "$2.pathname = $1;" js_setPathname :: JSString -> Location -> IO () -foreign import javascript safe "$2.search = $1;" js_setSearch :: JSString -> Location -> IO () -foreign import javascript safe "$2.hash = $1;" js_setHash :: JSString -> Location -> IO () -foreign import javascript safe "$2.username = $1;" js_setUsername :: JSString -> Location -> IO () -foreign import javascript safe "$2.password = $1;" js_setPassword :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.href = x; })" js_setHref :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.protocol = x; })" js_setProtocol :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.host = x; })" js_setHost :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.hostname = x; })" js_setHostname :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.port = x; })" js_setPort :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.pathname = x; })" js_setPathname :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.search = x; })" js_setSearch :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.hash = x; })" js_setHash :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.username = x; })" js_setUsername :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.password = x; })" js_setPassword :: JSString -> Location -> IO () -foreign import javascript safe "$2.assign($1);" js_assign :: JSString -> Location -> IO () -foreign import javascript safe "$2.reload($1);" js_reload :: Bool -> Location -> IO () -foreign import javascript safe "$2.replace($1);" js_replace :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.assign(x); })" js_assign :: JSString -> Location -> IO () +foreign import javascript safe "((x,y) => { y.reload(x); })" js_reload :: Bool -> Location -> IO () +foreign import javascript safe "((x,y) => { y.replace(x); })" js_replace :: JSString -> Location -> IO () diff --git a/JavaScript/Web/MessageEvent.hs b/JavaScript/Web/MessageEvent.hs --- a/JavaScript/Web/MessageEvent.hs +++ b/JavaScript/Web/MessageEvent.hs @@ -38,6 +38,7 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$r2 = $1.data;\ - \$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 3 : 2)" + "((x) => { var r2 = x.data;\ + \ var r1 = typeof r2 === 'string' ? 1 : (r2 instanceof ArrayBuffer ? 3 : 2);\ + \ h$ret1 = r2; return r1; })" js_getData :: MessageEvent -> (# Int#, JSVal #) diff --git a/JavaScript/Web/Performance.hs b/JavaScript/Web/Performance.hs --- a/JavaScript/Web/Performance.hs +++ b/JavaScript/Web/Performance.hs @@ -7,7 +7,7 @@ ( now ) where -import GHCJS.Foreign.Callback +import GHC.JS.Foreign.Callback import GHCJS.Marshal.Pure import GHCJS.Types @@ -27,5 +27,5 @@ -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "performance.now()" +foreign import javascript unsafe "(() => { return performance.now(); })" js_performanceNow :: IO Double diff --git a/JavaScript/Web/Storage.hs b/JavaScript/Web/Storage.hs --- a/JavaScript/Web/Storage.hs +++ b/JavaScript/Web/Storage.hs @@ -57,18 +57,18 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "window.localStorage" js_localStorage :: Storage + "window.localStorage" js_localStorage :: Storage foreign import javascript unsafe - "window.sessionStorage" js_sessionStorage :: Storage + "window.sessionStorage" js_sessionStorage :: Storage foreign import javascript unsafe - "$1.length" js_getLength :: Storage -> IO Int + "((x) => { return x.length; })" js_getLength :: Storage -> IO Int foreign import javascript unsafe - "$2.key($1)" js_getIndex :: Int -> Storage -> IO JSVal + "((x,y) => { return y.key(x); })" js_getIndex :: Int -> Storage -> IO JSVal foreign import javascript unsafe - "$2.getItem($1)" js_getItem :: JSString -> Storage -> IO JSVal + "((x,y) => { return y.getItem(x); })" js_getItem :: JSString -> Storage -> IO JSVal foreign import javascript safe - "$3.setItem($1,$2)" js_setItem :: JSString -> JSString -> Storage -> IO () + "((x,y,z) => { x.setItem(x,y); })" js_setItem :: JSString -> JSString -> Storage -> IO () foreign import javascript unsafe - "$2.removeItem($1)" js_removeItem :: JSString -> Storage -> IO () + "((x,y) => { y.removeItem(x); })" js_removeItem :: JSString -> Storage -> IO () foreign import javascript unsafe - "$1.clear();" js_clear :: Storage -> IO () + "((x) => { x.clear(); })" js_clear :: Storage -> IO () diff --git a/JavaScript/Web/StorageEvent.hs b/JavaScript/Web/StorageEvent.hs --- a/JavaScript/Web/StorageEvent.hs +++ b/JavaScript/Web/StorageEvent.hs @@ -51,12 +51,12 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1.key" js_getKey :: StorageEvent -> JSVal + "((x) => { return x.key; })" js_getKey :: StorageEvent -> JSVal foreign import javascript unsafe - "$1.oldValue" js_getOldValue :: StorageEvent -> JSVal + "((x) => { return x.oldValue; })" js_getOldValue :: StorageEvent -> JSVal foreign import javascript unsafe - "$1.newValue" js_getNewValue :: StorageEvent -> JSVal + "((x) => { return x.newValue; })" js_getNewValue :: StorageEvent -> JSVal foreign import javascript unsafe - "$1.url" js_getUrl :: StorageEvent -> JSString + "((x) => { return x.url; })" js_getUrl :: StorageEvent -> JSString foreign import javascript unsafe - "$1.storageArea" js_getStorageArea :: StorageEvent -> JSVal + "((x) => { return x.storageArea; })" js_getStorageArea :: StorageEvent -> JSVal diff --git a/JavaScript/Web/WebSocket.hs b/JavaScript/Web/WebSocket.hs --- a/JavaScript/Web/WebSocket.hs +++ b/JavaScript/Web/WebSocket.hs @@ -27,9 +27,10 @@ ) where import GHCJS.Concurrent -import GHCJS.Prim -import GHCJS.Foreign.Callback.Internal (Callback(..)) -import qualified GHCJS.Foreign.Callback as CB +import GHCJS.Types +import GHC.JS.Prim +import GHC.JS.Foreign.Callback (Callback) +import qualified GHC.JS.Foreign.Callback as CB import GHC.Exts @@ -88,8 +89,8 @@ maybeCallback :: (JSVal -> a) -> Maybe (a -> IO ()) -> IO JSVal maybeCallback _ Nothing = return jsNull maybeCallback f (Just g) = do - Callback cb <- CB.syncCallback1 CB.ContinueAsync (g . f) - return cb + cb <- CB.syncCallback1 CB.ContinueAsync (g . f) + return (jsval cb) handleOpenErr :: JSVal -> IO () handleOpenErr r @@ -151,40 +152,40 @@ -- ----------------------------------------------------------------------------- foreign import javascript safe - "new WebSocket($1)" js_createDefault :: JSString -> IO WebSocket + "(($1) => { return new WebSocket($1); })" js_createDefault :: JSString -> IO WebSocket foreign import javascript safe - "new WebSocket($1, $2)" js_createStr :: JSString -> JSString -> IO WebSocket + "(($1,$2) => { return new WebSocket($1, $2); })" js_createStr :: JSString -> JSString -> IO WebSocket foreign import javascript safe - "new WebSocket($1, $2)" js_createArr :: JSString -> JSArray -> IO WebSocket + "(($1,$2) => { return new WebSocket($1, $2); })" js_createArr :: JSString -> JSArray -> IO WebSocket foreign import javascript interruptible - "h$openWebSocket($1, $2, $3, $c);" + "h$openWebSocket" js_open :: WebSocket -> JSVal -> JSVal -> IO JSVal foreign import javascript safe - "h$closeWebSocket($1, $2, $3);" + "h$closeWebSocket" js_close :: Int -> JSString -> WebSocket -> IO () foreign import javascript unsafe - "$2.send($1);" js_send :: JSString -> WebSocket -> IO () + "((x,y) => { y.send(x); })" js_send :: JSString -> WebSocket -> IO () foreign import javascript unsafe - "$2.send($1);" js_sendBlob :: Blob -> WebSocket -> IO () + "((x,y) => { y.send(x); })" js_sendBlob :: Blob -> WebSocket -> IO () foreign import javascript unsafe - "$2.send($1);" js_sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO () + "((x,y) => { y.send(x); })" js_sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO () foreign import javascript unsafe - "$1.bufferedAmount" js_getBufferedAmount :: WebSocket -> IO Int + "((x) => { return x.bufferedAmount; })" js_getBufferedAmount :: WebSocket -> IO Int foreign import javascript unsafe - "$1.readyState" js_getReadyState :: WebSocket -> IO Int + "((x) => { return x.readyState; })" js_getReadyState :: WebSocket -> IO Int foreign import javascript unsafe - "$1.protocol" js_getProtocol :: WebSocket -> IO JSString + "((x) => { return x.protocol; })" js_getProtocol :: WebSocket -> IO JSString foreign import javascript unsafe - "$1.extensions" js_getExtensions :: WebSocket -> IO JSString + "((x) => { return x.extensions; })" js_getExtensions :: WebSocket -> IO JSString foreign import javascript unsafe - "$1.url" js_getUrl :: WebSocket -> JSString + "((x) => { return x.url; })" js_getUrl :: WebSocket -> JSString foreign import javascript unsafe - "$1.binaryType === 'blob' ? 0 : 1" + "((x) => { return x.binaryType === 'blob' ? 0 : 1; })" js_getBinaryType :: WebSocket -> IO Int foreign import javascript unsafe - "$1.lastError" js_getLastError :: WebSocket -> IO JSVal + "((x) => { return x.lastError; })" js_getLastError :: WebSocket -> IO JSVal foreign import javascript unsafe - "$2.binaryType = $1" + "((x,y) => { y.binaryType = x; })" js_setBinaryType :: JSString -> WebSocket -> IO () diff --git a/JavaScript/Web/Worker.hs b/JavaScript/Web/Worker.hs --- a/JavaScript/Web/Worker.hs +++ b/JavaScript/Web/Worker.hs @@ -6,7 +6,7 @@ , terminate ) where -import GHCJS.Prim +import GHC.JS.Prim import Data.JSString import Data.Typeable @@ -28,8 +28,8 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "new Worker($1)" js_create :: JSString -> IO Worker + "(($1) => { return new Worker($1); })" js_create :: JSString -> IO Worker foreign import javascript unsafe - "$2.postMessage($1)" js_postMessage :: JSVal -> Worker -> IO () + "((x,y) => { y.postMessage(x); })" js_postMessage :: JSVal -> Worker -> IO () foreign import javascript unsafe - "$1.terminate()" js_terminate :: Worker -> IO () + "((x) => { x.terminate(); })" js_terminate :: Worker -> IO () diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -2,7 +2,8 @@ ForeignFunctionInterface, JavaScriptFFI, EmptyDataDecls, TypeFamilies, DataKinds, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, - LambdaCase, MultiParamTypeClasses, DeriveGeneric #-} + LambdaCase, MultiParamTypeClasses, DeriveGeneric, + TypeOperators #-} module JavaScript.Web.XMLHttpRequest ( xhr , xhrByteString @@ -22,7 +23,7 @@ import Control.Monad import GHCJS.Types -import GHCJS.Prim +import GHC.JS.Prim import GHCJS.Marshal import GHCJS.Marshal.Pure import GHCJS.Internal.Types @@ -201,57 +202,57 @@ -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1.withCredentials = true;" + "((x) => { x.withCredentials = true; })" js_setWithCredentials :: XHR -> IO () foreign import javascript unsafe - "new XMLHttpRequest()" + "((x) => { return new XMLHttpRequest(); })" js_createXHR :: IO XHR foreign import javascript unsafe - "$2.responseType = $1;" + "((x,y) => { y.responseType = x; })" js_setResponseType :: JSString -> XHR -> IO () foreign import javascript unsafe - "$1.abort();" + "((x) => { return x.abort(); })" js_abort :: XHR -> IO () foreign import javascript unsafe - "$3.setRequestHeader($1,$2);" + "((x,y,z) => { x.setRequestHeader(x,y); })" js_setRequestHeader :: JSString -> JSString -> XHR -> IO () foreign import javascript unsafe - "$3.open($1,$2)" + "((x,y,z) => { x.open(x,y); })" js_open2 :: JSString -> JSString -> XHR -> IO () foreign import javascript unsafe - "$5.open($1,$2,true,$4,$5);" + "(($1,$2,$3,$4,$5) => { $5.open($1,$2,true,$4,$5); })" js_open4 :: JSString -> JSString -> JSString -> JSString -> XHR -> IO () foreign import javascript unsafe "new FormData()" js_createFormData :: IO JSFormData foreign import javascript unsafe - "$3.append($1,$2)" + "((x,y,z) => { x.append(x,y); })" js_appendFormData2 :: JSString -> JSVal -> JSFormData -> IO () foreign import javascript unsafe - "$4.append($1,$2,$3)" + "(($1,$2,$3,$4) => { $4.append($1,$2,$3); })" js_appendFormData3 :: JSString -> JSVal -> JSString -> JSFormData -> IO () foreign import javascript unsafe - "$1.status" + "((x) => { return x.status; })" js_getStatus :: XHR -> IO Int foreign import javascript unsafe - "$1.response" + "((x) => { return x.response; })" js_getResponse :: XHR -> IO JSVal foreign import javascript unsafe - "$1.response ? true : false" + "((x) => { return x.response ? true : false; })" js_hasResponse :: XHR -> IO Bool foreign import javascript unsafe - "$1.getAllResponseHeaders()" + "((x) => { return x.getAllResponseHeaders(); })" js_getAllResponseHeaders :: XHR -> IO JSString foreign import javascript unsafe - "$2.getResponseHeader($1)" + "((x,y) => { y.getResponseHeader(x); })" js_getResponseHeader :: JSString -> XHR -> IO JSVal -- ----------------------------------------------------------------------------- foreign import javascript interruptible - "h$sendXHR($1, null, $c);" + "((x,c) => { return h$sendXHR(x, null, c); })" js_send0 :: XHR -> IO Int foreign import javascript interruptible - "h$sendXHR($2, $1, $c);" + "((x,y,c) => { return h$sendXHR(y, x, c); })" js_send1 :: JSVal -> XHR -> IO Int diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcjs-base -version: 0.2.1.0 +version: 0.8.0.0 synopsis: base library for GHCJS homepage: http://github.com/ghcjs/ghcjs-base license: MIT @@ -15,32 +15,20 @@ location: https://github.com/ghcjs/ghcjs-base library - if impl(ghc >= 8.10.1) - js-sources: jsbits/array.js.pp - jsbits/animationFrame.js.pp - jsbits/export.js.pp - jsbits/jsstring.js.pp - jsbits/jsstringRaw.js.pp - jsbits/foreign.js.pp - jsbits/text.js.pp - jsbits/utils.js.pp - jsbits/xhr.js.pp - jsbits/websocket.js.pp - else - js-sources: jsbits-old/array.js - jsbits-old/animationFrame.js - jsbits-old/export.js - jsbits-old/jsstring.js - jsbits-old/jsstringRaw.js - jsbits-old/foreign.js - jsbits-old/text.js - jsbits-old/utils.js - jsbits-old/xhr.js - jsbits-old/websocket.js + js-sources: jsbits/array.js + jsbits/animationFrame.js + jsbits/buffer.js + jsbits/export.js + jsbits/jsstring.js + jsbits/jsstringRaw.js + jsbits/foreign.js + jsbits/text.js + jsbits/utils.js + jsbits/xhr.js + jsbits/websocket.js other-extensions: DeriveDataTypeable DeriveGeneric ForeignFunctionInterface - JavaScriptFFI GHCForeignImportPrim MagicHash UnboxedTuples @@ -80,8 +68,6 @@ GHCJS.Buffer.Types GHCJS.Concurrent GHCJS.Foreign - GHCJS.Foreign.Callback - GHCJS.Foreign.Callback.Internal GHCJS.Foreign.Export GHCJS.Foreign.Internal GHCJS.Marshal @@ -138,27 +124,26 @@ JavaScript.TypedArray.Internal.Types JavaScript.TypedArray.ArrayBuffer.Internal JavaScript.TypedArray.DataView.Internal - build-depends: base >= 4.7 && < 5, + build-depends: base >= 4.18 && < 5, ghc-prim, - ghcjs-prim, - integer-gmp, binary >= 0.8 && < 0.11, - bytestring >= 0.10 && < 0.11, - text >= 1.1 && < 1.3, - aeson >= 0.8 && < 2.1, - scientific >= 0.3 && < 0.4, - vector >= 0.10 && < 0.13, - containers >= 0.5 && < 0.7, - time >= 1.5 && < 1.10, + bytestring >= 0.10 && < 0.13, + -- text internals need to be utf8 (text <2.0 is utf16) + text >= 2.0 && < 2.2, + aeson >= 0.8 && < 2.3, + scientific >= 0.3.7 && < 0.4, + vector >= 0.10 && < 0.14, + containers >= 0.5 && < 0.8, + time >= 1.5 && < 1.13, hashable >= 1.2 && < 1.5, unordered-containers >= 0.2 && < 0.3, attoparsec >= 0.11 && < 0.15, transformers >= 0.3 && < 0.7, - primitive >= 0.5 && < 0.8, - deepseq >= 1.3 && < 1.5, + primitive >= 0.5 && < 0.10, + deepseq >= 1.3 && < 1.6, dlist >= 0.7 && < 1.1 default-language: Haskell2010 - if !impl(ghcjs) && !os(ghcjs) + if !arch(javascript) buildable: False test-suite tests @@ -172,8 +157,9 @@ Tests.QuickCheckUtils Tests.Regressions Tests.Utils + Tests.Buffer ghc-options: - -Wall -rtsopts + -Wall -rtsopts test/compat.js build-depends: HUnit >= 1.2, QuickCheck >= 2.7, @@ -184,7 +170,6 @@ deepseq, directory, ghc-prim, - ghcjs-prim, ghcjs-base, primitive, quickcheck-unicode, @@ -193,5 +178,5 @@ test-framework-hunit >= 0.2, test-framework-quickcheck2 >= 0.2 default-language: Haskell2010 - if !impl(ghcjs) && !os(ghcjs) + if !arch(javascript) buildable: False diff --git a/jsbits-old/animationFrame.js b/jsbits-old/animationFrame.js deleted file mode 100644 --- a/jsbits-old/animationFrame.js +++ /dev/null @@ -1,18 +0,0 @@ -function h$animationFrameCancel(h) { - if(h.handle) window.cancelAnimationFrame(h.handle); - if(h.callback) { - h$release(h.callback) - h.callback = null; - } -} - -function h$animationFrameRequest(h) { - h.handle = window.requestAnimationFrame(function(ts) { - var cb = h.callback; - if(cb) { - h$release(cb); - h.callback = null; - cb(ts); - } - }); -} diff --git a/jsbits-old/array.js b/jsbits-old/array.js deleted file mode 100644 --- a/jsbits-old/array.js +++ /dev/null @@ -1,40 +0,0 @@ -#include - -/* - convert an array to a Haskell list, wrapping each element in a - JSVal constructor - */ -function h$fromArray(a) { - var r = HS_NIL; - for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSVAL(a[i]), r); - return a; -} - -/* - convert an array to a Haskell list. No additional wrapping of the - elements is performed. Only use this when the elements are directly - usable as Haskell heap objects (numbers, boolean) or when the - array elements have already been appropriately wrapped - */ -function h$fromArrayNoWrap(a) { - var r = HS_NIL; - for(var i=a.length-1;i>=0;i--) r = MK_CONS(a[i], r); - return a; -} - -/* - convert a list of JSVal to an array. the list must have been fully forced, - not just the spine. - */ -function h$listToArray(xs) { - var a = [], i = 0; - while(IS_CONS(xs)) { - a[i++] = JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - } - return a; -} - -function h$listToArrayWrap(xs) { - return MK_JSVAL(h$listToArray(xs)); -} diff --git a/jsbits-old/export.js b/jsbits-old/export.js deleted file mode 100644 --- a/jsbits-old/export.js +++ /dev/null @@ -1,26 +0,0 @@ -function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) { - var e = { fp1a: fp1a - , fp1b: fp1b - , fp2a: fp2a - , fp2b: fp2b - , released: false - , root: o - , _key: -1 - }; - h$retain(e); - return e; -} - -function h$derefExport(fp1a,fp1b,fp2a,fp2b,e) { - if(!e || typeof e !== 'object') return null; - if(e.released) return null; - if(fp1a !== e.fp1a || fp1b !== e.fp1b || - fp2a !== e.fp2a || fp2b !== e.fp2b) return null; - return e.root; -} - -function h$releaseExport(e) { - h$release(e); - e.released = true; - e.root = null; -} diff --git a/jsbits-old/foreign.js b/jsbits-old/foreign.js deleted file mode 100644 --- a/jsbits-old/foreign.js +++ /dev/null @@ -1,8 +0,0 @@ -function h$foreignListProps(o) { - var r = HS_NIL; - if(typeof o === 'undefined' || o === null) return null; - throw "h$foreignListProps"; -/* for(var p in o) { - - } */ -} diff --git a/jsbits-old/jsstring.js b/jsbits-old/jsstring.js deleted file mode 100644 --- a/jsbits-old/jsstring.js +++ /dev/null @@ -1,1181 +0,0 @@ -#include - -/* - * Support code for the Data.JSString module. This code presents a JSString - * as a sequence of code points and hides the underlying encoding ugliness of - * the JavaScript strings. - * - * Use Data.JSString.Raw for direct access to the JSThis makes the operations more expen - */ - -/* - * Some workarounds here for JS engines that do not support proper - * code point access - */ - -#ifdef GHCJS_TRACE_JSSTRING -#define TRACE_JSSTRING(args...) h$log("jsstring: ", args); -#else -#define TRACE_JSSTRING(args...) -#endif - -#define IS_ASTRAL(cp) ((cp)>=0x10000) -#define IS_HI_SURR(cp) ((cp|1023)===0xDBFF) -#define IS_LO_SURR(cp) ((cp|1023)===0xDFFF) -#define FROM_SURR(hi,lo) ((((hi)-0xD800)<<10)+(lo)-0xDC00+0x10000) -#define HI_SURR(cp) ((((cp)-0x10000)>>>10)+0xDC00) -#define LO_SURR(cp) (((cp)&0x3FF)+0xD800) - -var h$jsstringEmpty = MK_JSVAL(''); - -var h$jsstringHead, h$jsstringTail, h$jsstringCons, - h$jsstringSingleton, h$jsstringSnoc, h$jsstringUncons, - h$jsstringIndex, h$jsstringUncheckedIndex; - -var h$fromCodePoint; - -if(String.prototype.fromCodePoint) { - h$fromCodePoint = String.fromCodePoint; -} else { - // polyfill from https://github.com/mathiasbynens/String.fromCodePoint (MIT-license) - h$fromCodePoint = - (function() { - var stringFromCharCode = String.fromCharCode; - var floor = Math.floor; - return function(_) { - var MAX_SIZE = 0x4000; - var codeUnits = []; - var highSurrogate; - var lowSurrogate; - var index = -1; - var length = arguments.length; - if (!length) { - return ''; - } - var result = ''; - while (++index < length) { - var codePoint = Number(arguments[index]); - if ( - !isFinite(codePoint) || // `NaN`, `+Infinity`, or `-Infinity` - codePoint < 0 || // not a valid Unicode code point - codePoint > 0x10FFFF || // not a valid Unicode code point - floor(codePoint) != codePoint // not an integer - ) { - throw RangeError('Invalid code point: ' + codePoint); - } - if (codePoint <= 0xFFFF) { // BMP code point - codeUnits.push(codePoint); - } else { // Astral code point; split in surrogate halves - // https://mathiasbynens.be/notes/javascript-encoding#surrogate-formulae - codePoint -= 0x10000; - highSurrogate = (codePoint >> 10) + 0xD800; - lowSurrogate = (codePoint % 0x400) + 0xDC00; - codeUnits.push(highSurrogate, lowSurrogate); - } - if (index + 1 == length || codeUnits.length > MAX_SIZE) { - result += stringFromCharCode.apply(null, codeUnits); - codeUnits.length = 0; - } - } - return result; - } - })(); -} - -if(String.prototype.codePointAt) { - h$jsstringSingleton = function(ch) { - TRACE_JSSTRING("(codePointAt) singleton: " + ch); - return String.fromCodePoint(ch); - } - h$jsstringHead = function(str) { - TRACE_JSSTRING("(codePointAt) head: " + str); - var cp = str.codePointAt(0); - return (cp === undefined) ? -1 : (cp|0); - } - h$jsstringTail = function(str) { - TRACE_JSSTRING("(codePointAt) tail: " + str); - var l = str.length; - if(l===0) return null; - var ch = str.codePointAt(0); - if(ch === undefined) return null; - // string length is at least two if ch comes from a surrogate pair - return str.substr(IS_ASTRAL(ch)?2:1); - } - h$jsstringCons = function(ch, str) { - TRACE_JSSTRING("(codePointAt) cons: " + ch + " '" + str + "'"); - return String.fromCodePoint(ch)+str; - } - h$jsstringSnoc = function(str, ch) { - TRACE_JSSTRING("(codePointAt) snoc: '" + str + "' " + ch); - return str+String.fromCodePoint(ch); - } - h$jsstringUncons = function(str) { - TRACE_JSSTRING("(codePointAt) uncons: '" + str + "'"); - var l = str.length; - if(l===0) { - RETURN_UBX_TUP2(-1, null); - } - var ch = str.codePointAt(0); - if(ch === undefined) { - RETURN_UBX_TUP2(-1, null); - } - RETURN_UBX_TUP2(ch, str.substr(IS_ASTRAL(ch)?2:1)); - } - // index is the first part of the character - h$jsstringIndex = function(i, str) { - TRACE_JSSTRING("(codePointAt) index: " + i + " '" + str + "'"); - var ch = str.codePointAt(i); - if(ch === undefined) return -1; - return ch; - } - h$jsstringUncheckedIndex = function(i, str) { - TRACE_JSSTRING("(codePointAt) uncheckedIndex: " + i + " '" + str.length + "'"); - return str.codePointAt(i); - } -} else { - h$jsstringSingleton = function(ch) { - TRACE_JSSTRING("(no codePointAt) singleton: " + ch); - return (IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) - : String.fromCharCode(ch); - } - h$jsstringHead = function(str) { - TRACE_JSSTRING("(no codePointAt) head: " + str); - var l = str.length; - if(l===0) return -1; - var ch = str.charCodeAt(0); - if(IS_HI_SURR(ch)) { - return (l>1) ? FROM_SURR(ch, str.charCodeAt(1)) : -1; - } else { - return ch; - } - } - h$jsstringTail = function(str) { - TRACE_JSSTRING("(no codePointAt) tail: " + str); - var l = str.length; - if(l===0) return null; - var ch = str.charCodeAt(0); - if(IS_HI_SURR(ch)) { - return (l>1)?str.substr(2):null; - } else return str.substr(1); - } - h$jsstringCons = function(ch, str) { - TRACE_JSSTRING("(no codePointAt) cons: " + ch + " '" + str + "'"); - return ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) - : String.fromCharCode(ch)) - + str; - } - h$jsstringSnoc = function(str, ch) { - TRACE_JSSTRING("(no codePointAt) snoc: '" + str + "' " + ch); - return str + ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) - : String.fromCharCode(ch)); - } - h$jsstringUncons = function(str) { - TRACE_JSSTRING("(no codePointAt) uncons: '" + str + "'"); - var l = str.length; - if(l===0) { - RETURN_UBX_TUP2(-1, null); - } - var ch = str.charCodeAt(0); - if(IS_HI_SURR(ch)) { - if(l > 1) { - RETURN_UBX_TUP2(FROM_SURR(ch, str.charCodeAt(1)), str.substr(2)); - } else { - RETURN_UBX_TUP2(-1, null); - } - } else { - RETURN_UBX_TUP2(ch, str.substr(1)); - } - } - // index is the first part of the character - h$jsstringIndex = function(i, str) { - // TRACE_JSSTRING("(no codePointAt) index: " + i + " '" + str + "'"); - var ch = str.charCodeAt(i); - if(ch != ch) return -1; // NaN test - return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch; - } - h$jsstringUncheckedIndex = function(i, str) { - TRACE_JSSTRING("(no codePointAt) uncheckedIndex: " + i + " '" + str.length + "'"); - var ch = str.charCodeAt(i); - return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch; - } -} - -function h$jsstringUnsnoc(str) { - TRACE_JSSTRING("unsnoc: '" + str + "'"); - var l = str.length; - if(l===0) { - RETURN_UBX_TUP2(-1, null); - } - var ch = str.charCodeAt(l-1); - if(IS_LO_SURR(ch)) { - if(l !== 1) { - RETURN_UBX_TUP2(FROM_SURR(str.charCodeAt(l-2),ch), str.substr(0,l-2)); - } else { - RETURN_UBX_TUP2(-1, null); - } - } else { - RETURN_UBX_TUP2(ch, str.substr(0,l-1)); - } -} - - -function h$jsstringPack(xs) { - var r = '', i = 0, a = [], c; - while(IS_CONS(xs)) { - c = CONS_HEAD(xs); - a[i++] = UNWRAP_NUMBER(c); - if(i >= 60000) { - r += h$fromCodePoint.apply(null, a); - a = []; - i = 0; - } - xs = CONS_TAIL(xs); - } - if(i > 0) r += h$fromCodePoint.apply(null, a); - TRACE_JSSTRING("pack: '" + r + "'"); - return r; -} - -function h$jsstringPackReverse(xs) { - var a = [], i = 0, c; - while(IS_CONS(xs)) { - c = CONS_HEAD(xs); - a[i++] = UNWRAP_NUMBER(c); - xs = CONS_TAIL(xs); - } - if(i===0) return ''; - var r = h$jsstringConvertArray(a.reverse()); - TRACE_JSSTRING("packReverse: '" + r + "'"); - return r; -} - -function h$jsstringPackArray(arr) { - TRACE_JSSTRING("pack array: " + arr); - return h$jsstringConvertArray(arr); -} - -function h$jsstringPackArrayReverse(arr) { - TRACE_JSSTRING("pack array reverse: " + arr); - return h$jsstringConvertArray(arr.reverse()); -} - -function h$jsstringConvertArray(arr) { - if(arr.length < 60000) { - return h$fromCodePoint.apply(null, arr); - } else { - var r = ''; - for(var i=0; i1) ? FROM_SURR(str.charCodeAt(l-2), ch) : -1; - - } else return ch; -} - -// index is the last part of the character -function h$jsstringIndexR(i, str) { - TRACE_JSSTRING("indexR: " + i + " '" + str + "'"); - if(i < 0 || i > str.length) return -1; - var ch = str.charCodeAt(i); - return (IS_LO_SURR(ch)) ? FROM_SURR(str.charCodeAt(i-1), ch) : ch; -} - -function h$jsstringNextIndex(i, str) { - TRACE_JSSTRING("nextIndex: " + i + " '" + str + "'"); - return i + (IS_HI_SURR(str.charCodeAt(i))?2:1); -} - -function h$jsstringTake(n, str) { - TRACE_JSSTRING("take: " + n + " '" + str + "'"); - if(n <= 0) return ''; - var i = 0, l = str.length, ch; - if(n >= l) return str; - while(n--) { - ch = str.charCodeAt(i++); - if(IS_HI_SURR(ch)) i++; - if(i >= l) return str; - } - return str.substr(0,i); -} - -function h$jsstringDrop(n, str) { - TRACE_JSSTRING("drop: " + n + " '" + str + "'"); - if(n <= 0) return str; - var i = 0, l = str.length, ch; - if(n >= l) return ''; - while(n--) { - ch = str.charCodeAt(i++); - if(IS_HI_SURR(ch)) i++; - if(i >= l) return ''; - } - return str.substr(i); -} - -function h$jsstringSplitAt(n, str) { - TRACE_JSSTRING("splitAt: " + n + " '" + str + "'"); - if(n <= 0) { - RETURN_UBX_TUP2("", str); - } else if(n >= str.length) { - RETURN_UBX_TUP2(str, ""); - } - var i = 0, l = str.length, ch; - while(n--) { - ch = str.charCodeAt(i++); - if(IS_HI_SURR(ch)) i++; - if(i >= l) { - RETURN_UBX_TUP2(str, ""); - } - } - RETURN_UBX_TUP2(str.substr(0,i),str.substr(i)); -} - -function h$jsstringTakeEnd(n, str) { - TRACE_JSSTRING("takeEnd: " + n + " '" + str + "'"); - if(n <= 0) return ''; - var l = str.length, i = l-1, ch; - if(n >= l) return str; - while(n-- && i > 0) { - ch = str.charCodeAt(i--); - if(IS_LO_SURR(ch)) i--; - } - return (i<0) ? str : str.substr(i+1); -} - -function h$jsstringDropEnd(n, str) { - TRACE_JSSTRING("dropEnd: " + n + " '" + str + "'"); - if(n <= 0) return str; - var l = str.length, i = l-1, ch; - if(n >= l) return ''; - while(n-- && i > 0) { - ch = str.charCodeAt(i--); - if(IS_LO_SURR(ch)) i--; - } - return (i<0) ? '' : str.substr(0,i+1); -} - -function h$jsstringIntercalate(x, ys) { - TRACE_JSSTRING("intercalate: '" + x + "'"); - var a = [], i = 0; - while(IS_CONS(ys)) { - if(i) a[i++] = x; - a[i++] = JSVAL_VAL(CONS_HEAD(ys)); - ys = CONS_TAIL(ys); - } - return a.join(''); -} - -function h$jsstringIntersperse(ch, ys) { - TRACE_JSSTRING("intersperse: " + ch + " '" + ys + "'"); - var i = 0, l = ys.length, j = 0, a = [], ych; - if(IS_ASTRAL(ch)) { - while(j < l) { - if(i) a[i++] = ch; - ych = ys.charCodeAt(j++); - a[i++] = ych; - if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++); - } - } else { - while(j < l) { - if(i) a[i++] = ch; - ych = ys.charCodeAt(j++); - a[i++] = ych; - if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++); - } - } - return h$jsstringConvertArray(a); -} - -function h$jsstringConcat(xs) { - TRACE_JSSTRING("concat"); - var a = [], i = 0; - while(IS_CONS(xs)) { - a[i++] = JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - } - return a.join(''); -} - -var h$jsstringStripPrefix, h$jsstringStripSuffix, - h$jsstringIsPrefixOf, h$jsstringIsSuffixOf, - h$jsstringIsInfixOf; -if(String.prototype.startsWith) { - h$jsstringStripPrefix = function(p, x) { - TRACE_JSSTRING("(startsWith) stripPrefix: '" + p + "' '" + x + "'"); - if(x.startsWith(p)) { - return MK_JUST(MK_JSVAL(x.substr(p.length))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsPrefixOf = function(p, x) { - TRACE_JSSTRING("(startsWith) isPrefixOf: '" + p + "' '" + x + "'"); - return x.startsWith(p); - } - -} else { - h$jsstringStripPrefix = function(p, x) { - TRACE_JSSTRING("(no startsWith) stripPrefix: '" + p + "' '" + x + "'"); - if(x.indexOf(p) === 0) { // this has worse complexity than it should - return MK_JUST(MK_JSVAL(x.substr(p.length))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsPrefixOf = function(p, x) { - TRACE_JSSTRING("(no startsWith) isPrefixOf: '" + p + "' '" + x + "'"); - return x.indexOf(p) === 0; // this has worse complexity than it should - } -} - -if(String.prototype.endsWith) { - h$jsstringStripSuffix = function(s, x) { - TRACE_JSSTRING("(endsWith) stripSuffix: '" + s + "' '" + x + "'"); - if(x.endsWith(s)) { - return MK_JUST(MK_JSVAL(x.substr(0,x.length-s.length))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsSuffixOf = function(s, x) { - TRACE_JSSTRING("(endsWith) isSuffixOf: '" + s + "' '" + x + "'"); - return x.endsWith(s); - } -} else { - h$jsstringStripSuffix = function(s, x) { - TRACE_JSSTRING("(no endsWith) stripSuffix: '" + s + "' '" + x + "'"); - var i = x.lastIndexOf(s); // this has worse complexity than it should - var l = x.length - s.length; - if(i !== -1 && i === l) { - return MK_JUST(MK_JSVAL(x.substr(0,l))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsSuffixOf = function(s, x) { - TRACE_JSSTRING("(no endsWith) isSuffixOf: '" + s + "' '" + x + "'"); - var i = x.lastIndexOf(s); // this has worse complexity than it should - return i !== -1 && i === x.length - s.length; - } -} - -if(String.prototype.includes) { - h$jsstringIsInfixOf = function(i, x) { - TRACE_JSSTRING("(includes) isInfixOf: '" + i + "' '" + x + "'"); - return x.includes(i); - } -} else { - h$jsstringIsInfixOf = function(i, x) { - TRACE_JSSTRING("(no includes) isInfixOf: '" + i + "' '" + x + "'"); - return x.indexOf(i) !== -1; // this has worse complexity than it should - } -} - -function h$jsstringCommonPrefixes(x, y) { - TRACE_JSSTRING("commonPrefixes: '" + x + "' '" + y + "'"); - var lx = x.length, ly = y.length, i = 0, cx; - var l = lx <= ly ? lx : ly; - if(lx === 0 || ly === 0 || x.charCodeAt(0) !== y.charCodeAt(0)) { - return HS_NOTHING; - } - while(++i= 0) r = MK_CONS(a[i], r); - return r; -} - -function h$jsstringSplitOn1(n, p, x) { - TRACE_JSSTRING("splitOn1: " + n + " '" + p + "' '" + x + "'"); - var i = x.indexOf(p, n); - if(i === -1) { - RETURN_UBX_TUP2(-1, null); - } - var r1 = (i==n) ? "" : x.substr(n, i-n); - RETURN_UBX_TUP2(i + p.length, r1); -} - -function h$jsstringSplitOn(p, x) { - TRACE_JSSTRING("splitOn: '" + p + "' '" + x + "'"); - var a = x.split(p); - var r = HS_NIL, i = a.length; - while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); - return r; -} - -// returns -1 for end of input, start of next token otherwise -// word in h$ret1 -// this function assumes that there are no whitespace characters >= 0x10000 -function h$jsstringWords1(n, x) { - TRACE_JSSTRING("words1: " + n + " '" + x + "'"); - var m = n, s = n, l = x.length; - if(m >= l) return -1; - // skip leading spaces - do { - if(m >= l) return -1; - } while(h$isSpace(x.charCodeAt(m++))); - // found start of word - s = m - 1; - while(m < l) { - if(h$isSpace(x.charCodeAt(m++))) { - // found end of word - var r1 = (m-s<=1) ? "" : x.substr(s,m-s-1); - RETURN_UBX_TUP2(m, r1); - } - } - // end of string - if(s < l) { - var r1 = s === 0 ? x : x.substr(s); - RETURN_UBX_TUP2(m, r1); - } - RETURN_UBX_TUP2(-1, null); -} - -function h$jsstringWords(x) { - TRACE_JSSTRING("words: '" + x + "'"); - var a = null, i = 0, n, s = -1, m = 0, w, l = x.length, r = HS_NIL; - outer: - while(m < l) { - // skip leading spaces - do { - if(m >= l) { s = m; break outer; } - } while(h$isSpace(x.charCodeAt(m++))); - // found start of word - s = m - 1; - while(m < l) { - if(h$isSpace(x.charCodeAt(m++))) { - // found end of word - w = (m-s<=1) ? h$jsstringEmpty - : MK_JSVAL(x.substr(s,m-s-1)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - s = m; - break; - } - } - } - // end of string - if(s !== -1 && s < l) { - w = MK_JSVAL(s === 0 ? x : x.substr(s)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - } - // build resulting list - while(--i>=0) r = MK_CONS(a[i], r); - return r; -} - -// returns -1 for end of input, start of next token otherwise -// line in h$ret1 -function h$jsstringLines1(n, x) { - TRACE_JSSTRING("lines1: " + n + " '" + x + "'"); - var m = n, l = x.length; - if(n >= l) return -1; - while(m < l) { - if(x.charCodeAt(m++) === 10) { - // found newline - if(n > 0 && n === l-1) return -1; // it was the last character - var r1 = (m-n<=1) ? "" : x.substr(n,m-n-1); - RETURN_UBX_TUP2(m, r1); - } - } - // end of string - RETURN_UBX_TUP2(m, x.substr(n)); -} - -function h$jsstringLines(x) { - TRACE_JSSTRING("lines: '" + x + "'"); - var a = null, m = 0, i = 0, l = x.length, s = 0, r = HS_NIL, w; - if(l === 0) return HS_NIL; - outer: - while(true) { - s = m; - do { - if(m >= l) break outer; - } while(x.charCodeAt(m++) !== 10); - w = (m-s<=1) ? h$jsstringEmpty : MK_JSVAL(x.substr(s,m-s-1)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - } - if(s < l) { - w = MK_JSVAL(x.substr(s)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - } - while(--i>=0) r = MK_CONS(a[i], r); - return r; -} - -function h$jsstringGroup(x) { - TRACE_JSSTRING("group: '" + x + "'"); - var xl = x.length; - if(xl === 0) return HS_NIL; - var i = xl-1, si, ch, s=xl, r=HS_NIL; - var tch = x.charCodeAt(i--); - if(IS_LO_SURR(tch)) tch = FROM_SURR(x.charCodeAt(i--), tch); - while(i >= 0) { - si = i; - ch = x.charCodeAt(i--); - if(IS_LO_SURR(ch)) { - ch = FROM_SURR(x.charCodeAt(i--), ch); - } - if(ch != tch) { - tch = ch; - r = MK_CONS(MK_JSVAL(x.substr(si+1,s-si)), r); - s = si; - } - } - return MK_CONS(MK_JSVAL(x.substr(0,s+1)), r); -} - -function h$jsstringChunksOf1(n, s, x) { - TRACE_JSSTRING("chunksOf1: " + n + " " + s + " '" + x + "'"); - var m = s, c = 0, l = x.length, ch; - if(n <= 0 || l === 0 || s >= l) return -1 - while(++m < l) { - ch = x.charCodeAt(m - 1); - if(IS_HI_SURR(ch)) ++m; - if(++c >= n) break; - } - var r1 = (m >= l && s === c) ? x : x.substr(s,m-s); - RETURN_UBX_TUP2(m, r1); -} - -function h$jsstringChunksOf(n, x) { - TRACE_JSSTRING("chunksOf: " + n + " '" + x + "'"); - var l = x.length; - if(l===0 || n <= 0) return HS_NIL; - if(l <= n) return MK_CONS(MK_JSVAL(x), HS_NIL); - var a = [], i = 0, s = 0, ch, m = 0, c, r = HS_NIL; - while(m < l) { - s = m; - c = 0; - while(m < l && ++c <= n) { - ch = x.charCodeAt(m++); - if(IS_HI_SURR(ch)) ++m; - } - if(c) a[i++] = x.substr(s, m-s); - } - while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); - return r; -} - -function h$jsstringCount(pat, src) { - TRACE_JSSTRING("count: '" + pat + "' '" + src + "'"); - var i = 0, n = 0, pl = pat.length, sl = src.length; - while(i>= 1; - } while(n > 1); - return r+str; -} - -// this does not deal with combining diacritics, Data.Text does not either -var h$jsstringReverse; -if(Array.from) { - h$jsstringReverse = function(str) { - TRACE_JSSTRING("(Array.from) reverse: '" + str + "'"); - return Array.from(str).reverse().join(''); - } -} else { - h$jsstringReverse = function(str) { - TRACE_JSSTRING("(no Array.from) reverse: '" + str + "'"); - var l = str.length, a = [], o = 0, i = 0, c, c1, s = ''; - while(i < l) { - c = str.charCodeAt(i); - if(IS_HI_SURR(c)) { - a[i] = str.charCodeAt(i+1); - a[i+1] = c; - i += 2; - } else a[i++] = c; - if(i-o > 60000) { - s = String.fromCharCode.apply(null, a.reverse()) + s; - o = -i; - a = []; - } - } - return (i===0) ? s : String.fromCharCode.apply(null,a.reverse()) + s; - } -} - -function h$jsstringUnpack(str) { - TRACE_JSSTRING("unpack: '" + str + "'"); - var r = HS_NIL, i = str.length-1, c; - while(i >= 0) { - c = str.charCodeAt(i--); - if(IS_LO_SURR(c)) c = FROM_SURR(str.charCodeAt(i--), c) - r = MK_CONS(c, r); - } - return r; -} - - - -#if __GLASGOW_HASKELL__ >= 800 -function h$jsstringDecInteger(val) { - TRACE_JSSTRING("decInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else if(IS_INTEGER_Jp(val)) { - return h$ghcjsbn_showBase(INTEGER_J_DATA(val), 10); - } else { - return '-' + h$ghcjsbn_showBase(INTEGER_J_DATA(val), 10); - } -} -#else -function h$jsstringDecInteger(val) { - TRACE_JSSTRING("decInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else { - return INTEGER_J_DATA(val).toString(); - } -} -#endif - -function h$jsstringDecI64(hi,lo) { - TRACE_JSSTRING("decI64: " + hi + " " + lo); - var lo0 = (lo < 0) ? lo+4294967296:lo; - if(hi < 0) { - if(hi === -1) return ''+(lo0-4294967296); - lo0 = 4294967296 - lo0; - var hi0 = -1 - hi; - var x0 = hi0 * 967296; - var x1 = (lo0 + x0) % 1000000; - var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000); - return '-' + x2 + h$jsstringDecIPadded6(x1); - } else { - if(hi === 0) return ''+lo0; - var x0 = hi * 967296; - var x1 = (lo0 + x0) % 1000000; - var x2 = hi*4294+Math.floor((x0+lo0-x1)/1000000); - return '' + x2 + h$jsstringDecIPadded6(x1); - } -} - -function h$jsstringDecW64(hi,lo) { - TRACE_JSSTRING("decW64: " + hi + " " + lo); - var lo0 = (lo < 0) ? lo+4294967296 : lo; - if(hi === 0) return ''+lo0; - var hi0 = (hi < 0) ? hi+4294967296 : hi; - var x0 = hi0 * 967296; - var x1 = (lo0 + x0) % 1000000; - var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000); - return '' + x2 + h$jsstringDecIPadded6(x1); -} - -#if __GLASGOW_HASKELL__ >= 800 -function h$jsstringHexInteger(val) { - TRACE_JSSTRING("hexInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else { - // we assume it's nonnegative. this condition is checked by the Haskell code - return h$ghcjsbn_showBase(INTEGER_J_DATA(val), 16); - } -} -#else -function h$jsstringHexInteger(val) { - TRACE_JSSTRING("hexInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else { - return INTEGER_J_DATA(val).toRadix(16); - } -} -#endif - -function h$jsstringHexI64(hi,lo) { - var lo0 = lo<0 ? lo+4294967296 : lo; - if(hi === 0) return lo0.toString(16); - return ((hi<0)?hi+4294967296:hi).toString(16) + h$jsstringHexIPadded8(lo0); -} - -function h$jsstringHexW64(hi,lo) { - var lo0 = lo<0 ? lo+4294967296 : lo; - if(hi === 0) return lo0.toString(16); - return ((hi<0)?hi+4294967296:hi).toString(16) + h$jsstringHexIPadded8(lo0); -} - -// n in [0, 1000000000) -function h$jsstringDecIPadded9(n) { - TRACE_JSSTRING("decIPadded9: " + n); - if(n === 0) return '000000000'; - var pad = (n>=100000000)?'': - (n>=10000000)?'0': - (n>=1000000)?'00': - (n>=100000)?'000': - (n>=10000)?'0000': - (n>=1000)?'00000': - (n>=100)?'000000': - (n>=10)?'0000000': - '00000000'; - return pad+n; -} - -// n in [0, 1000000) -function h$jsstringDecIPadded6(n) { - TRACE_JSSTRING("decIPadded6: " + n); - if(n === 0) return '000000'; - var pad = (n>=100000)?'': - (n>=10000)?'0': - (n>=1000)?'00': - (n>=100)?'000': - (n>=10)?'0000': - '00000'; - return pad+n; -} - -// n in [0, 2147483648) -function h$jsstringHexIPadded8(n) { - TRACE_JSSTRING("hexIPadded8: " + n); - if(n === 0) return '00000000'; - var pad = (n>=0x10000000)?'': - (n>=0x1000000)?'0': - (n>=0x100000)?'00': - (n>=0x10000)?'000': - (n>=0x1000)?'0000': - (n>=0x100)?'00000': - (n>=0x10)?'000000': - '0000000'; - return pad+n.toString(16); -} - -function h$jsstringZeroes(n) { - var r; - switch(n&7) { - case 0: r = ''; break; - case 1: r = '0'; break; - case 2: r = '00'; break; - case 3: r = '000'; break; - case 4: r = '0000'; break; - case 5: r = '00000'; break; - case 6: r = '000000'; break; - case 7: r = '0000000'; - } - for(var i=n>>3;i>0;i--) r = r + '00000000'; - return r; -} - -function h$jsstringDoubleToFixed(decs, d) { - if(decs >= 0) { - if(Math.abs(d) < 1e21) { - var r = d.toFixed(Math.min(20,decs)); - if(decs > 20) r = r + h$jsstringZeroes(decs-20); - return r; - } else { - var r = d.toExponential(); - var ei = r.indexOf('e'); - var di = r.indexOf('.'); - var e = parseInt(r.substr(ei+1)); - return r.substring(0,di) + r.substring(di,ei) + h$jsstringZeroes(di-ei+e) + - ((decs > 0) ? ('.' + h$jsstringZeroes(decs)) : ''); - } - } - var r = Math.abs(d).toExponential(); - var ei = r.indexOf('e'); - var e = parseInt(r.substr(ei+1)); - var m = d < 0 ? '-' : ''; - r = r.substr(0,1) + r.substring(2,ei); - if(e >= 0) { - return (e > r.length) ? m + r + h$jsstringZeroes(r.length-e-1) + '.0' - : m + r.substr(0,e+1) + '.' + r.substr(e+1); - } else { - return m + '0.' + h$jsstringZeroes(-e-1) + r; - } -} - -function h$jsstringDoubleToExponent(decs, d) { - var r; - if(decs ===-1) { - r = d.toExponential().replace('+',''); - } else { - r = d.toExponential(Math.max(1, Math.min(20,decs))).replace('+',''); - } - if(r.indexOf('.') === -1) { - r = r.replace('e', '.0e'); - } - if(decs > 20) r = r.replace('e', h$jsstringZeroes(decs-20)+'e'); - return r; -} - -function h$jsstringDoubleGeneric(decs, d) { - var r; - if(decs === -1) { - r = d.toString(10).replace('+',''); - } else { - r = d.toPrecision(Math.max(decs+1,1)).replace('+',''); - } - if(decs !== 0 && r.indexOf('.') === -1) { - if(r.indexOf('e') !== -1) { - r = r.replace('e', '.0e'); - } else { - r = r + '.0'; - } - } - return r; -} - -function h$jsstringAppend(x, y) { - TRACE_JSSTRING("append: '" + x + "' '" + y + "'"); - return x+y; -} - -function h$jsstringCompare(x, y) { - TRACE_JSSTRING("compare: '" + x + "' '" + y + "'"); - return (xy)?1:0); -} - -function h$jsstringUnlines(xs) { - var r = ''; - while(IS_CONS(xs)) { - r = r + JSVAL_VAL(CONS_HEAD(xs)) + '\n'; - xs = CONS_TAIL(xs); - } - return r; -} - -function h$jsstringUnwords(xs) { - if(IS_NIL(xs)) return ''; - var r = JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - while(IS_CONS(xs)) { - r = r + ' ' + JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - } - return r; -} - -function h$jsstringReplace(pat, rep, src) { - TRACE_JSSTRING("replace: '" + pat + "' '" + rep + "' '" + src + "'"); - var r = src.replace(pat, rep, 'g'); - // the 'g' flag is not supported everywhere, check and fall back if necessary - if(r.indexOf(pat) !== -1) { - r = src.split(pat).join(rep); - } - return r; -} - -function h$jsstringReplicateChar(n, ch) { - TRACE_JSSTRING("replicateChar: " + n + " " + ch); - return h$jsstringReplicate(n, h$jsstringSingleton(ch)); -} - -function h$jsstringIsInteger(str) { - return /^-?\d+$/.test(str); -} - -function h$jsstringIsNatural(str) { - return /^\d+$/.test(str); -} - -function h$jsstringReadInt(str) { - if(!/^-?\d+/.test(str)) return null; - var x = parseInt(str, 10); - var x0 = x|0; - return (x===x0) ? x0 : null; -} - -function h$jsstringLenientReadInt(str) { - var x = parseInt(str, 10); - var x0 = x|0; - return (x===x0) ? x0 : null; -} - -function h$jsstringReadWord(str) { - if(!/^\d+/.test(str)) return null; - var x = parseInt(str, 10); - var x0 = x|0; - if(x0<0) return (x===x0+2147483648) ? x0 : null; - else return (x===x0) ? x0 : null; -} - -function h$jsstringReadDouble(str) { - return parseFloat(str, 10); -} - -function h$jsstringLenientReadDouble(str) { - return parseFloat(str, 10); -} - -function h$jsstringReadInteger(str) { - TRACE_JSSTRING("readInteger: " + str); - if(!/^(-)?\d+$/.test(str)) { - return null; - } else if(str.length <= 9) { - return MK_INTEGER_S(parseInt(str, 10)); - } else { -#if __GLASGOW_HASKELL__ >= 800 - return h$ghcjsbn_readInteger(str); -#else - return MK_INTEGER_J(new BigInteger(str, 10)); -#endif - } -} - -function h$jsstringReadInt64(str) { - if(!/^(-)?\d+$/.test(str)) { - RETURN_UBX_TUP3(0, 0, 0); - } - if(str.charCodeAt(0) === 45) { // '-' - return h$jsstringReadValue64(str, 1, true); - } else { - return h$jsstringReadValue64(str, 0, false); - } -} - -function h$jsstringReadWord64(str) { - if(!/^\d+$/.test(str)) { - RETURN_UBX_TUP3(0, 0, 0); - } - return h$jsstringReadValue64(str, 0, false); -} - -var h$jsstringLongs = null; - -function h$jsstringReadValue64(str, start, negate) { - var l = str.length, i = start; - while(i < l) { - if(str.charCodeAt(i) !== 48) break; - i++; - } - if(i >= l) RETURN_UBX_TUP3(1, 0, 0); // only zeroes - if(h$jsstringLongs === null) { - h$jsstringLongs = []; - for(var t=10; t<=1000000000; t*=10) { - h$jsstringLongs.push(goog.math.Long.fromInt(t)); - } - } - var li = l-i; - if(li < 10 && !negate) { - RETURN_UBX_TUP3(1, 0, parseInt(str.substr(i), 10)); - } - var r = goog.math.Long.fromInt(parseInt(str.substr(li,9),10)); - li += 9; - while(li < l) { - r = r.multiply(h$jsstringLongs[Math.min(l-li-1,8)]) - .add(goog.math.Long.fromInt(parseInt(str.substr(li,9), 10))); - li += 9; - } - if(negate) { - r = r.negate(); - } - RETURN_UBX_TUP3(1, r.getHighBits(), r.getLowBits()); -} - -function h$jsstringExecRE(i, str, re) { - re.lastIndex = i; - var m = re.exec(str); - if(m === null) return -1; - var a = [], x, j = 1, r = HS_NIL; - while(true) { - x = m[j]; - if(typeof x === 'undefined') break; - a[j-1] = x; - j++; - } - j-=1; - while(--j>=0) r = MK_CONS(MK_JSVAL(a[j]), r); - RETURN_UBX_TUP3(m.index, m[0], r); -} - -function h$jsstringReplaceRE(pat, replacement, str) { - return str.replace(pat, replacement); -} - -function h$jsstringSplitRE(limit, re, str) { - re.lastIndex = i; - var s = (limit < 0) ? str.split(re) : str.split(re, limit); - var i = s.length, r = HS_NIL; - while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); - return r; -} diff --git a/jsbits-old/jsstringRaw.js b/jsbits-old/jsstringRaw.js deleted file mode 100644 --- a/jsbits-old/jsstringRaw.js +++ /dev/null @@ -1,21 +0,0 @@ -#include - -/* - * Functions that directly access JavaScript strings, ignoring character - * widths and surrogate pairs. - */ - -function h$jsstringRawChunksOf(k, x) { - var l = x.length; - if(l === 0) return HS_NIL; - if(l <= k) return MK_CONS(MK_JSVAL(x), HS_NIL); - var r=HS_NIL; - for(var i=ls-k;i>=0;i-=k) r = MK_CONS(MK_JSVAL(x.substr(i,i+k)),r); - return r; -} - -function h$jsstringRawSplitAt(k, x) { - if(k === 0) return MK_TUP2(h$jsstringEmpty, MK_JSVAL(x)); - if(k >= x.length) return MK_TUP2(MK_JSVAL(x), h$jsstringEmpty); - return MK_TUP2(MK_JSVAL(x.substr(0,k)), MK_JSVAL(x.substr(k))); -} diff --git a/jsbits-old/text.js b/jsbits-old/text.js deleted file mode 100644 --- a/jsbits-old/text.js +++ /dev/null @@ -1,53 +0,0 @@ -// conversion between JavaScript string and Data.Text -#include - - -/* - convert a Data.Text buffer with offset/length to a JavaScript string - */ -function h$textToString(arr, off, len) { - var a = []; - var end = off+len; - var k = 0; - var u1 = arr.u1; - var s = ''; - for(var i=off;i=0;i--) u1[i] = s.charCodeAt(i); - RETURN_UBX_TUP2(b, l); -} - -function h$lazyTextToString(txt) { - var s = ''; - while(LAZY_TEXT_IS_CHUNK(txt)) { - var head = LAZY_TEXT_CHUNK_HEAD(txt); - s += h$textToString(DATA_TEXT_ARRAY(head), DATA_TEXT_OFFSET(head), DATA_TEXT_LENGTH(head)); - txt = LAZY_TEXT_CHUNK_TAIL(txt); - } - return s; -} - -function h$safeTextFromString(x) { - if(typeof x !== 'string') { - RETURN_UBX_TUP2(null, 0); - } - return h$textFromString(x); -} diff --git a/jsbits-old/utils.js b/jsbits-old/utils.js deleted file mode 100644 --- a/jsbits-old/utils.js +++ /dev/null @@ -1,93 +0,0 @@ -#include - -function h$allProps(o) { - var a = [], i = 0; - for(var p in o) a[i++] = p; - return a; -} - -function h$listProps(o) { - var r = HS_NIL; - for(var p in o) { r = MK_CONS(MK_JSVAL(p), r); } - return r; -} - -function h$listAssocs(o) { - var r = HS_NIL; - for(var p in o) { r = MK_CONS(MK_TUP2(MK_JSVAL(p), MK_JSVAL(o[p])), r); } - return r; -} - -function h$isNumber(o) { - return typeof(o) === 'number'; -} - -// returns true for null, but not for functions and host objects -function h$isObject(o) { - return typeof(o) === 'object'; -} - -function h$isString(o) { - return typeof(o) === 'string'; -} - -function h$isSymbol(o) { - return typeof(o) === 'symbol'; -} - -function h$isBoolean(o) { - return typeof(o) === 'boolean'; -} - -function h$isFunction(o) { - return typeof(o) === 'function'; -} - -function h$jsTypeOf(o) { - var t = typeof(o); - if(t === 'undefined') return 0; - if(t === 'object') return 1; - if(t === 'boolean') return 2; - if(t === 'number') return 3; - if(t === 'string') return 4; - if(t === 'symbol') return 5; - if(t === 'function') return 6; - return 7; // other, host object etc -} - -/* - -- 0 - null, 1 - integer, - -- 2 - float, 3 - bool, - -- 4 - string, 5 - array - -- 6 - object -*/ -function h$jsonTypeOf(o) { - if (!(o instanceof Object)) { - if (o == null) { - return 0; - } else if (typeof o == 'number') { - if (h$isInteger(o)) { - return 1; - } else { - return 2; - } - } else if (typeof o == 'boolean') { - return 3; - } else { - return 4; - } - } else { - if (Object.prototype.toString.call(o) == '[object Array]') { - // it's an array - return 5; - } else if (!o) { - // null - return 0; - } else { - // it's an object - return 6; - } - } - -} - diff --git a/jsbits-old/websocket.js b/jsbits-old/websocket.js deleted file mode 100644 --- a/jsbits-old/websocket.js +++ /dev/null @@ -1,58 +0,0 @@ -#include - -function h$createWebSocket(url, protocols) { - return new WebSocket(url, protocols); -} - -/* - this must be called before the websocket has connected, - typically synchronously after creating the socket - */ -function h$openWebSocket(ws, mcb, ccb, c) { - if(ws.readyState !== 0) { - throw new Error("h$openWebSocket: unexpected readyState, socket must be CONNECTING"); - } - ws.lastError = null; - ws.onopen = function() { - if(mcb) { - ws.onmessage = mcb; - } - if(ccb || mcb) { - ws.onclose = function(ce) { - if(ws.onmessage) { - h$release(ws.onmessage); - ws.onmessage = null; - } - if(ccb) { - h$release(ccb); - ccb(ce); - } - }; - }; - ws.onerror = function(err) { - ws.lastError = err; - if(ws.onmessage) { - h$release(ws.onmessage); - ws.onmessage = null; - } - ws.close(); - }; - c(null); - }; - ws.onerror = function(err) { - if(ccb) h$release(ccb); - if(mcb) h$release(mcb); - ws.onmessage = null; - ws.close(); - c(err); - }; -} - -function h$closeWebSocket(status, reason, ws) { - ws.onerror = null; - if(ws.onmessage) { - h$release(ws.onmessage); - ws.onmessage = null; - } - ws.close(status, reason); -} diff --git a/jsbits-old/xhr.js b/jsbits-old/xhr.js deleted file mode 100644 --- a/jsbits-old/xhr.js +++ /dev/null @@ -1,16 +0,0 @@ -function h$sendXHR(xhr, d, cont) { - xhr.addEventListener('error', function () { - cont(2); - }); - xhr.addEventListener('abort', function() { - cont(1); - }); - xhr.addEventListener('load', function() { - cont(0); - }); - if(d) { - xhr.send(d); - } else { - xhr.send(); - } -} diff --git a/jsbits/animationFrame.js b/jsbits/animationFrame.js new file mode 100644 --- /dev/null +++ b/jsbits/animationFrame.js @@ -0,0 +1,19 @@ +//#OPTIONS: CPP +function h$animationFrameCancel(h) { + if(h.handle) window.cancelAnimationFrame(h.handle); + if(h.callback) { + h$release(h.callback) + h.callback = null; + } +} + +function h$animationFrameRequest(h) { + h.handle = window.requestAnimationFrame(function(ts) { + var cb = h.callback; + if(cb) { + h$release(cb); + h.callback = null; + cb(ts); + } + }); +} diff --git a/jsbits/animationFrame.js.pp b/jsbits/animationFrame.js.pp deleted file mode 100644 --- a/jsbits/animationFrame.js.pp +++ /dev/null @@ -1,18 +0,0 @@ -function h$animationFrameCancel(h) { - if(h.handle) window.cancelAnimationFrame(h.handle); - if(h.callback) { - h$release(h.callback) - h.callback = null; - } -} - -function h$animationFrameRequest(h) { - h.handle = window.requestAnimationFrame(function(ts) { - var cb = h.callback; - if(cb) { - h$release(cb); - h.callback = null; - cb(ts); - } - }); -} diff --git a/jsbits/array.js b/jsbits/array.js new file mode 100644 --- /dev/null +++ b/jsbits/array.js @@ -0,0 +1,40 @@ +//#OPTIONS: CPP + +/* + convert an array to a Haskell list, wrapping each element in a + JSVal constructor + */ +function h$fromArray(a) { + var r = HS_NIL; + for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSVAL(a[i]), r); + return a; +} + +/* + convert an array to a Haskell list. No additional wrapping of the + elements is performed. Only use this when the elements are directly + usable as Haskell heap objects (numbers, boolean) or when the + array elements have already been appropriately wrapped + */ +function h$fromArrayNoWrap(a) { + var r = HS_NIL; + for(var i=a.length-1;i>=0;i--) r = MK_CONS(a[i], r); + return a; +} + +/* + convert a list of JSVal to an array. the list must have been fully forced, + not just the spine. + */ +function h$listToArray(xs) { + var a = [], i = 0; + while(IS_CONS(xs)) { + a[i++] = JSVAL_VAL(CONS_HEAD(xs)); + xs = CONS_TAIL(xs); + } + return a; +} + +function h$listToArrayWrap(xs) { + return MK_JSVAL(h$listToArray(xs)); +} diff --git a/jsbits/array.js.pp b/jsbits/array.js.pp deleted file mode 100644 --- a/jsbits/array.js.pp +++ /dev/null @@ -1,40 +0,0 @@ -#include - -/* - convert an array to a Haskell list, wrapping each element in a - JSVal constructor - */ -function h$fromArray(a) { - var r = HS_NIL; - for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSVAL(a[i]), r); - return a; -} - -/* - convert an array to a Haskell list. No additional wrapping of the - elements is performed. Only use this when the elements are directly - usable as Haskell heap objects (numbers, boolean) or when the - array elements have already been appropriately wrapped - */ -function h$fromArrayNoWrap(a) { - var r = HS_NIL; - for(var i=a.length-1;i>=0;i--) r = MK_CONS(a[i], r); - return a; -} - -/* - convert a list of JSVal to an array. the list must have been fully forced, - not just the spine. - */ -function h$listToArray(xs) { - var a = [], i = 0; - while(IS_CONS(xs)) { - a[i++] = JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - } - return a; -} - -function h$listToArrayWrap(xs) { - return MK_JSVAL(h$listToArray(xs)); -} diff --git a/jsbits/buffer.js b/jsbits/buffer.js new file mode 100644 --- /dev/null +++ b/jsbits/buffer.js @@ -0,0 +1,9 @@ +//#OPTIONS: CPP + +function h$fromAddr(ptr, off) { + RETURN_UBX_TUP2(ptr, off); +} + +function h$toAddr(ptr) { + RETURN_UBX_TUP2(ptr,0); +} diff --git a/jsbits/export.js b/jsbits/export.js new file mode 100644 --- /dev/null +++ b/jsbits/export.js @@ -0,0 +1,27 @@ +//#OPTIONS: CPP +function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) { + var e = { fp1a: fp1a + , fp1b: fp1b + , fp2a: fp2a + , fp2b: fp2b + , released: false + , root: o + , _key: -1 + }; + h$retain(e); + return e; +} + +function h$derefExport(fp1a,fp1b,fp2a,fp2b,e) { + if(!e || typeof e !== 'object') return null; + if(e.released) return null; + if(fp1a !== e.fp1a || fp1b !== e.fp1b || + fp2a !== e.fp2a || fp2b !== e.fp2b) return null; + return e.root; +} + +function h$releaseExport(e) { + h$release(e); + e.released = true; + e.root = null; +} diff --git a/jsbits/export.js.pp b/jsbits/export.js.pp deleted file mode 100644 --- a/jsbits/export.js.pp +++ /dev/null @@ -1,26 +0,0 @@ -function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) { - var e = { fp1a: fp1a - , fp1b: fp1b - , fp2a: fp2a - , fp2b: fp2b - , released: false - , root: o - , _key: -1 - }; - h$retain(e); - return e; -} - -function h$derefExport(fp1a,fp1b,fp2a,fp2b,e) { - if(!e || typeof e !== 'object') return null; - if(e.released) return null; - if(fp1a !== e.fp1a || fp1b !== e.fp1b || - fp2a !== e.fp2a || fp2b !== e.fp2b) return null; - return e.root; -} - -function h$releaseExport(e) { - h$release(e); - e.released = true; - e.root = null; -} diff --git a/jsbits/foreign.js b/jsbits/foreign.js new file mode 100644 --- /dev/null +++ b/jsbits/foreign.js @@ -0,0 +1,9 @@ +//#OPTIONS: CPP +function h$foreignListProps(o) { + var r = HS_NIL; + if(typeof o === 'undefined' || o === null) return null; + throw "h$foreignListProps"; +/* for(var p in o) { + + } */ +} diff --git a/jsbits/foreign.js.pp b/jsbits/foreign.js.pp deleted file mode 100644 --- a/jsbits/foreign.js.pp +++ /dev/null @@ -1,8 +0,0 @@ -function h$foreignListProps(o) { - var r = HS_NIL; - if(typeof o === 'undefined' || o === null) return null; - throw "h$foreignListProps"; -/* for(var p in o) { - - } */ -} diff --git a/jsbits/jsstring.js b/jsbits/jsstring.js new file mode 100644 --- /dev/null +++ b/jsbits/jsstring.js @@ -0,0 +1,1180 @@ +//#OPTIONS: CPP + +/* + * Support code for the Data.JSString module. This code presents a JSString + * as a sequence of code points and hides the underlying encoding ugliness of + * the JavaScript strings. + * + * Use Data.JSString.Raw for direct access to the JSThis makes the operations more expen + */ + +/* + * Some workarounds here for JS engines that do not support proper + * code point access + */ + +#ifdef GHCJS_TRACE_JSSTRING +#define TRACE_JSSTRING(args...) h$log("jsstring: ", args); +#else +#define TRACE_JSSTRING(args...) +#endif + +#define IS_ASTRAL(cp) ((cp)>=0x10000) +#define IS_HI_SURR(cp) ((cp|1023)===0xDBFF) +#define IS_LO_SURR(cp) ((cp|1023)===0xDFFF) +#define FROM_SURR(hi,lo) ((((hi)-0xD800)<<10)+(lo)-0xDC00+0x10000) +#define HI_SURR(cp) ((((cp)-0x10000)>>>10)+0xDC00) +#define LO_SURR(cp) (((cp)&0x3FF)+0xD800) + +var h$jsstringEmpty = MK_JSVAL(''); + +var h$jsstringHead, h$jsstringTail, h$jsstringCons, + h$jsstringSingleton, h$jsstringSnoc, h$jsstringUncons, + h$jsstringIndex, h$jsstringUncheckedIndex; + +var h$fromCodePoint; + +if(String.prototype.fromCodePoint) { + h$fromCodePoint = String.fromCodePoint; +} else { + // polyfill from https://github.com/mathiasbynens/String.fromCodePoint (MIT-license) + h$fromCodePoint = + (function() { + var stringFromCharCode = String.fromCharCode; + var floor = Math.floor; + return function(_) { + var MAX_SIZE = 0x4000; + var codeUnits = []; + var highSurrogate; + var lowSurrogate; + var index = -1; + var length = arguments.length; + if (!length) { + return ''; + } + var result = ''; + while (++index < length) { + var codePoint = Number(arguments[index]); + if ( + !isFinite(codePoint) || // `NaN`, `+Infinity`, or `-Infinity` + codePoint < 0 || // not a valid Unicode code point + codePoint > 0x10FFFF || // not a valid Unicode code point + floor(codePoint) != codePoint // not an integer + ) { + throw RangeError('Invalid code point: ' + codePoint); + } + if (codePoint <= 0xFFFF) { // BMP code point + codeUnits.push(codePoint); + } else { // Astral code point; split in surrogate halves + // https://mathiasbynens.be/notes/javascript-encoding#surrogate-formulae + codePoint -= 0x10000; + highSurrogate = (codePoint >> 10) + 0xD800; + lowSurrogate = (codePoint % 0x400) + 0xDC00; + codeUnits.push(highSurrogate, lowSurrogate); + } + if (index + 1 == length || codeUnits.length > MAX_SIZE) { + result += stringFromCharCode.apply(null, codeUnits); + codeUnits.length = 0; + } + } + return result; + } + })(); +} + +if(String.prototype.codePointAt) { + h$jsstringSingleton = function(ch) { + TRACE_JSSTRING("(codePointAt) singleton: " + ch); + return String.fromCodePoint(ch); + } + h$jsstringHead = function(str) { + TRACE_JSSTRING("(codePointAt) head: " + str); + var cp = str.codePointAt(0); + return (cp === undefined) ? -1 : (cp|0); + } + h$jsstringTail = function(str) { + TRACE_JSSTRING("(codePointAt) tail: " + str); + var l = str.length; + if(l===0) return null; + var ch = str.codePointAt(0); + if(ch === undefined) return null; + // string length is at least two if ch comes from a surrogate pair + return str.substr(IS_ASTRAL(ch)?2:1); + } + h$jsstringCons = function(ch, str) { + TRACE_JSSTRING("(codePointAt) cons: " + ch + " '" + str + "'"); + return String.fromCodePoint(ch)+str; + } + h$jsstringSnoc = function(str, ch) { + TRACE_JSSTRING("(codePointAt) snoc: '" + str + "' " + ch); + return str+String.fromCodePoint(ch); + } + h$jsstringUncons = function(str) { + TRACE_JSSTRING("(codePointAt) uncons: '" + str + "'"); + var l = str.length; + if(l===0) { + RETURN_UBX_TUP2(-1, null); + } + var ch = str.codePointAt(0); + if(ch === undefined) { + RETURN_UBX_TUP2(-1, null); + } + RETURN_UBX_TUP2(ch, str.substr(IS_ASTRAL(ch)?2:1)); + } + // index is the first part of the character + h$jsstringIndex = function(i, str) { + TRACE_JSSTRING("(codePointAt) index: " + i + " '" + str + "'"); + var ch = str.codePointAt(i); + if(ch === undefined) return -1; + return ch; + } + h$jsstringUncheckedIndex = function(i, str) { + TRACE_JSSTRING("(codePointAt) uncheckedIndex: " + i + " '" + str.length + "'"); + return str.codePointAt(i); + } +} else { + h$jsstringSingleton = function(ch) { + TRACE_JSSTRING("(no codePointAt) singleton: " + ch); + return (IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) + : String.fromCharCode(ch); + } + h$jsstringHead = function(str) { + TRACE_JSSTRING("(no codePointAt) head: " + str); + var l = str.length; + if(l===0) return -1; + var ch = str.charCodeAt(0); + if(IS_HI_SURR(ch)) { + return (l>1) ? FROM_SURR(ch, str.charCodeAt(1)) : -1; + } else { + return ch; + } + } + h$jsstringTail = function(str) { + TRACE_JSSTRING("(no codePointAt) tail: " + str); + var l = str.length; + if(l===0) return null; + var ch = str.charCodeAt(0); + if(IS_HI_SURR(ch)) { + return (l>1)?str.substr(2):null; + } else return str.substr(1); + } + h$jsstringCons = function(ch, str) { + TRACE_JSSTRING("(no codePointAt) cons: " + ch + " '" + str + "'"); + return ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) + : String.fromCharCode(ch)) + + str; + } + h$jsstringSnoc = function(str, ch) { + TRACE_JSSTRING("(no codePointAt) snoc: '" + str + "' " + ch); + return str + ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) + : String.fromCharCode(ch)); + } + h$jsstringUncons = function(str) { + TRACE_JSSTRING("(no codePointAt) uncons: '" + str + "'"); + var l = str.length; + if(l===0) { + RETURN_UBX_TUP2(-1, null); + } + var ch = str.charCodeAt(0); + if(IS_HI_SURR(ch)) { + if(l > 1) { + RETURN_UBX_TUP2(FROM_SURR(ch, str.charCodeAt(1)), str.substr(2)); + } else { + RETURN_UBX_TUP2(-1, null); + } + } else { + RETURN_UBX_TUP2(ch, str.substr(1)); + } + } + // index is the first part of the character + h$jsstringIndex = function(i, str) { + // TRACE_JSSTRING("(no codePointAt) index: " + i + " '" + str + "'"); + var ch = str.charCodeAt(i); + if(ch != ch) return -1; // NaN test + return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch; + } + h$jsstringUncheckedIndex = function(i, str) { + TRACE_JSSTRING("(no codePointAt) uncheckedIndex: " + i + " '" + str.length + "'"); + var ch = str.charCodeAt(i); + return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch; + } +} + +function h$jsstringUnsnoc(str) { + TRACE_JSSTRING("unsnoc: '" + str + "'"); + var l = str.length; + if(l===0) { + RETURN_UBX_TUP2(-1, null); + } + var ch = str.charCodeAt(l-1); + if(IS_LO_SURR(ch)) { + if(l !== 1) { + RETURN_UBX_TUP2(FROM_SURR(str.charCodeAt(l-2),ch), str.substr(0,l-2)); + } else { + RETURN_UBX_TUP2(-1, null); + } + } else { + RETURN_UBX_TUP2(ch, str.substr(0,l-1)); + } +} + + +function h$jsstringPack(xs) { + var r = '', i = 0, a = [], c; + while(IS_CONS(xs)) { + c = CONS_HEAD(xs); + a[i++] = UNWRAP_NUMBER(c); + if(i >= 60000) { + r += h$fromCodePoint.apply(null, a); + a = []; + i = 0; + } + xs = CONS_TAIL(xs); + } + if(i > 0) r += h$fromCodePoint.apply(null, a); + TRACE_JSSTRING("pack: '" + r + "'"); + return r; +} + +function h$jsstringPackReverse(xs) { + var a = [], i = 0, c; + while(IS_CONS(xs)) { + c = CONS_HEAD(xs); + a[i++] = UNWRAP_NUMBER(c); + xs = CONS_TAIL(xs); + } + if(i===0) return ''; + var r = h$jsstringConvertArray(a.reverse()); + TRACE_JSSTRING("packReverse: '" + r + "'"); + return r; +} + +function h$jsstringPackArray(arr) { + TRACE_JSSTRING("pack array: " + arr); + return h$jsstringConvertArray(arr); +} + +function h$jsstringPackArrayReverse(arr) { + TRACE_JSSTRING("pack array reverse: " + arr); + return h$jsstringConvertArray(arr.reverse()); +} + +function h$jsstringConvertArray(arr) { + if(arr.length < 60000) { + return h$fromCodePoint.apply(null, arr); + } else { + var r = ''; + for(var i=0; i1) ? FROM_SURR(str.charCodeAt(l-2), ch) : -1; + + } else return ch; +} + +// index is the last part of the character +function h$jsstringIndexR(i, str) { + TRACE_JSSTRING("indexR: " + i + " '" + str + "'"); + if(i < 0 || i > str.length) return -1; + var ch = str.charCodeAt(i); + return (IS_LO_SURR(ch)) ? FROM_SURR(str.charCodeAt(i-1), ch) : ch; +} + +function h$jsstringNextIndex(i, str) { + TRACE_JSSTRING("nextIndex: " + i + " '" + str + "'"); + return i + (IS_HI_SURR(str.charCodeAt(i))?2:1); +} + +function h$jsstringTake(n, str) { + TRACE_JSSTRING("take: " + n + " '" + str + "'"); + if(n <= 0) return ''; + var i = 0, l = str.length, ch; + if(n >= l) return str; + while(n--) { + ch = str.charCodeAt(i++); + if(IS_HI_SURR(ch)) i++; + if(i >= l) return str; + } + return str.substr(0,i); +} + +function h$jsstringDrop(n, str) { + TRACE_JSSTRING("drop: " + n + " '" + str + "'"); + if(n <= 0) return str; + var i = 0, l = str.length, ch; + if(n >= l) return ''; + while(n--) { + ch = str.charCodeAt(i++); + if(IS_HI_SURR(ch)) i++; + if(i >= l) return ''; + } + return str.substr(i); +} + +function h$jsstringSplitAt(n, str) { + TRACE_JSSTRING("splitAt: " + n + " '" + str + "'"); + if(n <= 0) { + RETURN_UBX_TUP2("", str); + } else if(n >= str.length) { + RETURN_UBX_TUP2(str, ""); + } + var i = 0, l = str.length, ch; + while(n--) { + ch = str.charCodeAt(i++); + if(IS_HI_SURR(ch)) i++; + if(i >= l) { + RETURN_UBX_TUP2(str, ""); + } + } + RETURN_UBX_TUP2(str.substr(0,i),str.substr(i)); +} + +function h$jsstringTakeEnd(n, str) { + TRACE_JSSTRING("takeEnd: " + n + " '" + str + "'"); + if(n <= 0) return ''; + var l = str.length, i = l-1, ch; + if(n >= l) return str; + while(n-- && i >= 0) { + ch = str.charCodeAt(i--); + if(IS_LO_SURR(ch)) i--; + } + return (i<0) ? str : str.substr(i+1); +} + +function h$jsstringDropEnd(n, str) { + TRACE_JSSTRING("dropEnd: " + n + " '" + str + "'"); + if(n <= 0) return str; + var l = str.length, i = l-1, ch; + if(n >= l) return ''; + while(n-- && i >= 0) { + ch = str.charCodeAt(i--); + if(IS_LO_SURR(ch)) i--; + } + return (i<0) ? '' : str.substr(0,i+1); +} + +function h$jsstringIntercalate(x, ys) { + TRACE_JSSTRING("intercalate: '" + x + "'"); + var a = [], i = 0; + while(IS_CONS(ys)) { + if(i) a[i++] = x; + a[i++] = JSVAL_VAL(CONS_HEAD(ys)); + ys = CONS_TAIL(ys); + } + return a.join(''); +} + +function h$jsstringIntersperse(ch, ys) { + TRACE_JSSTRING("intersperse: " + ch + " '" + ys + "'"); + var i = 0, l = ys.length, j = 0, a = [], ych; + if(IS_ASTRAL(ch)) { + while(j < l) { + if(i) a[i++] = ch; + ych = ys.charCodeAt(j++); + a[i++] = ych; + if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++); + } + } else { + while(j < l) { + if(i) a[i++] = ch; + ych = ys.charCodeAt(j++); + a[i++] = ych; + if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++); + } + } + return h$jsstringConvertArray(a); +} + +function h$jsstringConcat(xs) { + TRACE_JSSTRING("concat"); + var a = [], i = 0; + while(IS_CONS(xs)) { + a[i++] = JSVAL_VAL(CONS_HEAD(xs)); + xs = CONS_TAIL(xs); + } + return a.join(''); +} + +var h$jsstringStripPrefix, h$jsstringStripSuffix, + h$jsstringIsPrefixOf, h$jsstringIsSuffixOf, + h$jsstringIsInfixOf; +if(String.prototype.startsWith) { + h$jsstringStripPrefix = function(p, x) { + TRACE_JSSTRING("(startsWith) stripPrefix: '" + p + "' '" + x + "'"); + if(x.startsWith(p)) { + return MK_JUST(MK_JSVAL(x.substr(p.length))); + } else { + return HS_NOTHING; + } + } + + h$jsstringIsPrefixOf = function(p, x) { + TRACE_JSSTRING("(startsWith) isPrefixOf: '" + p + "' '" + x + "'"); + return x.startsWith(p); + } + +} else { + h$jsstringStripPrefix = function(p, x) { + TRACE_JSSTRING("(no startsWith) stripPrefix: '" + p + "' '" + x + "'"); + if(x.indexOf(p) === 0) { // this has worse complexity than it should + return MK_JUST(MK_JSVAL(x.substr(p.length))); + } else { + return HS_NOTHING; + } + } + + h$jsstringIsPrefixOf = function(p, x) { + TRACE_JSSTRING("(no startsWith) isPrefixOf: '" + p + "' '" + x + "'"); + return x.indexOf(p) === 0; // this has worse complexity than it should + } +} + +if(String.prototype.endsWith) { + h$jsstringStripSuffix = function(s, x) { + TRACE_JSSTRING("(endsWith) stripSuffix: '" + s + "' '" + x + "'"); + if(x.endsWith(s)) { + return MK_JUST(MK_JSVAL(x.substr(0,x.length-s.length))); + } else { + return HS_NOTHING; + } + } + + h$jsstringIsSuffixOf = function(s, x) { + TRACE_JSSTRING("(endsWith) isSuffixOf: '" + s + "' '" + x + "'"); + return x.endsWith(s); + } +} else { + h$jsstringStripSuffix = function(s, x) { + TRACE_JSSTRING("(no endsWith) stripSuffix: '" + s + "' '" + x + "'"); + var i = x.lastIndexOf(s); // this has worse complexity than it should + var l = x.length - s.length; + if(i !== -1 && i === l) { + return MK_JUST(MK_JSVAL(x.substr(0,l))); + } else { + return HS_NOTHING; + } + } + + h$jsstringIsSuffixOf = function(s, x) { + TRACE_JSSTRING("(no endsWith) isSuffixOf: '" + s + "' '" + x + "'"); + var i = x.lastIndexOf(s); // this has worse complexity than it should + return i !== -1 && i === x.length - s.length; + } +} + +if(String.prototype.includes) { + h$jsstringIsInfixOf = function(i, x) { + TRACE_JSSTRING("(includes) isInfixOf: '" + i + "' '" + x + "'"); + return x.includes(i); + } +} else { + h$jsstringIsInfixOf = function(i, x) { + TRACE_JSSTRING("(no includes) isInfixOf: '" + i + "' '" + x + "'"); + return x.indexOf(i) !== -1; // this has worse complexity than it should + } +} + +function h$jsstringCommonPrefixes(x, y) { + TRACE_JSSTRING("commonPrefixes: '" + x + "' '" + y + "'"); + var lx = x.length, ly = y.length, i = 0, cx; + var l = lx <= ly ? lx : ly; + if(lx === 0 || ly === 0 || x.charCodeAt(0) !== y.charCodeAt(0)) { + return HS_NOTHING; + } + while(++i= 0) r = MK_CONS(a[i], r); + return r; +} + +function h$jsstringSplitOn1(n, p, x) { + TRACE_JSSTRING("splitOn1: " + n + " '" + p + "' '" + x + "'"); + var i = x.indexOf(p, n); + if(i === -1) { + RETURN_UBX_TUP2(-1, null); + } + var r1 = (i==n) ? "" : x.substr(n, i-n); + RETURN_UBX_TUP2(i + p.length, r1); +} + +function h$jsstringSplitOn(p, x) { + TRACE_JSSTRING("splitOn: '" + p + "' '" + x + "'"); + var a = x.split(p); + var r = HS_NIL, i = a.length; + while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); + return r; +} + +// returns -1 for end of input, start of next token otherwise +// word in h$ret1 +// this function assumes that there are no whitespace characters >= 0x10000 +function h$jsstringWords1(n, x) { + TRACE_JSSTRING("words1: " + n + " '" + x + "'"); + var m = n, s = n, l = x.length; + if(m >= l) return -1; + // skip leading spaces + do { + if(m >= l) return -1; + } while(h$isSpace(x.charCodeAt(m++))); + // found start of word + s = m - 1; + while(m < l) { + if(h$isSpace(x.charCodeAt(m++))) { + // found end of word + var r1 = (m-s<=1) ? "" : x.substr(s,m-s-1); + RETURN_UBX_TUP2(m, r1); + } + } + // end of string + if(s < l) { + var r1 = s === 0 ? x : x.substr(s); + RETURN_UBX_TUP2(m, r1); + } + RETURN_UBX_TUP2(-1, null); +} + +function h$jsstringWords(x) { + TRACE_JSSTRING("words: '" + x + "'"); + var a = null, i = 0, n, s = -1, m = 0, w, l = x.length, r = HS_NIL; + outer: + while(m < l) { + // skip leading spaces + do { + if(m >= l) { s = m; break outer; } + } while(h$isSpace(x.charCodeAt(m++))); + // found start of word + s = m - 1; + while(m < l) { + if(h$isSpace(x.charCodeAt(m++))) { + // found end of word + w = (m-s<=1) ? h$jsstringEmpty + : MK_JSVAL(x.substr(s,m-s-1)); + if(i) a[i++] = w; else { a = [w]; i = 1; } + s = m; + break; + } + } + } + // end of string + if(s !== -1 && s < l) { + w = MK_JSVAL(s === 0 ? x : x.substr(s)); + if(i) a[i++] = w; else { a = [w]; i = 1; } + } + // build resulting list + while(--i>=0) r = MK_CONS(a[i], r); + return r; +} + +// returns -1 for end of input, start of next token otherwise +// line in h$ret1 +function h$jsstringLines1(n, x) { + TRACE_JSSTRING("lines1: " + n + " '" + x + "'"); + var m = n, l = x.length; + if(n >= l) return -1; + while(m < l) { + if(x.charCodeAt(m++) === 10) { + // found newline + if(n > 0 && n === l-1) return -1; // it was the last character + var r1 = (m-n<=1) ? "" : x.substr(n,m-n-1); + RETURN_UBX_TUP2(m, r1); + } + } + // end of string + RETURN_UBX_TUP2(m, x.substr(n)); +} + +function h$jsstringLines(x) { + TRACE_JSSTRING("lines: '" + x + "'"); + var a = null, m = 0, i = 0, l = x.length, s = 0, r = HS_NIL, w; + if(l === 0) return HS_NIL; + outer: + while(true) { + s = m; + do { + if(m >= l) break outer; + } while(x.charCodeAt(m++) !== 10); + w = (m-s<=1) ? h$jsstringEmpty : MK_JSVAL(x.substr(s,m-s-1)); + if(i) a[i++] = w; else { a = [w]; i = 1; } + } + if(s < l) { + w = MK_JSVAL(x.substr(s)); + if(i) a[i++] = w; else { a = [w]; i = 1; } + } + while(--i>=0) r = MK_CONS(a[i], r); + return r; +} + +function h$jsstringGroup(x) { + TRACE_JSSTRING("group: '" + x + "'"); + var xl = x.length; + if(xl === 0) return HS_NIL; + var i = xl-1, si, ch, s=xl, r=HS_NIL; + var tch = x.charCodeAt(i--); + if(IS_LO_SURR(tch)) tch = FROM_SURR(x.charCodeAt(i--), tch); + while(i >= 0) { + si = i; + ch = x.charCodeAt(i--); + if(IS_LO_SURR(ch)) { + ch = FROM_SURR(x.charCodeAt(i--), ch); + } + if(ch != tch) { + tch = ch; + r = MK_CONS(MK_JSVAL(x.substr(si+1,s-si)), r); + s = si; + } + } + return MK_CONS(MK_JSVAL(x.substr(0,s+1)), r); +} + +function h$jsstringChunksOf1(n, s, x) { + TRACE_JSSTRING("chunksOf1: " + n + " " + s + " '" + x + "'"); + var m = s, c = 0, l = x.length, ch; + if(n <= 0 || l === 0 || s >= l) return -1 + while(++m < l) { + ch = x.charCodeAt(m - 1); + if(IS_HI_SURR(ch)) ++m; + if(++c >= n) break; + } + var r1 = (m >= l && s === c) ? x : x.substr(s,m-s); + RETURN_UBX_TUP2(m, r1); +} + +function h$jsstringChunksOf(n, x) { + TRACE_JSSTRING("chunksOf: " + n + " '" + x + "'"); + var l = x.length; + if(l===0 || n <= 0) return HS_NIL; + if(l <= n) return MK_CONS(MK_JSVAL(x), HS_NIL); + var a = [], i = 0, s = 0, ch, m = 0, c, r = HS_NIL; + while(m < l) { + s = m; + c = 0; + while(m < l && ++c <= n) { + ch = x.charCodeAt(m++); + if(IS_HI_SURR(ch)) ++m; + } + if(c) a[i++] = x.substr(s, m-s); + } + while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); + return r; +} + +function h$jsstringCount(pat, src) { + TRACE_JSSTRING("count: '" + pat + "' '" + src + "'"); + var i = 0, n = 0, pl = pat.length, sl = src.length; + while(i>= 1; + } while(n > 1); + return r+str; +} + +// this does not deal with combining diacritics, Data.Text does not either +var h$jsstringReverse; +if(Array.from) { + h$jsstringReverse = function(str) { + TRACE_JSSTRING("(Array.from) reverse: '" + str + "'"); + return Array.from(str).reverse().join(''); + } +} else { + h$jsstringReverse = function(str) { + TRACE_JSSTRING("(no Array.from) reverse: '" + str + "'"); + var l = str.length, a = [], o = 0, i = 0, c, c1, s = ''; + while(i < l) { + c = str.charCodeAt(i); + if(IS_HI_SURR(c)) { + a[i] = str.charCodeAt(i+1); + a[i+1] = c; + i += 2; + } else a[i++] = c; + if(i-o > 60000) { + s = String.fromCharCode.apply(null, a.reverse()) + s; + o = -i; + a = []; + } + } + return (i===0) ? s : String.fromCharCode.apply(null,a.reverse()) + s; + } +} + +function h$jsstringUnpack(str) { + TRACE_JSSTRING("unpack: '" + str + "'"); + var r = HS_NIL, i = str.length-1, c; + while(i >= 0) { + c = str.charCodeAt(i--); + if(IS_LO_SURR(c)) c = FROM_SURR(str.charCodeAt(i--), c) + r = MK_CONS(c, r); + } + return r; +} + +function h$jsstringDecBigNat(positive,x) { + TRACE_JSSTRING("decBigNat"); + const y = BigInt("0x" + h$jsstringHexBigNat(positive,x)).toString(); + return positive ? y : "-"+y; +} + +function h$jsstringDecI64(hi,lo) { + TRACE_JSSTRING("decI64: " + hi + " " + lo); + var lo0 = (lo < 0) ? lo+4294967296:lo; + if(hi < 0) { + if(hi === -1) return ''+(lo0-4294967296); + lo0 = 4294967296 - lo0; + var hi0 = -1 - hi; + var x0 = hi0 * 967296; + var x1 = (lo0 + x0) % 1000000; + var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000); + return '-' + x2 + h$jsstringDecIPadded6(x1); + } else { + if(hi === 0) return ''+lo0; + var x0 = hi * 967296; + var x1 = (lo0 + x0) % 1000000; + var x2 = hi*4294+Math.floor((x0+lo0-x1)/1000000); + return '' + x2 + h$jsstringDecIPadded6(x1); + } +} + +function h$jsstringDecW64(hi,lo) { + TRACE_JSSTRING("decW64: " + hi + " " + lo); + var lo0 = (lo < 0) ? lo+4294967296 : lo; + if(hi === 0) return ''+lo0; + var hi0 = (hi < 0) ? hi+4294967296 : hi; + var x0 = hi0 * 967296; + var x1 = (lo0 + x0) % 1000000; + var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000); + return '' + x2 + h$jsstringDecIPadded6(x1); +} + +function h$jsstringHexBigNat(positive,x) { + TRACE_JSSTRING("hexBigNat"); + var v = ""; + var i = x.u1.length - 1; + while (i >= 0) { + if (x.u1[i] !== 0) { + break; + } else { + i--; + } + } + if (i >= 0) { + v += x.u1[i].toString(16); + i--; + } + for (; i >= 0; i--) { + v += x.u1[i].toString(16).padStart(4, '0'); + } + return positive ? v : "-"+v; +} + +function h$jsstringHexI64(hi,lo) { + TRACE_JSSTRING("hexI64: " + hi + " " + lo); + var sign = (hi >>> 31) ? '-' : ''; + // unsigned right bitshift by zero to convert to UInt32 + var lo0 = sign ? ~(lo - 1) >>> 0 : lo; + if(hi === 0 || hi === -1) return sign + lo0.toString(16); + var hi0 = sign ? ~hi >>> 0 : hi; + return sign + hi0.toString(16) + lo0.toString(16).padStart(8, '0'); +} + +function h$jsstringHexW64(hi,lo) { + if (hi === 0) return lo.toString(16); + return hi.toString(16) + lo.toString(16).padStart(8, '0'); +} + +// n in [0, 1000000000) +function h$jsstringDecIPadded9(n) { + TRACE_JSSTRING("decIPadded9: " + n); + if(n === 0) return '000000000'; + var pad = (n>=100000000)?'': + (n>=10000000)?'0': + (n>=1000000)?'00': + (n>=100000)?'000': + (n>=10000)?'0000': + (n>=1000)?'00000': + (n>=100)?'000000': + (n>=10)?'0000000': + '00000000'; + return pad+n; +} + +// n in [0, 1000000) +function h$jsstringDecIPadded6(n) { + TRACE_JSSTRING("decIPadded6: " + n); + if(n === 0) return '000000'; + var pad = (n>=100000)?'': + (n>=10000)?'0': + (n>=1000)?'00': + (n>=100)?'000': + (n>=10)?'0000': + '00000'; + return pad+n; +} + +// n in [0, 2147483648) +function h$jsstringHexIPadded8(n) { + TRACE_JSSTRING("hexIPadded8: " + n); + if(n === 0) return '00000000'; + var pad = (n>=0x10000000)?'': + (n>=0x1000000)?'0': + (n>=0x100000)?'00': + (n>=0x10000)?'000': + (n>=0x1000)?'0000': + (n>=0x100)?'00000': + (n>=0x10)?'000000': + '0000000'; + return pad+n.toString(16); +} + +function h$jsstringZeroes(n) { + var r; + switch(n&7) { + case 0: r = ''; break; + case 1: r = '0'; break; + case 2: r = '00'; break; + case 3: r = '000'; break; + case 4: r = '0000'; break; + case 5: r = '00000'; break; + case 6: r = '000000'; break; + case 7: r = '0000000'; + } + for(var i=n>>3;i>0;i--) r = r + '00000000'; + return r; +} + +function h$jsstringDoubleToFixed(decs, d) { + if(decs >= 0) { + if(Math.abs(d) < 1e21) { + var r = d.toFixed(Math.min(20,decs)); + if(decs > 20) r = r + h$jsstringZeroes(decs-20); + return r; + } else { + var r = d.toExponential(); + var ei = r.indexOf('e'); + var di = r.indexOf('.'); + var e = parseInt(r.substr(ei+1)); + return r.substring(0,di) + r.substring(di,ei) + h$jsstringZeroes(di-ei+e) + + ((decs > 0) ? ('.' + h$jsstringZeroes(decs)) : ''); + } + } + var r = Math.abs(d).toExponential(); + var ei = r.indexOf('e'); + var e = parseInt(r.substr(ei+1)); + var m = d < 0 ? '-' : ''; + r = r.substr(0,1) + r.substring(2,ei); + if(e >= 0) { + return (e > r.length) ? m + r + h$jsstringZeroes(r.length-e-1) + '.0' + : m + r.substr(0,e+1) + '.' + r.substr(e+1); + } else { + return m + '0.' + h$jsstringZeroes(-e-1) + r; + } +} + +function h$jsstringDoubleToExponent(decs, d) { + var r; + if(decs ===-1) { + r = d.toExponential().replace('+',''); + } else { + r = d.toExponential(Math.max(1, Math.min(20,decs))).replace('+',''); + } + if(r.indexOf('.') === -1) { + r = r.replace('e', '.0e'); + } + if(decs > 20) r = r.replace('e', h$jsstringZeroes(decs-20)+'e'); + return r; +} + +function h$jsstringDoubleGeneric(decs, d) { + var r; + if(decs === -1) { + r = d.toString(10).replace('+',''); + } else { + r = d.toPrecision(Math.max(decs+1,1)).replace('+',''); + } + if(decs !== 0 && r.indexOf('.') === -1) { + if(r.indexOf('e') !== -1) { + r = r.replace('e', '.0e'); + } else { + r = r + '.0'; + } + } + return r; +} + +function h$jsstringAppend(x, y) { + TRACE_JSSTRING("append: '" + x + "' '" + y + "'"); + return x+y; +} + +function h$jsstringCompare(x, y) { + TRACE_JSSTRING("compare: '" + x + "' '" + y + "'"); + return (xy)?1:0); +} + +function h$jsstringUnlines(xs) { + var r = ''; + while(IS_CONS(xs)) { + r = r + JSVAL_VAL(CONS_HEAD(xs)) + '\n'; + xs = CONS_TAIL(xs); + } + return r; +} + +function h$jsstringUnwords(xs) { + if(IS_NIL(xs)) return ''; + var r = JSVAL_VAL(CONS_HEAD(xs)); + xs = CONS_TAIL(xs); + while(IS_CONS(xs)) { + r = r + ' ' + JSVAL_VAL(CONS_HEAD(xs)); + xs = CONS_TAIL(xs); + } + return r; +} + +function h$jsstringReplace(pat, rep, src) { + TRACE_JSSTRING("replace: '" + pat + "' '" + rep + "' '" + src + "'"); + var r = src.replace(pat, rep, 'g'); + // the 'g' flag is not supported everywhere, check and fall back if necessary + if(r.indexOf(pat) !== -1) { + r = src.split(pat).join(rep); + } + return r; +} + +function h$jsstringReplicateChar(n, ch) { + TRACE_JSSTRING("replicateChar: " + n + " " + ch); + return h$jsstringReplicate(n, h$jsstringSingleton(ch)); +} + +function h$jsstringIsInteger(str) { + return /^-?\d+$/.test(str); +} + +function h$jsstringIsNatural(str) { + return /^\d+$/.test(str); +} + +function h$jsstringReadInt(str) { + if(!/^-?\d+/.test(str)) return null; + var x = parseInt(str, 10); + var x0 = x|0; + return (x===x0) ? x0 : null; +} + +function h$jsstringLenientReadInt(str) { + var x = parseInt(str, 10); + var x0 = x|0; + return (x===x0) ? x0 : null; +} + +function h$jsstringReadWord(str) { + if(!/^\d+/.test(str)) return null; + var x = parseInt(str, 10); + var x0 = x|0; + if(x0<0) return (x===x0+2147483648) ? x0 : null; + else return (x===x0) ? x0 : null; +} + +function h$jsstringReadDouble(str) { + return parseFloat(str, 10); +} + +function h$jsstringLenientReadDouble(str) { + return parseFloat(str, 10); +} + +function h$jsstringReadInteger(str) { + TRACE_JSSTRING("readInteger: " + str); + if(!/^(-)?\d+$/.test(str)) { + return null; + } else if(str.length <= 9) { + return MK_INTEGER_S(parseInt(str, 10)); + } else { +#if __GLASGOW_HASKELL__ >= 800 + return h$ghcjsbn_readInteger(str); +#else + return MK_INTEGER_J(new BigInteger(str, 10)); +#endif + } +} + +function h$jsstringReadInt64(str) { + if(!/^(-)?\d+$/.test(str)) { + RETURN_UBX_TUP3(0, 0, 0); + } + if(str.charCodeAt(0) === 45) { // '-' + return h$jsstringReadValue64(str, 1, true); + } else { + return h$jsstringReadValue64(str, 0, false); + } +} + +function h$jsstringReadWord64(str) { + if(!/^\d+$/.test(str)) { + RETURN_UBX_TUP3(0, 0, 0); + } + return h$jsstringReadValue64(str, 0, false); +} + +var h$jsstringLongs = null; + +function h$jsstringReadValue64(str, start, negate) { + var l = str.length, i = start; + while(i < l) { + if(str.charCodeAt(i) !== 48) break; + i++; + } + if(i >= l) RETURN_UBX_TUP3(1, 0, 0); // only zeroes + if(h$jsstringLongs === null) { + h$jsstringLongs = []; + for(var t=10; t<=1000000000; t*=10) { + h$jsstringLongs.push(goog.math.Long.fromInt(t)); + } + } + var li = l-i; + if(li < 10 && !negate) { + RETURN_UBX_TUP3(1, 0, parseInt(str.substr(i), 10)); + } + var r = goog.math.Long.fromInt(parseInt(str.substr(li,9),10)); + li += 9; + while(li < l) { + r = r.multiply(h$jsstringLongs[Math.min(l-li-1,8)]) + .add(goog.math.Long.fromInt(parseInt(str.substr(li,9), 10))); + li += 9; + } + if(negate) { + r = r.negate(); + } + RETURN_UBX_TUP3(1, r.getHighBits(), r.getLowBits()); +} + +function h$jsstringExecRE(i, str, re) { + re.lastIndex = i; + var m = re.exec(str); + if(m === null) return -1; + var a = [], x, j = 1, r = HS_NIL; + while(true) { + x = m[j]; + if(typeof x === 'undefined') break; + a[j-1] = x; + j++; + } + j-=1; + while(--j>=0) r = MK_CONS(MK_JSVAL(a[j]), r); + RETURN_UBX_TUP3(m.index, m[0], r); +} + +function h$jsstringReplaceRE(pat, replacement, str) { + return str.replace(pat, replacement); +} + +function h$jsstringSplitRE(limit, re, str) { + re.lastIndex = i; + var s = (limit < 0) ? str.split(re) : str.split(re, limit); + var i = s.length, r = HS_NIL; + while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); + return r; +} + +function h$jsstringIndices(needle, startN, startI, haystack) { + var endI = haystack.indexOf(needle, startI); + if (endI === -1) { + RETURN_UBX_TUP2(-1, -1); + } + var n = startN; + for (var i = startI; i < endI; i++) { + if (!IS_LO_SURR(haystack.charCodeAt(i))) { + n++; + } + } + RETURN_UBX_TUP2(n, endI); +} diff --git a/jsbits/jsstring.js.pp b/jsbits/jsstring.js.pp deleted file mode 100644 --- a/jsbits/jsstring.js.pp +++ /dev/null @@ -1,1181 +0,0 @@ -#include - -/* - * Support code for the Data.JSString module. This code presents a JSString - * as a sequence of code points and hides the underlying encoding ugliness of - * the JavaScript strings. - * - * Use Data.JSString.Raw for direct access to the JSThis makes the operations more expen - */ - -/* - * Some workarounds here for JS engines that do not support proper - * code point access - */ - -#ifdef GHCJS_TRACE_JSSTRING -#define TRACE_JSSTRING(args...) h$log("jsstring: ", args); -#else -#define TRACE_JSSTRING(args...) -#endif - -#define IS_ASTRAL(cp) ((cp)>=0x10000) -#define IS_HI_SURR(cp) ((cp|1023)===0xDBFF) -#define IS_LO_SURR(cp) ((cp|1023)===0xDFFF) -#define FROM_SURR(hi,lo) ((((hi)-0xD800)<<10)+(lo)-0xDC00+0x10000) -#define HI_SURR(cp) ((((cp)-0x10000)>>>10)+0xDC00) -#define LO_SURR(cp) (((cp)&0x3FF)+0xD800) - -var h$jsstringEmpty = MK_JSVAL(''); - -var h$jsstringHead, h$jsstringTail, h$jsstringCons, - h$jsstringSingleton, h$jsstringSnoc, h$jsstringUncons, - h$jsstringIndex, h$jsstringUncheckedIndex; - -var h$fromCodePoint; - -if(String.prototype.fromCodePoint) { - h$fromCodePoint = String.fromCodePoint; -} else { - // polyfill from https://github.com/mathiasbynens/String.fromCodePoint (MIT-license) - h$fromCodePoint = - (function() { - var stringFromCharCode = String.fromCharCode; - var floor = Math.floor; - return function(_) { - var MAX_SIZE = 0x4000; - var codeUnits = []; - var highSurrogate; - var lowSurrogate; - var index = -1; - var length = arguments.length; - if (!length) { - return ''; - } - var result = ''; - while (++index < length) { - var codePoint = Number(arguments[index]); - if ( - !isFinite(codePoint) || // `NaN`, `+Infinity`, or `-Infinity` - codePoint < 0 || // not a valid Unicode code point - codePoint > 0x10FFFF || // not a valid Unicode code point - floor(codePoint) != codePoint // not an integer - ) { - throw RangeError('Invalid code point: ' + codePoint); - } - if (codePoint <= 0xFFFF) { // BMP code point - codeUnits.push(codePoint); - } else { // Astral code point; split in surrogate halves - // https://mathiasbynens.be/notes/javascript-encoding#surrogate-formulae - codePoint -= 0x10000; - highSurrogate = (codePoint >> 10) + 0xD800; - lowSurrogate = (codePoint % 0x400) + 0xDC00; - codeUnits.push(highSurrogate, lowSurrogate); - } - if (index + 1 == length || codeUnits.length > MAX_SIZE) { - result += stringFromCharCode.apply(null, codeUnits); - codeUnits.length = 0; - } - } - return result; - } - })(); -} - -if(String.prototype.codePointAt) { - h$jsstringSingleton = function(ch) { - TRACE_JSSTRING("(codePointAt) singleton: " + ch); - return String.fromCodePoint(ch); - } - h$jsstringHead = function(str) { - TRACE_JSSTRING("(codePointAt) head: " + str); - var cp = str.codePointAt(0); - return (cp === undefined) ? -1 : (cp|0); - } - h$jsstringTail = function(str) { - TRACE_JSSTRING("(codePointAt) tail: " + str); - var l = str.length; - if(l===0) return null; - var ch = str.codePointAt(0); - if(ch === undefined) return null; - // string length is at least two if ch comes from a surrogate pair - return str.substr(IS_ASTRAL(ch)?2:1); - } - h$jsstringCons = function(ch, str) { - TRACE_JSSTRING("(codePointAt) cons: " + ch + " '" + str + "'"); - return String.fromCodePoint(ch)+str; - } - h$jsstringSnoc = function(str, ch) { - TRACE_JSSTRING("(codePointAt) snoc: '" + str + "' " + ch); - return str+String.fromCodePoint(ch); - } - h$jsstringUncons = function(str) { - TRACE_JSSTRING("(codePointAt) uncons: '" + str + "'"); - var l = str.length; - if(l===0) { - RETURN_UBX_TUP2(-1, null); - } - var ch = str.codePointAt(0); - if(ch === undefined) { - RETURN_UBX_TUP2(-1, null); - } - RETURN_UBX_TUP2(ch, str.substr(IS_ASTRAL(ch)?2:1)); - } - // index is the first part of the character - h$jsstringIndex = function(i, str) { - TRACE_JSSTRING("(codePointAt) index: " + i + " '" + str + "'"); - var ch = str.codePointAt(i); - if(ch === undefined) return -1; - return ch; - } - h$jsstringUncheckedIndex = function(i, str) { - TRACE_JSSTRING("(codePointAt) uncheckedIndex: " + i + " '" + str.length + "'"); - return str.codePointAt(i); - } -} else { - h$jsstringSingleton = function(ch) { - TRACE_JSSTRING("(no codePointAt) singleton: " + ch); - return (IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) - : String.fromCharCode(ch); - } - h$jsstringHead = function(str) { - TRACE_JSSTRING("(no codePointAt) head: " + str); - var l = str.length; - if(l===0) return -1; - var ch = str.charCodeAt(0); - if(IS_HI_SURR(ch)) { - return (l>1) ? FROM_SURR(ch, str.charCodeAt(1)) : -1; - } else { - return ch; - } - } - h$jsstringTail = function(str) { - TRACE_JSSTRING("(no codePointAt) tail: " + str); - var l = str.length; - if(l===0) return null; - var ch = str.charCodeAt(0); - if(IS_HI_SURR(ch)) { - return (l>1)?str.substr(2):null; - } else return str.substr(1); - } - h$jsstringCons = function(ch, str) { - TRACE_JSSTRING("(no codePointAt) cons: " + ch + " '" + str + "'"); - return ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) - : String.fromCharCode(ch)) - + str; - } - h$jsstringSnoc = function(str, ch) { - TRACE_JSSTRING("(no codePointAt) snoc: '" + str + "' " + ch); - return str + ((IS_ASTRAL(ch)) ? String.fromCharCode(HI_SURR(ch), LO_SURR(ch)) - : String.fromCharCode(ch)); - } - h$jsstringUncons = function(str) { - TRACE_JSSTRING("(no codePointAt) uncons: '" + str + "'"); - var l = str.length; - if(l===0) { - RETURN_UBX_TUP2(-1, null); - } - var ch = str.charCodeAt(0); - if(IS_HI_SURR(ch)) { - if(l > 1) { - RETURN_UBX_TUP2(FROM_SURR(ch, str.charCodeAt(1)), str.substr(2)); - } else { - RETURN_UBX_TUP2(-1, null); - } - } else { - RETURN_UBX_TUP2(ch, str.substr(1)); - } - } - // index is the first part of the character - h$jsstringIndex = function(i, str) { - // TRACE_JSSTRING("(no codePointAt) index: " + i + " '" + str + "'"); - var ch = str.charCodeAt(i); - if(ch != ch) return -1; // NaN test - return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch; - } - h$jsstringUncheckedIndex = function(i, str) { - TRACE_JSSTRING("(no codePointAt) uncheckedIndex: " + i + " '" + str.length + "'"); - var ch = str.charCodeAt(i); - return (IS_HI_SURR(ch)) ? FROM_SURR(ch, str.charCodeAt(i+1)) : ch; - } -} - -function h$jsstringUnsnoc(str) { - TRACE_JSSTRING("unsnoc: '" + str + "'"); - var l = str.length; - if(l===0) { - RETURN_UBX_TUP2(-1, null); - } - var ch = str.charCodeAt(l-1); - if(IS_LO_SURR(ch)) { - if(l !== 1) { - RETURN_UBX_TUP2(FROM_SURR(str.charCodeAt(l-2),ch), str.substr(0,l-2)); - } else { - RETURN_UBX_TUP2(-1, null); - } - } else { - RETURN_UBX_TUP2(ch, str.substr(0,l-1)); - } -} - - -function h$jsstringPack(xs) { - var r = '', i = 0, a = [], c; - while(IS_CONS(xs)) { - c = CONS_HEAD(xs); - a[i++] = UNWRAP_NUMBER(c); - if(i >= 60000) { - r += h$fromCodePoint.apply(null, a); - a = []; - i = 0; - } - xs = CONS_TAIL(xs); - } - if(i > 0) r += h$fromCodePoint.apply(null, a); - TRACE_JSSTRING("pack: '" + r + "'"); - return r; -} - -function h$jsstringPackReverse(xs) { - var a = [], i = 0, c; - while(IS_CONS(xs)) { - c = CONS_HEAD(xs); - a[i++] = UNWRAP_NUMBER(c); - xs = CONS_TAIL(xs); - } - if(i===0) return ''; - var r = h$jsstringConvertArray(a.reverse()); - TRACE_JSSTRING("packReverse: '" + r + "'"); - return r; -} - -function h$jsstringPackArray(arr) { - TRACE_JSSTRING("pack array: " + arr); - return h$jsstringConvertArray(arr); -} - -function h$jsstringPackArrayReverse(arr) { - TRACE_JSSTRING("pack array reverse: " + arr); - return h$jsstringConvertArray(arr.reverse()); -} - -function h$jsstringConvertArray(arr) { - if(arr.length < 60000) { - return h$fromCodePoint.apply(null, arr); - } else { - var r = ''; - for(var i=0; i1) ? FROM_SURR(str.charCodeAt(l-2), ch) : -1; - - } else return ch; -} - -// index is the last part of the character -function h$jsstringIndexR(i, str) { - TRACE_JSSTRING("indexR: " + i + " '" + str + "'"); - if(i < 0 || i > str.length) return -1; - var ch = str.charCodeAt(i); - return (IS_LO_SURR(ch)) ? FROM_SURR(str.charCodeAt(i-1), ch) : ch; -} - -function h$jsstringNextIndex(i, str) { - TRACE_JSSTRING("nextIndex: " + i + " '" + str + "'"); - return i + (IS_HI_SURR(str.charCodeAt(i))?2:1); -} - -function h$jsstringTake(n, str) { - TRACE_JSSTRING("take: " + n + " '" + str + "'"); - if(n <= 0) return ''; - var i = 0, l = str.length, ch; - if(n >= l) return str; - while(n--) { - ch = str.charCodeAt(i++); - if(IS_HI_SURR(ch)) i++; - if(i >= l) return str; - } - return str.substr(0,i); -} - -function h$jsstringDrop(n, str) { - TRACE_JSSTRING("drop: " + n + " '" + str + "'"); - if(n <= 0) return str; - var i = 0, l = str.length, ch; - if(n >= l) return ''; - while(n--) { - ch = str.charCodeAt(i++); - if(IS_HI_SURR(ch)) i++; - if(i >= l) return ''; - } - return str.substr(i); -} - -function h$jsstringSplitAt(n, str) { - TRACE_JSSTRING("splitAt: " + n + " '" + str + "'"); - if(n <= 0) { - RETURN_UBX_TUP2("", str); - } else if(n >= str.length) { - RETURN_UBX_TUP2(str, ""); - } - var i = 0, l = str.length, ch; - while(n--) { - ch = str.charCodeAt(i++); - if(IS_HI_SURR(ch)) i++; - if(i >= l) { - RETURN_UBX_TUP2(str, ""); - } - } - RETURN_UBX_TUP2(str.substr(0,i),str.substr(i)); -} - -function h$jsstringTakeEnd(n, str) { - TRACE_JSSTRING("takeEnd: " + n + " '" + str + "'"); - if(n <= 0) return ''; - var l = str.length, i = l-1, ch; - if(n >= l) return str; - while(n-- && i > 0) { - ch = str.charCodeAt(i--); - if(IS_LO_SURR(ch)) i--; - } - return (i<0) ? str : str.substr(i+1); -} - -function h$jsstringDropEnd(n, str) { - TRACE_JSSTRING("dropEnd: " + n + " '" + str + "'"); - if(n <= 0) return str; - var l = str.length, i = l-1, ch; - if(n >= l) return ''; - while(n-- && i > 0) { - ch = str.charCodeAt(i--); - if(IS_LO_SURR(ch)) i--; - } - return (i<0) ? '' : str.substr(0,i+1); -} - -function h$jsstringIntercalate(x, ys) { - TRACE_JSSTRING("intercalate: '" + x + "'"); - var a = [], i = 0; - while(IS_CONS(ys)) { - if(i) a[i++] = x; - a[i++] = JSVAL_VAL(CONS_HEAD(ys)); - ys = CONS_TAIL(ys); - } - return a.join(''); -} - -function h$jsstringIntersperse(ch, ys) { - TRACE_JSSTRING("intersperse: " + ch + " '" + ys + "'"); - var i = 0, l = ys.length, j = 0, a = [], ych; - if(IS_ASTRAL(ch)) { - while(j < l) { - if(i) a[i++] = ch; - ych = ys.charCodeAt(j++); - a[i++] = ych; - if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++); - } - } else { - while(j < l) { - if(i) a[i++] = ch; - ych = ys.charCodeAt(j++); - a[i++] = ych; - if(IS_HI_SURR(ych)) a[i++] = ys.charCodeAt(j++); - } - } - return h$jsstringConvertArray(a); -} - -function h$jsstringConcat(xs) { - TRACE_JSSTRING("concat"); - var a = [], i = 0; - while(IS_CONS(xs)) { - a[i++] = JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - } - return a.join(''); -} - -var h$jsstringStripPrefix, h$jsstringStripSuffix, - h$jsstringIsPrefixOf, h$jsstringIsSuffixOf, - h$jsstringIsInfixOf; -if(String.prototype.startsWith) { - h$jsstringStripPrefix = function(p, x) { - TRACE_JSSTRING("(startsWith) stripPrefix: '" + p + "' '" + x + "'"); - if(x.startsWith(p)) { - return MK_JUST(MK_JSVAL(x.substr(p.length))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsPrefixOf = function(p, x) { - TRACE_JSSTRING("(startsWith) isPrefixOf: '" + p + "' '" + x + "'"); - return x.startsWith(p); - } - -} else { - h$jsstringStripPrefix = function(p, x) { - TRACE_JSSTRING("(no startsWith) stripPrefix: '" + p + "' '" + x + "'"); - if(x.indexOf(p) === 0) { // this has worse complexity than it should - return MK_JUST(MK_JSVAL(x.substr(p.length))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsPrefixOf = function(p, x) { - TRACE_JSSTRING("(no startsWith) isPrefixOf: '" + p + "' '" + x + "'"); - return x.indexOf(p) === 0; // this has worse complexity than it should - } -} - -if(String.prototype.endsWith) { - h$jsstringStripSuffix = function(s, x) { - TRACE_JSSTRING("(endsWith) stripSuffix: '" + s + "' '" + x + "'"); - if(x.endsWith(s)) { - return MK_JUST(MK_JSVAL(x.substr(0,x.length-s.length))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsSuffixOf = function(s, x) { - TRACE_JSSTRING("(endsWith) isSuffixOf: '" + s + "' '" + x + "'"); - return x.endsWith(s); - } -} else { - h$jsstringStripSuffix = function(s, x) { - TRACE_JSSTRING("(no endsWith) stripSuffix: '" + s + "' '" + x + "'"); - var i = x.lastIndexOf(s); // this has worse complexity than it should - var l = x.length - s.length; - if(i !== -1 && i === l) { - return MK_JUST(MK_JSVAL(x.substr(0,l))); - } else { - return HS_NOTHING; - } - } - - h$jsstringIsSuffixOf = function(s, x) { - TRACE_JSSTRING("(no endsWith) isSuffixOf: '" + s + "' '" + x + "'"); - var i = x.lastIndexOf(s); // this has worse complexity than it should - return i !== -1 && i === x.length - s.length; - } -} - -if(String.prototype.includes) { - h$jsstringIsInfixOf = function(i, x) { - TRACE_JSSTRING("(includes) isInfixOf: '" + i + "' '" + x + "'"); - return x.includes(i); - } -} else { - h$jsstringIsInfixOf = function(i, x) { - TRACE_JSSTRING("(no includes) isInfixOf: '" + i + "' '" + x + "'"); - return x.indexOf(i) !== -1; // this has worse complexity than it should - } -} - -function h$jsstringCommonPrefixes(x, y) { - TRACE_JSSTRING("commonPrefixes: '" + x + "' '" + y + "'"); - var lx = x.length, ly = y.length, i = 0, cx; - var l = lx <= ly ? lx : ly; - if(lx === 0 || ly === 0 || x.charCodeAt(0) !== y.charCodeAt(0)) { - return HS_NOTHING; - } - while(++i= 0) r = MK_CONS(a[i], r); - return r; -} - -function h$jsstringSplitOn1(n, p, x) { - TRACE_JSSTRING("splitOn1: " + n + " '" + p + "' '" + x + "'"); - var i = x.indexOf(p, n); - if(i === -1) { - RETURN_UBX_TUP2(-1, null); - } - var r1 = (i==n) ? "" : x.substr(n, i-n); - RETURN_UBX_TUP2(i + p.length, r1); -} - -function h$jsstringSplitOn(p, x) { - TRACE_JSSTRING("splitOn: '" + p + "' '" + x + "'"); - var a = x.split(p); - var r = HS_NIL, i = a.length; - while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); - return r; -} - -// returns -1 for end of input, start of next token otherwise -// word in h$ret1 -// this function assumes that there are no whitespace characters >= 0x10000 -function h$jsstringWords1(n, x) { - TRACE_JSSTRING("words1: " + n + " '" + x + "'"); - var m = n, s = n, l = x.length; - if(m >= l) return -1; - // skip leading spaces - do { - if(m >= l) return -1; - } while(h$isSpace(x.charCodeAt(m++))); - // found start of word - s = m - 1; - while(m < l) { - if(h$isSpace(x.charCodeAt(m++))) { - // found end of word - var r1 = (m-s<=1) ? "" : x.substr(s,m-s-1); - RETURN_UBX_TUP2(m, r1); - } - } - // end of string - if(s < l) { - var r1 = s === 0 ? x : x.substr(s); - RETURN_UBX_TUP2(m, r1); - } - RETURN_UBX_TUP2(-1, null); -} - -function h$jsstringWords(x) { - TRACE_JSSTRING("words: '" + x + "'"); - var a = null, i = 0, n, s = -1, m = 0, w, l = x.length, r = HS_NIL; - outer: - while(m < l) { - // skip leading spaces - do { - if(m >= l) { s = m; break outer; } - } while(h$isSpace(x.charCodeAt(m++))); - // found start of word - s = m - 1; - while(m < l) { - if(h$isSpace(x.charCodeAt(m++))) { - // found end of word - w = (m-s<=1) ? h$jsstringEmpty - : MK_JSVAL(x.substr(s,m-s-1)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - s = m; - break; - } - } - } - // end of string - if(s !== -1 && s < l) { - w = MK_JSVAL(s === 0 ? x : x.substr(s)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - } - // build resulting list - while(--i>=0) r = MK_CONS(a[i], r); - return r; -} - -// returns -1 for end of input, start of next token otherwise -// line in h$ret1 -function h$jsstringLines1(n, x) { - TRACE_JSSTRING("lines1: " + n + " '" + x + "'"); - var m = n, l = x.length; - if(n >= l) return -1; - while(m < l) { - if(x.charCodeAt(m++) === 10) { - // found newline - if(n > 0 && n === l-1) return -1; // it was the last character - var r1 = (m-n<=1) ? "" : x.substr(n,m-n-1); - RETURN_UBX_TUP2(m, r1); - } - } - // end of string - RETURN_UBX_TUP2(m, x.substr(n)); -} - -function h$jsstringLines(x) { - TRACE_JSSTRING("lines: '" + x + "'"); - var a = null, m = 0, i = 0, l = x.length, s = 0, r = HS_NIL, w; - if(l === 0) return HS_NIL; - outer: - while(true) { - s = m; - do { - if(m >= l) break outer; - } while(x.charCodeAt(m++) !== 10); - w = (m-s<=1) ? h$jsstringEmpty : MK_JSVAL(x.substr(s,m-s-1)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - } - if(s < l) { - w = MK_JSVAL(x.substr(s)); - if(i) a[i++] = w; else { a = [w]; i = 1; } - } - while(--i>=0) r = MK_CONS(a[i], r); - return r; -} - -function h$jsstringGroup(x) { - TRACE_JSSTRING("group: '" + x + "'"); - var xl = x.length; - if(xl === 0) return HS_NIL; - var i = xl-1, si, ch, s=xl, r=HS_NIL; - var tch = x.charCodeAt(i--); - if(IS_LO_SURR(tch)) tch = FROM_SURR(x.charCodeAt(i--), tch); - while(i >= 0) { - si = i; - ch = x.charCodeAt(i--); - if(IS_LO_SURR(ch)) { - ch = FROM_SURR(x.charCodeAt(i--), ch); - } - if(ch != tch) { - tch = ch; - r = MK_CONS(MK_JSVAL(x.substr(si+1,s-si)), r); - s = si; - } - } - return MK_CONS(MK_JSVAL(x.substr(0,s+1)), r); -} - -function h$jsstringChunksOf1(n, s, x) { - TRACE_JSSTRING("chunksOf1: " + n + " " + s + " '" + x + "'"); - var m = s, c = 0, l = x.length, ch; - if(n <= 0 || l === 0 || s >= l) return -1 - while(++m < l) { - ch = x.charCodeAt(m - 1); - if(IS_HI_SURR(ch)) ++m; - if(++c >= n) break; - } - var r1 = (m >= l && s === c) ? x : x.substr(s,m-s); - RETURN_UBX_TUP2(m, r1); -} - -function h$jsstringChunksOf(n, x) { - TRACE_JSSTRING("chunksOf: " + n + " '" + x + "'"); - var l = x.length; - if(l===0 || n <= 0) return HS_NIL; - if(l <= n) return MK_CONS(MK_JSVAL(x), HS_NIL); - var a = [], i = 0, s = 0, ch, m = 0, c, r = HS_NIL; - while(m < l) { - s = m; - c = 0; - while(m < l && ++c <= n) { - ch = x.charCodeAt(m++); - if(IS_HI_SURR(ch)) ++m; - } - if(c) a[i++] = x.substr(s, m-s); - } - while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); - return r; -} - -function h$jsstringCount(pat, src) { - TRACE_JSSTRING("count: '" + pat + "' '" + src + "'"); - var i = 0, n = 0, pl = pat.length, sl = src.length; - while(i>= 1; - } while(n > 1); - return r+str; -} - -// this does not deal with combining diacritics, Data.Text does not either -var h$jsstringReverse; -if(Array.from) { - h$jsstringReverse = function(str) { - TRACE_JSSTRING("(Array.from) reverse: '" + str + "'"); - return Array.from(str).reverse().join(''); - } -} else { - h$jsstringReverse = function(str) { - TRACE_JSSTRING("(no Array.from) reverse: '" + str + "'"); - var l = str.length, a = [], o = 0, i = 0, c, c1, s = ''; - while(i < l) { - c = str.charCodeAt(i); - if(IS_HI_SURR(c)) { - a[i] = str.charCodeAt(i+1); - a[i+1] = c; - i += 2; - } else a[i++] = c; - if(i-o > 60000) { - s = String.fromCharCode.apply(null, a.reverse()) + s; - o = -i; - a = []; - } - } - return (i===0) ? s : String.fromCharCode.apply(null,a.reverse()) + s; - } -} - -function h$jsstringUnpack(str) { - TRACE_JSSTRING("unpack: '" + str + "'"); - var r = HS_NIL, i = str.length-1, c; - while(i >= 0) { - c = str.charCodeAt(i--); - if(IS_LO_SURR(c)) c = FROM_SURR(str.charCodeAt(i--), c) - r = MK_CONS(c, r); - } - return r; -} - - - -#if __GLASGOW_HASKELL__ >= 800 -function h$jsstringDecInteger(val) { - TRACE_JSSTRING("decInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else if(IS_INTEGER_Jp(val)) { - return h$ghcjsbn_showBase(INTEGER_J_DATA(val), 10); - } else { - return '-' + h$ghcjsbn_showBase(INTEGER_J_DATA(val), 10); - } -} -#else -function h$jsstringDecInteger(val) { - TRACE_JSSTRING("decInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else { - return INTEGER_J_DATA(val).toString(); - } -} -#endif - -function h$jsstringDecI64(hi,lo) { - TRACE_JSSTRING("decI64: " + hi + " " + lo); - var lo0 = (lo < 0) ? lo+4294967296:lo; - if(hi < 0) { - if(hi === -1) return ''+(lo0-4294967296); - lo0 = 4294967296 - lo0; - var hi0 = -1 - hi; - var x0 = hi0 * 967296; - var x1 = (lo0 + x0) % 1000000; - var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000); - return '-' + x2 + h$jsstringDecIPadded6(x1); - } else { - if(hi === 0) return ''+lo0; - var x0 = hi * 967296; - var x1 = (lo0 + x0) % 1000000; - var x2 = hi*4294+Math.floor((x0+lo0-x1)/1000000); - return '' + x2 + h$jsstringDecIPadded6(x1); - } -} - -function h$jsstringDecW64(hi,lo) { - TRACE_JSSTRING("decW64: " + hi + " " + lo); - var lo0 = (lo < 0) ? lo+4294967296 : lo; - if(hi === 0) return ''+lo0; - var hi0 = (hi < 0) ? hi+4294967296 : hi; - var x0 = hi0 * 967296; - var x1 = (lo0 + x0) % 1000000; - var x2 = hi0*4294+Math.floor((x0+lo0-x1)/1000000); - return '' + x2 + h$jsstringDecIPadded6(x1); -} - -#if __GLASGOW_HASKELL__ >= 800 -function h$jsstringHexInteger(val) { - TRACE_JSSTRING("hexInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else { - // we assume it's nonnegative. this condition is checked by the Haskell code - return h$ghcjsbn_showBase(INTEGER_J_DATA(val), 16); - } -} -#else -function h$jsstringHexInteger(val) { - TRACE_JSSTRING("hexInteger"); - if(IS_INTEGER_S(val)) { - return '' + INTEGER_S_DATA(val); - } else { - return INTEGER_J_DATA(val).toRadix(16); - } -} -#endif - -function h$jsstringHexI64(hi,lo) { - var lo0 = lo<0 ? lo+4294967296 : lo; - if(hi === 0) return lo0.toString(16); - return ((hi<0)?hi+4294967296:hi).toString(16) + h$jsstringHexIPadded8(lo0); -} - -function h$jsstringHexW64(hi,lo) { - var lo0 = lo<0 ? lo+4294967296 : lo; - if(hi === 0) return lo0.toString(16); - return ((hi<0)?hi+4294967296:hi).toString(16) + h$jsstringHexIPadded8(lo0); -} - -// n in [0, 1000000000) -function h$jsstringDecIPadded9(n) { - TRACE_JSSTRING("decIPadded9: " + n); - if(n === 0) return '000000000'; - var pad = (n>=100000000)?'': - (n>=10000000)?'0': - (n>=1000000)?'00': - (n>=100000)?'000': - (n>=10000)?'0000': - (n>=1000)?'00000': - (n>=100)?'000000': - (n>=10)?'0000000': - '00000000'; - return pad+n; -} - -// n in [0, 1000000) -function h$jsstringDecIPadded6(n) { - TRACE_JSSTRING("decIPadded6: " + n); - if(n === 0) return '000000'; - var pad = (n>=100000)?'': - (n>=10000)?'0': - (n>=1000)?'00': - (n>=100)?'000': - (n>=10)?'0000': - '00000'; - return pad+n; -} - -// n in [0, 2147483648) -function h$jsstringHexIPadded8(n) { - TRACE_JSSTRING("hexIPadded8: " + n); - if(n === 0) return '00000000'; - var pad = (n>=0x10000000)?'': - (n>=0x1000000)?'0': - (n>=0x100000)?'00': - (n>=0x10000)?'000': - (n>=0x1000)?'0000': - (n>=0x100)?'00000': - (n>=0x10)?'000000': - '0000000'; - return pad+n.toString(16); -} - -function h$jsstringZeroes(n) { - var r; - switch(n&7) { - case 0: r = ''; break; - case 1: r = '0'; break; - case 2: r = '00'; break; - case 3: r = '000'; break; - case 4: r = '0000'; break; - case 5: r = '00000'; break; - case 6: r = '000000'; break; - case 7: r = '0000000'; - } - for(var i=n>>3;i>0;i--) r = r + '00000000'; - return r; -} - -function h$jsstringDoubleToFixed(decs, d) { - if(decs >= 0) { - if(Math.abs(d) < 1e21) { - var r = d.toFixed(Math.min(20,decs)); - if(decs > 20) r = r + h$jsstringZeroes(decs-20); - return r; - } else { - var r = d.toExponential(); - var ei = r.indexOf('e'); - var di = r.indexOf('.'); - var e = parseInt(r.substr(ei+1)); - return r.substring(0,di) + r.substring(di,ei) + h$jsstringZeroes(di-ei+e) + - ((decs > 0) ? ('.' + h$jsstringZeroes(decs)) : ''); - } - } - var r = Math.abs(d).toExponential(); - var ei = r.indexOf('e'); - var e = parseInt(r.substr(ei+1)); - var m = d < 0 ? '-' : ''; - r = r.substr(0,1) + r.substring(2,ei); - if(e >= 0) { - return (e > r.length) ? m + r + h$jsstringZeroes(r.length-e-1) + '.0' - : m + r.substr(0,e+1) + '.' + r.substr(e+1); - } else { - return m + '0.' + h$jsstringZeroes(-e-1) + r; - } -} - -function h$jsstringDoubleToExponent(decs, d) { - var r; - if(decs ===-1) { - r = d.toExponential().replace('+',''); - } else { - r = d.toExponential(Math.max(1, Math.min(20,decs))).replace('+',''); - } - if(r.indexOf('.') === -1) { - r = r.replace('e', '.0e'); - } - if(decs > 20) r = r.replace('e', h$jsstringZeroes(decs-20)+'e'); - return r; -} - -function h$jsstringDoubleGeneric(decs, d) { - var r; - if(decs === -1) { - r = d.toString(10).replace('+',''); - } else { - r = d.toPrecision(Math.max(decs+1,1)).replace('+',''); - } - if(decs !== 0 && r.indexOf('.') === -1) { - if(r.indexOf('e') !== -1) { - r = r.replace('e', '.0e'); - } else { - r = r + '.0'; - } - } - return r; -} - -function h$jsstringAppend(x, y) { - TRACE_JSSTRING("append: '" + x + "' '" + y + "'"); - return x+y; -} - -function h$jsstringCompare(x, y) { - TRACE_JSSTRING("compare: '" + x + "' '" + y + "'"); - return (xy)?1:0); -} - -function h$jsstringUnlines(xs) { - var r = ''; - while(IS_CONS(xs)) { - r = r + JSVAL_VAL(CONS_HEAD(xs)) + '\n'; - xs = CONS_TAIL(xs); - } - return r; -} - -function h$jsstringUnwords(xs) { - if(IS_NIL(xs)) return ''; - var r = JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - while(IS_CONS(xs)) { - r = r + ' ' + JSVAL_VAL(CONS_HEAD(xs)); - xs = CONS_TAIL(xs); - } - return r; -} - -function h$jsstringReplace(pat, rep, src) { - TRACE_JSSTRING("replace: '" + pat + "' '" + rep + "' '" + src + "'"); - var r = src.replace(pat, rep, 'g'); - // the 'g' flag is not supported everywhere, check and fall back if necessary - if(r.indexOf(pat) !== -1) { - r = src.split(pat).join(rep); - } - return r; -} - -function h$jsstringReplicateChar(n, ch) { - TRACE_JSSTRING("replicateChar: " + n + " " + ch); - return h$jsstringReplicate(n, h$jsstringSingleton(ch)); -} - -function h$jsstringIsInteger(str) { - return /^-?\d+$/.test(str); -} - -function h$jsstringIsNatural(str) { - return /^\d+$/.test(str); -} - -function h$jsstringReadInt(str) { - if(!/^-?\d+/.test(str)) return null; - var x = parseInt(str, 10); - var x0 = x|0; - return (x===x0) ? x0 : null; -} - -function h$jsstringLenientReadInt(str) { - var x = parseInt(str, 10); - var x0 = x|0; - return (x===x0) ? x0 : null; -} - -function h$jsstringReadWord(str) { - if(!/^\d+/.test(str)) return null; - var x = parseInt(str, 10); - var x0 = x|0; - if(x0<0) return (x===x0+2147483648) ? x0 : null; - else return (x===x0) ? x0 : null; -} - -function h$jsstringReadDouble(str) { - return parseFloat(str, 10); -} - -function h$jsstringLenientReadDouble(str) { - return parseFloat(str, 10); -} - -function h$jsstringReadInteger(str) { - TRACE_JSSTRING("readInteger: " + str); - if(!/^(-)?\d+$/.test(str)) { - return null; - } else if(str.length <= 9) { - return MK_INTEGER_S(parseInt(str, 10)); - } else { -#if __GLASGOW_HASKELL__ >= 800 - return h$ghcjsbn_readInteger(str); -#else - return MK_INTEGER_J(new BigInteger(str, 10)); -#endif - } -} - -function h$jsstringReadInt64(str) { - if(!/^(-)?\d+$/.test(str)) { - RETURN_UBX_TUP3(0, 0, 0); - } - if(str.charCodeAt(0) === 45) { // '-' - return h$jsstringReadValue64(str, 1, true); - } else { - return h$jsstringReadValue64(str, 0, false); - } -} - -function h$jsstringReadWord64(str) { - if(!/^\d+$/.test(str)) { - RETURN_UBX_TUP3(0, 0, 0); - } - return h$jsstringReadValue64(str, 0, false); -} - -var h$jsstringLongs = null; - -function h$jsstringReadValue64(str, start, negate) { - var l = str.length, i = start; - while(i < l) { - if(str.charCodeAt(i) !== 48) break; - i++; - } - if(i >= l) RETURN_UBX_TUP3(1, 0, 0); // only zeroes - if(h$jsstringLongs === null) { - h$jsstringLongs = []; - for(var t=10; t<=1000000000; t*=10) { - h$jsstringLongs.push(goog.math.Long.fromInt(t)); - } - } - var li = l-i; - if(li < 10 && !negate) { - RETURN_UBX_TUP3(1, 0, parseInt(str.substr(i), 10)); - } - var r = goog.math.Long.fromInt(parseInt(str.substr(li,9),10)); - li += 9; - while(li < l) { - r = r.multiply(h$jsstringLongs[Math.min(l-li-1,8)]) - .add(goog.math.Long.fromInt(parseInt(str.substr(li,9), 10))); - li += 9; - } - if(negate) { - r = r.negate(); - } - RETURN_UBX_TUP3(1, r.getHighBits(), r.getLowBits()); -} - -function h$jsstringExecRE(i, str, re) { - re.lastIndex = i; - var m = re.exec(str); - if(m === null) return -1; - var a = [], x, j = 1, r = HS_NIL; - while(true) { - x = m[j]; - if(typeof x === 'undefined') break; - a[j-1] = x; - j++; - } - j-=1; - while(--j>=0) r = MK_CONS(MK_JSVAL(a[j]), r); - RETURN_UBX_TUP3(m.index, m[0], r); -} - -function h$jsstringReplaceRE(pat, replacement, str) { - return str.replace(pat, replacement); -} - -function h$jsstringSplitRE(limit, re, str) { - re.lastIndex = i; - var s = (limit < 0) ? str.split(re) : str.split(re, limit); - var i = s.length, r = HS_NIL; - while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); - return r; -} diff --git a/jsbits/jsstringRaw.js b/jsbits/jsstringRaw.js new file mode 100644 --- /dev/null +++ b/jsbits/jsstringRaw.js @@ -0,0 +1,21 @@ +//#OPTIONS: CPP + +/* + * Functions that directly access JavaScript strings, ignoring character + * widths and surrogate pairs. + */ + +function h$jsstringRawChunksOf(k, x) { + var l = x.length; + if(l === 0) return HS_NIL; + if(l <= k) return MK_CONS(MK_JSVAL(x), HS_NIL); + var r=HS_NIL; + for(var i=ls-k;i>=0;i-=k) r = MK_CONS(MK_JSVAL(x.substr(i,i+k)),r); + return r; +} + +function h$jsstringRawSplitAt(k, x) { + if(k === 0) return MK_TUP2(h$jsstringEmpty, MK_JSVAL(x)); + if(k >= x.length) return MK_TUP2(MK_JSVAL(x), h$jsstringEmpty); + return MK_TUP2(MK_JSVAL(x.substr(0,k)), MK_JSVAL(x.substr(k))); +} diff --git a/jsbits/jsstringRaw.js.pp b/jsbits/jsstringRaw.js.pp deleted file mode 100644 --- a/jsbits/jsstringRaw.js.pp +++ /dev/null @@ -1,21 +0,0 @@ -#include - -/* - * Functions that directly access JavaScript strings, ignoring character - * widths and surrogate pairs. - */ - -function h$jsstringRawChunksOf(k, x) { - var l = x.length; - if(l === 0) return HS_NIL; - if(l <= k) return MK_CONS(MK_JSVAL(x), HS_NIL); - var r=HS_NIL; - for(var i=ls-k;i>=0;i-=k) r = MK_CONS(MK_JSVAL(x.substr(i,i+k)),r); - return r; -} - -function h$jsstringRawSplitAt(k, x) { - if(k === 0) return MK_TUP2(h$jsstringEmpty, MK_JSVAL(x)); - if(k >= x.length) return MK_TUP2(MK_JSVAL(x), h$jsstringEmpty); - return MK_TUP2(MK_JSVAL(x.substr(0,k)), MK_JSVAL(x.substr(k))); -} diff --git a/jsbits/text.js b/jsbits/text.js new file mode 100644 --- /dev/null +++ b/jsbits/text.js @@ -0,0 +1,38 @@ +//#OPTIONS: CPP +// conversion between JavaScript string and Data.Text + + +/* + convert a Data.Text buffer with offset/length to a JavaScript string + */ +function h$textToString(arr, off, len) { + return new TextDecoder().decode(arr.u8.subarray(off, off+len)); +} + +/* + convert a JavaScript string to a Data.Text buffer, second return + value is length + */ +function h$textFromString(s) { + var encoder = new TextEncoder("utf-8"); + u8 = encoder.encode(s); + b = h$wrapBuffer(u8.buffer, true, u8.byteOffset, u8.byteLength); + RETURN_UBX_TUP2(b, u8.byteLength); +} + +function h$lazyTextToString(txt) { + var s = ''; + while(LAZY_TEXT_IS_CHUNK(txt)) { + var head = LAZY_TEXT_CHUNK_HEAD(txt); + s += h$textToString(DATA_TEXT_ARRAY(head), DATA_TEXT_OFFSET(head), DATA_TEXT_LENGTH(head)); + txt = LAZY_TEXT_CHUNK_TAIL(txt); + } + return s; +} + +function h$safeTextFromString(x) { + if(typeof x !== 'string') { + RETURN_UBX_TUP2(null, 0); + } + return h$textFromString(x); +} diff --git a/jsbits/text.js.pp b/jsbits/text.js.pp deleted file mode 100644 --- a/jsbits/text.js.pp +++ /dev/null @@ -1,53 +0,0 @@ -// conversion between JavaScript string and Data.Text -#include - - -/* - convert a Data.Text buffer with offset/length to a JavaScript string - */ -function h$textToString(arr, off, len) { - var a = []; - var end = off+len; - var k = 0; - var u1 = arr.u1; - var s = ''; - for(var i=off;i=0;i--) u1[i] = s.charCodeAt(i); - RETURN_UBX_TUP2(b, l); -} - -function h$lazyTextToString(txt) { - var s = ''; - while(LAZY_TEXT_IS_CHUNK(txt)) { - var head = LAZY_TEXT_CHUNK_HEAD(txt); - s += h$textToString(DATA_TEXT_ARRAY(head), DATA_TEXT_OFFSET(head), DATA_TEXT_LENGTH(head)); - txt = LAZY_TEXT_CHUNK_TAIL(txt); - } - return s; -} - -function h$safeTextFromString(x) { - if(typeof x !== 'string') { - RETURN_UBX_TUP2(null, 0); - } - return h$textFromString(x); -} diff --git a/jsbits/utils.js b/jsbits/utils.js new file mode 100644 --- /dev/null +++ b/jsbits/utils.js @@ -0,0 +1,93 @@ +//#OPTIONS: CPP + +function h$allProps(o) { + var a = [], i = 0; + for(var p in o) a[i++] = p; + return a; +} + +function h$listProps(o) { + var r = HS_NIL; + for(var p in o) { r = MK_CONS(MK_JSVAL(p), r); } + return r; +} + +function h$listAssocs(o) { + var r = HS_NIL; + for(var p in o) { r = MK_CONS(MK_TUP2(MK_JSVAL(p), MK_JSVAL(o[p])), r); } + return r; +} + +function h$isNumber(o) { + return typeof(o) === 'number'; +} + +// returns true for null, but not for functions and host objects +function h$isObject(o) { + return typeof(o) === 'object'; +} + +function h$isString(o) { + return typeof(o) === 'string'; +} + +function h$isSymbol(o) { + return typeof(o) === 'symbol'; +} + +function h$isBoolean(o) { + return typeof(o) === 'boolean'; +} + +function h$isFunction(o) { + return typeof(o) === 'function'; +} + +function h$jsTypeOf(o) { + var t = typeof(o); + if(t === 'undefined') return 0; + if(t === 'object') return 1; + if(t === 'boolean') return 2; + if(t === 'number') return 3; + if(t === 'string') return 4; + if(t === 'symbol') return 5; + if(t === 'function') return 6; + return 7; // other, host object etc +} + +/* + -- 0 - null, 1 - integer, + -- 2 - float, 3 - bool, + -- 4 - string, 5 - array + -- 6 - object +*/ +function h$jsonTypeOf(o) { + if (!(o instanceof Object)) { + if (o == null) { + return 0; + } else if (typeof o == 'number') { + if (h$isInteger(o)) { + return 1; + } else { + return 2; + } + } else if (typeof o == 'boolean') { + return 3; + } else { + return 4; + } + } else { + if (Object.prototype.toString.call(o) == '[object Array]') { + // it's an array + return 5; + } else if (!o) { + // null + return 0; + } else { + // it's an object + return 6; + } + } + +} + diff --git a/jsbits/utils.js.pp b/jsbits/utils.js.pp deleted file mode 100644 --- a/jsbits/utils.js.pp +++ /dev/null @@ -1,93 +0,0 @@ -#include - -function h$allProps(o) { - var a = [], i = 0; - for(var p in o) a[i++] = p; - return a; -} - -function h$listProps(o) { - var r = HS_NIL; - for(var p in o) { r = MK_CONS(MK_JSVAL(p), r); } - return r; -} - -function h$listAssocs(o) { - var r = HS_NIL; - for(var p in o) { r = MK_CONS(MK_TUP2(MK_JSVAL(p), MK_JSVAL(o[p])), r); } - return r; -} - -function h$isNumber(o) { - return typeof(o) === 'number'; -} - -// returns true for null, but not for functions and host objects -function h$isObject(o) { - return typeof(o) === 'object'; -} - -function h$isString(o) { - return typeof(o) === 'string'; -} - -function h$isSymbol(o) { - return typeof(o) === 'symbol'; -} - -function h$isBoolean(o) { - return typeof(o) === 'boolean'; -} - -function h$isFunction(o) { - return typeof(o) === 'function'; -} - -function h$jsTypeOf(o) { - var t = typeof(o); - if(t === 'undefined') return 0; - if(t === 'object') return 1; - if(t === 'boolean') return 2; - if(t === 'number') return 3; - if(t === 'string') return 4; - if(t === 'symbol') return 5; - if(t === 'function') return 6; - return 7; // other, host object etc -} - -/* - -- 0 - null, 1 - integer, - -- 2 - float, 3 - bool, - -- 4 - string, 5 - array - -- 6 - object -*/ -function h$jsonTypeOf(o) { - if (!(o instanceof Object)) { - if (o == null) { - return 0; - } else if (typeof o == 'number') { - if (h$isInteger(o)) { - return 1; - } else { - return 2; - } - } else if (typeof o == 'boolean') { - return 3; - } else { - return 4; - } - } else { - if (Object.prototype.toString.call(o) == '[object Array]') { - // it's an array - return 5; - } else if (!o) { - // null - return 0; - } else { - // it's an object - return 6; - } - } - -} - diff --git a/jsbits/websocket.js b/jsbits/websocket.js new file mode 100644 --- /dev/null +++ b/jsbits/websocket.js @@ -0,0 +1,58 @@ +//#OPTIONS: CPP + +function h$createWebSocket(url, protocols) { + return new WebSocket(url, protocols); +} + +/* + this must be called before the websocket has connected, + typically synchronously after creating the socket + */ +function h$openWebSocket(ws, mcb, ccb, c) { + if(ws.readyState !== 0) { + throw new Error("h$openWebSocket: unexpected readyState, socket must be CONNECTING"); + } + ws.lastError = null; + ws.onopen = function() { + if(mcb) { + ws.onmessage = mcb; + } + if(ccb || mcb) { + ws.onclose = function(ce) { + if(ws.onmessage) { + h$release(ws.onmessage); + ws.onmessage = null; + } + if(ccb) { + h$release(ccb); + ccb(ce); + } + }; + }; + ws.onerror = function(err) { + ws.lastError = err; + if(ws.onmessage) { + h$release(ws.onmessage); + ws.onmessage = null; + } + ws.close(); + }; + c(null); + }; + ws.onerror = function(err) { + if(ccb) h$release(ccb); + if(mcb) h$release(mcb); + ws.onmessage = null; + ws.close(); + c(err); + }; +} + +function h$closeWebSocket(status, reason, ws) { + ws.onerror = null; + if(ws.onmessage) { + h$release(ws.onmessage); + ws.onmessage = null; + } + ws.close(status, reason); +} diff --git a/jsbits/websocket.js.pp b/jsbits/websocket.js.pp deleted file mode 100644 --- a/jsbits/websocket.js.pp +++ /dev/null @@ -1,58 +0,0 @@ -#include - -function h$createWebSocket(url, protocols) { - return new WebSocket(url, protocols); -} - -/* - this must be called before the websocket has connected, - typically synchronously after creating the socket - */ -function h$openWebSocket(ws, mcb, ccb, c) { - if(ws.readyState !== 0) { - throw new Error("h$openWebSocket: unexpected readyState, socket must be CONNECTING"); - } - ws.lastError = null; - ws.onopen = function() { - if(mcb) { - ws.onmessage = mcb; - } - if(ccb || mcb) { - ws.onclose = function(ce) { - if(ws.onmessage) { - h$release(ws.onmessage); - ws.onmessage = null; - } - if(ccb) { - h$release(ccb); - ccb(ce); - } - }; - }; - ws.onerror = function(err) { - ws.lastError = err; - if(ws.onmessage) { - h$release(ws.onmessage); - ws.onmessage = null; - } - ws.close(); - }; - c(null); - }; - ws.onerror = function(err) { - if(ccb) h$release(ccb); - if(mcb) h$release(mcb); - ws.onmessage = null; - ws.close(); - c(err); - }; -} - -function h$closeWebSocket(status, reason, ws) { - ws.onerror = null; - if(ws.onmessage) { - h$release(ws.onmessage); - ws.onmessage = null; - } - ws.close(status, reason); -} diff --git a/jsbits/xhr.js b/jsbits/xhr.js new file mode 100644 --- /dev/null +++ b/jsbits/xhr.js @@ -0,0 +1,17 @@ +//#OPTIONS: CPP +function h$sendXHR(xhr, d, cont) { + xhr.addEventListener('error', function () { + cont(2); + }); + xhr.addEventListener('abort', function() { + cont(1); + }); + xhr.addEventListener('load', function() { + cont(0); + }); + if(d) { + xhr.send(d); + } else { + xhr.send(); + } +} diff --git a/jsbits/xhr.js.pp b/jsbits/xhr.js.pp deleted file mode 100644 --- a/jsbits/xhr.js.pp +++ /dev/null @@ -1,16 +0,0 @@ -function h$sendXHR(xhr, d, cont) { - xhr.addEventListener('error', function () { - cont(2); - }); - xhr.addEventListener('abort', function() { - cont(1); - }); - xhr.addEventListener('load', function() { - cont(0); - }); - if(d) { - xhr.send(d); - } else { - xhr.send(); - } -} diff --git a/test/Tests/Buffer.hs b/test/Tests/Buffer.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Buffer.hs @@ -0,0 +1,80 @@ +module Tests.Buffer ( + tests +) where + +import Control.Exception (ErrorCall(..), catch) +import Control.Monad (forM_) +import Data.Primitive.ByteArray +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Word (Word8) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Property, ioProperty, (==>)) +import Test.Framework (Test, testGroup) +import Test.HUnit ((@=?), assertFailure) + +import GHCJS.Buffer + +byteLengthWorks :: Int -> Property +byteLengthWorks i = (i >= 0) ==> (ioProperty $ do + buf <- create i + return (i == byteLength buf)) + +fromByteStringNoOffset :: IO () +fromByteStringNoOffset = do + let bs = BS8.pack ['a'..'z'] + (buf, offset, len) = fromByteString bs + 0 @=? offset + 26 @=? len + 26 @=? byteLength buf + let ba = toByteArray buf + forM_ [0..25] $ \i -> do + BS.index bs i @=? indexByteArray ba i + +fromByteStringWithOffset :: IO () +fromByteStringWithOffset = do + let bs = BS8.pack ['a'..'z'] + sliced = BS.take 10 . BS.drop 5 $ bs + (buf, offset, len) = fromByteString sliced + 5 @=? offset + 10 @=? len + 26 @=? byteLength buf + let ba = toByteArray buf + forM_ [0..25] $ \i -> do + BS.index bs i @=? indexByteArray ba i + +atoz :: IO ByteArray +atoz = do + ba <- newByteArray 26 + forM_ [0..25] $ \i -> writeByteArray ba i (fromIntegral i + 65 :: Word8) + unsafeFreezeByteArray ba + +wrapIntoByteString :: IO () +wrapIntoByteString = do + buf <- fromByteArray `fmap` atoz + BS8.pack ['A'..'Z'] @=? toByteString 0 Nothing buf + BS8.pack ['K'..'Z'] @=? toByteString 10 Nothing buf + BS8.pack ['K'..'O'] @=? toByteString 10 (Just 5) buf + +toByteStringOffset :: IO () +toByteStringOffset = do + buf <- fromByteArray `fmap` atoz + tst (toByteString (-1) Nothing buf) "toByteString: negative offset" + tst (toByteString 100 Nothing buf) "toByteString: offset past end of buffer" + tst (toByteString 0 (Just (-1)) buf) "toByteString: negative length" + tst (toByteString 0 (Just (-1)) buf) "toByteString: negative length" + tst (toByteString 0 (Just 27) buf) "toByteString: length past end of buffer" + tst (toByteString 20 (Just 7) buf) "toByteString: length past end of buffer" + where tst expr expected = ign expr expected `catch` \(ErrorCall msg) -> expected @=? msg + ign expr expected = seq expr $ assertFailure ("Expected error " ++ show expected ++ " but got nothing") + +tests :: Test +tests = + testGroup "Buffer" [ + testProperty "byte length works" byteLengthWorks, + testCase "fromByteString - no offset" fromByteStringNoOffset, + testCase "fromByteString - offset" fromByteStringWithOffset, + testCase "toByteString" wrapIntoByteString, + testCase "toByteString - offset" toByteStringOffset + ] diff --git a/test/Tests/Properties.hs b/test/Tests/Properties.hs --- a/test/Tests/Properties.hs +++ b/test/Tests/Properties.hs @@ -758,6 +758,7 @@ testProperty "j_decimal_int16" j_decimal_int16, testProperty "j_decimal_int32" j_decimal_int32, testProperty "j_decimal_int64" j_decimal_int64, + testProperty "j_decimal_word" j_decimal_word, testProperty "j_decimal_word8" j_decimal_word8, testProperty "j_decimal_word16" j_decimal_word16, @@ -783,9 +784,9 @@ testProperty "j_hexadecimal_word64" j_hexadecimal_word64 ], testGroup "realfloat" [ - -- disabled due to rounding differences - -- testProperty "j_realfloat_double" j_realfloat_double, - -- testProperty "j_formatRealFloat_double" j_formatRealFloat_double + -- disabled due to rounding differences + -- testProperty "j_realfloat_double" j_realfloat_double, + -- testProperty "j_formatRealFloat_double" j_formatRealFloat_double ] ], diff --git a/test/Tests/Properties/Numeric.hs b/test/Tests/Properties/Numeric.hs --- a/test/Tests/Properties/Numeric.hs +++ b/test/Tests/Properties/Numeric.hs @@ -40,7 +40,10 @@ j_decimal_word64_big (BigBounded (a::Word64)) = j_decimal a j_hex :: (Integral a, Show a) => a -> Bool -j_hex = flip showHex "" `eq` (J.unpack . JI.hexadecimal) +j_hex = hex `eq` (J.unpack . JI.hexadecimal) + where + hex n | n < 0 = '-' : showHex (-n) "" + | otherwise = showHex n "" j_hexadecimal_integer (a::Integer) = j_hex a j_hexadecimal_int (a::Int) = j_hex a diff --git a/test/Tests/QuickCheckUtils.hs b/test/Tests/QuickCheckUtils.hs --- a/test/Tests/QuickCheckUtils.hs +++ b/test/Tests/QuickCheckUtils.hs @@ -271,17 +271,6 @@ , E "32le" IO.utf32le, E "32be" IO.utf32be ] -windowsNewlineMode :: IO.NewlineMode -windowsNewlineMode = IO.NewlineMode - { IO.inputNL = IO.CRLF, IO.outputNL = IO.CRLF - } - -instance Arbitrary IO.NewlineMode where - arbitrary = oneof . map return $ - [ IO.noNewlineTranslation, IO.universalNewlineMode, IO.nativeNewlineMode - , windowsNewlineMode - ] - instance Arbitrary IO.BufferMode where arbitrary = oneof [ return IO.NoBuffering, return IO.LineBuffering,