diff --git a/.gitignore b/.gitignore index 2e38caf..a6e13ef 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *~ *# /dist +.stack-work/ diff --git a/Data/JSString.hs b/Data/JSString.hs index 7c18fa6..b3971dc 100644 --- a/Data/JSString.hs +++ b/Data/JSString.hs @@ -159,16 +159,16 @@ import qualified GHC.CString as GHC import Unsafe.Coerce -import GHCJS.Prim (JSRef) +import GHCJS.Prim (JSVal) import Data.JSString.Internal.Type import Data.JSString.Internal.Fusion (stream, unstream) import qualified Data.JSString.Internal.Fusion as S import qualified Data.JSString.Internal.Fusion.Common as S -getJSRef :: JSString -> JSRef () -getJSRef (JSString x) = x -{-# INLINE getJSRef #-} +getJSVal :: JSString -> JSVal +getJSVal (JSString x) = x +{-# INLINE getJSVal #-} instance Exts.IsString JSString where fromString = pack @@ -241,7 +241,7 @@ unpack = S.unstreamList . stream {-# INLINE [1] unpack #-} unpack' :: JSString -> String -unpack' x = case js_unpack x of (# z #) -> z +unpack' x = unsafeCoerce (js_unpack x) {-# INLINE unpack' #-} -- | /O(n)/ Convert a literal string into a JSString. Subject to fusion. @@ -1181,7 +1181,7 @@ group x = group' x -- fixme, implement lazier version {-# INLINE group #-} group' :: JSString -> [JSString] -group' x = case js_group x of (# z #) -> z +group' x = unsafeCoerce (js_group x) {-# INLINE group' #-} -- | /O(n^2)/ Return all initial segments of the given 'JSString', shortest @@ -1266,7 +1266,7 @@ splitOn' :: JSString -> [JSString] splitOn' pat src | null pat = emptyError "splitOn'" - | otherwise = case js_splitOn pat src of (# z #) -> z + | otherwise = unsafeCoerce (js_splitOn pat src) {-# NOINLINE splitOn' #-} --- {-# INLINE [1] splitOn' #-} @@ -1314,7 +1314,7 @@ chunksOf (I# k) p = go 0# -- > chunksOf 3 "foobarbaz" == ["foo","bar","baz"] -- > chunksOf 4 "haskell.org" == ["hask","ell.","org"] chunksOf' :: Int -> JSString -> [JSString] -chunksOf' (I# k) p = case js_chunksOf k p of (# z #) -> z +chunksOf' (I# k) p = unsafeCoerce (js_chunksOf k p) {-# INLINE chunksOf' #-} -- ---------------------------------------------------------------------------- @@ -1423,7 +1423,7 @@ breakOnAll' :: JSString -- ^ @needle@ to search for -> [(JSString, JSString)] breakOnAll' pat src | null pat = emptyError "breakOnAll'" - | otherwise = case js_breakOnAll pat src of (# z #) -> z + | otherwise = unsafeCoerce (js_breakOnAll pat src) {-# INLINE breakOnAll' #-} ------------------------------------------------------------------------------- @@ -1512,7 +1512,7 @@ words x = loop 0# -- js_words x {- t@(Text arr off len) = loop 0 0 -- fixme: strict words' that allocates the whole list in one go words' :: JSString -> [JSString] -words' x = case js_words x of (# z #) -> z +words' x = unsafeCoerce (js_words x) {-# INLINE words' #-} -- | /O(n)/ Breaks a 'JSString' up into a list of 'JSString's at @@ -1527,7 +1527,7 @@ lines ps = loop 0# {-# INLINE lines #-} lines' :: JSString -> [JSString] -lines' ps = case js_lines ps of (# z #) -> z +lines' ps = unsafeCoerce (js_lines ps) {-# INLINE lines' #-} {- @@ -1619,7 +1619,7 @@ isInfixOf needle haystack = js_isInfixOf needle haystack -- > fnordLength (stripPrefix "fnord" -> Just suf) = T.length suf -- > fnordLength _ = -1 stripPrefix :: JSString -> JSString -> Maybe JSString -stripPrefix x y = case js_stripPrefix x y of (# z #) -> z +stripPrefix x y = unsafeCoerce (js_stripPrefix x y) {-# INLINE stripPrefix #-} -- | /O(n)/ Find the longest non-empty common prefix of two strings @@ -1635,7 +1635,7 @@ stripPrefix x y = case js_stripPrefix x y of (# z #) -> z -- > commonPrefixes "veeble" "fetzer" == Nothing -- > commonPrefixes "" "baz" == Nothing commonPrefixes :: JSString -> JSString -> Maybe (JSString,JSString,JSString) -commonPrefixes x y = case js_commonPrefixes x y of (# z #) -> z +commonPrefixes x y = unsafeCoerce (js_commonPrefixes x y) {-# INLINE commonPrefixes #-} -- | /O(n)/ Return the prefix of the second string if its suffix @@ -1657,7 +1657,7 @@ commonPrefixes x y = case js_commonPrefixes x y of (# z #) -> z -- > quuxLength (stripSuffix "quux" -> Just pre) = T.length pre -- > quuxLength _ = -1 stripSuffix :: JSString -> JSString -> Maybe JSString -stripSuffix x y = case js_stripSuffix x y of (# z #) -> z +stripSuffix x y = unsafeCoerce (js_stripSuffix x y) {-# INLINE stripSuffix #-} -- | Add a list of non-negative numbers. Errors out on overflow. @@ -1687,7 +1687,7 @@ foreign import javascript unsafe foreign import javascript unsafe "$1===''" js_null :: JSString -> Bool foreign import javascript unsafe - "$1===null" js_isNull :: JSRef () -> Bool + "$1===null" js_isNull :: JSVal -> Bool foreign import javascript unsafe "$1===$2" js_eq :: JSString -> JSString -> Bool foreign import javascript unsafe @@ -1699,7 +1699,7 @@ foreign import javascript unsafe foreign import javascript unsafe "h$jsstringSingleton" js_singleton :: Char -> JSString foreign import javascript unsafe - "h$jsstringUnpack" js_unpack :: JSString -> (# String #) + "h$jsstringUnpack" js_unpack :: JSString -> Exts.Any -- String foreign import javascript unsafe "h$jsstringCons" js_cons :: Char -> JSString -> JSString foreign import javascript unsafe @@ -1731,13 +1731,13 @@ foreign import javascript unsafe "h$jsstringLast" js_last :: JSString -> Int# foreign import javascript unsafe - "h$jsstringInit" js_init :: JSString -> JSRef () -- null for empty string + "h$jsstringInit" js_init :: JSString -> JSVal -- null for empty string foreign import javascript unsafe - "h$jsstringTail" js_tail :: JSString -> JSRef () -- null for empty string + "h$jsstringTail" js_tail :: JSString -> JSVal -- null for empty string foreign import javascript unsafe "h$jsstringReverse" js_reverse :: JSString -> JSString foreign import javascript unsafe - "h$jsstringGroup" js_group :: JSString -> (# [JSString] #) -- Exts.Any {- [JSString] -} + "h$jsstringGroup" js_group :: JSString -> Exts.Any {- [JSString] -} --foreign import javascript unsafe -- "h$jsstringGroup1" js_group1 -- :: Int# -> Bool -> JSString -> (# Int#, JSString #) @@ -1751,11 +1751,11 @@ foreign import javascript unsafe foreign import javascript unsafe "h$jsstringWords1" js_words1 :: Int# -> JSString -> (# Int#, JSString #) foreign import javascript unsafe - "h$jsstringWords" js_words :: JSString -> (# [JSString] #) -- Exts.Any {- [JSString] -} + "h$jsstringWords" js_words :: JSString -> Exts.Any -- [JSString] foreign import javascript unsafe "h$jsstringLines1" js_lines1 :: Int# -> JSString -> (# Int#, JSString #) foreign import javascript unsafe - "h$jsstringLines" js_lines :: JSString -> (# [JSString] #) -- Exts.Any {- [JSString] -} + "h$jsstringLines" js_lines :: JSString -> Exts.Any -- [JSString] foreign import javascript unsafe "h$jsstringUnlines" js_unlines :: Exts.Any {- [JSString] -} -> JSString foreign import javascript unsafe @@ -1768,16 +1768,16 @@ foreign import javascript unsafe "h$jsstringIsInfixOf" js_isInfixOf :: JSString -> JSString -> Bool foreign import javascript unsafe "h$jsstringStripPrefix" js_stripPrefix - :: JSString -> JSString -> (# Maybe JSString #) + :: JSString -> JSString -> Exts.Any -- Maybe JSString foreign import javascript unsafe "h$jsstringStripSuffix" js_stripSuffix - :: JSString -> JSString -> (# Maybe JSString #) + :: JSString -> JSString -> Exts.Any -- Maybe JSString foreign import javascript unsafe "h$jsstringCommonPrefixes" js_commonPrefixes - :: JSString -> JSString -> (# Maybe (JSString, JSString, JSString) #) + :: JSString -> JSString -> Exts.Any -- Maybe (JSString, JSString, JSString) foreign import javascript unsafe "h$jsstringChunksOf" js_chunksOf - :: Int# -> JSString -> (# [JSString] #) + :: Int# -> JSString -> Exts.Any -- [JSString] foreign import javascript unsafe "h$jsstringChunksOf1" js_chunksOf1 :: Int# -> Int# -> JSString -> (# Int#, JSString #) @@ -1786,7 +1786,7 @@ foreign import javascript unsafe :: Int# -> JSString -> (# JSString, JSString #) foreign import javascript unsafe "h$jsstringSplitOn" js_splitOn - :: JSString -> JSString -> (# [JSString] #) + :: JSString -> JSString -> Exts.Any -- [JSString] foreign import javascript unsafe "h$jsstringSplitOn1" js_splitOn1 :: Int# -> JSString -> JSString -> (# Int#, JSString #) @@ -1798,7 +1798,7 @@ foreign import javascript unsafe :: JSString -> JSString -> (# JSString, JSString #) foreign import javascript unsafe "h$jsstringBreakOnAll" js_breakOnAll - :: JSString -> JSString -> (# [(JSString, JSString)] #) + :: JSString -> JSString -> Exts.Any -- [(JSString, JSString)] foreign import javascript unsafe "h$jsstringBreakOnAll1" js_breakOnAll1 :: Int# -> JSString -> JSString -> (# Int#, JSString, JSString #) diff --git a/Data/JSString/Internal.hs b/Data/JSString/Internal.hs index 36e129e..7b66280 100644 --- a/Data/JSString/Internal.hs +++ b/Data/JSString/Internal.hs @@ -12,9 +12,9 @@ import Control.DeepSeq (NFData(..)) import qualified GHC.Exts as Exts import Unsafe.Coerce -import GHCJS.Prim (JSRef) +import GHCJS.Prim (JSVal) -newtype JSString = JSString (JSRef ()) +newtype JSString = JSString (JSVal ()) instance Monoid JSString where mempty = empty diff --git a/Data/JSString/Internal/Fusion.hs b/Data/JSString/Internal/Fusion.hs index cba4740..4118acb 100644 --- a/Data/JSString/Internal/Fusion.hs +++ b/Data/JSString/Internal/Fusion.hs @@ -185,10 +185,10 @@ foreign import javascript unsafe foreign import javascript unsafe "$1.length" js_length :: JSString -> Int# foreign import javascript unsafe - "$r = [$1];" js_newSingletonArray :: Char -> IO (JSRef ()) + "$r = [$1];" js_newSingletonArray :: Char -> IO JSVal foreign import javascript unsafe - "$3[$2] = $1;" js_writeArray :: Char -> Int -> (JSRef ()) -> IO () + "$3[$2] = $1;" js_writeArray :: Char -> Int -> JSVal -> IO () foreign import javascript unsafe - "h$jsstringPackArray" js_packString :: (JSRef ()) -> IO JSString + "h$jsstringPackArray" js_packString :: JSVal -> IO JSString foreign import javascript unsafe - "h$jsstringPackArrayReverse" js_packReverse :: (JSRef ()) -> IO JSString + "h$jsstringPackArrayReverse" js_packReverse :: JSVal -> IO JSString diff --git a/Data/JSString/Internal/Type.hs b/Data/JSString/Internal/Type.hs index ac233cf..4fff668 100644 --- a/Data/JSString/Internal/Type.hs +++ b/Data/JSString/Internal/Type.hs @@ -36,11 +36,13 @@ import Data.Int (Int32, Int64) import Data.Typeable (Typeable) import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#) -import GHCJS.Prim (JSRef) +import GHCJS.Prim (JSVal) + +import GHCJS.Internal.Types -- | A wrapper around a JavaScript string -newtype JSString = JSString { unJSString :: JSRef () } - deriving Typeable +newtype JSString = JSString JSVal +instance IsJSVal JSString instance NFData JSString where rnf !x = () diff --git a/Data/JSString/Raw.hs b/Data/JSString/Raw.hs index 769ca1f..31b2c19 100644 --- a/Data/JSString/Raw.hs +++ b/Data/JSString/Raw.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, - MagicHash, UnboxedTuples, UnliftedFFITypes + MagicHash, UnboxedTuples, UnliftedFFITypes, GHCForeignImportPrim #-} {- @@ -110,7 +110,7 @@ rawChunksOf (I# k) x = {-# INLINE rawChunksOf #-} rawChunksOf' :: Int -> JSString -> [JSString] -rawChunksOf' (I# k) x = case js_rawChunksOf k x of (# z #) -> z +rawChunksOf' (I# k) x = unsafeCoerce (js_rawChunksOf k x) {-# INLINE rawChunksOf' #-} rawSplitAt :: Int -> JSString -> (JSString, JSString) @@ -144,5 +144,5 @@ foreign import javascript unsafe foreign import javascript unsafe "$2.charCodeAt($1)" js_charCodeAt :: Int# -> JSString -> Int# foreign import javascript unsafe - "$hsRawChunksOf" js_rawChunksOf :: Int# -> JSString -> (# [JSString] #) + "$hsRawChunksOf" js_rawChunksOf :: Int# -> JSString -> Exts.Any -- [JSString] diff --git a/Data/JSString/Read.hs b/Data/JSString/Read.hs index f95c7b5..2dbbd03 100644 --- a/Data/JSString/Read.hs +++ b/Data/JSString/Read.hs @@ -6,14 +6,23 @@ module Data.JSString.Read ( isInteger , isNatural , readInt , readIntMaybe + , lenientReadInt + , readInt64 + , readInt64Maybe + , readWord64 + , readWord64Maybe , readDouble , readDoubleMaybe , readInteger , readIntegerMaybe ) where -import GHC.Exts (ByteArray#, Int#, Int64#, Word64#, Int(..)) + +import GHCJS.Types + +import GHC.Exts (Any, Int#, Int64#, Word64#, Int(..)) import GHC.Int (Int64(..)) import GHC.Word (Word64(..)) +import Unsafe.Coerce import Data.Maybe import Data.JSString @@ -127,10 +136,10 @@ readIntegerMaybe j = convertNullMaybe js_readInteger j -- ---------------------------------------------------------------------------- -convertNullMaybe :: (JSString -> ByteArray#) -> JSString -> Maybe a +convertNullMaybe :: (JSString -> JSVal) -> JSString -> Maybe a convertNullMaybe f j | js_isNull r = Nothing - | otherwise = case js_toHeapObject r of (# h #) -> Just h + | otherwise = Just (unsafeCoerce (js_toHeapObject r)) where r = f j {-# INLINE convertNullMaybe #-} @@ -141,21 +150,21 @@ readError xs = error ("Data.JSString.Read." ++ xs) -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "$1===null" js_isNull :: ByteArray# -> Bool + "$r = $1===null;" js_isNull :: JSVal -> Bool foreign import javascript unsafe - "$r=$1;" js_toHeapObject :: ByteArray# -> (# a #) + "$r=$1;" js_toHeapObject :: JSVal -> Any foreign import javascript unsafe - "h$jsstringReadInteger" js_readInteger :: JSString -> ByteArray# + "h$jsstringReadInteger" js_readInteger :: JSString -> JSVal foreign import javascript unsafe - "h$jsstringReadInt" js_readInt :: JSString -> ByteArray# + "h$jsstringReadInt" js_readInt :: JSString -> JSVal foreign import javascript unsafe - "h$jsstringLenientReadInt" js_lenientReadInt :: JSString -> ByteArray# + "h$jsstringLenientReadInt" js_lenientReadInt :: JSString -> JSVal foreign import javascript unsafe "h$jsstringReadInt64" js_readInt64 :: JSString -> (# Int#, Int64# #) foreign import javascript unsafe "h$jsstringReadWord64" js_readWord64 :: JSString -> (# Int#, Word64# #) foreign import javascript unsafe - "h$jsstringReadDouble" js_readDouble :: JSString -> ByteArray# + "h$jsstringReadDouble" js_readDouble :: JSString -> JSVal foreign import javascript unsafe "h$jsstringIsInteger" js_isInteger :: JSString -> Bool foreign import javascript unsafe diff --git a/Data/JSString/RegExp.hs b/Data/JSString/RegExp.hs index e132e73..0ec8e1c 100644 --- a/Data/JSString/RegExp.hs +++ b/Data/JSString/RegExp.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE JavaScriptFFI, ForeignFunctionInterface, GHCForeignImportPrim, - UnliftedFFITypes, UnboxedTuples, MagicHash - #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MagicHash #-} module Data.JSString.RegExp ( RegExp , pattern @@ -15,11 +19,14 @@ module Data.JSString.RegExp ( RegExp ) where import GHCJS.Prim -import GHC.Exts (Int#, Int(..)) +import GHC.Exts (Any, Int#, Int(..)) + +import Unsafe.Coerce (unsafeCoerce) import Data.JSString +import Data.Typeable -newtype RegExp = RegExp (JSRef ()) +newtype RegExp = RegExp JSVal deriving Typeable data REFlags = REFlags { multiline :: !Bool , ignoreCase :: !Bool @@ -32,9 +39,11 @@ data Match = Match { matched :: !JSString -- ^ the matched string } create :: REFlags -> JSString -> RegExp -create flags pat = js_createRE (multiline flags) - (ignoreCase flags) - pat +create flags pat = js_createRE pat flags' + where + flags' | multiline flags = if ignoreCase flags then "mi" else "m" + | otherwise = if ignoreCase flags then "i" else "" +{-# INLINE create #-} pattern :: RegExp -> JSString pattern re = js_pattern re @@ -45,8 +54,6 @@ isMultiline re = js_isMultiline re isIgnoreCase :: RegExp -> Bool isIgnoreCase re = js_isIgnoreCase re -{-# INLINE create #-} - test :: JSString -> RegExp -> Bool test x re = js_test x re {-# INLINE test #-} @@ -63,7 +70,7 @@ execNext m re = case matchRawIndex m of exec' :: Int# -> JSString -> RegExp -> Maybe Match exec' i x re = case js_exec i x re of (# -1#, _, _ #) -> Nothing - (# i', y, z #) -> Just (Match y z (I# i) x) + (# i', y, z #) -> Just (Match y (unsafeCoerce z) (I# i) x) {-# INLINE exec' #-} matches :: JSString -> RegExp -> [Match] @@ -73,30 +80,30 @@ matches x r = maybe [] go (exec x r) {-# INLINE matches #-} replace :: RegExp -> JSString -> JSString -> JSString -replace x r = undefined +replace x r = error "Data.JSString.RegExp.replace not implemented" {-# INLINE replace #-} split :: JSString -> RegExp -> [JSString] -split x r = case js_split -1# x r of (# y #) -> y +split x r = unsafeCoerce (js_split -1# x r) {-# INLINE split #-} splitN :: Int -> JSString -> RegExp -> [JSString] -splitN (I# k) x r = case js_split k x r of (# y #) -> y +splitN (I# k) x r = unsafeCoerce (js_split k x r) {-# INLINE splitN #-} -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "new RegExp($1,$2,$3)" js_createRE :: Bool -> Bool -> JSString -> RegExp + "new RegExp($1,$2)" js_createRE :: JSString -> JSString -> RegExp foreign import javascript unsafe "$2.test($1)" js_test :: JSString -> RegExp -> Bool foreign import javascript unsafe "h$jsstringExecRE" js_exec - :: Int# -> JSString -> RegExp -> (# Int#, JSString, [JSString] #) + :: Int# -> JSString -> RegExp -> (# Int#, JSString, Any {- [JSString] -} #) foreign import javascript unsafe "h$jsstringReplaceRE" js_replace :: RegExp -> JSString -> JSString -> JSString foreign import javascript unsafe - "h$jsstringSplitRE" js_split :: Int# -> JSString -> RegExp -> (# [JSString] #) + "h$jsstringSplitRE" js_split :: Int# -> JSString -> RegExp -> Any -- [JSString] foreign import javascript unsafe "$1.multiline" js_isMultiline :: RegExp -> Bool foreign import javascript unsafe diff --git a/Data/JSString/Text.hs b/Data/JSString/Text.hs index 8601620..478008b 100644 --- a/Data/JSString/Text.hs +++ b/Data/JSString/Text.hs @@ -11,8 +11,8 @@ module Data.JSString.Text , textFromJSString , lazyTextToJSString , lazyTextFromJSString - , textFromJSRef - , lazyTextFromJSRef + , textFromJSVal + , lazyTextFromJSVal ) where import GHCJS.Prim @@ -51,16 +51,16 @@ lazyTextFromJSString = TL.fromStrict . textFromJSString {-# INLINE lazyTextFromJSString #-} -- | returns the empty Text if not a string -textFromJSRef :: JSRef a -> T.Text -textFromJSRef j = case js_fromString' j of +textFromJSVal :: JSVal -> T.Text +textFromJSVal j = case js_fromString' j of (# _, 0# #) -> T.empty (# ba, length #) -> T.Text (A.Array ba) 0 (I# length) -{-# INLINE textFromJSRef #-} +{-# INLINE textFromJSVal #-} -- | returns the empty Text if not a string -lazyTextFromJSRef :: JSRef a -> TL.Text -lazyTextFromJSRef = TL.fromStrict . textFromJSRef -{-# INLINE lazyTextFromJSRef #-} +lazyTextFromJSVal :: JSVal -> TL.Text +lazyTextFromJSVal = TL.fromStrict . textFromJSVal +{-# INLINE lazyTextFromJSVal #-} -- ---------------------------------------------------------------------------- @@ -72,7 +72,7 @@ foreign import javascript unsafe js_fromString :: JSString -> (# ByteArray#, Int# #) foreign import javascript unsafe "h$textFromString" - js_fromString' :: JSRef a -> (# ByteArray#, Int# #) + js_fromString' :: JSVal -> (# ByteArray#, Int# #) foreign import javascript unsafe "h$lazyTextToString" js_lazyTextToString :: Any -> JSString diff --git a/GHCJS/Buffer.hs b/GHCJS/Buffer.hs index b08a63f..f4f1a5a 100644 --- a/GHCJS/Buffer.hs +++ b/GHCJS/Buffer.hs @@ -52,10 +52,9 @@ import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Internal as BS import Data.Primitive.ByteArray -import qualified JavaScript.TypedArray.Internal.Types as I -import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer) -import JavaScript.TypedArray.DataView.Internal (SomeDataView) -import qualified JavaScript.TypedArray.Internal as I +import JavaScript.TypedArray + hiding (fromByteArrayPrim, toByteArrayPrim, fromMutableByteArrayPrim, toMutableByteArrayPrim + , toByteArray, fromByteArray) import GHC.ForeignPtr @@ -72,23 +71,23 @@ getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any getArrayBuffer buf = js_getArrayBuffer buf {-# INLINE getArrayBuffer #-} -getInt32Array :: SomeBuffer any -> I.SomeInt32Array any +getInt32Array :: SomeBuffer any -> SomeTypedArray any Int32 getInt32Array buf = js_getInt32Array buf {-# INLINE getInt32Array #-} -getUint8Array :: SomeBuffer any -> I.SomeUint8Array any +getUint8Array :: SomeBuffer any -> SomeTypedArray any Word8 getUint8Array buf = js_getUint8Array buf {-# INLINE getUint8Array #-} -getUint16Array :: SomeBuffer any -> I.SomeUint16Array any +getUint16Array :: SomeBuffer any -> SomeTypedArray any Word16 getUint16Array buf = js_getUint16Array buf {-# INLINE getUint16Array #-} -getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any +getFloat32Array :: SomeBuffer any -> SomeTypedArray any Float getFloat32Array buf = js_getFloat32Array buf {-# INLINE getFloat32Array #-} -getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any +getFloat64Array :: SomeBuffer any -> SomeTypedArray any Double getFloat64Array buf = js_getFloat64Array buf {-# INLINE getFloat64Array #-} @@ -180,9 +179,11 @@ unsafeToPtr :: Buffer -> Ptr a unsafeToPtr buf = Ptr (js_toAddr buf) {-# INLINE unsafeToPtr #-} -byteLength :: SomeBuffer any -> Int -byteLength buf = js_byteLength buf -{-# INLINE byteLength #-} +instance ArrayBufferData (SomeBuffer m) where + {-# INLINE byteLength #-} + byteLength = js_byteLength + {-# INLINE sliceImmutable #-} + sliceImmutable = undefined -- ---------------------------------------------------------------------------- @@ -198,15 +199,15 @@ foreign import javascript unsafe foreign import javascript unsafe "$1.buf" js_getArrayBuffer :: SomeBuffer any -> SomeArrayBuffer any foreign import javascript unsafe - "$1.i3" js_getInt32Array :: SomeBuffer any -> I.SomeInt32Array any + "$1.i3" js_getInt32Array :: SomeBuffer any -> SomeTypedArray any Int32 foreign import javascript unsafe - "$1.u8" js_getUint8Array :: SomeBuffer any -> I.SomeUint8Array any + "$1.u8" js_getUint8Array :: SomeBuffer any -> SomeTypedArray any Word8 foreign import javascript unsafe - "$1.u1" js_getUint16Array :: SomeBuffer any -> I.SomeUint16Array any + "$1.u1" js_getUint16Array :: SomeBuffer any -> SomeTypedArray any Word16 foreign import javascript unsafe - "$1.f3" js_getFloat32Array :: SomeBuffer any -> I.SomeFloat32Array any + "$1.f3" js_getFloat32Array :: SomeBuffer any -> SomeTypedArray any Float foreign import javascript unsafe - "$1.f6" js_getFloat64Array :: SomeBuffer any -> I.SomeFloat64Array any + "$1.f6" js_getFloat64Array :: SomeBuffer any -> SomeTypedArray any Double foreign import javascript unsafe "$1.dv" js_getDataView :: SomeBuffer any -> SomeDataView any @@ -214,14 +215,14 @@ foreign import javascript unsafe -- these things have the same representation (modulo boxing), -- conversion is free -foreign import javascript unsafe +foreign import javascript unsafe "$r = $1;" js_toByteArray :: SomeBuffer any -> ByteArray# -foreign import javascript unsafe - "$r = $1;" js_fromByteArray :: ByteArray# -> JSRef () foreign import javascript unsafe - "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSRef () + "$r = $1;" js_fromByteArray :: ByteArray# -> JSVal +foreign import javascript unsafe + "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSVal foreign import javascript unsafe - "$r = $1;" js_toMutableByteArray :: JSRef () -> MutableByteArray# s + "$r = $1;" js_toMutableByteArray :: JSVal -> MutableByteArray# s foreign import javascript unsafe "$r1 = $1; $r2 = 0;" js_toAddr :: SomeBuffer any -> Addr# foreign import javascript unsafe diff --git a/GHCJS/Buffer/Types.hs b/GHCJS/Buffer/Types.hs index c55186e..5fbe687 100644 --- a/GHCJS/Buffer/Types.hs +++ b/GHCJS/Buffer/Types.hs @@ -5,7 +5,7 @@ module GHCJS.Buffer.Types where import GHCJS.Types import GHCJS.Internal.Types -newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer (JSRef ()) +newtype SomeBuffer (a :: MutabilityType s) = SomeBuffer JSVal type Buffer = SomeBuffer Immutable type MutableBuffer = SomeBuffer Mutable diff --git a/GHCJS/Concurrent.hs b/GHCJS/Concurrent.hs index ea73e2c..fa9650c 100644 --- a/GHCJS/Concurrent.hs +++ b/GHCJS/Concurrent.hs @@ -26,9 +26,10 @@ -} module GHCJS.Concurrent ( isThreadSynchronous - , isContinueAsync - , OnBlock (..) + , isThreadContinueAsync + , OnBlocked(..) , WouldBlockException(..) + , withoutPreemption , synchronously ) where @@ -47,30 +48,52 @@ import Data.Typeable import Unsafe.Coerce -data OnBlock = ContinueAsync - | ThrowWouldBlock - deriving (Data, Typeable, Enum, Show, Eq, Ord) +{- | + 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. + + When the thread encounters a black hole from another thread, the scheduler + will attempt to clear it by temporarily switching to that thread. + -} + +withoutPreemption :: IO a -> IO a +withoutPreemption x = Ex.mask $ \restore -> do + oldS <- js_setNoPreemption True + if oldS + then restore x + else restore x `Ex.finally` js_setNoPreemption False +{-# INLINE withoutPreemption #-} + {- | - Runs the action synchronously, which means that the thread will not + Run the action synchronously, which means that the thread will not be preempted by the scheduler. If the thread encounters a blocking - operation, the scheduler will switch to other threads. When the thread - is scheduled again, it will still be non-preemptible. + operation, the runtime throws a WouldBlock exception. When the thread encounters a black hole from another thread, the scheduler will attempt to clear it by temporarily switching to that thread. -} synchronously :: IO a -> IO a -synchronously x = do +synchronously x = Ex.mask $ \restore -> do oldS <- js_setSynchronous True if oldS - then x - else x `Ex.finally` js_setSynchronous False + then restore x + else restore x `Ex.finally` js_setSynchronous False {-# INLINE synchronously #-} -makeAsynchronous :: ThreadId -> IO () -makeAsynchronous (ThreadId tid) = js_makeAsynchronous tid - {- | Returns whether the 'ThreadId' is a synchronous thread -} isThreadSynchronous :: ThreadId -> IO Bool @@ -80,8 +103,15 @@ isThreadSynchronous = fmap (`testBit` 0) . syncThreadState Returns whether the 'ThreadId' will continue running async. Always returns 'True' when the thread is not synchronous. -} -isContinueAsync :: ThreadId -> IO Bool -isContinueAsync = fmap (`testBit` 1) . syncThreadState +isThreadContinueAsync :: ThreadId -> IO Bool +isThreadContinueAsync = fmap (`testBit` 1) . syncThreadState + +{- | + Returns whether the 'ThreadId' is not preemptible. Always + returns 'True' when the thread is synchronous. + -} +isThreadNonPreemptible :: ThreadId -> IO Bool +isThreadNonPreemptible = fmap (`testBit` 2) . syncThreadState syncThreadState :: ThreadId-> IO Int syncThreadState (ThreadId tid) = js_syncThreadState tid @@ -91,11 +121,12 @@ syncThreadState (ThreadId tid) = js_syncThreadState tid foreign import javascript unsafe "h$syncThreadState($1)" js_syncThreadState :: ThreadId# -> IO Int +foreign import javascript unsafe + "$r = h$currentThread.noPreemption;\ + \h$currentThread.noPreemption = $1;" + js_setNoPreemption :: Bool -> IO Bool; + foreign import javascript unsafe "$r = h$currentThread.isSynchronous;\ \h$currentThread.isSynchronous = $1;" js_setSynchronous :: Bool -> IO Bool - -foreign import javascript unsafe - "$1.isSynchronous = false;" - js_makeAsynchronous :: ThreadId# -> IO () diff --git a/GHCJS/Foreign.hs b/GHCJS/Foreign.hs index b26876b..5bbc5c5 100644 --- a/GHCJS/Foreign.hs +++ b/GHCJS/Foreign.hs @@ -3,18 +3,18 @@ {-# LANGUAGE DefaultSignatures #-} {- | Basic interop between Haskell and JavaScript. - The principal type here is 'JSRef', which is a lifted type that contains - a JavaScript reference. The 'JSRef' type is parameterized with one phantom + The principal type here is 'JSVal', which is a lifted type that contains + a JavaScript reference. The 'JSVal' type is parameterized with one phantom type, and GHCJS.Types defines several type synonyms for specific variants. - The code in this module makes no assumptions about 'JSRef a' types. + The code in this module makes no assumptions about 'JSVal a' types. Operations that can result in a JS exception that can kill a Haskell thread - are marked unsafe (for example if the 'JSRef' contains a null or undefined + are marked unsafe (for example if the 'JSVal' contains a null or undefined value). There are safe variants where the JS exception is propagated as a Haskell exception, so that it can be handled on the Haskell side. For more specific types, like 'JSArray' or 'JSBool', the code assumes that - the contents of the 'JSRef' actually is a JavaScript array or bool value. + the contents of the 'JSVal' actually is a JavaScript array or bool value. If it contains an unexpected value, the code can result in exceptions that kill the Haskell thread, even for functions not marked unsafe. @@ -70,7 +70,7 @@ module GHCJS.Foreign ( jsTrue , jsTypeOf, JSType(..) , jsonTypeOf, JSONType(..) {- , wrapBuffer, wrapMutableBuffer - , byteArrayJSRef, mutableByteArrayJSRef + , byteArrayJSVal, mutableByteArrayJSVal , bufferByteString, byteArrayByteString , unsafeMutableByteArrayByteString -} ) where @@ -88,14 +88,14 @@ import qualified Data.Text as T class ToJSString a where toJSString :: a -> JSString --- toJSString = castRef . ptoJSRef +-- toJSString = ptoJSVal class FromJSString a where fromJSString :: JSString -> a --- default PFromJSRef --- fromJSString = pfromJSRef . castRef +-- default PFromJSVal +-- fromJSString = pfromJSVal -- {-# INLINE fromJSString #-} {- instance ToJSString [Char] @@ -114,8 +114,8 @@ instance FromJSString JSString o is not a JS object or the property cannot be accessed -} getProp :: ToJSString a => a -- ^ the property name - -> JSRef b -- ^ the object - -> IO (JSRef c) -- ^ the property value + -> JSVal b -- ^ the object + -> IO (JSVal c) -- ^ the property value getProp p o = js_getProp (toJSString p) o {-# INLINE getProp #-} @@ -123,8 +123,8 @@ getProp p o = js_getProp (toJSString p) o if o is not a JS object or the property cannot be accessed -} unsafeGetProp :: ToJSString a => a -- ^ the property name - -> JSRef b -- ^ the object - -> IO (JSRef c) -- ^ the property value, Nothing if the object doesn't have a property with the given name + -> JSVal b -- ^ the object + -> IO (JSVal c) -- ^ the property value, Nothing if the object doesn't have a property with the given name unsafeGetProp p o = js_unsafeGetProp (toJSString p) o {-# INLINE unsafeGetProp #-} @@ -132,8 +132,8 @@ unsafeGetProp p o = js_unsafeGetProp (toJSString p) o o is not a JS object or the property cannot be accessed -} getPropMaybe :: ToJSString a => a -- ^ the property name - -> JSRef b -- ^ the object - -> IO (Maybe (JSRef c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name + -> JSVal b -- ^ the object + -> IO (Maybe (JSVal c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name getPropMaybe p o = do p' <- js_getProp (toJSString p) o if isUndefined p' then return Nothing else return (Just p') @@ -143,8 +143,8 @@ getPropMaybe p o = do if o is not a JS object or the property cannot be accessed -} unsafeGetPropMaybe :: ToJSString a => a -- ^ the property name - -> JSRef b -- ^ the object - -> IO (Maybe (JSRef c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name + -> JSVal b -- ^ the object + -> IO (Maybe (JSVal c)) -- ^ the property value, Nothing if the object doesn't have a property with the given name unsafeGetPropMaybe p o = do p' <- js_unsafeGetProp (toJSString p) o if isUndefined p' then return Nothing else return (Just p') @@ -155,8 +155,8 @@ unsafeGetPropMaybe p o = do be set -} setProp :: ToJSString a => a -- ^ the property name - -> JSRef b -- ^ the value - -> JSRef c -- ^ the object + -> JSVal b -- ^ the value + -> JSVal c -- ^ the object -> IO () setProp p v o = js_setProp (toJSString p) v o {-# INLINE setProp #-} @@ -165,8 +165,8 @@ setProp p v o = js_setProp (toJSString p) v o if the property cannot be set. -} unsafeSetProp :: ToJSString a => a -- ^ the property name - -> JSRef b -- ^ the value - -> JSRef c -- ^ the object + -> JSVal b -- ^ the value + -> JSVal c -- ^ the object -> IO () unsafeSetProp p v o = js_unsafeSetProp (toJSString p) v o diff --git a/GHCJS/Foreign/Callback.hs b/GHCJS/Foreign/Callback.hs index 97a09b8..7e8e846 100644 --- a/GHCJS/Foreign/Callback.hs +++ b/GHCJS/Foreign/Callback.hs @@ -4,14 +4,24 @@ 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 @@ -24,17 +34,6 @@ import Data.Typeable 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 (Show, Eq, Enum, Typeable) - {- | 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 @@ -60,30 +59,63 @@ syncCallback onBlocked x = js_syncCallback (onBlocked == ContinueAsync) (unsafeC {- | 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 JSRef value to + 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 - -> (JSRef a -> IO ()) -- ^ the Haskell function - -> IO (Callback (JSRef a -> IO ())) -- ^ the callback +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 JSRef values to + 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 - -> (JSRef a -> JSRef b -> IO ()) -- ^ the Haskell function - -> IO (Callback (JSRef a -> JSRef b -> IO ())) -- ^ the callback +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. @@ -95,25 +127,34 @@ asyncCallback :: IO () -- ^ the action that the callback runs -> IO (Callback (IO ())) -- ^ the callback asyncCallback x = js_asyncCallback (unsafeCoerce x) -asyncCallback1 :: (JSRef a -> IO ()) -- ^ the function that the callback calls - -> IO (Callback (JSRef a -> IO ())) -- ^ the calback +asyncCallback1 :: (JSVal -> IO ()) -- ^ the function that the callback calls + -> IO (Callback (JSVal -> IO ())) -- ^ the calback asyncCallback1 x = js_asyncCallbackApply 1 (unsafeCoerce x) -asyncCallback2 :: (JSRef a -> JSRef b -> IO ()) -- ^ the Haskell function that the callback calls - -> IO (Callback (JSRef a -> JSRef b -> IO ())) -- ^ the callback +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 index 0d02923..ab6dc45 100644 --- a/GHCJS/Foreign/Callback/Internal.hs +++ b/GHCJS/Foreign/Callback/Internal.hs @@ -1,12 +1,12 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module GHCJS.Foreign.Callback.Internal where import GHCJS.Types import GHCJS.Marshal.Internal -newtype Callback a = Callback (JSRef ()) +import Data.Typeable -instance PToJSRef (Callback a) where - pToJSRef (Callback x) = castRef x +newtype Callback a = Callback JSVal deriving Typeable +instance IsJSVal (Callback a) -instance ToJSRef (Callback a) where - toJSRef = toJSRef_pure diff --git a/GHCJS/Foreign/Export.hs b/GHCJS/Foreign/Export.hs index ed2becb..502b5c2 100644 --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes, - GHCForeignImportPrim, ScopedTypeVariables, UnboxedTuples, - MagicHash, EmptyDataDecls, CPP - #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE EmptyDataDecls #-} {- | Dynamically export Haskell values to JavaScript @@ -22,11 +26,13 @@ import Data.Typeable import Data.Typeable.Internal (TypeRep(..)) import Data.Word import Unsafe.Coerce +import qualified GHC.Exts as Exts import GHCJS.Prim +import GHCJS.Types -data (Export_ a) -type Export a = JSRef (Export_ a) +newtype Export a = Export JSVal +instance IsJSVal (Export a) {- | Export any Haskell value to a JavaScript reference without evaluating it. @@ -39,17 +45,14 @@ type Export a = JSRef (Export_ a) export :: Typeable a => a -> IO (Export a) export x = js_export w1 w2 (unsafeCoerce x) where -#if __GLASGOW_HASKELL__ >= 709 TypeRep (Fingerprint w1 w2) _ _ _ = typeOf x -#else - TypeRep (Fingerprint w1 w2) _ _ = typeOf x -#endif {- | Export the value and run the action. The value is only exported for the duration of the action. Dereferencing it after the 'withExport' call has returned will always return 'Nothing'. -} +-- fixme is this safe with nested exports? withExport :: Typeable a => a -> (Export a -> IO b) -> IO b withExport x m = bracket (export x) releaseExport m @@ -60,16 +63,11 @@ withExport x m = bracket (export x) releaseExport m derefExport :: forall a. Typeable a => Export a -> IO (Maybe a) derefExport e = do -#if __GLASGOW_HASKELL__ >= 709 let TypeRep (Fingerprint w1 w2) _ _ _ = typeOf (undefined :: a) -#else - let TypeRep (Fingerprint w1 w2) _ _ = typeOf (undefined :: a) -#endif r <- js_derefExport w1 w2 e if isNull r then return Nothing - else case js_toHeapObject r of - (# x #) -> return (Just x) + else Just . unsafeCoerce <$> js_toHeapObject r {- | Release all memory associated with the export. Subsequent calls to @@ -84,11 +82,10 @@ foreign import javascript unsafe "h$exportValue" js_export :: Word64 -> Word64 -> Any -> IO (Export a) foreign import javascript unsafe - "h$derefExportedValue" - js_derefExport :: Word64 -> Word64 -> JSRef a -> IO (JSRef ()) + "h$derefExport" + js_derefExport :: Word64 -> Word64 -> Export a -> IO JSVal foreign import javascript unsafe - "$r = $1;" js_toHeapObject :: JSRef a -> (# b #) - + "$r = $1;" js_toHeapObject :: JSVal -> IO Any foreign import javascript unsafe "h$releaseExport" - js_releaseExport :: JSRef a -> IO () + js_releaseExport :: Export a -> IO () diff --git a/GHCJS/Foreign/Internal.hs b/GHCJS/Foreign/Internal.hs index 386e8cb..5ac81f0 100644 --- a/GHCJS/Foreign/Internal.hs +++ b/GHCJS/Foreign/Internal.hs @@ -4,18 +4,18 @@ {- | Basic interop between Haskell and JavaScript. - The principal type here is 'JSRef', which is a lifted type that contains - a JavaScript reference. The 'JSRef' type is parameterized with one phantom + The principal type here is 'JSVal', which is a lifted type that contains + a JavaScript reference. The 'JSVal' type is parameterized with one phantom type, and GHCJS.Types defines several type synonyms for specific variants. - The code in this module makes no assumptions about 'JSRef a' types. + The code in this module makes no assumptions about 'JSVal a' types. Operations that can result in a JS exception that can kill a Haskell thread - are marked unsafe (for example if the 'JSRef' contains a null or undefined + are marked unsafe (for example if the 'JSVal' contains a null or undefined value). There are safe variants where the JS exception is propagated as a Haskell exception, so that it can be handled on the Haskell side. For more specific types, like 'JSArray' or 'JSBool', the code assumes that - the contents of the 'JSRef' actually is a JavaScript array or bool value. + the contents of the 'JSVal' actually is a JavaScript array or bool value. If it contains an unexpected value, the code can result in exceptions that kill the Haskell thread, even for functions not marked unsafe. @@ -74,7 +74,7 @@ module GHCJS.Foreign.Internal ( JSType(..) -- , js_setProp, js_unsafeSetProp -- , listProps {- , wrapBuffer, wrapMutableBuffer - , byteArrayJSRef, mutableByteArrayJSRef + , byteArrayJSVal, mutableByteArrayJSVal , bufferByteString, byteArrayByteString , unsafeMutableByteArrayByteString -} ) where @@ -128,65 +128,65 @@ data JSONType = JSONNull | JSONObject deriving (Show, Eq, Ord, Enum, Typeable) -fromJSBool :: JSRef Bool -> Bool +fromJSBool :: JSVal -> Bool fromJSBool b = js_fromBool b {-# INLINE fromJSBool #-} -toJSBool :: Bool -> JSRef Bool +toJSBool :: Bool -> JSVal toJSBool True = jsTrue toJSBool _ = jsFalse {-# INLINE toJSBool #-} -jsTrue :: JSRef Bool +jsTrue :: JSVal jsTrue = mkRef (js_true 0#) {-# INLINE jsTrue #-} -jsFalse :: JSRef Bool +jsFalse :: JSVal jsFalse = mkRef (js_false 0#) {-# INLINE jsFalse #-} -jsNull :: JSRef a +jsNull :: JSVal jsNull = mkRef (js_null 0#) {-# INLINE jsNull #-} -jsUndefined :: JSRef a +jsUndefined :: JSVal jsUndefined = mkRef (js_undefined 0#) {-# INLINE jsUndefined #-} -- check whether a reference is `truthy' in the JavaScript sense -isTruthy :: JSRef a -> Bool +isTruthy :: JSVal -> Bool isTruthy b = js_isTruthy b {-# INLINE isTruthy #-} --- isUndefined :: JSRef a -> Bool +-- isUndefined :: JSVal -> Bool -- isUndefined o = js_isUndefined o -- {-# INLINE isUndefined #-} --- isNull :: JSRef a -> Bool +-- isNull :: JSVal -> Bool -- isNull o = js_isNull o -- {-# INLINE isNull #-} -isObject :: JSRef a -> Bool +isObject :: JSVal -> Bool isObject o = js_isObject o {-# INLINE isObject #-} -isNumber :: JSRef a -> Bool +isNumber :: JSVal -> Bool isNumber o = js_isNumber o {-# INLINE isNumber #-} -isString :: JSRef a -> Bool +isString :: JSVal -> Bool isString o = js_isString o {-# INLINE isString #-} -isBoolean :: JSRef a -> Bool +isBoolean :: JSVal -> Bool isBoolean o = js_isBoolean o {-# INLINE isBoolean #-} -isFunction :: JSRef a -> Bool +isFunction :: JSVal -> Bool isFunction o = js_isFunction o {-# INLINE isFunction #-} -isSymbol :: JSRef a -> Bool +isSymbol :: JSVal -> Bool isSymbol o = js_isSymbol o {-# INLINE isSymbol #-} @@ -221,27 +221,27 @@ ptr'ToPtr :: Ptr' a -> Ptr b ptr'ToPtr = unsafeCoerce -} {- -toArray :: [JSRef a] -> IO (JSArray a) -toArray xs = fmap castRef (Prim.toJSArray xs) +toArray :: [JSVal a] -> IO (JSArray a) +toArray xs = Prim.toJSArray xs {-# INLINE toArray #-} -pushArray :: JSRef a -> JSArray a -> IO () +pushArray :: JSVal a -> JSArray a -> IO () pushArray r arr = js_push r arr {-# INLINE pushArray #-} -fromArray :: JSArray (JSRef a) -> IO [JSRef a] -fromArray a = Prim.fromJSArray (castRef a) +fromArray :: JSArray (JSVal a) -> IO [JSVal a] +fromArray a = Prim.fromJSArray a {-# INLINE fromArray #-} lengthArray :: JSArray a -> IO Int lengthArray a = js_length a {-# INLINE lengthArray #-} -indexArray :: Int -> JSArray a -> IO (JSRef a) +indexArray :: Int -> JSArray a -> IO (JSVal a) indexArray = js_index {-# INLINE indexArray #-} -unsafeIndexArray :: Int -> JSArray a -> IO (JSRef a) +unsafeIndexArray :: Int -> JSArray a -> IO (JSVal a) unsafeIndexArray = js_unsafeIndex {-# INLINE unsafeIndexArray #-} @@ -249,41 +249,41 @@ newArray :: IO (JSArray a) newArray = js_emptyArray {-# INLINE newArray #-} -newObj :: IO (JSRef a) +newObj :: IO (JSVal a) newObj = js_emptyObj {-# INLINE newObj #-} -listProps :: JSRef a -> IO [JSString] +listProps :: JSVal a -> IO [JSString] listProps o = fmap unsafeCoerce . Prim.fromJSArray =<< js_listProps o {-# INLINE listProps #-} -} -jsTypeOf :: JSRef a -> JSType +jsTypeOf :: JSVal -> JSType jsTypeOf r = tagToEnum# (js_jsTypeOf r) {-# INLINE jsTypeOf #-} -jsonTypeOf :: JSRef a -> JSONType +jsonTypeOf :: JSVal -> JSONType jsonTypeOf r = tagToEnum# (js_jsonTypeOf r) {-# INLINE jsonTypeOf #-} {- {- | Convert a JavaScript ArrayBuffer to a 'ByteArray' without copying. Throws - a 'JSException' if the 'JSRef' is not an ArrayBuffer. + a 'JSException' if the 'JSVal' is not an ArrayBuffer. -} wrapBuffer :: Int -- ^ offset from the start in bytes, if this is not a multiple of 8, -- not all types can be read from the ByteArray# -> Int -- ^ length in bytes (use zero or a negative number to use the whole ArrayBuffer) - -> JSRef a -- ^ JavaScript ArrayBuffer object + -> JSVal a -- ^ JavaScript ArrayBuffer object -> IO ByteArray -- ^ result wrapBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size buf {-# INLINE wrapBuffer #-} {- | Convert a JavaScript ArrayBuffer to a 'MutableByteArray' without copying. Throws - a 'JSException' if the 'JSRef' is not an ArrayBuffer. + a 'JSException' if the 'JSVal' is not an ArrayBuffer. -} wrapMutableBuffer :: Int -- ^ offset from the start in bytes, if this is not a multiple of 8, -- not all types can be read from / written to the ByteArray# -> Int -- ^ the length in bytes (use zero or a negative number to use the whole ArrayBuffer) - -> JSRef a -- ^ JavaScript ArrayBuffer object + -> JSVal a -- ^ JavaScript ArrayBuffer object -> IO (MutableByteArray s) wrapMutableBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size buf {-# INLINE wrapMutableBuffer #-} @@ -299,9 +299,9 @@ wrapMutableBuffer offset size buf = unsafeCoerce <$> js_wrapBuffer offset size b * o.dv : a DataView Some of the views will be null if the offset is not a multiple of 8. -} -byteArrayJSRef :: ByteArray# -> JSRef a -byteArrayJSRef a = unsafeCoerce (ByteArray a) -{-# INLINE byteArrayJSRef #-} +byteArrayJSVal :: ByteArray# -> JSVal a +byteArrayJSVal a = unsafeCoerce (ByteArray a) +{-# INLINE byteArrayJSVal #-} {- | Get the underlying JS object from a 'MutableByteArray#'. The object o contains an ArrayBuffer (o.buf) and several typed array views on it (which @@ -314,12 +314,12 @@ byteArrayJSRef a = unsafeCoerce (ByteArray a) * o.dv : a DataView Some of the views will be null if the offset is not a multiple of 8. -} -mutableByteArrayJSRef :: MutableByteArray# s -> JSRef a -mutableByteArrayJSRef a = unsafeCoerce (MutableByteArray a) -{-# INLINE mutableByteArrayJSRef #-} +mutableByteArrayJSVal :: MutableByteArray# s -> JSVal a +mutableByteArrayJSVal a = unsafeCoerce (MutableByteArray a) +{-# INLINE mutableByteArrayJSVal #-} foreign import javascript safe "h$wrapBuffer($3, true, $1, $2)" - js_wrapBuffer :: Int -> Int -> JSRef a -> IO (JSRef ()) + js_wrapBuffer :: Int -> Int -> JSVal a -> IO (JSVal ()) {- | Convert an ArrayBuffer to a strict 'ByteString' this wraps the original buffer, without copying. @@ -327,7 +327,7 @@ foreign import javascript safe "h$wrapBuffer($3, true, $1, $2)" -} bufferByteString :: Int -- ^ offset from the start in bytes -> Int -- ^ length in bytes (use zero or a negative number to get the whole ArrayBuffer) - -> JSRef a + -> JSVal a -> IO ByteString bufferByteString offset length buf = do (ByteArray ba) <- wrapBuffer offset length buf @@ -370,48 +370,48 @@ unsafeMutableByteArrayByteString arr = foreign import javascript unsafe "$r = $1===true;" - js_fromBool :: JSRef a -> Bool + js_fromBool :: JSVal -> Bool foreign import javascript unsafe "$1 ? true : false" - js_isTruthy :: JSRef a -> Bool + 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 "$r = [];" js_emptyArray :: IO (JSArray a) --- foreign import javascript unsafe "$r = {};" js_emptyObj :: IO (JSRef a) +-- foreign import javascript unsafe "$r = {};" js_emptyObj :: IO (JSVal a) --foreign import javascript unsafe "$3[$1] = $2;" --- js_unsafeWriteArray :: Int# -> JSRef a -> JSArray b -> IO () +-- js_unsafeWriteArray :: Int# -> JSVal a -> JSArray b -> IO () -- foreign import javascript unsafe "h$fromArray" -- js_fromArray :: JSArray a -> IO Ref# -- [a] --foreign import javascript safe "$2.push($1)" --- js_push :: JSRef a -> JSArray a -> IO () +-- js_push :: JSVal a -> JSArray a -> IO () --foreign import javascript safe "$1.length" js_length :: JSArray a -> IO Int --foreign import javascript safe "$2[$1]" --- js_index :: Int -> JSArray a -> IO (JSRef a) +-- js_index :: Int -> JSArray a -> IO (JSVal a) --foreign import javascript unsafe "$2[$1]" --- js_unsafeIndex :: Int -> JSArray a -> IO (JSRef a) +-- js_unsafeIndex :: Int -> JSArray a -> IO (JSVal a) foreign import javascript unsafe "$2[$1]" - js_unsafeGetProp :: JSString -> JSRef a -> IO (JSRef b) + js_unsafeGetProp :: JSString -> JSVal -> IO JSVal foreign import javascript unsafe "$3[$1] = $2" - js_unsafeSetProp :: JSString -> JSRef a -> JSRef b -> IO () + js_unsafeSetProp :: JSString -> JSVal -> JSVal -> IO () {- foreign import javascript safe "h$listProps($1)" - js_listProps :: JSRef a -> IO (JSArray JSString) + js_listProps :: JSVal a -> IO (JSArray JSString) -} foreign import javascript unsafe "h$jsTypeOf($1)" - js_jsTypeOf :: JSRef a -> Int# + js_jsTypeOf :: JSVal -> Int# foreign import javascript unsafe "h$jsonTypeOf($1)" - js_jsonTypeOf :: JSRef a -> Int# + js_jsonTypeOf :: JSVal -> Int# -- foreign import javascript unsafe "h$listToArray" -- js_toArray :: Any -> IO (JSArray a) -- foreign import javascript unsafe "$1 === null" --- js_isNull :: JSRef a -> Bool - --- foreign import javascript unsafe "h$isUndefined" js_isUndefined :: JSRef a -> Bool -foreign import javascript unsafe "h$isObject" js_isObject :: JSRef a -> Bool -foreign import javascript unsafe "h$isBoolean" js_isBoolean :: JSRef a -> Bool -foreign import javascript unsafe "h$isNumber" js_isNumber :: JSRef a -> Bool -foreign import javascript unsafe "h$isString" js_isString :: JSRef a -> Bool -foreign import javascript unsafe "h$isSymbol" js_isSymbol :: JSRef a -> Bool -foreign import javascript unsafe "h$isFunction" js_isFunction :: JSRef a -> Bool +-- js_isNull :: JSVal a -> Bool + +-- foreign import javascript unsafe "h$isUndefined" js_isUndefined :: JSVal a -> Bool +foreign import javascript unsafe "h$isObject" js_isObject :: JSVal -> Bool +foreign import javascript unsafe "h$isBoolean" js_isBoolean :: JSVal -> Bool +foreign import javascript unsafe "h$isNumber" js_isNumber :: JSVal -> Bool +foreign import javascript unsafe "h$isString" js_isString :: JSVal -> Bool +foreign import javascript unsafe "h$isSymbol" js_isSymbol :: JSVal -> Bool +foreign import javascript unsafe "h$isFunction" js_isFunction :: JSVal -> Bool diff --git a/GHCJS/Internal/Types.hs b/GHCJS/Internal/Types.hs index da98330..754b72e 100644 --- a/GHCJS/Internal/Types.hs +++ b/GHCJS/Internal/Types.hs @@ -1,7 +1,34 @@ -{-# LANGUAGE EmptyDataDecls, TypeFamilies, DataKinds, KindSignatures, PolyKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} module GHCJS.Internal.Types where +import Data.Coerce +import Unsafe.Coerce + +import Control.DeepSeq + +import GHCJS.Prim (JSVal) + +instance NFData JSVal where + rnf x = x `seq` () + +class IsJSVal a where + jsval_ :: a -> JSVal + + default jsval_ :: Coercible a JSVal => a -> JSVal + jsval_ = coerce + {-# INLINE jsval_ #-} + +jsval :: IsJSVal a => a -> JSVal +jsval = jsval_ +{-# INLINE jsval #-} + data MutabilityType s = Mutable | Immutable | STMutable s diff --git a/GHCJS/Marshal.hs b/GHCJS/Marshal.hs index 6960e57..a36aca2 100644 --- a/GHCJS/Marshal.hs +++ b/GHCJS/Marshal.hs @@ -14,10 +14,10 @@ BangPatterns #-} -module GHCJS.Marshal ( FromJSRef(..) - , ToJSRef(..) - , toJSRef_aeson - , toJSRef_pure +module GHCJS.Marshal ( FromJSVal(..) + , ToJSVal(..) + , toJSVal_aeson + , toJSVal_pure ) where import Control.Applicative @@ -60,243 +60,243 @@ import qualified JavaScript.Object.Internal as OI import GHCJS.Marshal.Internal -instance FromJSRef (JSRef a) where - fromJSRefUnchecked x = return (castRef x) - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = return . Just . castRef - {-# INLINE fromJSRef #-} -instance FromJSRef () where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure --- {-# INLINE fromJSRef #-} -instance FromJSRef a => FromJSRef [a] where - fromJSRef = fromJSRefListOf - {-# INLINE fromJSRef #-} -instance FromJSRef a => FromJSRef (Maybe a) where - fromJSRefUnchecked x | isUndefined x || isNull x = return Nothing - | otherwise = fromJSRef (castRef x) - {-# INLINE fromJSRefUnchecked #-} - fromJSRef x | isUndefined x || isNull x = return (Just Nothing) - | otherwise = fmap (fmap Just) fromJSRef (castRef x) - {-# INLINE fromJSRef #-} -instance FromJSRef JSString where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Text where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Char where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} - fromJSRefUncheckedListOf = fromJSRefUnchecked_pure . castRef - {-# INLINE fromJSRefListOf #-} - fromJSRefListOf = fromJSRef_pure . castRef - {-# INLINE fromJSRefUncheckedListOf #-} -instance FromJSRef Bool where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Int where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Int8 where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Int16 where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Int32 where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Word where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Word8 where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Word16 where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Word32 where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Float where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef Double where - fromJSRefUnchecked = fromJSRefUnchecked_pure - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = fromJSRef_pure - {-# INLINE fromJSRef #-} -instance FromJSRef AE.Value where - fromJSRef r = case jsonTypeOf r of +instance FromJSVal JSVal where + fromJSValUnchecked x = return x + {-# INLINE fromJSValUnchecked #-} + fromJSVal = return . Just + {-# INLINE fromJSVal #-} +instance FromJSVal () where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure +-- {-# INLINE fromJSVal #-} +instance FromJSVal a => FromJSVal [a] where + fromJSVal = fromJSValListOf + {-# INLINE fromJSVal #-} +instance FromJSVal a => FromJSVal (Maybe a) where + fromJSValUnchecked x | isUndefined x || isNull x = return Nothing + | otherwise = fromJSVal x + {-# INLINE fromJSValUnchecked #-} + fromJSVal x | isUndefined x || isNull x = return (Just Nothing) + | otherwise = fmap (fmap Just) fromJSVal x + {-# INLINE fromJSVal #-} +instance FromJSVal JSString where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Text where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Char where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} + fromJSValUncheckedListOf = fromJSValUnchecked_pure + {-# INLINE fromJSValListOf #-} + fromJSValListOf = fromJSVal_pure + {-# INLINE fromJSValUncheckedListOf #-} +instance FromJSVal Bool where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int8 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int16 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Int32 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word8 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word16 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Word32 where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Float where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal Double where + fromJSValUnchecked = fromJSValUnchecked_pure + {-# INLINE fromJSValUnchecked #-} + fromJSVal = fromJSVal_pure + {-# INLINE fromJSVal #-} +instance FromJSVal AE.Value where + fromJSVal r = case jsonTypeOf r of JSONNull -> return (Just AE.Null) JSONInteger -> liftM (AE.Number . flip scientific 0 . (toInteger :: Int -> Integer)) - <$> (fromJSRef $ castRef r) + <$> fromJSVal r JSONFloat -> liftM (AE.Number . (fromFloatDigits :: Double -> Scientific)) - <$> fromJSRef (castRef r) - JSONBool -> liftM AE.Bool <$> fromJSRef (castRef r) - JSONString -> liftM AE.String <$> fromJSRef (castRef r) - JSONArray -> liftM (AE.Array . V.fromList) <$> fromJSRef (castRef r) + <$> fromJSVal r + JSONBool -> liftM AE.Bool <$> fromJSVal r + JSONString -> liftM AE.String <$> fromJSVal r + JSONArray -> liftM (AE.Array . V.fromList) <$> fromJSVal r JSONObject -> do - props <- OI.listProps (OI.Object $ castRef r) + props <- OI.listProps (OI.Object r) runMaybeT $ do propVals <- forM props $ \p -> do - v <- MaybeT (fromJSRef =<< OI.getProp p (OI.Object $ castRef r)) + v <- MaybeT (fromJSVal =<< OI.getProp p (OI.Object r)) return (JSS.textFromJSString p, v) return (AE.Object (H.fromList propVals)) - {-# INLINE fromJSRef #-} -instance (FromJSRef a, FromJSRef b) => FromJSRef (a,b) where - fromJSRef r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1 - {-# INLINE fromJSRef #-} -instance (FromJSRef a, FromJSRef b, FromJSRef c) => FromJSRef (a,b,c) where - fromJSRef r = runMaybeT $ (,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 - {-# INLINE fromJSRef #-} -instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d) => FromJSRef (a,b,c,d) where - fromJSRef r = runMaybeT $ (,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 - {-# INLINE fromJSRef #-} -instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e) => FromJSRef (a,b,c,d,e) where - fromJSRef r = runMaybeT $ (,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 - {-# INLINE fromJSRef #-} -instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e, FromJSRef f) => FromJSRef (a,b,c,d,e,f) where - fromJSRef r = runMaybeT $ (,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 - {-# INLINE fromJSRef #-} -instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e, FromJSRef f, FromJSRef g) => FromJSRef (a,b,c,d,e,f,g) where - fromJSRef r = runMaybeT $ (,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 - {-# INLINE fromJSRef #-} -instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e, FromJSRef f, FromJSRef g, FromJSRef h) => FromJSRef (a,b,c,d,e,f,g,h) where - fromJSRef r = runMaybeT $ (,,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 <*> jf r 7 - {-# INLINE fromJSRef #-} + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where + fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c) => FromJSVal (a,b,c) where + fromJSVal r = runMaybeT $ (,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d) => FromJSVal (a,b,c,d) where + fromJSVal r = runMaybeT $ (,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e) => FromJSVal (a,b,c,d,e) where + fromJSVal r = runMaybeT $ (,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f) => FromJSVal (a,b,c,d,e,f) where + fromJSVal r = runMaybeT $ (,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g) => FromJSVal (a,b,c,d,e,f,g) where + fromJSVal r = runMaybeT $ (,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 + {-# INLINE fromJSVal #-} +instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g, FromJSVal h) => FromJSVal (a,b,c,d,e,f,g,h) where + fromJSVal r = runMaybeT $ (,,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 <*> jf r 7 + {-# INLINE fromJSVal #-} -jf :: FromJSRef a => JSRef b -> Int -> MaybeT IO a +jf :: FromJSVal a => JSVal -> Int -> MaybeT IO a jf r n = MaybeT $ do - r' <- AI.read n (AI.SomeJSArray $ castRef r) + r' <- AI.read n (AI.SomeJSArray r) if isUndefined r then return Nothing - else fromJSRef r' + else fromJSVal r' -instance ToJSRef (JSRef a) where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef AE.Value where - toJSRef = toJSRef_aeson - {-# INLINE toJSRef #-} -instance ToJSRef JSString where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Text where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Char where - toJSRef = return . pToJSRef - {-# INLINE toJSRef #-} - toJSRefListOf = return . pToJSRef - {-# INLINE toJSRefListOf #-} -instance ToJSRef Bool where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Int where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Int8 where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Int16 where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Int32 where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Word where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Word8 where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Word16 where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Word32 where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Float where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef Double where - toJSRef = toJSRef_pure - {-# INLINE toJSRef #-} -instance ToJSRef a => ToJSRef [a] where - toJSRef = toJSRefListOf - {-# INLINE toJSRef #-} -instance ToJSRef a => ToJSRef (Maybe a) where - toJSRef Nothing = return jsNull - toJSRef (Just a) = castRef <$> toJSRef a - {-# INLINE toJSRef #-} -instance (ToJSRef a, ToJSRef b) => ToJSRef (a,b) where - toJSRef (a,b) = join $ arr2 <$> toJSRef a <*> toJSRef b - {-# INLINE toJSRef #-} -instance (ToJSRef a, ToJSRef b, ToJSRef c) => ToJSRef (a,b,c) where - toJSRef (a,b,c) = join $ arr3 <$> toJSRef a <*> toJSRef b <*> toJSRef c - {-# INLINE toJSRef #-} -instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d) => ToJSRef (a,b,c,d) where - toJSRef (a,b,c,d) = join $ arr4 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d - {-# INLINE toJSRef #-} -instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d, ToJSRef e) => ToJSRef (a,b,c,d,e) where - toJSRef (a,b,c,d,e) = join $ arr5 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d <*> toJSRef e - {-# INLINE toJSRef #-} -instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d, ToJSRef e, ToJSRef f) => ToJSRef (a,b,c,d,e,f) where - toJSRef (a,b,c,d,e,f) = join $ arr6 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d <*> toJSRef e <*> toJSRef f - {-# INLINE toJSRef #-} -instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d, ToJSRef e, ToJSRef f, ToJSRef g) => ToJSRef (a,b,c,d,e,f,g) where - toJSRef (a,b,c,d,e,f,g) = join $ arr7 <$> toJSRef a <*> toJSRef b <*> toJSRef c <*> toJSRef d <*> toJSRef e <*> toJSRef f <*> toJSRef g - {-# INLINE toJSRef #-} +instance ToJSVal JSVal where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal AE.Value where + toJSVal = toJSVal_aeson + {-# INLINE toJSVal #-} +instance ToJSVal JSString where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Text where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Char where + toJSVal = return . pToJSVal + {-# INLINE toJSVal #-} + toJSValListOf = return . pToJSVal + {-# INLINE toJSValListOf #-} +instance ToJSVal Bool where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int8 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int16 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Int32 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word8 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word16 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Word32 where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Float where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal Double where + toJSVal = toJSVal_pure + {-# INLINE toJSVal #-} +instance ToJSVal a => ToJSVal [a] where + toJSVal = toJSValListOf + {-# INLINE toJSVal #-} +instance ToJSVal a => ToJSVal (Maybe a) where + toJSVal Nothing = return jsNull + toJSVal (Just a) = toJSVal a + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b) => ToJSVal (a,b) where + toJSVal (a,b) = join $ arr2 <$> toJSVal a <*> toJSVal b + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c) => ToJSVal (a,b,c) where + toJSVal (a,b,c) = join $ arr3 <$> toJSVal a <*> toJSVal b <*> toJSVal c + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d) => ToJSVal (a,b,c,d) where + toJSVal (a,b,c,d) = join $ arr4 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e) => ToJSVal (a,b,c,d,e) where + toJSVal (a,b,c,d,e) = join $ arr5 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f) => ToJSVal (a,b,c,d,e,f) where + toJSVal (a,b,c,d,e,f) = join $ arr6 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f + {-# INLINE toJSVal #-} +instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f, ToJSVal g) => ToJSVal (a,b,c,d,e,f,g) where + 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 :: JSRef a -> IO (JSRef b) -foreign import javascript unsafe "[$1,$2]" arr2 :: JSRef a -> JSRef b -> IO (JSRef c) -foreign import javascript unsafe "[$1,$2,$3]" arr3 :: JSRef a -> JSRef b -> JSRef c -> IO (JSRef d) -foreign import javascript unsafe "[$1,$2,$3,$4]" arr4 :: JSRef a -> JSRef b -> JSRef c -> JSRef d -> IO (JSRef e) -foreign import javascript unsafe "[$1,$2,$3,$4,$5]" arr5 :: JSRef a -> JSRef b -> JSRef c -> JSRef d -> JSRef e -> IO (JSRef f) -foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]" arr6 :: JSRef a -> JSRef b -> JSRef c -> JSRef d -> JSRef e -> JSRef f -> IO (JSRef g) -foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" arr7 :: JSRef a -> JSRef b -> JSRef c -> JSRef d -> JSRef e -> JSRef f -> JSRef g -> IO (JSRef h) +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 -toJSRef_aeson :: AE.ToJSON a => a -> IO (JSRef a) -toJSRef_aeson x = cv (AE.toJSON x) +toJSVal_aeson :: AE.ToJSON a => a -> IO JSVal +toJSVal_aeson x = cv (AE.toJSON x) where - cv = fmap castRef . convertValue + cv = convertValue - convertValue :: AE.Value -> IO (JSRef ()) + convertValue :: AE.Value -> IO JSVal convertValue AE.Null = return jsNull - convertValue (AE.String t) = return (castRef $ pToJSRef t) - convertValue (AE.Array a) = (\(AI.SomeJSArray x) -> castRef x) <$> + convertValue (AE.String t) = return (pToJSVal t) + convertValue (AE.Array a) = (\(AI.SomeJSArray x) -> x) <$> (AI.fromListIO =<< mapM convertValue (V.toList a)) - convertValue (AE.Number n) = castRef <$> toJSRef (realToFrac n :: Double) - convertValue (AE.Bool b) = return (castRef $ toJSBool b) + convertValue (AE.Number n) = toJSVal (realToFrac n :: Double) + convertValue (AE.Bool b) = return (toJSBool b) convertValue (AE.Object o) = do obj@(OI.Object obj') <- OI.create mapM_ (\(k,v) -> convertValue v >>= \v' -> OI.setProp (JSS.textToJSString k) v' obj) (H.toList o) diff --git a/GHCJS/Marshal/Internal.hs b/GHCJS/Marshal/Internal.hs index 272b51d..0b4884a 100644 --- a/GHCJS/Marshal/Internal.hs +++ b/GHCJS/Marshal/Internal.hs @@ -2,16 +2,16 @@ TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances #-} -module GHCJS.Marshal.Internal ( FromJSRef(..) - , ToJSRef(..) - , PToJSRef(..) - , PFromJSRef(..) +module GHCJS.Marshal.Internal ( FromJSVal(..) + , ToJSVal(..) + , PToJSVal(..) + , PFromJSVal(..) , Purity(..) - , toJSRef_generic - , fromJSRef_generic - , toJSRef_pure - , fromJSRef_pure - , fromJSRefUnchecked_pure + , toJSVal_generic + , fromJSVal_generic + , toJSVal_pure + , fromJSVal_pure + , fromJSValUnchecked_pure ) where import Control.Applicative @@ -38,166 +38,166 @@ data Purity = PureShared -- ^ conversion is pure even if the original value i | PureExclusive -- ^ conversion is pure if the we only convert once deriving (Eq, Ord, Typeable, Data) -class PToJSRef a where +class PToJSVal a where -- type PureOut a :: Purity - pToJSRef :: a -> JSRef a + pToJSVal :: a -> JSVal -class PFromJSRef a where +class PFromJSVal a where -- type PureIn a :: Purity - pFromJSRef :: JSRef a -> a + pFromJSVal :: JSVal -> a -class ToJSRef a where - toJSRef :: a -> IO (JSRef a) +class ToJSVal a where + toJSVal :: a -> IO JSVal - toJSRefListOf :: [a] -> IO (JSRef [a]) - toJSRefListOf = fmap castRef . (Prim.toJSArray <=< mapM toJSRef) + toJSValListOf :: [a] -> IO JSVal + toJSValListOf = Prim.toJSArray <=< mapM toJSVal - -- default toJSRef :: PToJSRef a => a -> IO (JSRef a) - -- toJSRef x = return (pToJSRef x) + -- default toJSVal :: PToJSVal a => a -> IO (JSVal a) + -- toJSVal x = return (pToJSVal x) - default toJSRef :: (Generic a, GToJSRef (Rep a ())) => a -> IO (JSRef a) - toJSRef = toJSRef_generic id + default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> IO JSVal + toJSVal = toJSVal_generic id -class FromJSRef a where - fromJSRef :: JSRef a -> IO (Maybe a) +class FromJSVal a where + fromJSVal :: JSVal -> IO (Maybe a) - fromJSRefUnchecked :: JSRef a -> IO a - fromJSRefUnchecked = fmap fromJust . fromJSRef - {-# INLINE fromJSRefUnchecked #-} + fromJSValUnchecked :: JSVal -> IO a + fromJSValUnchecked = fmap fromJust . fromJSVal + {-# INLINE fromJSValUnchecked #-} - fromJSRefListOf :: JSRef [a] -> IO (Maybe [a]) - fromJSRefListOf = fmap sequence . (mapM fromJSRef <=< Prim.fromJSArray . castRef) -- fixme should check that it's an array + fromJSValListOf :: JSVal -> IO (Maybe [a]) + fromJSValListOf = fmap sequence . (mapM fromJSVal <=< Prim.fromJSArray) -- fixme should check that it's an array - fromJSRefUncheckedListOf :: JSRef [a] -> IO [a] - fromJSRefUncheckedListOf = mapM fromJSRefUnchecked <=< Prim.fromJSArray . castRef + fromJSValUncheckedListOf :: JSVal -> IO [a] + fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< Prim.fromJSArray - -- default fromJSRef :: PFromJSRef a => JSRef a -> IO (Maybe a) - -- fromJSRef x = return (Just (pFromJSRef x)) + -- default fromJSVal :: PFromJSVal a => JSVal a -> IO (Maybe a) + -- fromJSVal x = return (Just (pFromJSVal x)) - default fromJSRef :: (Generic a, GFromJSRef (Rep a ())) => JSRef a -> IO (Maybe a) - fromJSRef = fromJSRef_generic id + default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> IO (Maybe a) + fromJSVal = fromJSVal_generic id - -- default fromJSRefUnchecked :: PFromJSRef a => a -> IO a - -- fromJSRefUnchecked x = return (pFromJSRef x) + -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a + -- fromJSValUnchecked x = return (pFromJSVal x) -- ----------------------------------------------------------------------------- -class GToJSRef a where - gToJSRef :: (String -> String) -> Bool -> a -> IO (JSRef ()) +class GToJSVal a where + gToJSVal :: (String -> String) -> Bool -> a -> IO JSVal class GToJSProp a where - gToJSProp :: (String -> String) -> JSRef () -> a -> IO () + gToJSProp :: (String -> String) -> JSVal -> a -> IO () class GToJSArr a where gToJSArr :: (String -> String) -> MutableJSArray -> a -> IO () -instance (ToJSRef b) => GToJSRef (K1 a b c) where - gToJSRef _ _ (K1 x) = castRef <$> toJSRef x +instance (ToJSVal b) => GToJSVal (K1 a b c) where + gToJSVal _ _ (K1 x) = toJSVal x -instance GToJSRef p => GToJSRef (Par1 p) where - gToJSRef f b (Par1 p) = gToJSRef f b p +instance GToJSVal p => GToJSVal (Par1 p) where + gToJSVal f b (Par1 p) = gToJSVal f b p -instance GToJSRef (f p) => GToJSRef (Rec1 f p) where - gToJSRef f b (Rec1 x) = gToJSRef f b x +instance GToJSVal (f p) => GToJSVal (Rec1 f p) where + gToJSVal f b (Rec1 x) = gToJSVal f b x -instance (GToJSRef (a p), GToJSRef (b p)) => GToJSRef ((a :+: b) p) where - gToJSRef f _ (L1 x) = gToJSRef f True x - gToJSRef f _ (R1 x) = gToJSRef f True x +instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where + gToJSVal f _ (L1 x) = gToJSVal f True x + gToJSVal f _ (R1 x) = gToJSVal f True x -instance (Datatype c, GToJSRef (a p)) => GToJSRef (M1 D c a p) where - gToJSRef f b m@(M1 x) = gToJSRef f b x +instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where + gToJSVal f b m@(M1 x) = gToJSVal f b x -instance (Constructor c, GToJSRef (a p)) => GToJSRef (M1 C c a p) where - gToJSRef f True m@(M1 x) = do +instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where + gToJSVal f True m@(M1 x) = do obj@(OI.Object obj') <- OI.create - v <- gToJSRef f (conIsRecord m) x + v <- gToJSVal f (conIsRecord m) x OI.setProp (packJSS . f $ conName m) v obj return obj' - gToJSRef f _ m@(M1 x) = gToJSRef f (conIsRecord m) x + gToJSVal f _ m@(M1 x) = gToJSVal f (conIsRecord m) x -instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => GToJSRef ((a :*: b) p) where - gToJSRef f True xy = do +instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => GToJSVal ((a :*: b) p) where + gToJSVal f True xy = do (OI.Object obj') <- OI.create gToJSProp f obj' xy return obj' - gToJSRef f False xy = do + gToJSVal f False xy = do arr@(AI.SomeJSArray arr') <- AI.create gToJSArr f arr xy - return (castRef arr') + return arr' -instance GToJSRef (a p) => GToJSRef (M1 S c a p) where - gToJSRef f b (M1 x) = gToJSRef f b x +instance GToJSVal (a p) => GToJSVal (M1 S c a p) where + gToJSVal f b (M1 x) = gToJSVal f b x instance (GToJSProp (a p), GToJSProp (b p)) => GToJSProp ((a :*: b) p) where gToJSProp f o (x :*: y) = gToJSProp f o x >> gToJSProp f o y -instance (Selector c, GToJSRef (a p)) => GToJSProp (M1 S c a p) where +instance (Selector c, GToJSVal (a p)) => GToJSProp (M1 S c a p) where gToJSProp f o m@(M1 x) = do - r <- gToJSRef f False x + r <- gToJSVal f False x OI.setProp (packJSS . f $ selName m) r (OI.Object o) instance (GToJSArr (a p), GToJSArr (b p)) => GToJSArr ((a :*: b) p) where gToJSArr f a (x :*: y) = gToJSArr f a x >> gToJSArr f a y -instance GToJSRef (a p) => GToJSArr (M1 S c a p) where +instance GToJSVal (a p) => GToJSArr (M1 S c a p) where gToJSArr f a (M1 x) = do - r <- gToJSRef f False x - AI.push (castRef r) a + r <- gToJSVal f False x + AI.push r a -instance GToJSRef (V1 p) where - gToJSRef _ _ _ = return Prim.jsNull +instance GToJSVal (V1 p) where + gToJSVal _ _ _ = return Prim.jsNull -instance GToJSRef (U1 p) where - gToJSRef _ _ _ = return (castRef F.jsTrue) +instance GToJSVal (U1 p) where + gToJSVal _ _ _ = return F.jsTrue -toJSRef_generic :: forall a . (Generic a, GToJSRef (Rep a ())) - => (String -> String) -> a -> IO (JSRef a) -toJSRef_generic f x = castRef <$> gToJSRef f False (from x :: Rep a ()) +toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ())) + => (String -> String) -> a -> IO JSVal +toJSVal_generic f x = gToJSVal f False (from x :: Rep a ()) -- ----------------------------------------------------------------------------- -class GFromJSRef a where - gFromJSRef :: (String -> String) -> Bool -> JSRef () -> IO (Maybe a) +class GFromJSVal a where + gFromJSVal :: (String -> String) -> Bool -> JSVal -> IO (Maybe a) class GFromJSProp a where - gFromJSProp :: (String -> String) -> JSRef () -> IO (Maybe a) + gFromJSProp :: (String -> String) -> JSVal -> IO (Maybe a) class GFromJSArr a where gFromJSArr :: (String -> String) -> MutableJSArray -> Int -> IO (Maybe (a,Int)) -instance FromJSRef b => GFromJSRef (K1 a b c) where - gFromJSRef _ _ r = fmap K1 <$> fromJSRef (castRef r) +instance FromJSVal b => GFromJSVal (K1 a b c) where + gFromJSVal _ _ r = fmap K1 <$> fromJSVal r -instance GFromJSRef p => GFromJSRef (Par1 p) where - gFromJSRef f b r = gFromJSRef f b r +instance GFromJSVal p => GFromJSVal (Par1 p) where + gFromJSVal f b r = gFromJSVal f b r -instance GFromJSRef (f p) => GFromJSRef (Rec1 f p) where - gFromJSRef f b r = gFromJSRef f b r +instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where + gFromJSVal f b r = gFromJSVal f b r -instance (GFromJSRef (a p), GFromJSRef (b p)) => GFromJSRef ((a :+: b) p) where - gFromJSRef f b r = do - l <- gFromJSRef f True r +instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where + gFromJSVal f b r = do + l <- gFromJSVal f True r case l of Just x -> return (L1 <$> Just x) - Nothing -> fmap R1 <$> gFromJSRef f True r + Nothing -> fmap R1 <$> gFromJSVal f True r -instance (Datatype c, GFromJSRef (a p)) => GFromJSRef (M1 D c a p) where - gFromJSRef f b r = fmap M1 <$> gFromJSRef f b r +instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where + gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r -instance forall c a p . (Constructor c, GFromJSRef (a p)) => GFromJSRef (M1 C c a p) where - gFromJSRef f True r = do +instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where + gFromJSVal f True r = do r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r) if isUndefined r' then return Nothing - else fmap M1 <$> gFromJSRef f (conIsRecord (undefined :: M1 C c a p)) r' - gFromJSRef f _ r = fmap M1 <$> gFromJSRef f (conIsRecord (undefined :: M1 C c a p)) r + else fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r' + gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r -instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSRef ((a :*: b) p) where - gFromJSRef f True r = gFromJSProp f r - gFromJSRef f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0 +instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where + gFromJSVal f True r = gFromJSProp f r + gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0 -instance GFromJSRef (a p) => GFromJSRef (M1 S c a p) where - gFromJSRef f b r = fmap M1 <$> gFromJSRef f b r +instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where + gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) where gFromJSProp f r = do @@ -206,12 +206,12 @@ instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) whe Nothing -> return Nothing Just a' -> fmap (a':*:) <$> gFromJSProp f r -instance forall c a p . (Selector c, GFromJSRef (a p)) => GFromJSProp (M1 S c a p) where +instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where gFromJSProp f o = do p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o) if isUndefined p then return Nothing - else fmap M1 <$> gFromJSRef f False p + else fmap M1 <$> gFromJSVal f False p instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where gFromJSArr f r n = do @@ -223,36 +223,36 @@ instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where Just (b',bn) -> return (Just (a' :*: b',bn)) _ -> return Nothing -instance (GFromJSRef (a p)) => GFromJSArr (M1 S c a p) where +instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where gFromJSArr f o n = do r <- AI.read n o if isUndefined r then return Nothing - else fmap ((,n+1) . M1) <$> gFromJSRef f False (castRef r) + else fmap ((,n+1) . M1) <$> gFromJSVal f False r -instance GFromJSRef (V1 p) where - gFromJSRef _ _ _ = return Nothing +instance GFromJSVal (V1 p) where + gFromJSVal _ _ _ = return Nothing -instance GFromJSRef (U1 p) where - gFromJSRef _ _ _ = return (Just U1) +instance GFromJSVal (U1 p) where + gFromJSVal _ _ _ = return (Just U1) -fromJSRef_generic :: forall a . (Generic a, GFromJSRef (Rep a ())) - => (String -> String) -> JSRef a -> IO (Maybe a) -fromJSRef_generic f x = fmap to <$> (gFromJSRef f False (castRef x) :: IO (Maybe (Rep a ()))) +fromJSVal_generic :: forall a . (Generic a, GFromJSVal (Rep a ())) + => (String -> String) -> JSVal -> IO (Maybe a) +fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: IO (Maybe (Rep a ()))) -- ----------------------------------------------------------------------------- -fromJSRef_pure :: PFromJSRef a => JSRef a -> IO (Maybe a) -fromJSRef_pure x = return (Just (pFromJSRef x)) -{-# INLINE fromJSRef_pure #-} +fromJSVal_pure :: PFromJSVal a => JSVal -> IO (Maybe a) +fromJSVal_pure x = return (Just (pFromJSVal x)) +{-# INLINE fromJSVal_pure #-} -fromJSRefUnchecked_pure :: PFromJSRef a => JSRef a -> IO a -fromJSRefUnchecked_pure x = return (pFromJSRef x) -{-# INLINE fromJSRefUnchecked_pure #-} +fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> IO a +fromJSValUnchecked_pure x = return (pFromJSVal x) +{-# INLINE fromJSValUnchecked_pure #-} -toJSRef_pure :: PToJSRef a => a -> IO (JSRef a) -toJSRef_pure x = return (pToJSRef x) -{-# INLINE toJSRef_pure #-} +toJSVal_pure :: PToJSVal a => a -> IO JSVal +toJSVal_pure x = return (pToJSVal x) +{-# INLINE toJSVal_pure #-} -- ----------------------------------------------------------------------------- diff --git a/GHCJS/Marshal/Pure.hs b/GHCJS/Marshal/Pure.hs index bd95698..e043516 100644 --- a/GHCJS/Marshal/Pure.hs +++ b/GHCJS/Marshal/Pure.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE CPP, - DefaultSignatures, - TypeOperators, - ScopedTypeVariables, - DefaultSignatures, - FlexibleContexts, - FlexibleInstances, - OverloadedStrings, - TupleSections, - MagicHash, - JavaScriptFFI, - ForeignFunctionInterface, - UnliftedFFITypes, - BangPatterns, - TypeFamilies, - DataKinds, - DeriveDataTypeable - #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + {- experimental pure marshalling for lighter weight interaction in the quasiquoter -} -module GHCJS.Marshal.Pure ( PFromJSRef(..) - , PToJSRef(..) +module GHCJS.Marshal.Pure ( PFromJSVal(..) + , PToJSVal(..) ) where import Data.Char (chr, ord) @@ -56,99 +56,94 @@ type family IsPureExclusive a where IsPureExclusive PureShared = True -} -instance PFromJSRef (JSRef a) where pFromJSRef = castRef - {-# INLINE pFromJSRef #-} -instance PFromJSRef () where pFromJSRef _ = () - {-# INLINE pFromJSRef #-} - -instance PFromJSRef JSString where pFromJSRef = JSString . castRef - {-# INLINE pFromJSRef #-} -instance PFromJSRef [Char] where pFromJSRef = Prim.fromJSString - {-# INLINE pFromJSRef #-} -instance PFromJSRef Text where pFromJSRef = textFromJSRef - {-# INLINE pFromJSRef #-} -instance PFromJSRef Char where pFromJSRef x = C# (jsrefToChar x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Bool where pFromJSRef = isTruthy -- fromJSBool . castRef - {-# INLINE pFromJSRef #-} -instance PFromJSRef Int where pFromJSRef x = I# (jsrefToInt x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Int8 where pFromJSRef x = I8# (jsrefToInt8 x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Int16 where pFromJSRef x = I16# (jsrefToInt16 x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Int32 where pFromJSRef x = I32# (jsrefToInt x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Word where pFromJSRef x = W# (jsrefToWord x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Word8 where pFromJSRef x = W8# (jsrefToWord8 x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Word16 where pFromJSRef x = W16# (jsrefToWord16 x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Word32 where pFromJSRef x = W32# (jsrefToWord x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Float where pFromJSRef x = F# (jsrefToFloat x) - {-# INLINE pFromJSRef #-} -instance PFromJSRef Double where pFromJSRef x = D# (jsrefToDouble x) - {-# INLINE pFromJSRef #-} +instance PFromJSVal JSVal where pFromJSVal = id + {-# INLINE pFromJSVal #-} +instance PFromJSVal () where pFromJSVal _ = () + {-# INLINE pFromJSVal #-} -instance PFromJSRef a => PFromJSRef (Maybe a) where - pFromJSRef x | isUndefined x || isNull x = Nothing - pFromJSRef x = Just (pFromJSRef (castRef x)) - {-# INLINE pFromJSRef #-} +instance PFromJSVal JSString where pFromJSVal = JSString + {-# INLINE pFromJSVal #-} +instance PFromJSVal [Char] where pFromJSVal = Prim.fromJSString + {-# INLINE pFromJSVal #-} +instance PFromJSVal Text where pFromJSVal = textFromJSVal + {-# INLINE pFromJSVal #-} +instance PFromJSVal Char where pFromJSVal x = C# (jsvalToChar x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Bool where pFromJSVal = isTruthy + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int where pFromJSVal x = I# (jsvalToInt x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int8 where pFromJSVal x = I8# (jsvalToInt8 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int16 where pFromJSVal x = I16# (jsvalToInt16 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Int32 where pFromJSVal x = I32# (jsvalToInt x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word where pFromJSVal x = W# (jsvalToWord x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word8 where pFromJSVal x = W8# (jsvalToWord8 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word16 where pFromJSVal x = W16# (jsvalToWord16 x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Word32 where pFromJSVal x = W32# (jsvalToWord x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Float where pFromJSVal x = F# (jsvalToFloat x) + {-# INLINE pFromJSVal #-} +instance PFromJSVal Double where pFromJSVal x = D# (jsvalToDouble x) + {-# INLINE pFromJSVal #-} -instance PToJSRef (JSRef a) where pToJSRef = castRef - {-# INLINE pToJSRef #-} -instance PToJSRef JSString where pToJSRef = castRef . unJSString - {-# INLINE pToJSRef #-} -instance PToJSRef [Char] where pToJSRef = Prim.toJSString - {-# INLINE pToJSRef #-} -instance PToJSRef Text where pToJSRef = castRef . unJSString . textToJSString - {-# INLINE pToJSRef #-} -instance PToJSRef Char where pToJSRef (C# c) = charToJSRef c - {-# INLINE pToJSRef #-} -instance PToJSRef Bool where pToJSRef True = castRef jsTrue - pToJSRef False = castRef jsFalse - {-# INLINE pToJSRef #-} -instance PToJSRef Int where pToJSRef (I# x) = intToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Int8 where pToJSRef (I8# x) = intToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Int16 where pToJSRef (I16# x) = intToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Int32 where pToJSRef (I32# x) = intToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Word where pToJSRef (W# x) = wordToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Word8 where pToJSRef (W8# x) = wordToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Word16 where pToJSRef (W16# x) = wordToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Word32 where pToJSRef (W32# x) = wordToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Float where pToJSRef (F# x) = floatToJSRef x - {-# INLINE pToJSRef #-} -instance PToJSRef Double where pToJSRef (D# x) = doubleToJSRef x - {-# INLINE pToJSRef #-} +instance PToJSVal JSVal where pToJSVal = id + {-# INLINE pToJSVal #-} +instance PToJSVal JSString where pToJSVal = jsval + {-# INLINE pToJSVal #-} +instance PToJSVal [Char] where pToJSVal = Prim.toJSString + {-# INLINE pToJSVal #-} +instance PToJSVal Text where pToJSVal = jsval . textToJSString + {-# INLINE pToJSVal #-} +instance PToJSVal Char where pToJSVal (C# c) = charToJSVal c + {-# INLINE pToJSVal #-} +instance PToJSVal Bool where pToJSVal True = jsTrue + pToJSVal False = jsFalse + {-# INLINE pToJSVal #-} +instance PToJSVal Int where pToJSVal (I# x) = intToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Int8 where pToJSVal (I8# x) = intToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Int16 where pToJSVal (I16# x) = intToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Int32 where pToJSVal (I32# x) = intToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Word where pToJSVal (W# x) = wordToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Word8 where pToJSVal (W8# x) = wordToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Word16 where pToJSVal (W16# x) = wordToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Word32 where pToJSVal (W32# x) = wordToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Float where pToJSVal (F# x) = floatToJSVal x + {-# INLINE pToJSVal #-} +instance PToJSVal Double where pToJSVal (D# x) = doubleToJSVal x + {-# INLINE pToJSVal #-} -instance PToJSRef a => PToJSRef (Maybe a) where - pToJSRef Nothing = jsNull - pToJSRef (Just a) = castRef (pToJSRef a) - {-# INLINE pToJSRef #-} +instance PToJSVal a => PToJSVal (Maybe a) where + pToJSVal Nothing = jsNull + pToJSVal (Just a) = pToJSVal a + {-# INLINE pToJSVal #-} -foreign import javascript unsafe "$r = $1|0;" jsrefToWord :: JSRef a -> Word# -foreign import javascript unsafe "$r = $1&0xff;" jsrefToWord8 :: JSRef a -> Word# -foreign import javascript unsafe "$r = $1&0xffff;" jsrefToWord16 :: JSRef a -> Word# -foreign import javascript unsafe "$r = $1|0;" jsrefToInt :: JSRef a -> Int# -foreign import javascript unsafe "$r = $1<<24>>24;" jsrefToInt8 :: JSRef a -> Int# -foreign import javascript unsafe "$r = $1<<16>>16;" jsrefToInt16 :: JSRef a -> Int# -foreign import javascript unsafe "$r = +$1;" jsrefToFloat :: JSRef a -> Float# -foreign import javascript unsafe "$r = +$1;" jsrefToDouble :: JSRef a -> Double# -foreign import javascript unsafe "$r = $1&0x7fffffff;" jsrefToChar :: JSRef a -> Char# +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 "$r = $1;" wordToJSRef :: Word# -> JSRef a -foreign import javascript unsafe "$r = $1;" intToJSRef :: Int# -> JSRef a -foreign import javascript unsafe "$r = $1;" doubleToJSRef :: Double# -> JSRef a -foreign import javascript unsafe "$r = $1;" floatToJSRef :: Float# -> JSRef a -foreign import javascript unsafe "$r = $1;" charToJSRef :: Char# -> JSRef a +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 diff --git a/GHCJS/Nullable.hs b/GHCJS/Nullable.hs new file mode 100644 index 0000000..a573755 --- /dev/null +++ b/GHCJS/Nullable.hs @@ -0,0 +1,22 @@ +module GHCJS.Nullable ( Nullable(..) + , nullableToMaybe + , maybeToNullable + ) where + +import GHCJS.Foreign (isTruthy) +import GHCJS.Prim (JSVal(..)) +import GHCJS.Marshal.Pure (PToJSVal(..), PFromJSVal(..)) + +newtype Nullable a = Nullable JSVal + +nullableToMaybe :: PFromJSVal a => Nullable a -> Maybe a +nullableToMaybe (Nullable r) = if (isTruthy r) + then Just $ pFromJSVal r + else Nothing +{-# INLINE nullableToMaybe #-} + +maybeToNullable :: PToJSVal a => Maybe a -> Nullable a +maybeToNullable = Nullable . pToJSVal +{-# INLINE maybeToNullable #-} + + diff --git a/GHCJS/Types.hs b/GHCJS/Types.hs index 9de3943..564ab59 100644 --- a/GHCJS/Types.hs +++ b/GHCJS/Types.hs @@ -1,70 +1,69 @@ -{-# LANGUAGE EmptyDataDecls, MagicHash, BangPatterns, - CPP, ForeignFunctionInterface, JavaScriptFFI #-} - -module GHCJS.Types ( JSRef +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} + +module GHCJS.Types ( JSVal + , WouldBlockException(..) + , JSException(..) + , IsJSVal + , jsval , isNull , isUndefined , nullRef - , castRef , JSString --- , JSObject --- , JSBool --- , JSNumber --- , JSFun , mkRef , Ref# + , toPtr + , fromPtr + , JSRef ) where import Data.JSString.Internal.Type (JSString) +import GHCJS.Internal.Types + +import GHCJS.Prim import GHC.Int import GHC.Types import GHC.Prim import GHC.Ptr -import GHCJS.Prim import Control.DeepSeq - import Unsafe.Coerce -instance NFData (JSRef a) where - rnf x = x `seq` () - --- fixme remove -data JSBool_ -data JSNumber_ -data JSObject_ a --- data JSArray_ a -data JSFun_ a - -type JSBool = JSRef JSBool_ -type JSNumber = JSRef JSNumber_ -type JSObject a = JSRef (JSObject_ a) -type JSFun a = JSRef (JSFun_ a) - type Ref# = ByteArray# -mkRef :: ByteArray# -> JSRef a -mkRef x = JSRef x +mkRef :: ByteArray# -> JSVal +mkRef x = JSVal x -nullRef :: JSRef a +nullRef :: JSVal nullRef = js_nullRef {-# INLINE nullRef #-} -castRef :: JSRef a -> JSRef b -castRef = unsafeCoerce -{-# INLINE castRef #-} - -toPtr :: JSRef a -> Ptr b -toPtr (JSRef x) = unsafeCoerce (Ptr' x 0#) +toPtr :: JSVal -> Ptr a +toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#) {-# INLINE toPtr #-} -fromPtr :: Ptr a -> JSRef b -fromPtr p = let !(Ptr' x _) = unsafeCoerce p - in JSRef x +fromPtr :: Ptr a -> JSVal +fromPtr p = js_ptrVal p {-# INLINE fromPtr #-} data Ptr' a = Ptr' ByteArray# Int# -foreign import javascript unsafe "$r = null" js_nullRef :: JSRef a +foreign import javascript unsafe "$r = null;" + js_nullRef :: JSVal + +foreign import javascript unsafe "$r = $1_1;" + js_ptrVal :: Ptr a -> JSVal + +foreign import javascript unsafe "$r1 = $1; $r2 = 0;" + js_mkPtr :: JSVal -> Ptr a +-- | This is a deprecated copmatibility wrapper for the old JSRef type. +-- +-- See https://github.com/ghcjs/ghcjs/issues/421 +type JSRef a = JSVal +{-# DEPRECATED JSRef "Use JSVal instead, or a more specific newtype wrapper of JSVal " #-} diff --git a/JavaScript/Array.hs b/JavaScript/Array.hs index 63e1bdd..33fd4b9 100644 --- a/JavaScript/Array.hs +++ b/JavaScript/Array.hs @@ -10,7 +10,6 @@ module JavaScript.Array , fromListIO , toList , toListIO - , length , index, (!) , read , write @@ -42,11 +41,11 @@ import JavaScript.Array.Internal -- import qualified JavaScript.Array.Internal as I {- -fromList :: [JSRef a] -> IO (JSArray a) +fromList :: [JSVal] -> IO (JSArray a) fromList xs = fmap JSArray (I.fromList xs) {-# INLINE fromList #-} -toList :: JSArray a -> IO [JSRef a] +toList :: JSArray a -> IO [JSVal] toList (JSArray x) = I.toList x {-# INLINE toList #-} @@ -63,17 +62,17 @@ append (JSArray x) (JSArray y) = fmap JSArray (I.append x y) {-# INLINE append #-} -} -(!) :: JSArray -> Int -> JSRef a +(!) :: JSArray -> Int -> JSVal x ! n = index n x {-# INLINE (!) #-} {- -index :: Int -> JSArray a -> IO (JSRef a) +index :: Int -> JSArray a -> IO JSVal index n (JSArray x) = I.index n x {-# INLINE index #-} -write :: Int -> JSRef a -> JSArray a -> IO () +write :: Int -> JSVal -> JSArray a -> IO () write n e (JSArray x) = I.write n e x {-# INLINE write #-} @@ -89,19 +88,19 @@ slice :: Int -> Int -> JSArray a -> IO (JSArray a) slice s n (JSArray x) = fmap JSArray (I.slice s n x) {-# INLINE slice #-} -push :: JSRef a -> JSArray a -> IO () +push :: JSVal -> JSArray a -> IO () push e (JSArray x) = I.push e x {-# INLINE push #-} -pop :: JSArray a -> IO (JSRef a) +pop :: JSArray a -> IO JSVal pop (JSArray x) = I.pop x {-# INLINE pop #-} -unshift :: JSRef a -> JSArray a -> IO () +unshift :: JSVal -> JSArray a -> IO () unshift e (JSArray x) = I.unshift e x {-# INLINE unshift #-} -shift :: JSArray a -> IO (JSRef a) +shift :: JSArray a -> IO JSVal shift (JSArray x) = I.shift x {-# INLINE shift #-} diff --git a/JavaScript/Array/Immutable.hs b/JavaScript/Array/Immutable.hs index c7caac0..ba8fea6 100644 --- a/JavaScript/Array/Immutable.hs +++ b/JavaScript/Array/Immutable.hs @@ -1,3 +1,3 @@ module JavaScript.Array.Immutable where -newtype JSIArray a = JSIArray (JSRef ()) +newtype JSIArray a = JSIArray (JSVal ()) diff --git a/JavaScript/Array/Internal.hs b/JavaScript/Array/Internal.hs index 58aa37b..135fe5a 100644 --- a/JavaScript/Array/Internal.hs +++ b/JavaScript/Array/Internal.hs @@ -19,8 +19,9 @@ import GHCJS.Internal.Types import qualified GHCJS.Prim as Prim import GHCJS.Types -newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray (JSRef ()) +newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal deriving (Typeable) +instance IsJSVal (SomeJSArray m) type JSArray = SomeJSArray Immutable type MutableJSArray = SomeJSArray Mutable @@ -47,47 +48,48 @@ append :: SomeJSArray m -> SomeJSArray m -> IO (SomeJSArray m1) append x y = IO (js_append x y) {-# INLINE append #-} -fromList :: [JSRef a] -> JSArray +fromList :: [JSVal] -> JSArray fromList xs = rnf xs `seq` js_toJSArrayPure (unsafeCoerce xs) {-# INLINE fromList #-} -fromListIO :: [JSRef a] -> IO (SomeJSArray m) +fromListIO :: [JSVal] -> IO (SomeJSArray m) fromListIO xs = IO (\s -> rnf xs `seq` js_toJSArray (unsafeCoerce xs) s) {-# INLINE fromListIO #-} -toList :: JSArray -> [JSRef a] -toList x = case js_fromJSArrayPure x of (# xs #) -> xs +toList :: JSArray -> [JSVal] +toList x = unsafeCoerce (js_fromJSArrayPure x) {-# INLINE toList #-} -toListIO :: SomeJSArray m -> IO [JSRef a] -toListIO x = IO (js_fromJSArray x) +toListIO :: SomeJSArray m -> IO [JSVal] +toListIO x = IO $ \s -> case js_fromJSArray x s of + (# s', xs #) -> (# s', unsafeCoerce xs #) {-# INLINE toListIO #-} -index :: Int -> JSArray -> JSRef a +index :: Int -> JSArray -> JSVal index n x = js_indexPure n x {-# INLINE index #-} -read :: Int -> SomeJSArray m -> IO (JSRef a) +read :: Int -> SomeJSArray m -> IO JSVal read n x = IO (js_index n x) {-# INLINE read #-} -write :: Int -> JSRef a -> MutableJSArray -> IO () +write :: Int -> JSVal -> MutableJSArray -> IO () write n e x = IO (js_setIndex n e x) {-# INLINE write #-} -push :: JSRef a -> MutableJSArray -> IO () +push :: JSVal -> MutableJSArray -> IO () push e x = IO (js_push e x) {-# INLINE push #-} -pop :: MutableJSArray -> IO (JSRef a) +pop :: MutableJSArray -> IO JSVal pop x = IO (js_pop x) {-# INLINE pop #-} -unshift :: JSRef a -> MutableJSArray -> IO () +unshift :: JSVal -> MutableJSArray -> IO () unshift e x = IO (js_unshift e x) {-# INLINE unshift #-} -shift :: MutableJSArray -> IO (JSRef a) +shift :: MutableJSArray -> IO JSVal shift x = IO (js_shift x) {-# INLINE shift #-} @@ -144,15 +146,15 @@ foreign import javascript unsafe "$r = [];" foreign import javascript unsafe "$1.length" js_length :: SomeJSArray m -> State# s -> (# State# s, Int #) foreign import javascript unsafe "$2[$1]" - js_index :: Int -> SomeJSArray m -> State# s -> (# State# s, JSRef a #) + js_index :: Int -> SomeJSArray m -> State# s -> (# State# s, JSVal #) foreign import javascript unsafe "$2[$1]" - js_indexPure :: Int -> JSArray -> JSRef a + js_indexPure :: Int -> JSArray -> JSVal foreign import javascript unsafe "$1.length" js_lengthPure :: JSArray -> Int foreign import javascript unsafe "$3[$1] = $2" - js_setIndex :: Int -> JSRef a -> SomeJSArray m -> State# s -> (# State# s, () #) + js_setIndex :: Int -> JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) foreign import javascript unsafe "$3.slice($1,$2)" js_slice :: Int -> Int -> SomeJSArray m -> State# s -> (# State# s, SomeJSArray m1 #) @@ -168,25 +170,24 @@ foreign import javascript unsafe "$1.concat($2)" js_append :: SomeJSArray m0 -> SomeJSArray m1 -> State# s -> (# State# s, SomeJSArray m2 #) foreign import javascript unsafe "$2.push($1)" - js_push :: JSRef a -> SomeJSArray m -> State# s -> (# State# s, () #) + js_push :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) foreign import javascript unsafe "$1.pop()" - js_pop :: SomeJSArray m -> State# s -> (# State# s, JSRef a #) + js_pop :: SomeJSArray m -> State# s -> (# State# s, JSVal #) foreign import javascript unsafe "$2.unshift($1)" - js_unshift :: JSRef a -> SomeJSArray m -> State# s -> (# State# s, () #) + js_unshift :: JSVal -> SomeJSArray m -> State# s -> (# State# s, () #) foreign import javascript unsafe "$1.shift()" - js_shift :: SomeJSArray m -> State# s -> (# State# s, JSRef a #) + js_shift :: SomeJSArray m -> State# s -> (# State# s, JSVal #) foreign import javascript unsafe "$1.reverse()" js_reverse :: SomeJSArray m -> State# s -> (# State# s, () #) +foreign import javascript unsafe "h$toHsListJSVal($1)" + js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, Exts.Any #) +foreign import javascript unsafe "h$toHsListJSVal($1)" + js_fromJSArrayPure :: JSArray -> Exts.Any -- [JSVal] -foreign import javascript unsafe "h$toHsListJSRef($1)" - js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, [JSRef a] #) -foreign import javascript unsafe "h$toHsListJSRef($1)" - js_fromJSArrayPure :: JSArray -> (# [JSRef a] #) - -foreign import javascript unsafe "h$fromHsListJSRef($1)" +foreign import javascript unsafe "h$fromHsListJSVal($1)" js_toJSArray :: Exts.Any -> State# s -> (# State# s, SomeJSArray m #) -foreign import javascript unsafe "h$fromHsListJSRef($1)" +foreign import javascript unsafe "h$fromHsListJSVal($1)" js_toJSArrayPure :: Exts.Any -> JSArray diff --git a/JavaScript/Array/ST.hs b/JavaScript/Array/ST.hs index 8c2e235..0b5207d 100644 --- a/JavaScript/Array/ST.hs +++ b/JavaScript/Array/ST.hs @@ -55,35 +55,35 @@ append :: STJSArray s -> STJSArray s -> ST s (STJSArray s) append x y = ST (I.js_append x y) {-# INLINE append #-} -fromList :: [JSRef a] -> ST s (STJSArray s) +fromList :: [JSVal] -> ST s (STJSArray s) fromList xs = ST (\s -> rnf xs `seq` I.js_toJSArray (unsafeCoerce xs) s) {-# INLINE fromList #-} -toList :: STJSArray s -> ST s [JSRef a] -toList x = ST (I.js_fromJSArray x) +toList :: STJSArray s -> ST s [JSVal] +toList x = ST (unsafeCoerce (I.js_fromJSArray x)) {-# INLINE toList #-} -read :: Int -> STJSArray s -> ST s (JSRef a) +read :: Int -> STJSArray s -> ST s (JSVal) read n x = ST (I.js_index n x) {-# INLINE read #-} -write :: Int -> JSRef a -> STJSArray s -> ST s () +write :: Int -> JSVal -> STJSArray s -> ST s () write n e x = ST (I.js_setIndex n e x) {-# INLINE write #-} -push :: JSRef a -> STJSArray s -> ST s () +push :: JSVal -> STJSArray s -> ST s () push e x = ST (I.js_push e x) {-# INLINE push #-} -pop :: STJSArray s -> ST s (JSRef a) +pop :: STJSArray s -> ST s JSVal pop x = ST (I.js_pop x) {-# INLINE pop #-} -unshift :: JSRef a -> STJSArray s -> ST s () +unshift :: JSVal -> STJSArray s -> ST s () unshift e x = ST (I.js_unshift e x) {-# INLINE unshift #-} -shift :: STJSArray s -> ST s (JSRef a) +shift :: STJSArray s -> ST s JSVal shift x = ST (I.js_shift x) {-# INLINE shift #-} diff --git a/JavaScript/Cast.hs b/JavaScript/Cast.hs index ddc8d87..517b36a 100644 --- a/JavaScript/Cast.hs +++ b/JavaScript/Cast.hs @@ -7,20 +7,20 @@ module JavaScript.Cast ( Cast(..) import GHCJS.Prim -cast :: forall a. Cast a => JSRef () -> Maybe a +cast :: forall a. Cast a => JSVal -> Maybe a cast x | js_checkCast x (instanceRef (undefined :: a)) = Just (unsafeWrap x) | otherwise = Nothing {-# INLINE cast #-} -unsafeCast :: Cast a => JSRef () -> a +unsafeCast :: Cast a => JSVal -> a unsafeCast x = unsafeWrap x {-# INLINE unsafeCast #-} class Cast a where - unsafeWrap :: JSRef () -> a - instanceRef :: a -> JSRef () + unsafeWrap :: JSVal -> a + instanceRef :: a -> JSVal -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1 instanceof $2" js_checkCast :: JSRef () -> JSRef () -> Bool + "$1 instanceof $2" js_checkCast :: JSVal -> JSVal -> Bool diff --git a/JavaScript/JSON/Types/Internal.hs b/JavaScript/JSON/Types/Internal.hs index 0b9ce2b..f68689f 100644 --- a/JavaScript/JSON/Types/Internal.hs +++ b/JavaScript/JSON/Types/Internal.hs @@ -77,6 +77,8 @@ import qualified GHCJS.Prim.Internal.Build as IB import qualified JavaScript.Array as A import qualified JavaScript.Array.Internal as AI +import Unsafe.Coerce + data JSONException = UnknownKey deriving (Show, Typeable) @@ -84,7 +86,7 @@ instance Exception JSONException -- any JSON value newtype SomeValue (m :: MutabilityType s) = - SomeValue (JSRef ()) deriving (Typeable) + SomeValue JSVal deriving (Typeable) type Value = SomeValue Immutable type MutableValue = SomeValue Mutable instance NFData (SomeValue (m :: MutabilityType s)) where @@ -92,7 +94,7 @@ instance NFData (SomeValue (m :: MutabilityType s)) where -- a dictionary (object) newtype SomeObject (m :: MutabilityType s) = - SomeObject (JSRef ()) deriving (Typeable) + SomeObject JSVal deriving (Typeable) type Object = SomeObject Immutable type MutableObject = SomeObject Mutable instance NFData (SomeObject (m :: MutabilityType s)) where @@ -113,11 +115,12 @@ objectPropertiesIO o = js_objectProperties o {-# INLINE objectPropertiesIO #-} objectAssocs :: Object -> [(JSString, Value)] -objectAssocs o = case js_listAssocsPure o of (# x #) -> x +objectAssocs o = unsafeCoerce (js_listAssocsPure o) {-# INLINE objectAssocs #-} objectAssocsIO :: SomeObject m -> IO [(JSString, Value)] -objectAssocsIO o = IO (js_listAssocs o) +objectAssocsIO o = IO $ \s -> case js_listAssocs o s of + (# s', r #) -> (# s', unsafeCoerce r #) {-# INLINE objectAssocsIO #-} type Pair = (JSString, Value) @@ -178,9 +181,9 @@ match :: SomeValue m -> SomeValue' m match (SomeValue v) = case F.jsonTypeOf v of F.JSONNull -> Null - F.JSONBool -> Bool (js_jsrefToBool v) - F.JSONInteger -> Number (js_jsrefToDouble v) - F.JSONFloat -> Number (js_jsrefToDouble v) + F.JSONBool -> Bool (js_jsvalToBool v) + F.JSONInteger -> Number (js_jsvalToDouble v) + F.JSONFloat -> Number (js_jsvalToDouble v) F.JSONString -> String (JSString v) F.JSONArray -> Array (AI.SomeJSArray v) F.JSONObject -> Object (SomeObject v) @@ -231,7 +234,7 @@ stringValue (JSString x) = SomeValue x {-# INLINE stringValue #-} doubleValue :: Double -> Value -doubleValue d = SomeValue (js_doubleToJSRef d) +doubleValue d = SomeValue (js_doubleToJSVal d) {-# INLINE doubleValue #-} boolValue :: Bool -> Value @@ -276,29 +279,29 @@ foreign import javascript unsafe -- types must be checked before using these conversions foreign import javascript unsafe - "$r = $1;" js_jsrefToDouble :: JSRef () -> Double + "$r = $1;" js_jsvalToDouble :: JSVal -> Double foreign import javascript unsafe - "$r = $1;" js_jsrefToBool :: JSRef () -> Bool + "$r = $1;" js_jsvalToBool :: JSVal -> Bool -- ----------------------------------------------------------------------------- -- various lookups foreign import javascript unsafe "$2[$1]" - js_lookupDictPure :: JSString -> Object -> JSRef () + js_lookupDictPure :: JSString -> Object -> JSVal foreign import javascript unsafe "typeof($2)==='object'?$2[$1]:undefined" - js_lookupDictPureSafe :: JSString -> Value -> JSRef () + js_lookupDictPureSafe :: JSString -> Value -> JSVal foreign import javascript unsafe - "$2[$1]" js_lookupArrayPure :: Int -> A.JSArray -> JSRef () + "$2[$1]" js_lookupArrayPure :: Int -> A.JSArray -> JSVal foreign import javascript unsafe "h$isArray($2) ? $2[$1] : undefined" - js_lookupArrayPureSafe :: Int -> Value -> JSRef () + js_lookupArrayPureSafe :: Int -> Value -> JSVal foreign import javascript unsafe "$r = $1;" - js_doubleToJSRef :: Double -> JSRef () + js_doubleToJSVal :: Double -> JSVal foreign import javascript unsafe "JSON.decode(JSON.encode($1))" @@ -315,10 +318,10 @@ foreign import javascript unsafe foreign import javascript unsafe "h$listAssocs" - js_listAssocsPure :: Object -> (# [(JSString, Value)] #) + js_listAssocsPure :: Object -> Exts.Any -- [(JSString, Value)] foreign import javascript unsafe "h$listAssocs" - js_listAssocs :: SomeObject m -> Exts.State# s -> (# Exts.State# s, [(JSString, Value)] #) + js_listAssocs :: SomeObject m -> Exts.State# s -> (# Exts.State# s, Exts.Any {- [(JSString, Value)] -} #) foreign import javascript unsafe "JSON.stringify($1)" diff --git a/JavaScript/Object.hs b/JavaScript/Object.hs index 7330c10..f3c59ec 100644 --- a/JavaScript/Object.hs +++ b/JavaScript/Object.hs @@ -40,23 +40,23 @@ listProps (Object o) = I.listProps o handling code prevents some optimizations in some JS engines, you may want to use unsafeGetProp instead -} -getProp :: JSString -> Object -> IO (JSRef a) +getProp :: JSString -> Object -> IO (JSVal a) getProp p (Object o) = I.getProp p o {-# INLINE getProp #-} -unsafeGetProp :: JSString -> Object -> IO (JSRef a) +unsafeGetProp :: JSString -> Object -> IO (JSVal a) unsafeGetProp p (Object o) = I.unsafeGetProp p o {-# INLINE unsafeGetProp #-} -setProp :: JSString -> JSRef a -> Object -> IO () +setProp :: JSString -> JSVal a -> Object -> IO () setProp p v (Object o) = I.setProp p v o {-# INLINE setProp #-} -unsafeSetProp :: JSString -> JSRef a -> Object -> IO () +unsafeSetProp :: JSString -> JSVal a -> Object -> IO () unsafeSetProp p v (Object o) = I.unsafeSetProp p v o {-# INLINE unsafeSetProp #-} -isInstanceOf :: Object -> JSRef a -> Bool +isInstanceOf :: Object -> JSVal a -> Bool isInstanceOf (Object o) s = I.isInstanceOf o s {-# INLINE isInstanceOf #-} -} @@ -64,15 +64,15 @@ isInstanceOf (Object o) s = I.isInstanceOf o s -- ----------------------------------------------------------------------------- {- foreign import javascript safe "$2[$1]" - js_getProp :: JSString -> JSRef a -> IO (JSRef b) + js_getProp :: JSString -> JSVal a -> IO (JSVal b) foreign import javascript unsafe "$2[$1]" - js_unsafeGetProp :: JSString -> JSRef a -> IO (JSRef b) + js_unsafeGetProp :: JSString -> JSVal a -> IO (JSVal b) foreign import javascript safe "$3[$1] = $2" - js_setProp :: JSString -> JSRef a -> JSRef b -> IO () + js_setProp :: JSString -> JSVal a -> JSVal b -> IO () foreign import javascript unsafe "$3[$1] = $2" - js_unsafeSetProp :: JSString -> JSRef a -> JSRef b -> IO () + js_unsafeSetProp :: JSString -> JSVal a -> JSVal b -> IO () foreign import javascript unsafe "$1 instanceof $2" - js_isInstanceOf :: Object -> JSRef a -> Bool + js_isInstanceOf :: Object -> JSVal a -> Bool foreign import javascript unsafe "h$allProps" js_allProps :: Object -> IO (JSArray JSString) foreign import javascript unsafe "h$listProps" diff --git a/JavaScript/Object/Internal.hs b/JavaScript/Object/Internal.hs index 2d031e4..aa05cb3 100644 --- a/JavaScript/Object/Internal.hs +++ b/JavaScript/Object/Internal.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface, JavaScriptFFI, - UnboxedTuples, GHCForeignImportPrim, EmptyDataDecls, UnliftedFFITypes - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UnliftedFFITypes #-} module JavaScript.Object.Internal ( Object(..) @@ -23,7 +27,11 @@ import GHCJS.Types import qualified JavaScript.Array as JA import JavaScript.Array.Internal (JSArray, SomeJSArray(..)) -newtype Object = Object (JSRef ()) deriving (Typeable) +import Unsafe.Coerce +import qualified GHC.Exts as Exts + +newtype Object = Object JSVal deriving (Typeable) +instance IsJSVal Object -- | create an empty object create :: IO Object @@ -35,7 +43,7 @@ allProps o = js_allProps o {-# INLINE allProps #-} listProps :: Object -> IO [JSString] -listProps o = case js_listProps o of (# ps #) -> return ps +listProps o = unsafeCoerce (js_listProps o) {-# INLINE listProps #-} {- | get a property from an object. If accessing the property results in @@ -43,23 +51,23 @@ listProps o = case js_listProps o of (# ps #) -> return ps handling code prevents some optimizations in some JS engines, you may want to use unsafeGetProp instead -} -getProp :: JSString -> Object -> IO (JSRef a) +getProp :: JSString -> Object -> IO JSVal getProp p o = js_getProp p o {-# INLINE getProp #-} -unsafeGetProp :: JSString -> Object -> IO (JSRef a) +unsafeGetProp :: JSString -> Object -> IO JSVal unsafeGetProp p o = js_unsafeGetProp p o {-# INLINE unsafeGetProp #-} -setProp :: JSString -> JSRef a -> Object -> IO () +setProp :: JSString -> JSVal -> Object -> IO () setProp p v o = js_setProp p v o {-# INLINE setProp #-} -unsafeSetProp :: JSString -> JSRef a -> Object -> IO () +unsafeSetProp :: JSString -> JSVal -> Object -> IO () unsafeSetProp p v o = js_unsafeSetProp p v o {-# INLINE unsafeSetProp #-} -isInstanceOf :: Object -> JSRef a -> Bool +isInstanceOf :: Object -> JSVal -> Bool isInstanceOf o s = js_isInstanceOf o s {-# INLINE isInstanceOf #-} @@ -68,16 +76,16 @@ isInstanceOf o s = js_isInstanceOf o s foreign import javascript unsafe "$r = {};" js_create :: IO Object foreign import javascript safe "$2[$1]" - js_getProp :: JSString -> Object -> IO (JSRef b) + js_getProp :: JSString -> Object -> IO JSVal foreign import javascript unsafe "$2[$1]" - js_unsafeGetProp :: JSString -> Object -> IO (JSRef b) + js_unsafeGetProp :: JSString -> Object -> IO JSVal foreign import javascript safe "$3[$1] = $2" - js_setProp :: JSString -> JSRef a -> Object -> IO () + js_setProp :: JSString -> JSVal -> Object -> IO () foreign import javascript unsafe "$3[$1] = $2" - js_unsafeSetProp :: JSString -> JSRef a -> Object -> IO () + js_unsafeSetProp :: JSString -> JSVal -> Object -> IO () foreign import javascript unsafe "$1 instanceof $2" - js_isInstanceOf :: Object -> JSRef a -> Bool + js_isInstanceOf :: Object -> JSVal -> Bool foreign import javascript unsafe "h$allProps" js_allProps :: Object -> IO JSArray foreign import javascript unsafe "h$listProps" - js_listProps :: Object -> (# [JSString] #) + js_listProps :: Object -> IO Exts.Any -- [JSString] diff --git a/JavaScript/TypedArray.hs b/JavaScript/TypedArray.hs index 2fb9301..ddd00be 100644 --- a/JavaScript/TypedArray.hs +++ b/JavaScript/TypedArray.hs @@ -1,19 +1,322 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : JavaScript.TypedArray +-- +-- Maintainer : Artem Chirkin +-- Stability : experimental +-- Portability : +-- +-- Immutable operatons on JavaScript typed arrays +-- +----------------------------------------------------------------------------- + +#define DVIEW8(T), get/**/T, unsafeGet/**/T +#define DVIEW(T), get/**/T/**/LE, get/**/T/**/BE, unsafeGet/**/T/**/LE, unsafeGet/**/T/**/BE, unsafeGet/**/T, get/**/T + module JavaScript.TypedArray - ( TypedArray(..) - , Int8Array, Int16Array, Int32Array - , Uint8Array, Uint16Array, Uint32Array - , Uint8ClampedArray - , length - , byteLength - , byteOffset - , buffer - , subarray - , set - , unsafeSet + ( module JavaScript.TypedArray.Types + , ArrayBufferData (..) + , TypedArrayOperations (..) + , arrayLength, arrayBuffer + , dataView, dataView', unsafeDataView', dvByteLength, dvByteOffset, dvBuffer + , ImmutableArrayBufferPrim (..) + , MutableArrayBufferPrim (..) + DVIEW(Int) + DVIEW(Int32) + DVIEW(Int16) + DVIEW(Word) + DVIEW(Word32) + DVIEW(Word16) + DVIEW(Float) + DVIEW(Double) + DVIEW8(Word8) + DVIEW8(Int8) ) where -import Prelude () + +import GHC.Exts (State#, MutableByteArray#, ByteArray#) + +import Data.Word +import Data.Int +import Data.Coerce +import Data.Primitive.ByteArray (ByteArray (..)) +import Data.JSString (unpack') +import Foreign.C.Types +import Unsafe.Coerce (unsafeCoerce) + +import GHCJS.Internal.Types import JavaScript.TypedArray.Internal -import JavaScript.TypedArray.Internal.Types +import JavaScript.TypedArray.Types + + + +-- | Create a DataView for part of an ArrayBuffer. +-- Throws a `JSException' if the range specified by the +-- offset and length exceeds the size of the buffer +dataView' :: Int -- ^ start in bytes + -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing' + -> SomeArrayBuffer (m :: MutabilityType s) -- ^ buffer to view + -> SomeDataView (m :: MutabilityType s) +dataView' byteOffset mbyteLength (SomeArrayBuffer b) = + case mbyteLength of + Nothing -> js_dataView2 byteOffset b + Just bl -> js_dataView byteOffset bl b +{-# INLINE dataView' #-} + +-- | Create a DataView for part of an ArrayBuffer. +-- If the range specified by the offset and length exceeds the size +-- off the buffer, the resulting exception from the underlying call +-- kills the Haskell thread. +unsafeDataView' :: Int -- ^ start in bytes + -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing' + -> SomeArrayBuffer (m :: MutabilityType s) -- ^ buffer to view + -> SomeDataView (m :: MutabilityType s) +unsafeDataView' byteOffset mbyteLength (SomeArrayBuffer b) = + case mbyteLength of + Nothing -> js_dataView2 byteOffset b + Just bl -> js_dataView byteOffset bl b +{-# INLINE unsafeDataView' #-} + +----------------------------------------------------------------------------- +-- Helper instances +----------------------------------------------------------------------------- + +instance Show (SomeTypedArray m t) where + show = unpack' . js_show + + + +----------------------------------------------------------------------------- +-- | Convert data to primitive arrays +----------------------------------------------------------------------------- + +class ImmutableArrayBufferPrim a where + -- | Convert from primitive ByteArray without copying data + fromByteArrayPrim :: ByteArray# -> a + -- | Convert to primitive ByteArray without copying data + toByteArrayPrim :: a -> ByteArray# + -- | Convert from ByteArray without copying data + fromByteArray :: ByteArray -> IO a + fromByteArray (ByteArray ba) = pure (fromByteArrayPrim ba) + {-# INLINE fromByteArray #-} + -- | Convert to ByteArray without copying data + toByteArray :: a -> IO ByteArray + toByteArray b = pure $ ByteArray (toByteArrayPrim b) + {-# INLINE toByteArray #-} + +class MutableArrayBufferPrim a where + -- | Convert from primitive MutableByteArray without copying data + fromMutableByteArrayPrim :: MutableByteArray# s -> State# s -> (# State# s, a #) + -- | Convert to primitive MutableByteArray without copying data + toMutableByteArrayPrim :: a -> State# s -> (# State# s, MutableByteArray# s #) + +-- SomeArrayBuffer instances + +instance ImmutableArrayBufferPrim ArrayBuffer where + {-# INLINE fromByteArrayPrim #-} + fromByteArrayPrim = js_unwrapImmutableArrayBuffer + {-# INLINE toByteArrayPrim #-} + toByteArrayPrim = js_wrapImmutableArrayBuffer + +instance MutableArrayBufferPrim (SomeArrayBuffer m) where + {-# INLINE fromMutableByteArrayPrim #-} + fromMutableByteArrayPrim = js_unwrapArrayBuffer + {-# INLINE toMutableByteArrayPrim #-} + toMutableByteArrayPrim = js_wrapArrayBuffer + +-- SomeDataView instances + +instance ImmutableArrayBufferPrim DataView where + {-# INLINE fromByteArrayPrim #-} + fromByteArrayPrim = js_unwrapImmutableDataView + {-# INLINE toByteArrayPrim #-} + toByteArrayPrim dv = js_wrapImmutableArrayBufferView (coerce dv) + +instance MutableArrayBufferPrim (SomeDataView m) where + {-# INLINE fromMutableByteArrayPrim #-} + fromMutableByteArrayPrim = js_unwrapDataView + {-# INLINE toMutableByteArrayPrim #-} + toMutableByteArrayPrim dv = js_wrapArrayBufferView (coerce dv) + +-- TypedArray instances + +#define TYPEDARRAYPRIMCONVERT(T,JSType,JSSize)\ +instance ImmutableArrayBufferPrim (TypedArray T) where{\ + {-# INLINE fromByteArrayPrim #-};\ + fromByteArrayPrim = js_unwrapImmutable/**/T/**/Array;\ + {-# INLINE toByteArrayPrim #-};\ + toByteArrayPrim arr = js_wrapImmutableArrayBufferView (coerce arr)};\ +instance MutableArrayBufferPrim (SomeTypedArray m T) where{\ + {-# INLINE fromMutableByteArrayPrim #-};\ + fromMutableByteArrayPrim = js_unwrap/**/T/**/Array;\ + {-# INLINE toMutableByteArrayPrim #-};\ + toMutableByteArrayPrim arr = js_wrapArrayBufferView (coerce arr)} + +TYPEDARRAYPRIMCONVERT(Int,Int32,4) +TYPEDARRAYPRIMCONVERT(Int32,Int32,4) +TYPEDARRAYPRIMCONVERT(Int16,Int16,2) +TYPEDARRAYPRIMCONVERT(Int8,Int8,1) +TYPEDARRAYPRIMCONVERT(Word,Uint32,4) +TYPEDARRAYPRIMCONVERT(Word32,Uint32,4) +TYPEDARRAYPRIMCONVERT(Word16,Uint16,2) +TYPEDARRAYPRIMCONVERT(Word8,Uint8,1) +TYPEDARRAYPRIMCONVERT(Word8Clamped,Uint8Clamped,1) +TYPEDARRAYPRIMCONVERT(Float,Float32,4) +TYPEDARRAYPRIMCONVERT(Double,Float64,8) +TYPEDARRAYPRIMCONVERT(CChar,Int8,1) +TYPEDARRAYPRIMCONVERT(CSChar,Int8,1) +TYPEDARRAYPRIMCONVERT(CUChar,Uint8,1) +TYPEDARRAYPRIMCONVERT(CShort,Int16,2) +TYPEDARRAYPRIMCONVERT(CUShort,Uint16,2) +TYPEDARRAYPRIMCONVERT(CInt,Int32,4) +TYPEDARRAYPRIMCONVERT(CUInt,Uint32,4) +TYPEDARRAYPRIMCONVERT(CLong,Int32,4) +TYPEDARRAYPRIMCONVERT(CULong,Uint32,4) +TYPEDARRAYPRIMCONVERT(CFloat,Float32,4) +TYPEDARRAYPRIMCONVERT(CDouble,Float64,8) + +----------------------------------------------------------------------------- +-- | Common functions on buffers and views +----------------------------------------------------------------------------- + +class ArrayBufferData a where + -- | Length of buffer or its view in bytes + byteLength :: a -> Int + -- | Slice array (elements) or buffer (bytes). + -- See documentation on TypedArray.prototype.slice() and ArrayBuffer.prototype.slice() + sliceImmutable :: Int -> Maybe Int -> a -> a + +instance ArrayBufferData (SomeArrayBuffer m) where + {-# INLINE byteLength #-} + byteLength = js_byteLength . coerce + {-# INLINE sliceImmutable #-} + sliceImmutable i0 Nothing arr = coerce $ js_slice1_imm i0 (coerce arr) + sliceImmutable i0 (Just i1) arr = coerce $ js_slice_imm i0 i1 (coerce arr) + +instance ArrayBufferData (SomeTypedArray m t) where + {-# INLINE byteLength #-} + byteLength = js_byteLength . coerce + {-# INLINE sliceImmutable #-} + sliceImmutable i0 Nothing arr = coerce $ js_slice1_imm i0 (coerce arr) + sliceImmutable i0 (Just i1) arr = coerce $ js_slice_imm i0 i1 (coerce arr) + + + +----------------------------------------------------------------------------- +-- | Typed array immutable functions +----------------------------------------------------------------------------- + +class TypedArrayOperations a where + -- | Init a new typed array filled with zeroes + typedArray :: Int -> TypedArray a + -- | Fill a new typed array with a given value + fillNewTypedArray :: Int -> a -> TypedArray a + -- | Create a new typed array from list + fromList :: [a] -> TypedArray a + -- | Create a new typed array from elements of another typed array + fromArray :: TypedArray b -> TypedArray a + -- | Create a typed array view on a given array buffer (do not copy data) + arrayView :: SomeArrayBuffer (m :: MutabilityType s) -> SomeTypedArray (m :: MutabilityType s) a + -- | Index typed array + (!) :: TypedArray a -> Int -> a + -- | Size of an array element, in bytes + elemSize :: SomeTypedArray (m :: MutabilityType s) a -> Int + -- | First occurence of a given element in the array, starting from specified index + indexOf :: Int -> a -> TypedArray a -> Int + -- | Last occurence of a given element in the array, search backwards starting from specified index + lastIndexOf :: Int -> a -> TypedArray a -> Int + + +#define TYPEDARRAY(T,JSType,JSSize)\ +instance TypedArrayOperations T where{\ + {-# INLINE typedArray #-};\ + typedArray = js_create/**/T/**/Array;\ + {-# INLINE fillNewTypedArray #-};\ + fillNewTypedArray = js_fillNew/**/T/**/Array;\ + {-# INLINE fromList #-};\ + fromList = js_fromList/**/T/**/Array . unsafeCoerce . seqList;\ + {-# INLINE fromArray #-};\ + fromArray = js_fromArray/**/T/**/Array;\ + {-# INLINE arrayView #-};\ + arrayView = js_view/**/T/**/Array;\ + {-# INLINE (!) #-};\ + (!) = js_index/**/T/**/Array;\ + {-# INLINE elemSize #-};\ + elemSize _ = JSSize;\ + {-# INLINE indexOf #-};\ + indexOf = js_indexOf/**/T/**/Array;\ + {-# INLINE lastIndexOf #-};\ + lastIndexOf = js_lastIndexOf/**/T/**/Array} + + +TYPEDARRAY(Int,Int32,4) +TYPEDARRAY(Int32,Int32,4) +TYPEDARRAY(Int16,Int16,2) +TYPEDARRAY(Int8,Int8,1) +TYPEDARRAY(Word,Uint32,4) +TYPEDARRAY(Word32,Uint32,4) +TYPEDARRAY(Word16,Uint16,2) +TYPEDARRAY(Word8,Uint8,1) +TYPEDARRAY(Word8Clamped,Uint8Clamped,1) +TYPEDARRAY(Float,Float32,4) +TYPEDARRAY(Double,Float64,8) +TYPEDARRAY(CChar,Int8,1) +TYPEDARRAY(CSChar,Int8,1) +TYPEDARRAY(CUChar,Uint8,1) +TYPEDARRAY(CShort,Int16,2) +TYPEDARRAY(CUShort,Uint16,2) +TYPEDARRAY(CInt,Int32,4) +TYPEDARRAY(CUInt,Uint32,4) +TYPEDARRAY(CLong,Int32,4) +TYPEDARRAY(CULong,Uint32,4) +TYPEDARRAY(CFloat,Float32,4) +TYPEDARRAY(CDouble,Float64,8) + + +----------------------------------------------------------------------------- +-- DataView immutable functions +----------------------------------------------------------------------------- + +#define DATAVIEW8(T,JSType,JSSize)\ +get/**/T, unsafeGet/**/T\ + :: Int -> DataView -> T;\ +get/**/T = js_i_safeGet/**/T;\ +unsafeGet/**/T = js_i_unsafeGet/**/T;\ +{-# INLINE get/**/T #-};\ +{-# INLINE unsafeGet/**/T #-}; + +#define DATAVIEW(T,JSType,JSSize)\ +get/**/T/**/LE, get/**/T/**/BE, unsafeGet/**/T/**/LE, unsafeGet/**/T/**/BE, get/**/T, unsafeGet/**/T\ + :: Int -> DataView -> T;\ +get/**/T/**/LE = js_i_safeGet/**/T/**/LE;\ +get/**/T/**/BE = js_i_safeGet/**/T/**/BE;\ +unsafeGet/**/T/**/LE = js_i_unsafeGet/**/T/**/LE;\ +unsafeGet/**/T/**/BE = js_i_unsafeGet/**/T/**/BE;\ +{- | Shortcut for little-endian -};\ +get/**/T = get/**/T/**/LE;\ +{- | Shortcut for little-endian -};\ +unsafeGet/**/T = unsafeGet/**/T/**/LE;\ +{-# INLINE get/**/T/**/LE #-};\ +{-# INLINE get/**/T/**/BE #-};\ +{-# INLINE get/**/T #-};\ +{-# INLINE unsafeGet/**/T/**/LE #-};\ +{-# INLINE unsafeGet/**/T/**/BE #-};\ +{-# INLINE unsafeGet/**/T #-}; + +DATAVIEW(Int,Int32,4) +DATAVIEW(Int32,Int32,4) +DATAVIEW(Int16,Int16,2) +DATAVIEW(Word,Uint32,4) +DATAVIEW(Word32,Uint32,4) +DATAVIEW(Word16,Uint16,2) +DATAVIEW(Float,Float32,4) +DATAVIEW(Double,Float64,8) + +DATAVIEW8(Word8,Uint8,1) +DATAVIEW8(Int8,Int8,1) diff --git a/JavaScript/TypedArray/ArrayBuffer.hs b/JavaScript/TypedArray/ArrayBuffer.hs deleted file mode 100644 index 4af6b10..0000000 --- a/JavaScript/TypedArray/ArrayBuffer.hs +++ /dev/null @@ -1,48 +0,0 @@ -module JavaScript.TypedArray.ArrayBuffer - ( ArrayBuffer - , MutableArrayBuffer - , freeze, unsafeFreeze - , thaw, unsafeThaw - , byteLength - ) where - -import JavaScript.TypedArray.ArrayBuffer.Internal - -import GHC.Exts -import GHC.Types - -create :: Int -> IO MutableArrayBuffer -create n = fmap SomeArrayBuffer (IO (js_create n)) -{-# INLINE create #-} - -{- | Create an immutable 'ArrayBuffer' by copying a 'MutableArrayBuffer' -} -freeze :: MutableArrayBuffer -> IO ArrayBuffer -freeze (SomeArrayBuffer b) = fmap SomeArrayBuffer (IO (js_slice1 0 b)) -{-# INLINE freeze #-} - -{- | Create an immutable 'ArrayBuffer' from a 'MutableArrayBuffer' without - copying. The result shares the buffer with the argument, not modify - the data in the 'MutableArrayBuffer' after freezing - -} -unsafeFreeze :: MutableArrayBuffer -> IO ArrayBuffer -unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b) -{-# INLINE unsafeFreeze #-} - -{- | Create a 'MutableArrayBuffer' by copying an immutable 'ArrayBuffer' -} -thaw :: ArrayBuffer -> IO MutableArrayBuffer -thaw (SomeArrayBuffer b) = fmap SomeArrayBuffer (IO (js_slice1 0 b)) -{-# INLINE thaw #-} - -unsafeThaw :: ArrayBuffer -> IO MutableArrayBuffer -unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b) -{-# INLINE unsafeThaw #-} - -slice :: Int -> Maybe Int -> SomeArrayBuffer any -> SomeArrayBuffer any -slice begin (Just end) b = js_slice_imm begin end b -slice begin _ b = js_slice1_imm begin b -{-# INLINE slice #-} - -byteLength :: SomeArrayBuffer any -> Int -byteLength b = js_byteLength b -{-# INLINE byteLength #-} - diff --git a/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/JavaScript/TypedArray/ArrayBuffer/Internal.hs deleted file mode 100644 index f2d08fb..0000000 --- a/JavaScript/TypedArray/ArrayBuffer/Internal.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes, - GHCForeignImportPrim, MagicHash, UnboxedTuples, MagicHash, - TypeSynonymInstances, FlexibleInstances, DataKinds, PolyKinds - #-} -module JavaScript.TypedArray.ArrayBuffer.Internal where - -import GHCJS.Types - -import GHCJS.Internal.Types -import GHCJS.Marshal.Pure - -import GHC.Exts (State#) - -newtype SomeArrayBuffer (a :: MutabilityType s) = SomeArrayBuffer (JSRef ()) - -type ArrayBuffer = SomeArrayBuffer Immutable -type MutableArrayBuffer = SomeArrayBuffer Mutable -type STArrayBuffer s = SomeArrayBuffer (STMutable s) - - -instance PToJSRef MutableArrayBuffer where - pToJSRef (SomeArrayBuffer b) = castRef b -instance PFromJSRef MutableArrayBuffer where - pFromJSRef = SomeArrayBuffer . castRef - --- ---------------------------------------------------------------------------- - -foreign import javascript unsafe - "$1.byteLength" js_byteLength :: SomeArrayBuffer any -> Int -foreign import javascript unsafe - "new ArrayBuffer($1)" js_create :: Int -> State# s -> (# State# s, JSRef () #) -foreign import javascript unsafe - "$2.slice($1)" js_slice1 :: Int -> JSRef () -> State# s -> (# State# s, JSRef () #) - --- ---------------------------------------------------------------------------- --- immutable non-IO slice - -foreign import javascript unsafe - "$2.slice($1)" 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 diff --git a/JavaScript/TypedArray/ArrayBuffer/ST.hs b/JavaScript/TypedArray/ArrayBuffer/ST.hs deleted file mode 100644 index f9f9ff8..0000000 --- a/JavaScript/TypedArray/ArrayBuffer/ST.hs +++ /dev/null @@ -1,35 +0,0 @@ -module JavaScript.TypedArray.ArrayBuffer.ST - ( STArrayBuffer - , freeze, unsafeFreeze - , thaw, unsafeThaw - ) where - -import Control.Monad.ST - -import GHC.Types -import GHC.Exts -import GHC.ST - -import JavaScript.TypedArray.ArrayBuffer.Internal - -create :: Int -> ST s (STArrayBuffer s) -create n = fmap SomeArrayBuffer $ ST (js_create n) -{-# INLINE create #-} - -freeze :: STArrayBuffer s -> ST s ArrayBuffer -freeze (SomeArrayBuffer b) = fmap SomeArrayBuffer (ST (js_slice1 0 b)) -{-# INLINE freeze #-} - -unsafeFreeze :: STArrayBuffer s -> ST s ArrayBuffer -unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b) -{-# INLINE unsafeFreeze #-} - -{- | Create an 'STArrayBuffer' by copying an immutable 'ArrayBuffer' -} -thaw :: ArrayBuffer -> ST s (STArrayBuffer s) -thaw (SomeArrayBuffer b) = fmap SomeArrayBuffer (ST (js_slice1 0 b)) -{-# INLINE thaw #-} - -unsafeThaw :: ArrayBuffer -> ST s (STArrayBuffer s) -unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b) -{-# INLINE unsafeThaw #-} - diff --git a/JavaScript/TypedArray/ArrayBuffer/Type.hs b/JavaScript/TypedArray/ArrayBuffer/Type.hs deleted file mode 100644 index 26822ec..0000000 --- a/JavaScript/TypedArray/ArrayBuffer/Type.hs +++ /dev/null @@ -1,6 +0,0 @@ -module JavaScript.TypedArray.ArrayBuffer.Type where - -import GHCJS.Prim - - - diff --git a/JavaScript/TypedArray/DataView.hs b/JavaScript/TypedArray/DataView.hs deleted file mode 100644 index 83e074b..0000000 --- a/JavaScript/TypedArray/DataView.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE CPP #-} -module JavaScript.TypedArray.DataView - ( DataView - , MutableDataView - , dataView --- , mutableDataView - , freeze, unsafeFreeze - , thaw, unsafeThaw - -- * reading an immutable dataview - , getInt8, unsafeGetInt8 - , getInt16LE, getInt16BE, unsafeGetInt16LE, unsafeGetInt16BE - , getInt32LE, getInt32BE, unsafeGetInt32LE, unsafeGetInt32BE - , getUint8, unsafeGetUint8 - , getUint16LE, getUint16BE, unsafeGetUint16LE, unsafeGetUint16BE - , getUint32LE, getUint32BE, unsafeGetUint32LE, unsafeGetUint32BE - , getFloat32LE, getFloat32BE, unsafeGetFloat32LE, unsafeGetFloat32BE - , getFloat64LE, getFloat64BE, unsafeGetFloat64LE, unsafeGetFloat64BE - -- * reading a mutable dataview - , readInt8, unsafeReadInt8 - , readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE - , readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE - , readUint8, unsafeReadUint8 - , readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE - , readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE - , readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE - , readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE - -- * writing to a mutable dataview - , writeInt8, unsafeWriteInt8 - , writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE - , writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE - , writeUint8, unsafeWriteUint8 - , writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE - , writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE - , writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE - , writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE - ) where - -import GHC.Types (IO(..)) - -import Data.Int -import Data.Word - -import GHCJS.Prim - -import JavaScript.TypedArray.ArrayBuffer.Internal - ( SomeArrayBuffer(..), ArrayBuffer, MutableArrayBuffer ) -import qualified JavaScript.TypedArray.ArrayBuffer as A -import JavaScript.TypedArray.DataView.Internal - ( SomeDataView(..), DataView, MutableDataView ) -import qualified JavaScript.TypedArray.DataView.Internal as I - -{- | Create a 'DataView' for the whole 'ArrayBuffer' -} -dataView :: SomeArrayBuffer any -> SomeDataView any -dataView (SomeArrayBuffer b) = SomeDataView (I.js_dataView1 b) -{-# INLINE dataView #-} - -{- | Create a 'DataView' for part of an 'ArrayBuffer' - Throws a `JSException' if the range specified by the - offset and length exceeds the size of the buffer - -} -dataView' :: Int -- ^ start in bytes - -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing' - -> SomeArrayBuffer any -- ^ buffer to view - -> SomeDataView any -dataView' byteOffset mbyteLength (SomeArrayBuffer b) = - case mbyteLength of - Nothing -> I.js_dataView2 byteOffset b - Just byteLength -> I.js_dataView byteOffset byteLength b -{-# INLINE dataView' #-} - -{- | Create a 'DataView' for part of an 'ArrayBuffer'. - If the range specified by the offset and length exceeds the size - off the buffer, the resulting exception from the underlying call - kills the Haskell thread. - -} -unsafeDataView' :: Int -- ^ start in bytes - -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing' - -> SomeArrayBuffer any -- ^ buffer to view - -> SomeDataView any -unsafeDataView' byteOffset mbyteLength (SomeArrayBuffer b) = - case mbyteLength of - Nothing -> I.js_dataView2 byteOffset b - Just byteLength -> I.js_dataView byteOffset byteLength b -{-# INLINE unsafeDataView' #-} - -thaw :: DataView -> IO MutableDataView -thaw d = I.js_cloneDataView d -{-# INLINE thaw #-} - -unsafeThaw :: DataView -> IO MutableDataView -unsafeThaw (SomeDataView d) = return (SomeDataView d) -{-# INLINE unsafeThaw #-} - -freeze :: MutableDataView -> IO DataView -freeze d = I.js_cloneDataView d -{-# INLINE freeze #-} - -unsafeFreeze :: MutableDataView -> IO DataView -unsafeFreeze (SomeDataView d) = return (SomeDataView d) -{-# INLINE unsafeFreeze #-} - --- ---------------------------------------------------------------------------- --- immutable getters - -getInt8, unsafeGetInt8 :: Int -> DataView -> Int8 -getInt8 idx dv = I.js_i_getInt8 idx dv -unsafeGetInt8 idx dv = I.js_i_unsafeGetInt8 idx dv -{-# INLINE getInt8 #-} - -getUint8, unsafeGetUint8 :: Int -> DataView -> Word8 -getUint8 idx dv = I.js_i_getUint8 idx dv -unsafeGetUint8 idx dv = I.js_i_unsafeGetUint8 idx dv -{-# INLINE getUint8 #-} - -getInt16LE, getInt16BE, unsafeGetInt16LE, unsafeGetInt16BE - :: Int -> DataView -> Int16 -getInt16LE idx dv = I.js_i_getInt16LE idx dv -getInt16BE idx dv = I.js_i_getInt16BE idx dv -unsafeGetInt16LE idx dv = I.js_i_unsafeGetInt16LE idx dv -unsafeGetInt16BE idx dv = I.js_i_unsafeGetInt16BE idx dv -{-# INLINE getInt16LE #-} -{-# INLINE getInt16BE #-} -{-# INLINE unsafeGetInt16LE #-} -{-# INLINE unsafeGetInt16BE #-} - -getUint16LE, getUint16BE, unsafeGetUint16LE, unsafeGetUint16BE - :: Int -> DataView -> Word16 -getUint16LE idx dv = I.js_i_getUint16LE idx dv -getUint16BE idx dv = I.js_i_getUint16BE idx dv -unsafeGetUint16LE idx dv = I.js_i_unsafeGetUint16LE idx dv -unsafeGetUint16BE idx dv = I.js_i_unsafeGetUint16BE idx dv -{-# INLINE getUint16LE #-} -{-# INLINE getUint16BE #-} -{-# INLINE unsafeGetUint16LE #-} -{-# INLINE unsafeGetUint16BE #-} - -getInt32LE, getInt32BE, unsafeGetInt32LE, unsafeGetInt32BE - :: Int -> DataView -> Int -getInt32LE idx dv = I.js_i_getInt32LE idx dv -getInt32BE idx dv = I.js_i_getInt32BE idx dv -unsafeGetInt32LE idx dv = I.js_i_unsafeGetInt32LE idx dv -unsafeGetInt32BE idx dv = I.js_i_unsafeGetInt32BE idx dv -{-# INLINE getInt32LE #-} -{-# INLINE getInt32BE #-} -{-# INLINE unsafeGetInt32LE #-} -{-# INLINE unsafeGetInt32BE #-} - -getUint32LE, getUint32BE, unsafeGetUint32LE, unsafeGetUint32BE - :: Int -> DataView -> Word -getUint32LE idx dv = I.js_i_getUint32LE idx dv -getUint32BE idx dv = I.js_i_getUint32BE idx dv -unsafeGetUint32LE idx dv = I.js_i_unsafeGetUint32LE idx dv -unsafeGetUint32BE idx dv = I.js_i_unsafeGetUint32BE idx dv -{-# INLINE getUint32LE #-} -{-# INLINE getUint32BE #-} -{-# INLINE unsafeGetUint32LE #-} -{-# INLINE unsafeGetUint32BE #-} - -getFloat32LE, getFloat32BE, unsafeGetFloat32LE, unsafeGetFloat32BE - :: Int -> DataView -> Double -getFloat32LE idx dv = I.js_i_getFloat32LE idx dv -getFloat32BE idx dv = I.js_i_getFloat32BE idx dv -unsafeGetFloat32LE idx dv = I.js_i_unsafeGetFloat32LE idx dv -unsafeGetFloat32BE idx dv = I.js_i_unsafeGetFloat32BE idx dv -{-# INLINE getFloat32LE #-} -{-# INLINE getFloat32BE #-} -{-# INLINE unsafeGetFloat32LE #-} -{-# INLINE unsafeGetFloat32BE #-} - -getFloat64LE, getFloat64BE, unsafeGetFloat64LE, unsafeGetFloat64BE - :: Int -> DataView -> Double -getFloat64LE idx dv = I.js_i_getFloat64LE idx dv -getFloat64BE idx dv = I.js_i_getFloat64BE idx dv -unsafeGetFloat64LE idx dv = I.js_i_unsafeGetFloat64LE idx dv -unsafeGetFloat64BE idx dv = I.js_i_unsafeGetFloat64BE idx dv -{-# INLINE getFloat64LE #-} -{-# INLINE getFloat64BE #-} -{-# INLINE unsafeGetFloat64LE #-} -{-# INLINE unsafeGetFloat64BE #-} - --- ---------------------------------------------------------------------------- --- mutable getters - -readInt8, unsafeReadInt8 :: Int -> MutableDataView -> IO Int8 -readInt8 idx dv = IO (I.js_m_getInt8 idx dv) -unsafeReadInt8 idx dv = IO (I.js_m_unsafeGetInt8 idx dv) -{-# INLINE readInt8 #-} - -readUint8, unsafeReadUint8 :: Int -> MutableDataView -> IO Word8 -readUint8 idx dv = IO (I.js_m_getUint8 idx dv) -unsafeReadUint8 idx dv = IO (I.js_m_unsafeGetUint8 idx dv) -{-# INLINE readUint8 #-} - -readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE - :: Int -> MutableDataView -> IO Int16 -readInt16LE idx dv = IO (I.js_m_getInt16LE idx dv) -readInt16BE idx dv = IO (I.js_m_getInt16BE idx dv) -unsafeReadInt16LE idx dv = IO (I.js_m_unsafeGetInt16LE idx dv) -unsafeReadInt16BE idx dv = IO (I.js_m_unsafeGetInt16BE idx dv) -{-# INLINE readInt16LE #-} -{-# INLINE readInt16BE #-} -{-# INLINE unsafeReadInt16LE #-} -{-# INLINE unsafeReadInt16BE #-} - -readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE - :: Int -> MutableDataView -> IO Word16 -readUint16LE idx dv = IO (I.js_m_getUint16LE idx dv) -readUint16BE idx dv = IO (I.js_m_getUint16BE idx dv) -unsafeReadUint16LE idx dv = IO (I.js_m_unsafeGetUint16LE idx dv) -unsafeReadUint16BE idx dv = IO (I.js_m_unsafeGetUint16BE idx dv) -{-# INLINE readUint16LE #-} -{-# INLINE readUint16BE #-} -{-# INLINE unsafeReadUint16LE #-} -{-# INLINE unsafeReadUint16BE #-} - -readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE - :: Int -> MutableDataView -> IO Int -readInt32LE idx dv = IO (I.js_m_getInt32LE idx dv) -readInt32BE idx dv = IO (I.js_m_getInt32BE idx dv) -unsafeReadInt32LE idx dv = IO (I.js_m_unsafeGetInt32LE idx dv) -unsafeReadInt32BE idx dv = IO (I.js_m_unsafeGetInt32BE idx dv) -{-# INLINE readInt32LE #-} -{-# INLINE readInt32BE #-} -{-# INLINE unsafeReadInt32LE #-} -{-# INLINE unsafeReadInt32BE #-} - -readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE - :: Int -> MutableDataView -> IO Word -readUint32LE idx dv = IO (I.js_m_getUint32LE idx dv) -readUint32BE idx dv = IO (I.js_m_getUint32BE idx dv) -unsafeReadUint32LE idx dv = IO (I.js_m_unsafeGetUint32LE idx dv) -unsafeReadUint32BE idx dv = IO (I.js_m_unsafeGetUint32BE idx dv) -{-# INLINE readUint32LE #-} -{-# INLINE readUint32BE #-} -{-# INLINE unsafeReadUint32LE #-} -{-# INLINE unsafeReadUint32BE #-} - -readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE - :: Int -> MutableDataView -> IO Double -readFloat32LE idx dv = IO (I.js_m_getFloat32LE idx dv) -readFloat32BE idx dv = IO (I.js_m_getFloat32BE idx dv) -unsafeReadFloat32LE idx dv = IO (I.js_m_unsafeGetFloat32LE idx dv) -unsafeReadFloat32BE idx dv = IO (I.js_m_unsafeGetFloat32BE idx dv) -{-# INLINE readFloat32LE #-} -{-# INLINE readFloat32BE #-} -{-# INLINE unsafeReadFloat32LE #-} -{-# INLINE unsafeReadFloat32BE #-} - -readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE - :: Int -> MutableDataView -> IO Double -readFloat64LE idx dv = IO (I.js_m_getFloat64LE idx dv) -readFloat64BE idx dv = IO (I.js_m_getFloat64BE idx dv) -unsafeReadFloat64LE idx dv = IO (I.js_m_unsafeGetFloat64LE idx dv) -unsafeReadFloat64BE idx dv = IO (I.js_m_unsafeGetFloat64BE idx dv) -{-# INLINE readFloat64LE #-} -{-# INLINE readFloat64BE #-} -{-# INLINE unsafeReadFloat64LE #-} -{-# INLINE unsafeReadFloat64BE #-} - --- ---------------------------------------------------------------------------- --- mutable setters - -writeInt8, unsafeWriteInt8 :: Int -> Int8 -> MutableDataView -> IO () -writeInt8 idx x dv = IO (I.js_setInt8 idx x dv) -unsafeWriteInt8 idx x dv = IO (I.js_unsafeSetInt8 idx x dv) -{-# INLINE writeInt8 #-} - -writeUint8, unsafeWriteUint8 :: Int -> Word8 -> MutableDataView -> IO () -writeUint8 idx x dv = IO (I.js_setUint8 idx x dv) -unsafeWriteUint8 idx x dv = IO (I.js_unsafeSetUint8 idx x dv) -{-# INLINE writeUint8 #-} - -writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE - :: Int -> Int16 -> MutableDataView -> IO () -writeInt16LE idx x dv = IO (I.js_setInt16LE idx x dv) -writeInt16BE idx x dv = IO (I.js_setInt16BE idx x dv) -unsafeWriteInt16LE idx x dv = IO (I.js_unsafeSetInt16LE idx x dv) -unsafeWriteInt16BE idx x dv = IO (I.js_unsafeSetInt16BE idx x dv) -{-# INLINE writeInt16LE #-} -{-# INLINE writeInt16BE #-} -{-# INLINE unsafeWriteInt16LE #-} -{-# INLINE unsafeWriteInt16BE #-} - -writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE - :: Int -> Word16 -> MutableDataView -> IO () -writeUint16LE idx x dv = IO (I.js_setUint16LE idx x dv) -writeUint16BE idx x dv = IO (I.js_setUint16BE idx x dv) -unsafeWriteUint16LE idx x dv = IO (I.js_unsafeSetUint16LE idx x dv) -unsafeWriteUint16BE idx x dv = IO (I.js_unsafeSetUint16BE idx x dv) -{-# INLINE writeUint16LE #-} -{-# INLINE writeUint16BE #-} -{-# INLINE unsafeWriteUint16LE #-} -{-# INLINE unsafeWriteUint16BE #-} - -writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE - :: Int -> Int -> MutableDataView -> IO () -writeInt32LE idx x dv = IO (I.js_setInt32LE idx x dv) -writeInt32BE idx x dv = IO (I.js_setInt32BE idx x dv) -unsafeWriteInt32LE idx x dv = IO (I.js_unsafeSetInt32LE idx x dv) -unsafeWriteInt32BE idx x dv = IO (I.js_unsafeSetInt32BE idx x dv) -{-# INLINE writeInt32LE #-} -{-# INLINE writeInt32BE #-} -{-# INLINE unsafeWriteInt32LE #-} -{-# INLINE unsafeWriteInt32BE #-} - -writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE - :: Int -> Word -> MutableDataView -> IO () -writeUint32LE idx x dv = IO (I.js_setUint32LE idx x dv) -writeUint32BE idx x dv = IO (I.js_setUint32BE idx x dv) -unsafeWriteUint32LE idx x dv = IO (I.js_unsafeSetUint32LE idx x dv) -unsafeWriteUint32BE idx x dv = IO (I.js_unsafeSetUint32BE idx x dv) -{-# INLINE writeUint32LE #-} -{-# INLINE writeUint32BE #-} -{-# INLINE unsafeWriteUint32LE #-} -{-# INLINE unsafeWriteUint32BE #-} - -writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE - :: Int -> Double -> MutableDataView -> IO () -writeFloat32LE idx x dv = IO (I.js_setFloat32LE idx x dv) -writeFloat32BE idx x dv = IO (I.js_setFloat32BE idx x dv) -unsafeWriteFloat32LE idx x dv = IO (I.js_unsafeSetFloat32LE idx x dv) -unsafeWriteFloat32BE idx x dv = IO (I.js_unsafeSetFloat32BE idx x dv) -{-# INLINE writeFloat32LE #-} -{-# INLINE writeFloat32BE #-} -{-# INLINE unsafeWriteFloat32LE #-} -{-# INLINE unsafeWriteFloat32BE #-} - -writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE - :: Int -> Double -> MutableDataView -> IO () -writeFloat64LE idx x dv = IO (I.js_setFloat64LE idx x dv) -writeFloat64BE idx x dv = IO (I.js_setFloat64BE idx x dv) -unsafeWriteFloat64LE idx x dv = IO (I.js_unsafeSetFloat64LE idx x dv) -unsafeWriteFloat64BE idx x dv = IO (I.js_unsafeSetFloat64BE idx x dv) -{-# INLINE writeFloat64LE #-} -{-# INLINE writeFloat64BE #-} -{-# INLINE unsafeWriteFloat64LE #-} -{-# INLINE unsafeWriteFloat64BE #-} - diff --git a/JavaScript/TypedArray/DataView/Internal.hs b/JavaScript/TypedArray/DataView/Internal.hs deleted file mode 100644 index 9a85a8f..0000000 --- a/JavaScript/TypedArray/DataView/Internal.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE CPP, JavaScriptFFI, ForeignFunctionInterface, - UnliftedFFITypes, GHCForeignImportPrim, MagicHash, - UnboxedTuples, DeriveDataTypeable, DataKinds, KindSignatures, - PolyKinds - #-} -module JavaScript.TypedArray.DataView.Internal where - -import Data.Int -import Data.Typeable -import Data.Word - -import GHC.Exts ( State# ) - -import GHCJS.Prim -import GHCJS.Internal.Types - -import JavaScript.TypedArray.ArrayBuffer.Internal - -newtype SomeDataView (a :: MutabilityType s) = SomeDataView (JSRef ()) - deriving (Typeable) - -type DataView = SomeDataView Immutable -type MutableDataView = SomeDataView Mutable -type STDataView s = SomeDataView (STMutable s) - -#define JSU foreign import javascript unsafe -#define JSS foreign import javascript safe - -JSU "new DataView($1)" - js_dataView1 :: JSRef () -> JSRef () -JSS "new DataView($2,$1)" - js_dataView2 :: Int -> JSRef () -> SomeDataView m -JSU "new DataView($2,$1)" - js_unsafeDataView2 :: Int -> JSRef () -> SomeDataView m -JSS "new DataView($3,$1,$2)" - js_dataView :: Int -> Int -> JSRef () -> SomeDataView m -JSU "new DataView($3,$1,$2)" - js_unsafeDataView :: Int -> Int -> JSRef () -> JSRef () -JSU "new DataView($1.buffer.slice($1.byteOffset, $1.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 - -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 - --- ---------------------------------------------------------------------------- --- 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 #) - -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 #) - --- ---------------------------------------------------------------------------- --- 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, () #) - -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, () #) - diff --git a/JavaScript/TypedArray/DataView/ST.hs b/JavaScript/TypedArray/DataView/ST.hs deleted file mode 100644 index 1e2a59b..0000000 --- a/JavaScript/TypedArray/DataView/ST.hs +++ /dev/null @@ -1,232 +0,0 @@ -module JavaScript.TypedArray.DataView.ST - ( STDataView - , dataView - , freeze, unsafeFreeze - , thaw, unsafeThaw - -- * reading - , readInt8, unsafeReadInt8 - , readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE - , readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE - , readUint8, unsafeReadUint8 - , readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE - , readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE - , readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE - , readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE - -- * writing - , writeInt8, unsafeWriteInt8 - , writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE - , writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE - , writeUint8, unsafeWriteUint8 - , writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE - , writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE - , writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE - , writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE - ) where - -import Data.Int -import Data.Word - -import GHC.ST - -import GHCJS.Prim - -import JavaScript.TypedArray.ArrayBuffer.ST -import JavaScript.TypedArray.ArrayBuffer.Internal as AI -import JavaScript.TypedArray.DataView.Internal ( SomeDataView(..), STDataView ) -import qualified JavaScript.TypedArray.DataView.Internal as I - - -{- | Create a 'DataView' for the whole 'ArrayBuffer' -} -dataView :: STArrayBuffer s -> STDataView s -dataView (SomeArrayBuffer b) = SomeDataView (I.js_dataView1 b) -{-# INLINE dataView #-} - -{- | Create a 'STDataView' for part of an 'STArrayBuffer' - Throws a `JSException' if the range specified by the - offset and length exceeds the size of the buffer - -} -dataView' :: Int -- ^ start in bytes - -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing' - -> STArrayBuffer s -- ^ buffer to view - -> STDataView s -dataView' byteOffset mbyteLength (SomeArrayBuffer b) = - case mbyteLength of - Nothing -> I.js_dataView2 byteOffset b - Just byteLength -> I.js_dataView byteOffset byteLength b -{-# INLINE dataView' #-} - -{- | Create an 'STDataView' for part of an 'STArrayBuffer'. - If the range specified by the offset and length exceeds the size - off the buffer, the resulting exception from the underlying call - kills the Haskell thread. - -} -unsafeDataView' :: Int -- ^ start in bytes - -> Maybe Int -- ^ length in bytes, remainder of buffer if 'Nothing' - -> STArrayBuffer s -- ^ buffer to view - -> STDataView s -unsafeDataView' byteOffset mbyteLength (SomeArrayBuffer b) = - case mbyteLength of - Nothing -> I.js_dataView2 byteOffset b - Just byteLength -> I.js_dataView byteOffset byteLength b -{-# INLINE unsafeDataView' #-} - --- ---------------------------------------------------------------------------- --- mutable getters - -readInt8, unsafeReadInt8 :: Int -> STDataView s -> ST s Int8 -readInt8 idx dv = ST (I.js_m_getInt8 idx dv) -unsafeReadInt8 idx dv = ST (I.js_m_unsafeGetInt8 idx dv) -{-# INLINE readInt8 #-} - -readUint8, unsafeReadUint8 :: Int -> STDataView s -> ST s Word8 -readUint8 idx dv = ST (I.js_m_unsafeGetUint8 idx dv) -unsafeReadUint8 idx dv = ST (I.js_m_unsafeGetUint8 idx dv) -{-# INLINE readUint8 #-} - -readInt16LE, readInt16BE, unsafeReadInt16LE, unsafeReadInt16BE - :: Int -> STDataView s -> ST s Int16 -readInt16LE idx dv = ST (I.js_m_getInt16LE idx dv) -readInt16BE idx dv = ST (I.js_m_getInt16BE idx dv) -unsafeReadInt16LE idx dv = ST (I.js_m_unsafeGetInt16LE idx dv) -unsafeReadInt16BE idx dv = ST (I.js_m_unsafeGetInt16BE idx dv) -{-# INLINE readInt16LE #-} -{-# INLINE readInt16BE #-} -{-# INLINE unsafeReadInt16LE #-} -{-# INLINE unsafeReadInt16BE #-} - -readUint16LE, readUint16BE, unsafeReadUint16LE, unsafeReadUint16BE - :: Int -> STDataView s -> ST s Word16 -readUint16LE idx dv = ST (I.js_m_getUint16LE idx dv) -readUint16BE idx dv = ST (I.js_m_getUint16BE idx dv) -unsafeReadUint16LE idx dv = ST (I.js_m_unsafeGetUint16LE idx dv) -unsafeReadUint16BE idx dv = ST (I.js_m_unsafeGetUint16BE idx dv) -{-# INLINE readUint16LE #-} -{-# INLINE readUint16BE #-} -{-# INLINE unsafeReadUint16LE #-} -{-# INLINE unsafeReadUint16BE #-} - -readInt32LE, readInt32BE, unsafeReadInt32LE, unsafeReadInt32BE - :: Int -> STDataView s -> ST s Int -readInt32LE idx dv = ST (I.js_m_getInt32LE idx dv) -readInt32BE idx dv = ST (I.js_m_getInt32BE idx dv) -unsafeReadInt32LE idx dv = ST (I.js_m_unsafeGetInt32LE idx dv) -unsafeReadInt32BE idx dv = ST (I.js_m_unsafeGetInt32BE idx dv) -{-# INLINE readInt32LE #-} -{-# INLINE readInt32BE #-} -{-# INLINE unsafeReadInt32LE #-} -{-# INLINE unsafeReadInt32BE #-} - -readUint32LE, readUint32BE, unsafeReadUint32LE, unsafeReadUint32BE - :: Int -> STDataView s -> ST s Word -readUint32LE idx dv = ST (I.js_m_getUint32LE idx dv) -readUint32BE idx dv = ST (I.js_m_getUint32BE idx dv) -unsafeReadUint32LE idx dv = ST (I.js_m_unsafeGetUint32LE idx dv) -unsafeReadUint32BE idx dv = ST (I.js_m_unsafeGetUint32BE idx dv) -{-# INLINE readUint32LE #-} -{-# INLINE readUint32BE #-} -{-# INLINE unsafeReadUint32LE #-} -{-# INLINE unsafeReadUint32BE #-} - -readFloat32LE, readFloat32BE, unsafeReadFloat32LE, unsafeReadFloat32BE - :: Int -> STDataView s -> ST s Double -readFloat32LE idx dv = ST (I.js_m_getFloat32LE idx dv) -readFloat32BE idx dv = ST (I.js_m_getFloat32BE idx dv) -unsafeReadFloat32LE idx dv = ST (I.js_m_unsafeGetFloat32LE idx dv) -unsafeReadFloat32BE idx dv = ST (I.js_m_unsafeGetFloat32BE idx dv) -{-# INLINE readFloat32LE #-} -{-# INLINE readFloat32BE #-} -{-# INLINE unsafeReadFloat32LE #-} -{-# INLINE unsafeReadFloat32BE #-} - -readFloat64LE, readFloat64BE, unsafeReadFloat64LE, unsafeReadFloat64BE - :: Int -> STDataView s -> ST s Double -readFloat64LE idx dv = ST (I.js_m_getFloat64LE idx dv) -readFloat64BE idx dv = ST (I.js_m_getFloat64BE idx dv) -unsafeReadFloat64LE idx dv = ST (I.js_m_unsafeGetFloat64LE idx dv) -unsafeReadFloat64BE idx dv = ST (I.js_m_unsafeGetFloat64BE idx dv) -{-# INLINE readFloat64LE #-} -{-# INLINE readFloat64BE #-} -{-# INLINE unsafeReadFloat64LE #-} -{-# INLINE unsafeReadFloat64BE #-} - --- ---------------------------------------------------------------------------- --- mutable setters - -writeInt8, unsafeWriteInt8 :: Int -> Int8 -> STDataView s -> ST s () -writeInt8 idx x dv = ST (I.js_setInt8 idx x dv) -unsafeWriteInt8 idx x dv = ST (I.js_unsafeSetInt8 idx x dv) -{-# INLINE writeInt8 #-} -{-# INLINE unsafeWriteInt8 #-} - -writeUint8, unsafeWriteUint8 :: Int -> Word8 -> STDataView s -> ST s () -writeUint8 idx x dv = ST (I.js_setUint8 idx x dv) -unsafeWriteUint8 idx x dv = ST (I.js_unsafeSetUint8 idx x dv) -{-# INLINE writeUint8 #-} -{-# INLINE unsafeWriteUint8 #-} - -writeInt16LE, writeInt16BE, unsafeWriteInt16LE, unsafeWriteInt16BE - :: Int -> Int16 -> STDataView s -> ST s () -writeInt16LE idx x dv = ST (I.js_setInt16LE idx x dv) -writeInt16BE idx x dv = ST (I.js_setInt16BE idx x dv) -unsafeWriteInt16LE idx x dv = ST (I.js_unsafeSetInt16LE idx x dv) -unsafeWriteInt16BE idx x dv = ST (I.js_unsafeSetInt16BE idx x dv) -{-# INLINE writeInt16LE #-} -{-# INLINE writeInt16BE #-} -{-# INLINE unsafeWriteInt16LE #-} -{-# INLINE unsafeWriteInt16BE #-} - -writeUint16LE, writeUint16BE, unsafeWriteUint16LE, unsafeWriteUint16BE - :: Int -> Word16 -> STDataView s -> ST s () -writeUint16LE idx x dv = ST (I.js_setUint16LE idx x dv) -writeUint16BE idx x dv = ST (I.js_setUint16BE idx x dv) -unsafeWriteUint16LE idx x dv = ST (I.js_unsafeSetUint16LE idx x dv) -unsafeWriteUint16BE idx x dv = ST (I.js_unsafeSetUint16BE idx x dv) -{-# INLINE writeUint16LE #-} -{-# INLINE writeUint16BE #-} -{-# INLINE unsafeWriteUint16LE #-} -{-# INLINE unsafeWriteUint16BE #-} - -writeInt32LE, writeInt32BE, unsafeWriteInt32LE, unsafeWriteInt32BE - :: Int -> Int -> STDataView s -> ST s () -writeInt32LE idx x dv = ST (I.js_setInt32LE idx x dv) -writeInt32BE idx x dv = ST (I.js_setInt32BE idx x dv) -unsafeWriteInt32LE idx x dv = ST (I.js_unsafeSetInt32LE idx x dv) -unsafeWriteInt32BE idx x dv = ST (I.js_unsafeSetInt32BE idx x dv) -{-# INLINE writeInt32LE #-} -{-# INLINE writeInt32BE #-} -{-# INLINE unsafeWriteInt32LE #-} -{-# INLINE unsafeWriteInt32BE #-} - -writeUint32LE, writeUint32BE, unsafeWriteUint32LE, unsafeWriteUint32BE - :: Int -> Word -> STDataView s -> ST s () -writeUint32LE idx x dv = ST (I.js_setUint32LE idx x dv) -writeUint32BE idx x dv = ST (I.js_setUint32BE idx x dv) -unsafeWriteUint32LE idx x dv = ST (I.js_unsafeSetUint32LE idx x dv) -unsafeWriteUint32BE idx x dv = ST (I.js_unsafeSetUint32BE idx x dv) -{-# INLINE writeUint32LE #-} -{-# INLINE writeUint32BE #-} -{-# INLINE unsafeWriteUint32LE #-} -{-# INLINE unsafeWriteUint32BE #-} - -writeFloat32LE, writeFloat32BE, unsafeWriteFloat32LE, unsafeWriteFloat32BE - :: Int -> Double -> STDataView s -> ST s () -writeFloat32LE idx x dv = ST (I.js_setFloat32LE idx x dv) -writeFloat32BE idx x dv = ST (I.js_setFloat32BE idx x dv) -unsafeWriteFloat32LE idx x dv = ST (I.js_unsafeSetFloat32LE idx x dv) -unsafeWriteFloat32BE idx x dv = ST (I.js_unsafeSetFloat32BE idx x dv) -{-# INLINE writeFloat32LE #-} -{-# INLINE writeFloat32BE #-} -{-# INLINE unsafeWriteFloat32LE #-} -{-# INLINE unsafeWriteFloat32BE #-} - -writeFloat64LE, writeFloat64BE, unsafeWriteFloat64LE, unsafeWriteFloat64BE - :: Int -> Double -> STDataView s -> ST s () -writeFloat64LE idx x dv = ST (I.js_setFloat64LE idx x dv) -writeFloat64BE idx x dv = ST (I.js_setFloat64BE idx x dv) -unsafeWriteFloat64LE idx x dv = ST (I.js_unsafeSetFloat64LE idx x dv) -unsafeWriteFloat64BE idx x dv = ST (I.js_unsafeSetFloat64BE idx x dv) -{-# INLINE writeFloat64LE #-} -{-# INLINE writeFloat64BE #-} -{-# INLINE unsafeWriteFloat64LE #-} -{-# INLINE unsafeWriteFloat64BE #-} - diff --git a/JavaScript/TypedArray/IO.hs b/JavaScript/TypedArray/IO.hs new file mode 100644 index 0000000..4682242 --- /dev/null +++ b/JavaScript/TypedArray/IO.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} +----------------------------------------------------------------------------- +-- | +-- Module : JavaScript.TypedArray.IO +-- +-- Maintainer : Artem Chirkin +-- Stability : experimental +-- Portability : +-- +-- Mutable operatons on JavaScript typed arrays in IO monad +-- +----------------------------------------------------------------------------- + +module JavaScript.TypedArray.IO where + +import GHC.Exts (ByteArray#, MutableByteArray#) +import qualified GHC.Types as Exts + +import Control.Monad.Primitive (PrimState (..)) + +import Data.Coerce (coerce) +import Data.Word +import Data.Int +import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray (..)) +import Foreign.C.Types +import Unsafe.Coerce (unsafeCoerce) + + +import GHCJS.Internal.Types + +import JavaScript.TypedArray +import JavaScript.TypedArray.Types +import JavaScript.TypedArray.Internal + +----------------------------------------------------------------------------- +-- | mutable typed arrays +----------------------------------------------------------------------------- + +class IOTypedArrayOperations a where + -- | Init a new typed array filled with zeroes + newIOTypedArray :: Int -> IO (IOTypedArray a) + -- | Fill a new typed array with a given value + fillNewIOTypedArray :: Int -> a -> IO (IOTypedArray a) + -- | Create a new typed array from list + newFromList :: [a] -> IO (IOTypedArray a) + -- | Create a new typed array from elements of another typed array + newFromArray :: SomeTypedArray (m :: MutabilityType sk) b -> IO (IOTypedArray a) + -- | Get value from array at specified index + index :: Int -> IOTypedArray a -> IO a + -- | Set value into array at specified index + setIndex ::Int -> a -> IOTypedArray a -> IO () + -- | Set list into array with specified offset + setList :: Int -> [a] -> IOTypedArray a -> IO () + -- | Set array elements into array with specified offset + setArray :: Int -> SomeTypedArray (m :: MutabilityType sk) b -> IOTypedArray a -> IO () + + + +#define TYPEDARRAY(T,JSType,JSSize)\ +instance IOTypedArrayOperations T where{\ + {-# INLINE newIOTypedArray #-};\ + newIOTypedArray n = Exts.IO (js_createM/**/T/**/Array n);\ + {-# INLINE fillNewIOTypedArray #-};\ + fillNewIOTypedArray n v = Exts.IO (js_fillNewM/**/T/**/Array n v);\ + {-# INLINE newFromList #-};\ + newFromList xs = Exts.IO (js_fromListM/**/T/**/Array . unsafeCoerce . seqList $ xs);\ + {-# INLINE newFromArray #-};\ + newFromArray arr = Exts.IO (js_fromArrayM/**/T/**/Array arr);\ + {-# INLINE index #-};\ + index i arr = Exts.IO (js_getIndex/**/T/**/Array i arr);\ + {-# INLINE setIndex #-};\ + setIndex i v arr = Exts.IO (js_setIndex/**/T/**/Array i v arr);\ + {-# INLINE setList #-};\ + setList offset xs arr = Exts.IO (js_setList/**/T/**/Array offset (unsafeCoerce $ seqList xs) arr);\ + {-# INLINE setArray #-};\ + setArray offset ar0 arr = Exts.IO (js_setArray/**/T/**/Array offset ar0 arr)} + + +TYPEDARRAY(Int,Int32,4) +TYPEDARRAY(Int32,Int32,4) +TYPEDARRAY(Int16,Int16,2) +TYPEDARRAY(Int8,Int8,1) +TYPEDARRAY(Word,Uint32,4) +TYPEDARRAY(Word32,Uint32,4) +TYPEDARRAY(Word16,Uint16,2) +TYPEDARRAY(Word8,Uint8,1) +TYPEDARRAY(Word8Clamped,Uint8Clamped,1) +TYPEDARRAY(Float,Float32,4) +TYPEDARRAY(Double,Float64,8) +TYPEDARRAY(CChar,Int8,1) +TYPEDARRAY(CSChar,Int8,1) +TYPEDARRAY(CUChar,Uint8,1) +TYPEDARRAY(CShort,Int16,2) +TYPEDARRAY(CUShort,Uint16,2) +TYPEDARRAY(CInt,Int32,4) +TYPEDARRAY(CUInt,Uint32,4) +TYPEDARRAY(CLong,Int32,4) +TYPEDARRAY(CULong,Uint32,4) +TYPEDARRAY(CFloat,Float32,4) +TYPEDARRAY(CDouble,Float64,8) + + +----------------------------------------------------------------------------- +-- | mutable anything +----------------------------------------------------------------------------- + + + +class IOArrayBufferData mutable any | any -> mutable where + -- | Slice array (elements) or buffer (bytes). + -- See documentation on TypedArray.prototype.slice() and ArrayBuffer.prototype.slice() + slice :: Int -> Maybe Int -> any -> IO mutable + + +class ( MutableArrayBufferPrim mutable + ) => IOArrayBufferConversions immutable mutable + | immutable -> mutable + , mutable -> immutable where + -- | Create an immutable data by copying a mutable data + freeze :: mutable -> IO immutable + -- | Create an immutable data from a mutable data without + -- copying. The result shares the buffer with the argument, do not modify + -- the data in the original buffer after freezing + unsafeFreeze :: mutable -> IO immutable + -- | Create a mutable data by copying an immutable data + thaw :: immutable -> IO mutable + -- | Create a mutable data from an immutable data without + -- copying. The result shares the buffer with the argument. + unsafeThaw :: immutable -> IO mutable + -- | Convert from MutableByteArray without copying data + fromMutableByteArray :: MutableByteArray (PrimState IO) -> IO mutable + fromMutableByteArray (MutableByteArray ba) = Exts.IO (fromMutableByteArrayPrim ba) + {-# INLINE fromMutableByteArray #-} + -- | Convert to MutableByteArray without copying data + toMutableByteArray :: mutable -> IO (MutableByteArray (PrimState IO)) + toMutableByteArray b = Exts.IO $ \s -> + case toMutableByteArrayPrim b s of (# s1, ba #) -> (# s1, MutableByteArray ba #) + {-# INLINE toMutableByteArray #-} + + +instance IOArrayBufferData IOArrayBuffer (SomeArrayBuffer m) where + {-# INLINE slice #-} + slice i0 Nothing (SomeArrayBuffer b) = fmap SomeArrayBuffer . Exts.IO $ js_slice1 i0 b + slice i0 (Just i1) (SomeArrayBuffer b) = fmap SomeArrayBuffer . Exts.IO $ js_slice i0 i1 b + +instance IOArrayBufferConversions ArrayBuffer IOArrayBuffer where + {-# INLINE freeze #-} + freeze (SomeArrayBuffer b) = fmap SomeArrayBuffer (Exts.IO (js_slice1 0 b)) + {-# INLINE unsafeFreeze #-} + unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b) + {-# INLINE thaw #-} + thaw (SomeArrayBuffer b) = fmap SomeArrayBuffer (Exts.IO (js_slice1 0 b)) + {-# INLINE unsafeThaw #-} + unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b) + + +instance IOArrayBufferData (IOTypedArray t) (SomeTypedArray m t) where + {-# INLINE slice #-} + slice i0 Nothing (SomeTypedArray b) = fmap SomeTypedArray . Exts.IO $ js_slice1 i0 b + slice i0 (Just i1) (SomeTypedArray b) = fmap SomeTypedArray . Exts.IO $ js_slice i0 i1 b + +instance ( MutableArrayBufferPrim (IOTypedArray t) + ) => IOArrayBufferConversions (TypedArray t) (IOTypedArray t) where + {-# INLINE freeze #-} + freeze (SomeTypedArray b) = fmap SomeTypedArray (Exts.IO (js_slice1 0 b)) + {-# INLINE unsafeFreeze #-} + unsafeFreeze (SomeTypedArray b) = pure (SomeTypedArray b) + {-# INLINE thaw #-} + thaw (SomeTypedArray b) = fmap SomeTypedArray (Exts.IO (js_slice1 0 b)) + {-# INLINE unsafeThaw #-} + unsafeThaw (SomeTypedArray b) = pure (SomeTypedArray b) + +instance IOArrayBufferConversions DataView IODataView where + {-# INLINE freeze #-} + freeze dv = Exts.IO (js_cloneDataView dv) + {-# INLINE unsafeFreeze #-} + unsafeFreeze (SomeDataView b) = pure (SomeDataView b) + {-# INLINE thaw #-} + thaw dv = Exts.IO (js_cloneDataView dv) + {-# INLINE unsafeThaw #-} + unsafeThaw (SomeDataView b) = pure (SomeDataView b) + +#define DATAVIEW8(T,JSType,JSSize)\ +write/**/T, unsafeWrite/**/T\ + :: Int -> T -> IODataView -> IO ();\ +write/**/T idx x dv = Exts.IO (js_safeSet/**/T idx x dv);\ +unsafeWrite/**/T idx x dv = Exts.IO (js_unsafeSet/**/T idx x dv);\ +{-# INLINE write/**/T #-};\ +{-# INLINE unsafeWrite/**/T #-};\ +read/**/T, unsafeRead/**/T\ + :: Int -> IODataView -> IO T;\ +read/**/T idx dv = Exts.IO (js_m_safeGet/**/T idx dv);\ +unsafeRead/**/T idx dv = Exts.IO (js_m_unsafeGet/**/T idx dv);\ +{-# INLINE read/**/T #-};\ +{-# INLINE unsafeRead/**/T #-}; + +#define DATAVIEW(T,JSType,JSSize)\ +write/**/T/**/LE, write/**/T/**/BE, unsafeWrite/**/T/**/LE, unsafeWrite/**/T/**/BE, write/**/T, unsafeWrite/**/T\ + :: Int -> T -> IODataView -> IO ();\ +write/**/T/**/LE idx x dv = Exts.IO (js_safeSet/**/T/**/LE idx x dv);\ +write/**/T/**/BE idx x dv = Exts.IO (js_safeSet/**/T/**/BE idx x dv);\ +unsafeWrite/**/T/**/LE idx x dv = Exts.IO (js_unsafeSet/**/T/**/LE idx x dv);\ +unsafeWrite/**/T/**/BE idx x dv = Exts.IO (js_unsafeSet/**/T/**/BE idx x dv);\ +{- | Shortcut for little-endian -};\ +write/**/T = write/**/T/**/LE;\ +{- | Shortcut for little-endian -};\ +unsafeWrite/**/T = unsafeWrite/**/T/**/LE;\ +{-# INLINE write/**/T/**/LE #-};\ +{-# INLINE write/**/T/**/BE #-};\ +{-# INLINE unsafeWrite/**/T/**/LE #-};\ +{-# INLINE unsafeWrite/**/T/**/BE #-};\ +{-# INLINE write/**/T #-};\ +{-# INLINE unsafeWrite/**/T #-};\ +read/**/T/**/LE, read/**/T/**/BE, unsafeRead/**/T/**/LE, unsafeRead/**/T/**/BE, read/**/T, unsafeRead/**/T\ + :: Int -> IODataView -> IO T;\ +read/**/T/**/LE idx dv = Exts.IO (js_m_safeGet/**/T/**/LE idx dv);\ +read/**/T/**/BE idx dv = Exts.IO (js_m_safeGet/**/T/**/BE idx dv);\ +unsafeRead/**/T/**/LE idx dv = Exts.IO (js_m_unsafeGet/**/T/**/LE idx dv);\ +unsafeRead/**/T/**/BE idx dv = Exts.IO (js_m_unsafeGet/**/T/**/BE idx dv);\ +{- | Shortcut for little-endian -};\ +read/**/T = read/**/T/**/LE;\ +{- | Shortcut for little-endian -};\ +unsafeRead/**/T = unsafeRead/**/T/**/LE;\ +{-# INLINE read/**/T/**/LE #-};\ +{-# INLINE read/**/T/**/BE #-};\ +{-# INLINE unsafeRead/**/T/**/LE #-};\ +{-# INLINE unsafeRead/**/T/**/BE #-};\ +{-# INLINE read/**/T #-};\ +{-# INLINE unsafeRead/**/T #-}; + +DATAVIEW(Int,Int32,4) +DATAVIEW(Int32,Int32,4) +DATAVIEW(Int16,Int16,2) +DATAVIEW(Word,Uint32,4) +DATAVIEW(Word32,Uint32,4) +DATAVIEW(Word16,Uint16,2) +DATAVIEW(Float,Float32,4) +DATAVIEW(Double,Float64,8) + +DATAVIEW8(Word8,Uint8,1) +DATAVIEW8(Int8,Int8,1) + +----------------------------------------------------------------------------- +-- Misc +----------------------------------------------------------------------------- + +-- | Create new array buffer +newIOArrayBuffer :: Int -> IO IOArrayBuffer +newIOArrayBuffer size = Exts.IO (js_createArrayBuffer size) + diff --git a/JavaScript/TypedArray/Immutable.hs b/JavaScript/TypedArray/Immutable.hs deleted file mode 100644 index 410c668..0000000 --- a/JavaScript/TypedArray/Immutable.hs +++ /dev/null @@ -1 +0,0 @@ -module JavaScript.TypedArray.Immutable where diff --git a/JavaScript/TypedArray/Internal.hs b/JavaScript/TypedArray/Internal.hs index d05d4c2..7571759 100644 --- a/JavaScript/TypedArray/Internal.hs +++ b/JavaScript/TypedArray/Internal.hs @@ -1,527 +1,350 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, JavaScriptFFI, ForeignFunctionInterface, - UnliftedFFITypes, GHCForeignImportPrim, EmptyDataDecls, TypeFamilies, - TypeSynonymInstances, FlexibleInstances, DataKinds, PolyKinds, KindSignatures - #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples, JavaScriptFFI, GHCForeignImportPrim, UnliftedFFITypes #-} +{-# LANGUAGE PolyKinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.TypedArray.Internal +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- Maintainer : Artem Chirkin +-- Stability : experimental +-- Portability : +-- +-- JS imports used by typed arrays +-- +----------------------------------------------------------------------------- module JavaScript.TypedArray.Internal where -import Data.Typeable +import GHC.Exts (State#, MutableByteArray#, ByteArray#) +import qualified GHC.Exts as Exts -import GHC.Types -import GHC.Exts -import GHC.ST +import Data.Coerce (coerce) +import Data.Word +import Data.Int +import Foreign.C.Types -import GHC.Int -import GHC.Word - -import GHCJS.Internal.Types -import GHCJS.Buffer.Types import GHCJS.Types -import JavaScript.Array.Internal (SomeJSArray(..), JSArray) -import JavaScript.TypedArray.ArrayBuffer -import JavaScript.TypedArray.ArrayBuffer.Internal (SomeArrayBuffer(..)) -import JavaScript.TypedArray.Internal.Types - -elemSize :: SomeTypedArray e m -> Int -elemSize a = js_elemSize a -{-# INLINE [1] elemSize #-} -{-# RULES "elemSizeUint8Clamped" forall (x :: SomeUint8ClampedArray m). elemSize x = 1 #-} -{-# RULES "elemSizeUint8" forall (x :: SomeUint8Array m). elemSize x = 1 #-} -{-# RULES "elemSizeUint16" forall (x :: SomeUint16Array m). elemSize x = 2 #-} -{-# RULES "elemSizeUint32" forall (x :: SomeUint32Array m). elemSize x = 4 #-} -{-# RULES "elemSizeInt8" forall (x :: SomeInt8Array m). elemSize x = 1 #-} -{-# RULES "elemSizeInt16" forall (x :: SomeInt16Array m). elemSize x = 2 #-} -{-# RULES "elemSizeInt32" forall (x :: SomeInt32Array m). elemSize x = 4 #-} -{-# RULES "elemSizeFloat32" forall (x :: SomeFloat32Array m). elemSize x = 4 #-} -{-# RULES "elemSizeFloat64" forall (x :: SomeFloat64Array m). elemSize x = 8 #-} - -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) - create l = IO (js_createInt8Array l) - fromArray a = int8ArrayFrom a - fromArrayBuffer b = undefined - -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) - create l = IO (js_createInt16Array l) - fromArray a = int16ArrayFrom a - fromArrayBuffer b = undefined - -instance TypedArray IOInt32Array where - index i a = IO (indexI i a) - unsafeIndex i a = IO (unsafeIndexI i a) - setIndex i (I# x) a = IO (setIndexI i x a) - unsafeSetIndex i (I# x) a = IO (unsafeSetIndexI i x a) - indexOf s (I# x) a = IO (indexOfI s x a) - lastIndexOf s (I# x) a = IO (lastIndexOfI s x a) - create l = IO (js_createInt32Array l) - fromArray a = int32ArrayFrom a - fromArrayBuffer b = undefined - -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) - create l = IO (js_createUint8ClampedArray l) - fromArray a = uint8ClampedArrayFrom a - fromArrayBuffer b = undefined - -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) - create l = IO (js_createUint8Array l) - fromArray a = uint8ArrayFrom a - fromArrayBuffer b = undefined - -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) - create l = IO (js_createUint16Array l) - fromArray a = uint16ArrayFrom a - fromArrayBuffer b = undefined - -instance TypedArray IOUint32Array where - index i a = IO (indexW i a) - unsafeIndex i a = IO (unsafeIndexW i a) - setIndex i (W# x) a = IO (setIndexW i x a) - unsafeSetIndex i (W# x) a = IO (unsafeSetIndexW i x a) - indexOf s (W# x) a = IO (indexOfW s x a) - lastIndexOf s (W# x) a = IO (lastIndexOfW s x a) - create l = IO (js_createUint32Array l) - fromArray a = uint32ArrayFrom a - fromArrayBuffer b = undefined - -instance TypedArray IOFloat32Array where - index i a = IO (indexD i a) - unsafeIndex i a = IO (unsafeIndexD i a) - setIndex i x a = IO (setIndexD i x a) - unsafeSetIndex i x a = IO (unsafeSetIndexD i x a) - indexOf s x a = IO (indexOfD s x a) - lastIndexOf s x a = IO (lastIndexOfD s x a) - create l = IO (js_createFloat32Array l) - fromArray a = float32ArrayFrom a - fromArrayBuffer b = undefined - -instance TypedArray IOFloat64Array where - index i a = IO (indexD i a) - unsafeIndex i a = IO (unsafeIndexD i a) - setIndex i x a = IO (setIndexD i x a) - unsafeSetIndex i x a = IO (unsafeSetIndexD i x a) - indexOf s x a = IO (indexOfD s x a) - lastIndexOf s x a = IO (lastIndexOfD s x a) - create l = IO (js_createFloat64Array l) - fromArray a = float64ArrayFrom a - fromArrayBuffer b = undefined - - -class TypedArray a where - unsafeIndex :: Int -> a -> IO (Elem a) - index :: Int -> a -> IO (Elem a) - unsafeSetIndex :: Int -> Elem a -> a -> IO () - setIndex :: Int -> Elem a -> a -> IO () - create :: Int -> IO a - fromArray :: SomeJSArray m -> IO a - fromArrayBuffer :: MutableArrayBuffer -> Int -> Maybe Int -> IO a - indexOf :: Int -> Elem a -> a -> IO Int - lastIndexOf :: Int -> Elem a -> a -> IO Int - --- ----------------------------------------------------------------------------- - -indexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -indexI a i = \s -> case js_indexI a i s of (# s', v #) -> (# s', I# v #) -{-# 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 #) -{-# 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 #) -{-# INLINE indexI8 #-} - -indexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #) -indexW a i = \s -> case js_indexW a i s of (# s', v #) -> (# s', W# v #) -{-# 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 #) -{-# 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 #) -{-# INLINE indexW8 #-} - -indexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) -indexD a i = \s -> js_indexD a i s -{-# INLINE indexD #-} - --- ----------------------------------------------------------------------------- - -unsafeIndexI :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -unsafeIndexI a i = \s -> case js_unsafeIndexI a i s of (# s', v #) -> (# s', I# v #) -{-# 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 #) -{-# 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 #) -{-# INLINE unsafeIndexI8 #-} - -unsafeIndexW :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word #) -unsafeIndexW a i = \s -> case js_unsafeIndexW a i s of (# s', v #) -> (# s', W# v #) -{-# 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 #) -{-# 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 #) -{-# INLINE unsafeIndexW8 #-} - -unsafeIndexD :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) -unsafeIndexD a i = \s -> js_unsafeIndexD a i s -{-# INLINE unsafeIndexD #-} - --- ----------------------------------------------------------------------------- - -int8ArrayFrom :: SomeJSArray m0 -> IO (SomeInt8Array m1) -int8ArrayFrom a = js_int8ArrayFromArray a -{-# INLINE int8ArrayFrom #-} - -int16ArrayFrom :: SomeJSArray m0 -> IO (SomeInt16Array m1) -int16ArrayFrom a = js_int16ArrayFromArray a -{-# INLINE int16ArrayFrom #-} - -int32ArrayFrom :: SomeJSArray m0 -> IO (SomeInt32Array m1) -int32ArrayFrom a = js_int32ArrayFromArray a -{-# INLINE int32ArrayFrom #-} - -uint8ArrayFrom :: SomeJSArray m0 -> IO (SomeUint8Array m1) -uint8ArrayFrom a = js_uint8ArrayFromArray a -{-# INLINE uint8ArrayFrom #-} - -uint8ClampedArrayFrom :: SomeJSArray m0 -> IO (SomeUint8ClampedArray m1) -uint8ClampedArrayFrom a = js_uint8ClampedArrayFromArray a -{-# INLINE uint8ClampedArrayFrom #-} - -uint16ArrayFrom :: SomeJSArray m0 -> IO (SomeUint16Array m1) -uint16ArrayFrom a = js_uint16ArrayFromArray a -{-# INLINE uint16ArrayFrom #-} - -uint32ArrayFrom :: SomeJSArray m0 -> IO (SomeUint32Array m1) -uint32ArrayFrom a = js_uint32ArrayFromArray a -{-# INLINE uint32ArrayFrom #-} - -float32ArrayFrom :: SomeJSArray m0 -> IO (SomeFloat32Array m1) -float32ArrayFrom a = js_float32ArrayFromArray a -{-# INLINE float32ArrayFrom #-} - -float64ArrayFrom :: SomeJSArray m0 -> IO (SomeFloat64Array m1) -float64ArrayFrom a = js_float64ArrayFromArray a -{-# INLINE float64ArrayFrom #-} - --- ----------------------------------------------------------------------------- +import JavaScript.TypedArray.Types -setIndexI :: Mutability m ~ IsMutable - => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -setIndexI i x a = js_setIndexI i x a -{-# INLINE setIndexI #-} - -unsafeSetIndexI :: Mutability m ~ IsMutable - => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -unsafeSetIndexI i x a = js_unsafeSetIndexI i x a -{-# INLINE unsafeSetIndexI #-} - -setIndexW :: Mutability m ~ IsMutable - => Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -setIndexW i x a = js_setIndexW i x a -{-# INLINE setIndexW #-} - -unsafeSetIndexW :: Mutability m ~ IsMutable - => Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -unsafeSetIndexW i x a = js_unsafeSetIndexW i x a -{-# INLINE unsafeSetIndexW #-} - -setIndexD :: Mutability m ~ IsMutable - => Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) -setIndexD i x a = js_setIndexD i x a -{-# INLINE setIndexD #-} - -unsafeSetIndexD :: Mutability m ~ IsMutable - => Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) -unsafeSetIndexD i x a = js_unsafeSetIndexD i x a -{-# INLINE unsafeSetIndexD #-} - -indexOfI :: Mutability m ~ IsMutable - => Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -indexOfI s x a = js_indexOfI s x a -{-# INLINE indexOfI #-} - -indexOfW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -indexOfW s x a = js_indexOfW s x a -{-# INLINE indexOfW #-} - -indexOfD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -indexOfD s x a = js_indexOfD s x a -{-# INLINE indexOfD #-} - -lastIndexOfI :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -lastIndexOfI s x a = js_lastIndexOfI s x a -{-# INLINE lastIndexOfI #-} - -lastIndexOfW :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -lastIndexOfW s x a = js_lastIndexOfW s x a -{-# INLINE lastIndexOfW #-} - -lastIndexOfD :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -lastIndexOfD s x a = js_lastIndexOfD s x a -{-# INLINE lastIndexOfD #-} - --- ----------------------------------------------------------------------------- --- non-class operations usable for all typed array -{-| length of the typed array in elements -} -length :: SomeTypedArray e m -> Int -length x = js_length x -{-# INLINE length #-} - -{-| length of the array in bytes -} -byteLength :: SomeTypedArray e m -> Int -byteLength x = js_byteLength x -{-# INLINE byteLength #-} - -{-| offset of the array in the buffer -} -byteOffset :: SomeTypedArray e m -> Int -byteOffset x = js_byteOffset x -{-# INLINE byteOffset #-} - -{-| the underlying buffer of the array #-} -buffer :: SomeTypedArray e m -> SomeArrayBuffer m -buffer x = js_buffer x -{-# INLINE buffer #-} - -{-| create a view of the existing array -} -subarray :: Int -> Int -> SomeTypedArray e m -> SomeTypedArray e m -subarray begin end x = js_subarray begin end x -{-# INLINE subarray #-} - --- fixme convert JSException to Haskell exception -{-| copy the elements of one typed array to another -} -set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> IO () -set offset src dest = IO (js_set offset src dest) -{-# INLINE set #-} - -unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 Mutable -> IO () -unsafeSet offset src dest = IO (js_unsafeSet offset src dest) -{-# INLINE unsafeSet #-} - --- ----------------------------------------------------------------------------- -foreign import javascript unsafe - "$1.length" js_length :: SomeTypedArray e m -> Int -foreign import javascript unsafe - "$1.byteLength" js_byteLength :: SomeTypedArray e m -> Int -foreign import javascript unsafe - "$1.byteOffset" js_byteOffset :: SomeTypedArray e m -> Int -foreign import javascript unsafe - "$1.buffer" js_buffer :: SomeTypedArray e m -> SomeArrayBuffer m -foreign import javascript unsafe - "$3.subarray($1,$2)" - js_subarray :: Int -> Int -> SomeTypedArray e m -> SomeTypedArray e m -foreign import javascript safe - "$3.set($1,$2)" - js_set :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #) -foreign import javascript unsafe - "$3.set($1,$2)" - js_unsafeSet :: Int -> SomeTypedArray e m -> SomeTypedArray e1 m1 -> State# s -> (# State# s, () #) -foreign import javascript unsafe - "$1.BYTES_PER_ELEMENT" - js_elemSize :: SomeTypedArray e m -> Int - --- ----------------------------------------------------------------------------- --- index - -foreign import javascript safe - "$2[$1]" js_indexI - :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #) -foreign import javascript safe - "$2[$1]" js_indexW - :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #) -foreign import javascript safe - "$2[$1]" js_indexD - :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) +----------------------------------------------------------------------------- +-- Some simple functions -- the same for many types +----------------------------------------------------------------------------- -foreign import javascript unsafe - "$2[$1]" js_unsafeIndexI - :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Int# #) -foreign import javascript unsafe - "$2[$1]" js_unsafeIndexW - :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Word# #) -foreign import javascript unsafe - "$2[$1]" js_unsafeIndexD - :: Int -> SomeTypedArray e m -> State# s -> (# State# s, Double #) - --- ----------------------------------------------------------------------------- --- setIndex - -foreign import javascript safe - "$3[$1] = $2;" js_setIndexI - :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -foreign import javascript safe - "$3[$1] = $2;" js_setIndexW - :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -foreign import javascript safe - "$3[$1] = $2;" js_setIndexD - :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) -foreign import javascript unsafe - "$3[$1] = $2;" js_unsafeSetIndexI - :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -foreign import javascript unsafe - "$3[$1] = $2;" js_unsafeSetIndexW - :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, () #) -foreign import javascript unsafe - "$3[$1] = $2;" js_unsafeSetIndexD - :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, () #) +{-# INLINE arrayLength #-} +-- | Number of elements in the array +foreign import javascript unsafe "$1.length" + arrayLength :: SomeTypedArray m a -> Int --- ------------------------------------------------------------------------------ +{-# INLINE arrayBuffer #-} +-- | Get underlying ArrayBuffer +foreign import javascript unsafe "$1.buffer" + arrayBuffer :: SomeTypedArray m a -> SomeArrayBuffer m -foreign import javascript unsafe - "$3.indexOf($2,$1)" js_indexOfI - :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -foreign import javascript unsafe - "$3.indexOf($2,$1)" js_indexOfW - :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -foreign import javascript unsafe - "$3.indexOf($2,$1)" js_indexOfD - :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +{-# INLINE dataView #-} +-- | Create a DataView for the whole ArrayBuffer +foreign import javascript unsafe "new DataView($1)" + dataView :: SomeArrayBuffer m -> SomeDataView m -foreign import javascript unsafe - "$3.lastIndexOf($2,$1)" js_lastIndexOfI - :: Int -> Int# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -foreign import javascript unsafe - "$3.lastIndexOf($2,$1)" js_lastIndexOfW - :: Int -> Word# -> SomeTypedArray e m -> State# s -> (# State# s, Int #) -foreign import javascript unsafe - "$3.lastIndexOf($2,$1)" js_lastIndexOfD - :: Int -> Double -> SomeTypedArray e m -> State# s -> (# State# s, Int #) +{-# INLINE dvByteLength #-} +-- | Size of DataView in bytes +foreign import javascript unsafe "$1.byteLength" + dvByteLength :: SomeDataView m -> Int +{-# INLINE dvByteOffset #-} +-- | Offset of DataView within a buffer in bytes +foreign import javascript unsafe "$1.byteOffset" + dvByteOffset :: SomeDataView m -> Int +{-# INLINE dvBuffer #-} +-- | Underlying ArrayBuffer of DataView +foreign import javascript unsafe "$1.buffer" + dvBuffer :: SomeDataView m -> SomeArrayBuffer m --- ------------------------------------------------------------------------------ --- create +----------------------------------------------------------------------------- +-- Some not exposed js imports +----------------------------------------------------------------------------- -foreign import javascript unsafe - "new Int8Array($1)" - js_createInt8Array :: Int -> State# s -> (# State# s, SomeInt8Array m #) -foreign import javascript unsafe - "new Int16Array($1)" - js_createInt16Array :: Int -> State# s -> (# State# s, SomeInt16Array m #) -foreign import javascript unsafe - "new Int32Array($1)" - js_createInt32Array :: Int -> State# s -> (# State# s, SomeInt32Array m #) +{-# INLINE js_byteLength #-} +foreign import javascript unsafe "$1.byteLength" + js_byteLength :: JSVal -> Int + +{-# INLINE js_createArrayBuffer #-} +foreign import javascript unsafe "new ArrayBuffer($1)" + js_createArrayBuffer :: Int -> State# s -> (# State# s, SomeArrayBuffer m #) + +{-# INLINE js_show #-} +foreign import javascript unsafe "$r = '[' + $1.join(', ') + ']'" + js_show :: SomeTypedArray m t -> JSString + + + +-- slice mutable any + +{-# INLINE js_slice1 #-} +foreign import javascript unsafe + "$2.slice($1)" js_slice1 :: Int -> JSVal -> State# s -> (# State# s, JSVal #) + +{-# INLINE js_slice #-} +foreign import javascript unsafe + "$3.slice($1,$2)" js_slice :: Int -> Int -> JSVal -> State# s -> (# State# s, JSVal #) + + +-- slice immutable any + +{-# INLINE js_slice1_imm #-} +foreign import javascript unsafe + "$2.slice($1)" js_slice1_imm :: Int -> JSVal -> JSVal + +{-# INLINE js_slice_imm #-} +foreign import javascript unsafe + "$3.slice($1,$2)" js_slice_imm :: Int -> Int -> JSVal -> JSVal + +-- Creating data views + + +{-# INLINE js_dataView2 #-} +foreign import javascript safe "new DataView($2,$1)" + js_dataView2 :: Int -> JSVal -> SomeDataView m +{-# INLINE js_unsafeDataView2 #-} +foreign import javascript unsafe "new DataView($2,$1)" + js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m +{-# INLINE js_dataView #-} +foreign import javascript safe "new DataView($3,$1,$2)" + js_dataView :: Int -> Int -> JSVal -> SomeDataView m +{-# INLINE js_unsafeDataView #-} +foreign import javascript unsafe "new DataView($3,$1,$2)" + js_unsafeDataView :: Int -> Int -> JSVal -> JSVal -foreign import javascript unsafe - "new Uint8ClampedArray($1)" - js_createUint8ClampedArray :: Int -> State# s -> (# State# s, SomeUint8ClampedArray m #) -foreign import javascript unsafe - "new Uint8Array($1)" - js_createUint8Array :: Int -> State# s -> (# State# s, SomeUint8Array m #) -foreign import javascript unsafe - "new Uint16Array($1)" - js_createUint16Array :: Int -> State# s -> (# State# s, SomeUint16Array m #) -foreign import javascript unsafe - "new Uint32Array($1)" - js_createUint32Array :: Int -> State# s -> (# State# s, SomeUint32Array m #) - -foreign import javascript unsafe - "new Float32Array($1)" - js_createFloat32Array :: Int -> State# s -> (# State# s, SomeFloat32Array m #) -foreign import javascript unsafe - "new Float64Array($1)" - js_createFloat64Array :: Int -> State# s -> (# State# s, SomeFloat64Array m #) +{-# INLINE js_cloneDataView #-} +foreign import javascript unsafe "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))" + js_cloneDataView :: SomeDataView m0 -> State# s -> (# State# s, SomeDataView m #) --- ------------------------------------------------------------------------------ --- from array - -foreign import javascript unsafe - "Int8Array.from($1)" - js_int8ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt8Array m1) -foreign import javascript unsafe - "Int16Array.from($1)" - js_int16ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt16Array m1) -foreign import javascript unsafe - "Int32Array.from($1)" - js_int32ArrayFromArray :: SomeJSArray m0 -> IO (SomeInt32Array m1) -foreign import javascript unsafe - "Uint8ClampedArray.from($1)" - js_uint8ClampedArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8ClampedArray m1) -foreign import javascript unsafe - "Uint8Array.from($1)" - js_uint8ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint8Array m1) -foreign import javascript unsafe - "Uint16Array.from($1)" - js_uint16ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint16Array m1) -foreign import javascript unsafe - "Uint32Array.from($1)" - js_uint32ArrayFromArray :: SomeJSArray m0 -> IO (SomeUint32Array m1) -foreign import javascript unsafe - "Float32Array.from($1)" - js_float32ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat32Array m1) -foreign import javascript unsafe - "Float64Array.from($1)" - js_float64ArrayFromArray :: SomeJSArray m0 -> IO (SomeFloat64Array m1) - --- ------------------------------------------------------------------------------ --- from ArrayBuffer - -foreign import javascript unsafe - "new Int8Array($1)" - js_int8ArrayFromJSRef :: JSRef () -> SomeInt8Array m -foreign import javascript unsafe - "new Int16Array($1)" - js_int16ArrayFromJSRef :: JSRef () -> SomeInt16Array m -foreign import javascript unsafe - "new Int32Array($1)" - js_int32ArrayFromJSRef :: JSRef () -> SomeInt32Array m -foreign import javascript unsafe - "new Uint8ClampedArray($1)" - js_uint8ClampedArrayFromJSRef :: JSRef () -> SomeUint8ClampedArray m -foreign import javascript unsafe - "new Uint8Array($1)" - js_uint8ArrayFromJSRef :: JSRef () -> SomeUint8Array m -foreign import javascript unsafe - "new Uint16Array($1)" - js_uint16ArrayFromJSRef :: JSRef () -> SomeUint16Array m -foreign import javascript unsafe - "new Uint32Array($1)" - js_uint32ArrayFromJSRef :: JSRef () -> SomeUint32Array m -foreign import javascript unsafe - "new Float32Array($1)" - js_float32ArrayFromJSRef :: JSRef () -> SomeFloat32Array m -foreign import javascript unsafe - "new Float64Array($1)" - js_float64ArrayFromJSRef :: JSRef () -> SomeFloat64Array m +----------------------------------------------------------------------------- +-- All mutable data functions +----------------------------------------------------------------------------- +#define CREATEFUNCTIONS(T , JSName, JSArray, JSSize) \ +foreign import javascript unsafe "new JSArray($1)" js_createM/**/T/**/Array :: Int -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_createM/**/T/**/Array #-};\ +foreign import javascript unsafe "new JSArray($1).fill($2)" js_fillNewM/**/T/**/Array :: Int -> T -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fillNewM/**/T/**/Array #-};\ +foreign import javascript unsafe "var arr = h$fromListPrim($1); $r = new JSArray(arr.length); $r.set(arr);" js_fromListM/**/T/**/Array :: Exts.Any -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromListM/**/T/**/Array #-};\ +foreign import javascript unsafe "$r = new JSArray($1.length); $r.set($1);" js_fromArrayM/**/T/**/Array :: SomeTypedArray m0 t -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromArrayM/**/T/**/Array #-};\ +foreign import javascript unsafe "$3[$1] = $2" js_setIndex/**/T/**/Array :: Int -> T -> SomeTypedArray m T -> State# s -> (# State# s, () #); {-# INLINE js_setIndex/**/T/**/Array #-};\ +foreign import javascript unsafe "$3.set(h$fromListPrim($2), $1)" js_setList/**/T/**/Array :: Int -> Exts.Any -> SomeTypedArray m T -> State# s -> (# State# s, () #); {-# INLINE js_setList/**/T/**/Array #-};\ +foreign import javascript unsafe "$3.set($2, $1)" js_setArray/**/T/**/Array :: Int -> SomeTypedArray m0 t -> SomeTypedArray m T -> State# s -> (# State# s, () #); {-# INLINE js_setArray/**/T/**/Array #-}; + +CREATEFUNCTIONS(Int,Int32,Int32Array,4) +CREATEFUNCTIONS(Int32,Int32,Int32Array,4) +CREATEFUNCTIONS(Int16,Int16,Int16Array,2) +CREATEFUNCTIONS(Int8,Int8,Int8Array,1) +CREATEFUNCTIONS(Word,Uint32,Uint32Array,4) +CREATEFUNCTIONS(Word32,Uint32,Uint32Array,4) +CREATEFUNCTIONS(Word16,Uint16,Uint16Array,2) +CREATEFUNCTIONS(Word8,Uint8,Uint8Array,1) +CREATEFUNCTIONS(Float,Float32,Float32Array,4) +CREATEFUNCTIONS(Double,Float64,Float64Array,8) +CREATEFUNCTIONS(CChar,Int8,Int8Array,1) +CREATEFUNCTIONS(CSChar,Int8,Int8Array,1) +CREATEFUNCTIONS(CUChar,Uint8,Uint8Array,1) +CREATEFUNCTIONS(CShort,Int16,Int16Array,2) +CREATEFUNCTIONS(CUShort,Uint16,Uint16Array,2) +CREATEFUNCTIONS(CInt,Int32,Int32Array,4) +CREATEFUNCTIONS(CUInt,Uint32,Uint32Array,4) +CREATEFUNCTIONS(CLong,Int32,Int32Array,4) +CREATEFUNCTIONS(CULong,Uint32,Uint32Array,4) +CREATEFUNCTIONS(CFloat,Float32,Float32Array,4) +CREATEFUNCTIONS(CDouble,Float64,Float64Array,8) +CREATEFUNCTIONS(Word8Clamped,Uint8Clamped,Uint8ClampedArray,1) + +-- js_getIndexXXXArray operation for newtypes + +#define CREATEGETFUNCTION(T , JSName, JSArray, JSSize) \ +foreign import javascript unsafe "$2[$1]" js_getIndex/**/T/**/Array :: Int -> SomeTypedArray m T -> State# s -> (# State# s, T #); {-# INLINE js_getIndex/**/T/**/Array #-}; + +CREATEGETFUNCTION(Int,Int32,Int32Array,4) +CREATEGETFUNCTION(Int32,Int32,Int32Array,4) +CREATEGETFUNCTION(Int16,Int16,Int16Array,2) +CREATEGETFUNCTION(Int8,Int8,Int8Array,1) +CREATEGETFUNCTION(Word,Uint32,Uint32Array,4) +CREATEGETFUNCTION(Word32,Uint32,Uint32Array,4) +CREATEGETFUNCTION(Word16,Uint16,Uint16Array,2) +CREATEGETFUNCTION(Word8,Uint8,Uint8Array,1) +CREATEGETFUNCTION(Float,Float32,Float32Array,4) +CREATEGETFUNCTION(Double,Float64,Float64Array,8) + +#define CREATEGETFUNCTIONNT(T , T2, JSName, JSArray, JSSize) \ +{-# INLINE js_getIndex/**/T/**/Array #-};\ +js_getIndex/**/T/**/Array :: Int -> SomeTypedArray m T -> State# s -> (# State# s, T #);\ +js_getIndex/**/T/**/Array i arr s = case js_getIndex/**/T2/**/Array i (coerce arr) s of { (# s1, v #) -> (# s1, coerce v #) } + +CREATEGETFUNCTIONNT(CChar,Int8,Int8,Int8Array,1) +CREATEGETFUNCTIONNT(CSChar,Int8,Int8,Int8Array,1) +CREATEGETFUNCTIONNT(CUChar,Word8,Uint8,Uint8Array,1) +CREATEGETFUNCTIONNT(CShort,Int16,Int16,Int16Array,2) +CREATEGETFUNCTIONNT(CUShort,Word16,Uint16,Uint16Array,2) +CREATEGETFUNCTIONNT(CInt,Int32,Int32,Int32Array,4) +CREATEGETFUNCTIONNT(CUInt,Word32,Uint32,Uint32Array,4) +CREATEGETFUNCTIONNT(CLong,Int32,Int32,Int32Array,4) +CREATEGETFUNCTIONNT(CULong,Word32,Uint32,Uint32Array,4) +CREATEGETFUNCTIONNT(CFloat,Float,Float32,Float32Array,4) +CREATEGETFUNCTIONNT(CDouble,Double,Float64,Float64Array,8) +CREATEGETFUNCTIONNT(Word8Clamped,Word8,Uint8Clamped,Uint8ClampedArray,1) + + +----------------------------------------------------------------------------- +-- Conversions between types +----------------------------------------------------------------------------- + +{-# INLINE js_wrapImmutableArrayBuffer #-}; +foreign import javascript unsafe + "h$wrapBuffer" js_wrapImmutableArrayBuffer :: SomeArrayBuffer m -> ByteArray# +{-# INLINE js_unwrapImmutableArrayBuffer #-}; +foreign import javascript unsafe + "h$wrapBuffer" js_unwrapImmutableArrayBuffer :: ByteArray# -> SomeArrayBuffer m +{-# INLINE js_wrapArrayBuffer #-}; +foreign import javascript unsafe + "h$wrapBuffer" js_wrapArrayBuffer :: SomeArrayBuffer any -> State# s -> (# State# s, MutableByteArray# s #) +{-# INLINE js_unwrapArrayBuffer #-}; +foreign import javascript unsafe + "h$wrapBuffer" js_unwrapArrayBuffer :: MutableByteArray# s -> State# s -> (# State# s, SomeArrayBuffer any #) + +{-# INLINE js_wrapImmutableArrayBufferView #-}; +foreign import javascript unsafe + "h$wrapBuffer($1.buffer)" js_wrapImmutableArrayBufferView :: JSVal -> ByteArray# +{-# INLINE js_wrapArrayBufferView #-}; +foreign import javascript unsafe + "h$wrapBuffer($1.buffer)" js_wrapArrayBufferView :: JSVal -> State# s -> (# State# s, MutableByteArray# s #) + +{-# INLINE js_unwrapImmutableDataView #-}; +foreign import javascript unsafe + "$1.dv" js_unwrapImmutableDataView :: ByteArray# -> SomeDataView m +{-# INLINE js_unwrapDataView #-}; +foreign import javascript unsafe + "$1.dv" js_unwrapDataView :: MutableByteArray# s -> State# s -> (# State# s, SomeDataView m #) + +#define CREATECONVERTERS(T, JSPType, JSName, JSArray, JSSize) \ +foreign import javascript unsafe "$1.JSPType || new JSArray($1.buf)" js_unwrapImmutable/**/T/**/Array :: ByteArray# -> SomeTypedArray m T; {-# INLINE js_unwrapImmutable/**/T/**/Array #-};\ +foreign import javascript unsafe "$1.JSPType || new JSArray($1.buf)" js_unwrap/**/T/**/Array :: MutableByteArray# s -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_unwrap/**/T/**/Array #-}; + + +CREATECONVERTERS(Int,i3,Int32,Int32Array,4) +CREATECONVERTERS(Int32,i3,Int32,Int32Array,4) +CREATECONVERTERS(Int16,i1,Int16,Int16Array,2) +CREATECONVERTERS(Int8,i8,Int8,Int8Array,1) +CREATECONVERTERS(Word,u3,Uint32,Uint32Array,4) +CREATECONVERTERS(Word32,u3,Uint32,Uint32Array,4) +CREATECONVERTERS(Word16,u1,Uint16,Uint16Array,2) +CREATECONVERTERS(Word8,u8,Uint8,Uint8Array,1) +CREATECONVERTERS(Float,f3,Float32,Float32Array,4) +CREATECONVERTERS(Double,f6,Float64,Float64Array,8) +CREATECONVERTERS(CChar,i8,Int8,Int8Array,1) +CREATECONVERTERS(CSChar,i8,Int8,Int8Array,1) +CREATECONVERTERS(CUChar,u8,Uint8,Uint8Array,1) +CREATECONVERTERS(CShort,i1,Int16,Int16Array,2) +CREATECONVERTERS(CUShort,u1,Uint16,Uint16Array,2) +CREATECONVERTERS(CInt,i3,Int32,Int32Array,4) +CREATECONVERTERS(CUInt,u3,Uint32,Uint32Array,4) +CREATECONVERTERS(CLong,i3,Int32,Int32Array,4) +CREATECONVERTERS(CULong,u3,Uint32,Uint32Array,4) +CREATECONVERTERS(CFloat,f3,Float32,Float32Array,4) +CREATECONVERTERS(CDouble,f6,Float64,Float64Array,8) +CREATECONVERTERS(Word8Clamped,uc,Uint8Clamped,Uint8ClampedArray,1) + +----------------------------------------------------------------------------- +-- All immutable data functions +----------------------------------------------------------------------------- + +#define JSTYPEDARRAY(T , JSName, JSArray, JSSize) \ +foreign import javascript unsafe "new JSArray($1)" js_create/**/T/**/Array :: Int -> SomeTypedArray m T; {-# INLINE js_create/**/T/**/Array #-};\ +foreign import javascript unsafe "new JSArray($1).fill($2)" js_fillNew/**/T/**/Array :: Int -> T -> SomeTypedArray m T; {-# INLINE js_fillNew/**/T/**/Array #-};\ +foreign import javascript unsafe "var arr = h$fromListPrim($1); $r = new JSArray(arr.length); $r.set(arr);" js_fromList/**/T/**/Array :: Exts.Any -> SomeTypedArray m T; {-# INLINE js_fromList/**/T/**/Array #-};\ +foreign import javascript unsafe "$r = new JSArray($1.length); $r.set($1);" js_fromArray/**/T/**/Array :: SomeTypedArray m0 t -> SomeTypedArray m T; {-# INLINE js_fromArray/**/T/**/Array #-};\ +foreign import javascript unsafe "new JSArray($1)" js_view/**/T/**/Array :: SomeArrayBuffer m -> SomeTypedArray m T; {-# INLINE js_view/**/T/**/Array #-};\ +foreign import javascript unsafe "$r = $1[$2]" js_index/**/T/**/Array :: SomeTypedArray m T -> Int -> T; {-# INLINE js_index/**/T/**/Array #-};\ +foreign import javascript unsafe "$3.indexOf($2,$1)" js_indexOf/**/T/**/Array :: Int -> T -> SomeTypedArray m T -> Int; {-# INLINE js_indexOf/**/T/**/Array #-};\ +foreign import javascript unsafe "$3.lastIndexOf($2,$1)" js_lastIndexOf/**/T/**/Array :: Int -> T -> SomeTypedArray m T -> Int; {-# INLINE js_lastIndexOf/**/T/**/Array #-}; + +JSTYPEDARRAY(Int,Int32,Int32Array,4) +JSTYPEDARRAY(Int32,Int32,Int32Array,4) +JSTYPEDARRAY(Int16,Int16,Int16Array,2) +JSTYPEDARRAY(Int8,Int8,Int8Array,1) +JSTYPEDARRAY(Word,Uint32,Uint32Array,4) +JSTYPEDARRAY(Word32,Uint32,Uint32Array,4) +JSTYPEDARRAY(Word16,Uint16,Uint16Array,2) +JSTYPEDARRAY(Word8,Uint8,Uint8Array,1) +JSTYPEDARRAY(Word8Clamped,Uint8Clamped,Uint8ClampedArray,1) +JSTYPEDARRAY(Float,Float32,Float32Array,4) +JSTYPEDARRAY(Double,Float64,Float64Array,8) +JSTYPEDARRAY(CChar,Int8,Int8Array,1) +JSTYPEDARRAY(CSChar,Int8,Int8Array,1) +JSTYPEDARRAY(CUChar,Uint8,Uint8Array,1) +JSTYPEDARRAY(CShort,Int16,Int16Array,2) +JSTYPEDARRAY(CUShort,Uint16,Uint16Array,2) +JSTYPEDARRAY(CInt,Int32,Int32Array,4) +JSTYPEDARRAY(CUInt,Uint32,Uint32Array,4) +JSTYPEDARRAY(CLong,Int32,Int32Array,4) +JSTYPEDARRAY(CULong,Uint32,Uint32Array,4) +JSTYPEDARRAY(CFloat,Float32,Float32Array,4) +JSTYPEDARRAY(CDouble,Float64,Float64Array,8) + +----------------------------------------------------------------------------- +-- All DataView functions +----------------------------------------------------------------------------- + +#define DATAVIEW(T, JSget, JSset, JSSize) \ +foreign import javascript unsafe "$2.JSget($1)" js_i_unsafeGet/**/T/**/BE :: Int -> DataView -> T;{-# INLINE js_i_unsafeGet/**/T/**/BE #-};\ +foreign import javascript unsafe "$2.JSget($1,true)" js_i_unsafeGet/**/T/**/LE :: Int -> DataView -> T;{-# INLINE js_i_unsafeGet/**/T/**/LE #-};\ +foreign import javascript safe "$2.JSget($1)" js_i_safeGet/**/T/**/BE :: Int -> DataView -> T;{-# INLINE js_i_safeGet/**/T/**/BE #-};\ +foreign import javascript safe "$2.JSget($1,true)" js_i_safeGet/**/T/**/LE :: Int -> DataView -> T;{-# INLINE js_i_safeGet/**/T/**/LE #-};\ +foreign import javascript unsafe "$2.JSget($1)" js_m_unsafeGet/**/T/**/BE :: Int -> SomeDataView m -> State# s -> (# State# s, T #);{-# INLINE js_m_unsafeGet/**/T/**/BE #-};\ +foreign import javascript unsafe "$2.JSget($1,true)" js_m_unsafeGet/**/T/**/LE :: Int -> SomeDataView m -> State# s -> (# State# s, T #);{-# INLINE js_m_unsafeGet/**/T/**/LE #-};\ +foreign import javascript safe "$2.JSget($1)" js_m_safeGet/**/T/**/BE :: Int -> SomeDataView m -> State# s -> (# State# s, T #);{-# INLINE js_m_safeGet/**/T/**/BE #-};\ +foreign import javascript safe "$2.JSget($1,true)" js_m_safeGet/**/T/**/LE :: Int -> SomeDataView m -> State# s -> (# State# s, T #);{-# INLINE js_m_safeGet/**/T/**/LE #-};\ +foreign import javascript unsafe "$3.JSset($1,$2)" js_unsafeSet/**/T/**/BE :: Int -> T -> SomeDataView m -> State# s -> (# State# s, () #);{-# INLINE js_unsafeSet/**/T/**/BE #-};\ +foreign import javascript unsafe "$3.JSset($1,$2,true)" js_unsafeSet/**/T/**/LE :: Int -> T -> SomeDataView m -> State# s -> (# State# s, () #);{-# INLINE js_unsafeSet/**/T/**/LE #-};\ +foreign import javascript safe "$3.JSset($1,$2)" js_safeSet/**/T/**/BE :: Int -> T -> SomeDataView m -> State# s -> (# State# s, () #);{-# INLINE js_safeSet/**/T/**/BE #-};\ +foreign import javascript safe "$3.JSset($1,$2,true)" js_safeSet/**/T/**/LE :: Int -> T -> SomeDataView m -> State# s -> (# State# s, () #);{-# INLINE js_safeSet/**/T/**/LE #-}; + +#define DATAVIEW8(T, JSget, JSset, JSSize) \ +foreign import javascript unsafe "$2.JSget($1)" js_i_unsafeGet/**/T :: Int -> DataView -> T;{-# INLINE js_i_unsafeGet/**/T #-};\ +foreign import javascript safe "$2.JSget($1)" js_i_safeGet/**/T :: Int -> DataView -> T;{-# INLINE js_i_safeGet/**/T #-};\ +foreign import javascript unsafe "$2.JSget($1)" js_m_unsafeGet/**/T :: Int -> SomeDataView m -> State# s -> (# State# s, T #);{-# INLINE js_m_unsafeGet/**/T #-};\ +foreign import javascript safe "$2.JSget($1)" js_m_safeGet/**/T :: Int -> SomeDataView m -> State# s -> (# State# s, T #);{-# INLINE js_m_safeGet/**/T #-};\ +foreign import javascript unsafe "$3.JSset($1,$2)" js_unsafeSet/**/T :: Int -> T -> SomeDataView m -> State# s -> (# State# s, () #);{-# INLINE js_unsafeSet/**/T #-};\ +foreign import javascript safe "$3.JSset($1,$2)" js_safeSet/**/T :: Int -> T -> SomeDataView m -> State# s -> (# State# s, () #);{-# INLINE js_safeSet/**/T #-}; + + +DATAVIEW(Int,getInt32,setInt32,4) +DATAVIEW(Int32,getInt32,setInt32,4) +DATAVIEW(Int16,getInt16,setInt16,2) +DATAVIEW(Word,getUint32,setUint32,4) +DATAVIEW(Word32,getUint32,setUint32,4) +DATAVIEW(Word16,getUint16,setUint16,2) +DATAVIEW(Float,getFloat32,setFloat32,4) +DATAVIEW(Double,getFloat64,setFloat64,8) +--DATAVIEW(CShort,getInt16,setInt16,2) +--DATAVIEW(CUShort,getUint16,setUint16,2) +--DATAVIEW(CInt,getInt32,setInt32,4) +--DATAVIEW(CUInt,getUint32,setUint32,4) +--DATAVIEW(CLong,getInt32,setInt32,4) +--DATAVIEW(CULong,getUint32,setUint32,4) +--DATAVIEW(CFloat,getFloat32,setFloat32,4) +--DATAVIEW(CDouble,getFloat64,setFloat64,8) + + +DATAVIEW8(Word8,getUint8,setUint8,1) +DATAVIEW8(Int8,getInt8,setInt8,1) +--DATAVIEW8(CChar,getInt8,setInt8,1) +--DATAVIEW8(CSChar,getInt8,setInt8,1) +--DATAVIEW8(CUChar,getUint8,setUint8,1) + +----------------------------------------------------------------------------- +-- Misc +----------------------------------------------------------------------------- + +seqList :: [a] -> [a] +seqList xs = go xs `seq` xs + where go (x:ss) = x `seq` go ss + go [] = () diff --git a/JavaScript/TypedArray/Internal/Types.hs b/JavaScript/TypedArray/Internal/Types.hs deleted file mode 100644 index b752bd0..0000000 --- a/JavaScript/TypedArray/Internal/Types.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE EmptyDataDecls, DeriveDataTypeable, TypeFamilies, DataKinds, PolyKinds #-} - -module JavaScript.TypedArray.Internal.Types where - -import GHCJS.Types -import GHCJS.Internal.Types - -import Data.Int -import Data.Typeable -import Data.Word - -newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) = - SomeTypedArray (JSRef ()) - deriving (Typeable) - -{- -newtype SomeSTTypedArray s e = SomeSTTypedArray (JSRef ()) - deriving (Typeable) --} - -type SomeSTTypedArray s (e :: TypedArrayElem) = SomeTypedArray e (STMutable s) - --- ----------------------------------------------------------------------------- - -data TypedArrayElem = Int8Elem - | Int16Elem - | Int32Elem - | Uint8Elem - | Uint16Elem - | Uint32Elem - | Uint8ClampedElem - | Float32Elem - | Float64Elem - --- ----------------------------------------------------------------------------- - -type SomeInt8Array = SomeTypedArray Int8Elem -type SomeInt16Array = SomeTypedArray Int16Elem -type SomeInt32Array = SomeTypedArray Int32Elem - -type SomeUint8Array = SomeTypedArray Uint8Elem -type SomeUint16Array = SomeTypedArray Uint16Elem -type SomeUint32Array = SomeTypedArray Uint32Elem - -type SomeFloat32Array = SomeTypedArray Float32Elem -type SomeFloat64Array = SomeTypedArray Float64Elem - -type SomeUint8ClampedArray = SomeTypedArray Uint8ClampedElem - --- ----------------------------------------------------------------------------- - -type Int8Array = SomeInt8Array Immutable -type Int16Array = SomeInt16Array Immutable -type Int32Array = SomeInt32Array Immutable - -type Uint8Array = SomeUint8Array Immutable -type Uint16Array = SomeUint16Array Immutable -type Uint32Array = SomeUint32Array Immutable - -type Uint8ClampedArray = SomeUint8ClampedArray Immutable - -type Float32Array = SomeFloat32Array Immutable -type Float64Array = SomeFloat64Array Immutable - --- ----------------------------------------------------------------------------- - -type IOInt8Array = SomeInt8Array Mutable -type IOInt16Array = SomeInt16Array Mutable -type IOInt32Array = SomeInt32Array Mutable - -type IOUint8Array = SomeUint8Array Mutable -type IOUint16Array = SomeUint16Array Mutable -type IOUint32Array = SomeUint32Array Mutable - -type IOUint8ClampedArray = SomeUint8ClampedArray Mutable - -type IOFloat32Array = SomeFloat32Array Mutable -type IOFloat64Array = SomeFloat64Array Mutable - --- ----------------------------------------------------------------------------- - -type STInt8Array s = SomeSTTypedArray s Int8Elem -type STInt16Array s = SomeSTTypedArray s Int16Elem -type STInt32Array s = SomeSTTypedArray s Int32Elem - -type STUint8Array s = SomeSTTypedArray s Uint8Elem -type STUint16Array s = SomeSTTypedArray s Uint16Elem -type STUint32Array s = SomeSTTypedArray s Uint32Elem - -type STFloat32Array s = SomeSTTypedArray s Float32Elem -type STFloat64Array s = SomeSTTypedArray s Float64Elem - -type STUint8ClampedArray s = SomeSTTypedArray s Uint8ClampedElem - --- ----------------------------------------------------------------------------- - -type family Elem x where - Elem (SomeUint8Array m) = Word8 - Elem (SomeUint8ClampedArray m) = Word8 - Elem (SomeUint16Array m) = Word16 - Elem (SomeUint32Array m) = Word - Elem (SomeInt8Array m) = Int8 - Elem (SomeInt16Array m) = Int16 - Elem (SomeInt32Array m) = Int - 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 index 6fbe27a..dbc5a76 100644 --- a/JavaScript/TypedArray/ST.hs +++ b/JavaScript/TypedArray/ST.hs @@ -1,120 +1,253 @@ -{-# LANGUAGE MagicHash, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} - -module JavaScript.TypedArray.ST - ( {- STTypedArray(..) - , -} STInt8Array, STInt16Array, STInt32Array - , STUint8Array, STUint16Array, STUint32Array - , STFloat32Array, STFloat64Array - , STUint8ClampedArray - , length - , byteLength - , byteOffset - , buffer - , subarray - ) where - - -import Prelude ( Maybe, undefined ) - -import GHC.Exts +{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} +----------------------------------------------------------------------------- +-- | +-- Module : JavaScript.TypedArray.ST +-- +-- Maintainer : Artem Chirkin +-- Stability : experimental +-- Portability : +-- +-- Mutable operatons on JavaScript typed arrays in ST monad +-- +----------------------------------------------------------------------------- + +module JavaScript.TypedArray.ST where + + +-- import qualified GHC.Types as Exts import GHC.ST -import GHC.Int -import GHC.Word -import GHCJS.Types +import Control.Monad.Primitive (PrimState (..)) + +import Data.Word +import Data.Int +import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray (..)) +import Foreign.C.Types +import Unsafe.Coerce (unsafeCoerce) -import GHCJS.Buffer.Types -import GHCJS.Prim import GHCJS.Internal.Types -import qualified Data.ByteString as B -import Data.Primitive.ByteArray - -import qualified JavaScript.Array.Internal as JSA - -import qualified JavaScript.TypedArray.Internal as I -import JavaScript.TypedArray.Internal ( length, byteLength, byteOffset, buffer, subarray ) -import JavaScript.TypedArray.Internal.Types -import JavaScript.TypedArray.ArrayBuffer.Internal - ( SomeArrayBuffer, MutableArrayBuffer, STArrayBuffer ) -import JavaScript.TypedArray.DataView.Internal ( SomeDataView ) - -class STTypedArray s a where - unsafeIndex :: Int -> a -> ST s (Elem a) - index :: Int -> a -> ST s (Elem a) - unsafeSetIndex :: Int -> Elem a -> a -> ST s () - setIndex :: Int -> Elem a -> a -> ST s () - create :: Int -> ST s a --- fromArray :: JSArray e -> ST s a - fromBuffer :: STArrayBuffer s -> Int -> Maybe Int -> ST s a - indexOf :: Int -> Elem a -> a -> ST s Int - lastIndexOf :: Int -> Elem a -> a -> ST s Int - -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) - fromBuffer = undefined - lastIndexOf s (I8# x) a = ST (I.lastIndexOfI s x a) - create l = ST (I.js_createInt8Array l) - --- --------------------------------------------------------------------------- -{- -setIndexI :: SomeTypedArray e m -> Int -> Int# -> ST s () -setIndexI a i x = ST (I.js_setIndexI a i x) -{-# INLINE setIndexI #-} - -unsafeSetIndexI :: SomeTypedArray e m -> Int -> Int# -> ST s () -unsafeSetIndexI a i x = ST (I.js_unsafeSetIndexI a i x) -{-# INLINE unsafeSetIndexI #-} - -setIndexW :: SomeTypedArray e m -> Int -> Word# -> ST s () -setIndexW a i x = ST (I.js_setIndexW a i x) -{-# INLINE setIndexW #-} - -unsafeSetIndexW :: SomeTypedArray e m -> Int -> Word# -> ST s () -unsafeSetIndexW a i x = ST (I.js_unsafeSetIndexW a i x) -{-# INLINE unsafeSetIndexW #-} - -indexOfI :: SomeTypedArray e m -> Int# -> ST s Int -indexOfI a x = ST (I.js_indexOfI a x) -{-# INLINE indexOfI #-} - -indexOfW :: SomeTypedArray e m -> Word# -> ST s Int -indexOfW a x = ST (I.js_indexOfW a x) -{-# INLINE indexOfW #-} --} --- --------------------------------------------------------------------------- -{- -length :: SomeSTTypedArray s e -> Int -length x = I.length x -- ST (I.js_length x) -{-# INLINE length #-} - -byteLength :: SomeSTTypedArray s e -> Int -byteLength x = ST (I.js_byteLength x) -{-# INLINE byteLength #-} - -byteOffset :: SomeSTTypedArray s e -> Int -byteOffset x = ST (I.js_byteOffset x) -{-# INLINE byteOffset #-} - -buffer :: SomeSTTypedArray s e -> STArrayBuffer s -buffer x = ST (I.js_buffer x) -{-# INLINE buffer #-} - -subarray :: Int -> Int -> SomeSTTypedArray s e -> SomeSTTypedArray s e -subarray begin end x = ST (I.js_subarray begin end x) -{-# INLINE subarray #-} - --- fixme convert JSException to Haskell exception -set :: SomeSTTypedArray s e -> Int -> SomeSTTypedArray s e -> ST s () -set src offset dest = ST (I.js_set src offset dest) -{-# INLINE set #-} - -unsafeSet :: SomeSTTypedArray s e -> Int -> SomeSTTypedArray s e -> ST s () -unsafeSet src offset dest = ST (I.js_unsafeSet src offset dest) -{-# INLINE unsafeSet #-} - --} +import JavaScript.TypedArray +import JavaScript.TypedArray.Types +import JavaScript.TypedArray.Internal + +----------------------------------------------------------------------------- +-- | mutable typed arrays +----------------------------------------------------------------------------- + +class STTypedArrayOperations a where + -- | Init a new typed array filled with zeroes + newSTTypedArray :: Int -> ST s (STTypedArray s a) + -- | Fill a new typed array with a given value + fillNewSTTypedArray :: Int -> a -> ST s (STTypedArray s a) + -- | Create a new typed array from list + newFromList :: [a] -> ST s (STTypedArray s a) + -- | Create a new typed array from elements of another typed array + newFromArray :: SomeTypedArray (m :: MutabilityType sk) b -> ST s (STTypedArray s a) + -- | Get value from array at specified index + index :: Int -> STTypedArray s a -> ST s a + -- | Set value into array at specified index + setIndex ::Int -> a -> STTypedArray s a -> ST s () + -- | Set list into array with specified offset + setList :: Int -> [a] -> STTypedArray s a -> ST s () + -- | Set array elements into array with specified offset + setArray :: Int -> SomeTypedArray (m :: MutabilityType sk) b -> STTypedArray s a -> ST s () + + +#define TYPEDARRAY(T,JSType,JSSize)\ +instance STTypedArrayOperations T where{\ + {-# INLINE newSTTypedArray #-};\ + newSTTypedArray n = ST (js_createM/**/T/**/Array n);\ + {-# INLINE fillNewSTTypedArray #-};\ + fillNewSTTypedArray n v = ST (js_fillNewM/**/T/**/Array n v);\ + {-# INLINE newFromList #-};\ + newFromList xs = ST (js_fromListM/**/T/**/Array . unsafeCoerce . seqList $ xs);\ + {-# INLINE newFromArray #-};\ + newFromArray arr = ST (js_fromArrayM/**/T/**/Array arr);\ + {-# INLINE index #-};\ + index i arr = ST (js_getIndex/**/T/**/Array i arr);\ + {-# INLINE setIndex #-};\ + setIndex i v arr = ST (js_setIndex/**/T/**/Array i v arr);\ + {-# INLINE setList #-};\ + setList offset xs arr = ST (js_setList/**/T/**/Array offset (unsafeCoerce $ seqList xs) arr);\ + {-# INLINE setArray #-};\ + setArray offset ar0 arr = ST (js_setArray/**/T/**/Array offset ar0 arr)} + + +TYPEDARRAY(Int,Int32,4) +TYPEDARRAY(Int32,Int32,4) +TYPEDARRAY(Int16,Int16,2) +TYPEDARRAY(Int8,Int8,1) +TYPEDARRAY(Word,Uint32,4) +TYPEDARRAY(Word32,Uint32,4) +TYPEDARRAY(Word16,Uint16,2) +TYPEDARRAY(Word8,Uint8,1) +TYPEDARRAY(Word8Clamped,Uint8Clamped,1) +TYPEDARRAY(Float,Float32,4) +TYPEDARRAY(Double,Float64,8) +TYPEDARRAY(CChar,Int8,1) +TYPEDARRAY(CSChar,Int8,1) +TYPEDARRAY(CUChar,Uint8,1) +TYPEDARRAY(CShort,Int16,2) +TYPEDARRAY(CUShort,Uint16,2) +TYPEDARRAY(CInt,Int32,4) +TYPEDARRAY(CUInt,Uint32,4) +TYPEDARRAY(CLong,Int32,4) +TYPEDARRAY(CULong,Uint32,4) +TYPEDARRAY(CFloat,Float32,4) +TYPEDARRAY(CDouble,Float64,8) + + +----------------------------------------------------------------------------- +-- | mutable anything +----------------------------------------------------------------------------- + + + + +class STArrayBufferData s mutable any | any s -> mutable where + -- | Slice array (elements) or buffer (bytes). + -- See documentation on TypedArray.prototype.slice() and ArrayBuffer.prototype.slice() + slice :: Int -> Maybe Int -> any -> ST s mutable + + +class ( MutableArrayBufferPrim mutable + ) => STArrayBufferConversions s immutable mutable + | s immutable -> mutable + , mutable -> immutable s where + -- | Create an immutable data by copying a mutable data + freeze :: mutable -> ST s immutable + -- | Create an immutable data from a mutable data without + -- copying. The result shares the buffer with the argument, do not modify + -- the data in the original buffer after freezing + unsafeFreeze :: mutable -> ST s immutable + -- | Create a mutable data by copying an immutable data + thaw :: immutable -> ST s mutable + -- | Create a mutable data from an immutable data without + -- copying. The result shares the buffer with the argument. + unsafeThaw :: immutable -> ST s mutable + -- | Convert from MutableByteArray without copying data + fromMutableByteArray :: MutableByteArray (PrimState (ST s)) -> ST s mutable + fromMutableByteArray (MutableByteArray ba) = ST (fromMutableByteArrayPrim ba) + {-# INLINE fromMutableByteArray #-} + -- | Convert to MutableByteArray without copying data + toMutableByteArray :: mutable -> ST s (MutableByteArray (PrimState (ST s))) + toMutableByteArray b = ST $ \s -> + case toMutableByteArrayPrim b s of (# s1, ba #) -> (# s1, MutableByteArray ba #) + {-# INLINE toMutableByteArray #-} + + +instance STArrayBufferData s (STArrayBuffer s) (SomeArrayBuffer m) where + {-# INLINE slice #-} + slice i0 Nothing (SomeArrayBuffer b) = fmap SomeArrayBuffer . ST $ js_slice1 i0 b + slice i0 (Just i1) (SomeArrayBuffer b) = fmap SomeArrayBuffer . ST $ js_slice i0 i1 b + +instance STArrayBufferConversions s ArrayBuffer (STArrayBuffer s) where + {-# INLINE freeze #-} + freeze (SomeArrayBuffer b) = fmap SomeArrayBuffer (ST (js_slice1 0 b)) + {-# INLINE unsafeFreeze #-} + unsafeFreeze (SomeArrayBuffer b) = pure (SomeArrayBuffer b) + {-# INLINE thaw #-} + thaw (SomeArrayBuffer b) = fmap SomeArrayBuffer (ST (js_slice1 0 b)) + {-# INLINE unsafeThaw #-} + unsafeThaw (SomeArrayBuffer b) = pure (SomeArrayBuffer b) + + +instance STArrayBufferData s (STTypedArray s t) (SomeTypedArray m t) where + {-# INLINE slice #-} + slice i0 Nothing (SomeTypedArray b) = fmap SomeTypedArray . ST $ js_slice1 i0 b + slice i0 (Just i1) (SomeTypedArray b) = fmap SomeTypedArray . ST $ js_slice i0 i1 b + +instance ( MutableArrayBufferPrim (STTypedArray s t) + ) => STArrayBufferConversions s (TypedArray t) (STTypedArray s t) where + {-# INLINE freeze #-} + freeze (SomeTypedArray b) = fmap SomeTypedArray (ST (js_slice1 0 b)) + {-# INLINE unsafeFreeze #-} + unsafeFreeze (SomeTypedArray b) = pure (SomeTypedArray b) + {-# INLINE thaw #-} + thaw (SomeTypedArray b) = fmap SomeTypedArray (ST (js_slice1 0 b)) + {-# INLINE unsafeThaw #-} + unsafeThaw (SomeTypedArray b) = pure (SomeTypedArray b) + + +instance STArrayBufferConversions s DataView (STDataView s) where + {-# INLINE freeze #-} + freeze dv = ST (js_cloneDataView dv) + {-# INLINE unsafeFreeze #-} + unsafeFreeze (SomeDataView b) = pure (SomeDataView b) + {-# INLINE thaw #-} + thaw dv = ST (js_cloneDataView dv) + {-# INLINE unsafeThaw #-} + unsafeThaw (SomeDataView b) = pure (SomeDataView b) + +#define DATAVIEW8(T,JSType,JSSize)\ +write/**/T, unsafeWrite/**/T\ + :: Int -> T -> STDataView s -> ST s ();\ +write/**/T idx x dv = ST (js_safeSet/**/T idx x dv);\ +unsafeWrite/**/T idx x dv = ST (js_unsafeSet/**/T idx x dv);\ +{-# INLINE write/**/T #-};\ +{-# INLINE unsafeWrite/**/T #-};\ +read/**/T, unsafeRead/**/T\ + :: Int -> STDataView s -> ST s T;\ +read/**/T idx dv = ST (js_m_safeGet/**/T idx dv);\ +unsafeRead/**/T idx dv = ST (js_m_unsafeGet/**/T idx dv);\ +{-# INLINE read/**/T #-};\ +{-# INLINE unsafeRead/**/T #-}; + +#define DATAVIEW(T,JSType,JSSize)\ +write/**/T/**/LE, write/**/T/**/BE, unsafeWrite/**/T/**/LE, unsafeWrite/**/T/**/BE, write/**/T, unsafeWrite/**/T\ + :: Int -> T -> STDataView s -> ST s ();\ +write/**/T/**/LE idx x dv = ST (js_safeSet/**/T/**/LE idx x dv);\ +write/**/T/**/BE idx x dv = ST (js_safeSet/**/T/**/BE idx x dv);\ +unsafeWrite/**/T/**/LE idx x dv = ST (js_unsafeSet/**/T/**/LE idx x dv);\ +unsafeWrite/**/T/**/BE idx x dv = ST (js_unsafeSet/**/T/**/BE idx x dv);\ +{- | Shortcut for little-endian -};\ +write/**/T = write/**/T/**/LE;\ +{- | Shortcut for little-endian -};\ +unsafeWrite/**/T = unsafeWrite/**/T/**/LE;\ +{-# INLINE write/**/T/**/LE #-};\ +{-# INLINE write/**/T/**/BE #-};\ +{-# INLINE unsafeWrite/**/T/**/LE #-};\ +{-# INLINE unsafeWrite/**/T/**/BE #-};\ +{-# INLINE write/**/T #-};\ +{-# INLINE unsafeWrite/**/T #-};\ +read/**/T/**/LE, read/**/T/**/BE, unsafeRead/**/T/**/LE, unsafeRead/**/T/**/BE, read/**/T, unsafeRead/**/T\ + :: Int -> STDataView s -> ST s T;\ +read/**/T/**/LE idx dv = ST (js_m_safeGet/**/T/**/LE idx dv);\ +read/**/T/**/BE idx dv = ST (js_m_safeGet/**/T/**/BE idx dv);\ +unsafeRead/**/T/**/LE idx dv = ST (js_m_unsafeGet/**/T/**/LE idx dv);\ +unsafeRead/**/T/**/BE idx dv = ST (js_m_unsafeGet/**/T/**/BE idx dv);\ +{- | Shortcut for little-endian -};\ +read/**/T = read/**/T/**/LE;\ +{- | Shortcut for little-endian -};\ +unsafeRead/**/T = unsafeRead/**/T/**/LE;\ +{-# INLINE read/**/T/**/LE #-};\ +{-# INLINE read/**/T/**/BE #-};\ +{-# INLINE unsafeRead/**/T/**/LE #-};\ +{-# INLINE unsafeRead/**/T/**/BE #-};\ +{-# INLINE read/**/T #-};\ +{-# INLINE unsafeRead/**/T #-}; + +DATAVIEW(Int,Int32,4) +DATAVIEW(Int32,Int32,4) +DATAVIEW(Int16,Int16,2) +DATAVIEW(Word,Uint32,4) +DATAVIEW(Word32,Uint32,4) +DATAVIEW(Word16,Uint16,2) +DATAVIEW(Float,Float32,4) +DATAVIEW(Double,Float64,8) + +DATAVIEW8(Word8,Uint8,1) +DATAVIEW8(Int8,Int8,1) + +----------------------------------------------------------------------------- +-- Misc +----------------------------------------------------------------------------- + +-- | Create new array buffer +newSTArrayBuffer :: Int -> ST s (STArrayBuffer s) +newSTArrayBuffer size = ST (js_createArrayBuffer size) + diff --git a/JavaScript/TypedArray/Types.hs b/JavaScript/TypedArray/Types.hs new file mode 100644 index 0000000..ae69b24 --- /dev/null +++ b/JavaScript/TypedArray/Types.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveDataTypeable,GeneralizedNewtypeDeriving, TypeFamilies, CPP #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : JavaScript.TypedArray.Types +-- Copyright : (c) Artem Chirkin +-- License : BSD3 +-- +-- Maintainer : Artem Chirkin +-- Stability : experimental +-- Portability : +-- +-- +----------------------------------------------------------------------------- + +module JavaScript.TypedArray.Types where + + +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Data.Ix (Ix) +import Data.Data (Data) +import Data.Bits (Bits, FiniteBits) +import Foreign.Storable (Storable) + +import GHCJS.Internal.Types +import GHCJS.Marshal.Pure +import GHCJS.Types + +-- | Stub for Uint8ClampedArray in JS +newtype Word8Clamped = Clamped Word8 deriving + (Ord,Num,Eq,Bounded,Enum,Integral,Data,Real,Show,Ix,FiniteBits,Bits,Storable) + + +type TypedArray a = SomeTypedArray 'Immutable a +type STTypedArray s a = SomeTypedArray ('STMutable s) a +type IOTypedArray a = SomeTypedArray 'Mutable a + +-- | Any typed array, mutable or immutable +newtype SomeTypedArray (m :: MutabilityType s) (a :: *) = SomeTypedArray JSVal deriving Typeable +instance IsJSVal (SomeTypedArray m a) + +instance PToJSVal (SomeTypedArray m a) where + pToJSVal (SomeTypedArray v) = v +instance PFromJSVal (SomeTypedArray m a) where + pFromJSVal = SomeTypedArray + +-- | ArrayBuffer, mutable or immutable +newtype SomeArrayBuffer (a :: MutabilityType s) = SomeArrayBuffer JSVal deriving Typeable +instance IsJSVal (SomeArrayBuffer m) + +type ArrayBuffer = SomeArrayBuffer 'Immutable +type IOArrayBuffer = SomeArrayBuffer 'Mutable +type STArrayBuffer s = SomeArrayBuffer ('STMutable s) + +instance PToJSVal (SomeArrayBuffer m) where + pToJSVal (SomeArrayBuffer b) = b +instance PFromJSVal (SomeArrayBuffer m) where + pFromJSVal = SomeArrayBuffer + +-- | Data view on ArrayBuffer, mutable or immutable +newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal deriving Typeable +instance IsJSVal (SomeDataView m) + + +type DataView = SomeDataView 'Immutable +type IODataView = SomeDataView 'Mutable +type STDataView s = SomeDataView ('STMutable s) + +instance PToJSVal (SomeDataView m) where + pToJSVal (SomeDataView b) = b +instance PFromJSVal (SomeDataView m) where + pFromJSVal = SomeDataView + + diff --git a/JavaScript/Web/AnimationFrame.hs b/JavaScript/Web/AnimationFrame.hs index d5f2c5d..d03833b 100644 --- a/JavaScript/Web/AnimationFrame.hs +++ b/JavaScript/Web/AnimationFrame.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, InterruptibleFFI, - DeriveDataTypeable - #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE DeriveDataTypeable #-} {- | Animation frames are the browser's mechanism for smooth animation. @@ -27,29 +28,31 @@ import GHCJS.Types import Control.Exception (onException) import Data.Typeable -newtype AnimationFrameHandle = AnimationFrameHandle (JSRef ()) +newtype AnimationFrameHandle = AnimationFrameHandle JSVal deriving (Typeable) {- | Wait for an animation frame callback to continue running the current thread. Use 'GHCJS.Concurrent.synchronously' if the thread should - not be preempted. + not be preempted. This will return the high-performance clock time + stamp once an animation frame is reached. -} -waitForAnimationFrame :: IO () +waitForAnimationFrame :: IO Double waitForAnimationFrame = do h <- js_makeAnimationFrameHandle js_waitForAnimationFrame h `onException` js_cancelAnimationFrame h {- | Run the action in an animationframe callback. The action runs in a - synchronous thread. + synchronous thread, and is passed the high-performance clock time + stamp for that frame. -} -inAnimationFrame :: OnBlocked -- ^ what to do when encountering a blocking call - -> IO () -- ^ the action to run +inAnimationFrame :: OnBlocked -- ^ what to do when encountering a blocking call + -> (Double -> IO ()) -- ^ the action to run -> IO AnimationFrameHandle inAnimationFrame onBlocked x = do - cb <- syncCallback onBlocked x - h <- js_makeAnimationFrameHandleCallback (pToJSRef cb) + cb <- syncCallback1 onBlocked (x . pFromJSVal) + h <- js_makeAnimationFrameHandleCallback (jsval cb) js_requestAnimationFrame h return h @@ -62,11 +65,11 @@ cancelAnimationFrame h = js_cancelAnimationFrame h foreign import javascript unsafe "{ handle: null, callback: null }" js_makeAnimationFrameHandle :: IO AnimationFrameHandle foreign import javascript unsafe "{ handle: null, callback: $1 }" - js_makeAnimationFrameHandleCallback :: JSRef a -> IO AnimationFrameHandle + js_makeAnimationFrameHandleCallback :: JSVal -> IO AnimationFrameHandle foreign import javascript unsafe "h$animationFrameCancel" js_cancelAnimationFrame :: AnimationFrameHandle -> IO () foreign import javascript interruptible "$1.handle = window.requestAnimationFrame($c);" - js_waitForAnimationFrame :: AnimationFrameHandle -> IO () + 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 index 6e61155..6004687 100644 --- a/JavaScript/Web/Blob/Internal.hs +++ b/JavaScript/Web/Blob/Internal.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DataKinds, KindSignatures, - DeriveDataTypeable, EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} + module JavaScript.Web.Blob.Internal where import Data.Typeable @@ -9,7 +14,7 @@ import GHCJS.Types data BlobType = BlobTypeBlob | BlobTypeFile -newtype SomeBlob (a :: BlobType) = SomeBlob (JSRef ()) deriving Typeable +newtype SomeBlob (a :: BlobType) = SomeBlob JSVal deriving Typeable type File = SomeBlob BlobTypeFile type Blob = SomeBlob BlobTypeBlob diff --git a/JavaScript/Web/Canvas.hs b/JavaScript/Web/Canvas.hs index 70903b1..b256d69 100644 --- a/JavaScript/Web/Canvas.hs +++ b/JavaScript/Web/Canvas.hs @@ -107,11 +107,11 @@ data Repeat = Repeat | NoRepeat deriving (Eq, Ord, Show, Enum, Data, Typeable) -unsafeToCanvas :: JSRef () -> Canvas -unsafeToCanvas r = Canvas (castRef r) +unsafeToCanvas :: JSVal -> Canvas +unsafeToCanvas r = Canvas r {-# INLINE unsafeToCanvas #-} -toCanvas :: JSRef () -> Maybe Canvas +toCanvas :: JSVal -> Maybe Canvas toCanvas x = error "toCanvas" -- fixme {-# INLINE toCanvas #-} @@ -282,7 +282,7 @@ font f ctx = js_font f ctx measureText :: JSString -> Context -> IO Double measureText t ctx = js_measureText t ctx >>= O.getProp "width" - >>= liftM fromJust . fromJSRef + >>= liftM fromJust . fromJSVal {-# INLINE measureText #-} fillRect :: Double -> Double -> Double -> Double -> Context -> IO () @@ -389,9 +389,9 @@ foreign import javascript unsafe "$2.lineCap = $1" js_lineCap :: JSString -> Context -> IO () foreign import javascript unsafe "$2.miterLimit = $1" js_miterLimit :: Double -> Context -> IO () -foreign import javascript unsafe "h$ghcjs_setLineDash($1,$2)" +foreign import javascript unsafe "$2.setLineDash($1)" js_setLineDash :: JSArray -> Context -> IO () -foreign import javascript unsafe "h$ghcjs_lineDashOffset($1,$2)" +foreign import javascript unsafe "$2.lineDashOffset = $1" js_lineDashOffset :: Double -> Context -> IO () foreign import javascript unsafe "$2.font = $1" js_font :: JSString -> Context -> IO () diff --git a/JavaScript/Web/Canvas/ImageData.hs b/JavaScript/Web/Canvas/ImageData.hs index fbebf0d..77f3cf4 100644 --- a/JavaScript/Web/Canvas/ImageData.hs +++ b/JavaScript/Web/Canvas/ImageData.hs @@ -18,7 +18,7 @@ width :: ImageData -> Int width i = js_width i {-# INLINE width #-} -getData :: ImageData -> Uint8ClampedArray +getData :: ImageData -> TypedArray Word8Clamped getData i = js_getData i {-# INLINE getData #-} @@ -29,5 +29,5 @@ foreign import javascript unsafe foreign import javascript unsafe "$1.height" js_height :: ImageData -> Int foreign import javascript unsafe - "$1.data" js_getData :: ImageData -> Uint8ClampedArray + "$1.data" js_getData :: ImageData -> TypedArray Word8Clamped diff --git a/JavaScript/Web/Canvas/Internal.hs b/JavaScript/Web/Canvas/Internal.hs index 8980e97..3c46bdd 100644 --- a/JavaScript/Web/Canvas/Internal.hs +++ b/JavaScript/Web/Canvas/Internal.hs @@ -11,19 +11,18 @@ module JavaScript.Web.Canvas.Internal ( Canvas(..) import GHCJS.Types -data Canvas_ -data Context_ -data Pattern_ -data Gradient_ -data Image_ -data ImageData_ -data TextMetrics_ - -newtype Canvas = Canvas (JSRef Canvas_) -newtype Context = Context (JSRef Context_) -newtype Gradient = Gradient (JSRef Gradient_) -newtype Image = Image (JSRef Image_) -newtype ImageData = ImageData (JSRef ImageData_) -newtype Pattern = Pattern (JSRef Pattern_) -newtype TextMetrics = TextMetrics (JSRef TextMetrics_) +newtype Canvas = Canvas JSVal +newtype Context = Context JSVal +newtype Gradient = Gradient JSVal +newtype Image = Image JSVal +newtype ImageData = ImageData JSVal +newtype Pattern = Pattern JSVal +newtype TextMetrics = TextMetrics JSVal +instance IsJSVal Canvas +instance IsJSVal Context +instance IsJSVal Gradient +instance IsJSVal Image +instance IsJSVal ImageData +instance IsJSVal Pattern +instance IsJSVal TextMetrics diff --git a/JavaScript/Web/CloseEvent/Internal.hs b/JavaScript/Web/CloseEvent/Internal.hs index 095ac55..83e767e 100644 --- a/JavaScript/Web/CloseEvent/Internal.hs +++ b/JavaScript/Web/CloseEvent/Internal.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module JavaScript.Web.CloseEvent.Internal where import GHCJS.Types -newtype CloseEvent = CloseEvent (JSRef ()) +import Data.Typeable + +newtype CloseEvent = CloseEvent JSVal deriving Typeable diff --git a/JavaScript/Web/ErrorEvent.hs b/JavaScript/Web/ErrorEvent.hs index 2ef52bc..ad95631 100644 --- a/JavaScript/Web/ErrorEvent.hs +++ b/JavaScript/Web/ErrorEvent.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} module JavaScript.Web.ErrorEvent ( ErrorEvent , message @@ -32,14 +33,19 @@ colno :: ErrorEvent -> Int colno ee = js_getColno ee {-# INLINE colno #-} -error :: ErrorEvent -> JSRef () +error :: ErrorEvent -> JSVal error ee = js_getError ee {-# INLINE error #-} -- ----------------------------------------------------------------------------- -foreign import javascript unsafe "$1.message" js_getMessage :: ErrorEvent -> JSString -foreign import javascript unsafe "$1.filename" js_getFilename :: ErrorEvent -> JSString -foreign import javascript unsafe "$1.lineno" js_getLineno :: ErrorEvent -> Int -foreign import javascript unsafe "$1.colno" js_getColno :: ErrorEvent -> Int -foreign import javascript unsafe "$1.error" js_getError :: ErrorEvent -> JSRef () +foreign import javascript unsafe "$1.message" + js_getMessage :: ErrorEvent -> JSString +foreign import javascript unsafe "$1.filename" + js_getFilename :: ErrorEvent -> JSString +foreign import javascript unsafe "$1.lineno" + js_getLineno :: ErrorEvent -> Int +foreign import javascript unsafe "$1.colno" + js_getColno :: ErrorEvent -> Int +foreign import javascript unsafe "$1.error" + js_getError :: ErrorEvent -> JSVal diff --git a/JavaScript/Web/ErrorEvent/Internal.hs b/JavaScript/Web/ErrorEvent/Internal.hs index daf269e..db26aa2 100644 --- a/JavaScript/Web/ErrorEvent/Internal.hs +++ b/JavaScript/Web/ErrorEvent/Internal.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module JavaScript.Web.ErrorEvent.Internal where import GHCJS.Types -newtype ErrorEvent = ErrorEvent (JSRef ()) +import Data.Typeable + +newtype ErrorEvent = ErrorEvent JSVal deriving Typeable diff --git a/JavaScript/Web/History.hs b/JavaScript/Web/History.hs new file mode 100644 index 0000000..27574ec --- /dev/null +++ b/JavaScript/Web/History.hs @@ -0,0 +1,3 @@ +module JavaScript.Web.History () where + +-- todo: implement diff --git a/JavaScript/Web/Location.hs b/JavaScript/Web/Location.hs new file mode 100644 index 0000000..7468499 --- /dev/null +++ b/JavaScript/Web/Location.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module JavaScript.Web.Location ( Location + , getWindowLocation + , getHref + , setHref + , getProtocol + , setProtocol + , getHost + , setHost + , getHostname + , setHostname + , getPort + , setPort + , getPathname + , setPathname + , getSearch + , setSearch + , getHash + , setHash + , getUsername + , setUsername + , getPassword + , setPassword + , getOrigin + , assign + , reload + , replace + ) where + +import Data.Typeable + +import Data.JSString (JSString) +import qualified Data.JSString as JSS + +import GHCJS.Types + +newtype Location = Location JSVal deriving (Typeable) +instance IsJSVal Location + +getWindowLocation :: IO Location +getWindowLocation = js_getWindowLocation +{-# INLINE getWindowLocation #-} + +getHref :: Location -> IO JSString +getHref = js_getHref +{-# INLINE getHref #-} + +setHref :: JSString -> Location -> IO () +setHref = js_setHref +{-# INLINE setHref #-} + +getProtocol :: Location -> IO JSString +getProtocol = js_getProtocol +{-# INLINE getProtocol #-} + +setProtocol :: JSString -> Location -> IO () +setProtocol = js_setProtocol +{-# INLINE setProtocol #-} + +getHost :: Location -> IO JSString +getHost = js_getHost +{-# INLINE getHost #-} + +setHost :: JSString -> Location -> IO () +setHost = js_setHost +{-# INLINE setHost #-} + +getHostname :: Location -> IO JSString +getHostname = js_getHostname +{-# INLINE getHostname #-} + +setHostname :: JSString -> Location -> IO () +setHostname = js_setHostname +{-# INLINE setHostname #-} + +getPort :: Location -> IO JSString +getPort = js_getPort +{-# INLINE getPort #-} + +setPort :: JSString -> Location -> IO () +setPort = js_setPort +{-# INLINE setPort #-} + +getPathname :: Location -> IO JSString +getPathname = js_getPathname +{-# INLINE getPathname #-} + +setPathname :: JSString -> Location -> IO () +setPathname = js_setPathname +{-# INLINE setPathname #-} + +getSearch :: Location -> IO JSString +getSearch = js_getSearch +{-# INLINE getSearch #-} + +setSearch :: JSString -> Location -> IO () +setSearch = js_setSearch +{-# INLINE setSearch #-} + +getHash :: Location -> IO JSString +getHash = js_getHash +{-# INLINE getHash #-} + +setHash :: JSString -> Location -> IO () +setHash = js_setHash +{-# INLINE setHash #-} + +getUsername :: Location -> IO JSString +getUsername = js_getUsername +{-# INLINE getUsername #-} + +setUsername :: JSString -> Location -> IO () +setUsername = js_setUsername +{-# INLINE setUsername #-} + +getPassword :: Location -> IO JSString +getPassword = js_getPassword +{-# INLINE getPassword #-} + +setPassword :: JSString -> Location -> IO () +setPassword = js_setPassword +{-# INLINE setPassword #-} + +getOrigin :: Location -> IO JSString +getOrigin = js_getUsername +{-# INLINE getOrigin #-} + +assign :: JSString -> Location -> IO () +assign = js_assign +{-# INLINE assign #-} + +reload :: Bool -> Location -> IO () +reload = js_reload +{-# INLINE reload #-} + +replace :: JSString -> Location -> IO () +replace = js_assign +{-# INLINE replace #-} + +------------------------------------------------------------------------------- + +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 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 "$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 () diff --git a/JavaScript/Web/MessageEvent.hs b/JavaScript/Web/MessageEvent.hs index 14837a3..ab241b3 100644 --- a/JavaScript/Web/MessageEvent.hs +++ b/JavaScript/Web/MessageEvent.hs @@ -4,6 +4,7 @@ #-} module JavaScript.Web.MessageEvent ( MessageEvent + , getData , MessageEventData(..) ) where @@ -16,7 +17,7 @@ import Data.Typeable import JavaScript.Web.MessageEvent.Internal import JavaScript.Web.Blob.Internal (Blob, SomeBlob(..)) -import JavaScript.TypedArray.ArrayBuffer.Internal (ArrayBuffer, SomeArrayBuffer(..)) +import JavaScript.TypedArray import Data.JSString.Internal.Type (JSString(..)) @@ -38,6 +39,5 @@ getData me = case js_getData me of foreign import javascript unsafe "$r2 = $1.data;\ - \$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 2 : 3" - js_getData :: MessageEvent -> (# Int#, JSRef () #) - + \$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 2 : 3)" + js_getData :: MessageEvent -> (# Int#, JSVal #) diff --git a/JavaScript/Web/MessageEvent/Internal.hs b/JavaScript/Web/MessageEvent/Internal.hs index 1dae349..14b9590 100644 --- a/JavaScript/Web/MessageEvent/Internal.hs +++ b/JavaScript/Web/MessageEvent/Internal.hs @@ -6,5 +6,4 @@ import Data.Typeable import GHCJS.Types -newtype MessageEvent = MessageEvent (JSRef ()) - deriving (Typeable) +newtype MessageEvent = MessageEvent JSVal deriving (Typeable) diff --git a/JavaScript/Web/Performance.hs b/JavaScript/Web/Performance.hs new file mode 100644 index 0000000..7e32c7a --- /dev/null +++ b/JavaScript/Web/Performance.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} + +{- | The Performance interface represents timing-related performance information for the given page. + -} + +module JavaScript.Web.Performance + ( now + ) where + +import GHCJS.Foreign.Callback +import GHCJS.Marshal.Pure +import GHCJS.Types + +import Control.Exception (onException) +import Data.Typeable + +{- | The 'now' computation returns a high resolution time stamp, measured in + milliseconds, accurate to one thousandth of a millisecond. + + The value represented by 0 varies according the context, but + in dedicated workers created from a Window context, the epoch is the value + of the @PerformanceTiming.navigationStart@ property. + -} +now :: IO Double +now = js_performanceNow +{-# INLINE now #-} + +-- ----------------------------------------------------------------------------- + +foreign import javascript unsafe "performance.now()" + js_performanceNow :: IO Double diff --git a/JavaScript/Web/Storage.hs b/JavaScript/Web/Storage.hs index 21a2c99..dba9875 100644 --- a/JavaScript/Web/Storage.hs +++ b/JavaScript/Web/Storage.hs @@ -63,9 +63,9 @@ foreign import javascript unsafe foreign import javascript unsafe "$1.length" js_getLength :: Storage -> IO Int foreign import javascript unsafe - "$2.key($1)" js_getIndex :: Int -> Storage -> IO (JSRef ()) + "$2.key($1)" js_getIndex :: Int -> Storage -> IO JSVal foreign import javascript unsafe - "$2.getItem($1)" js_getItem :: JSString -> Storage -> IO (JSRef ()) + "$2.getItem($1)" js_getItem :: JSString -> Storage -> IO JSVal foreign import javascript safe "$3.setItem($1,$2)" js_setItem :: JSString -> JSString -> Storage -> IO () foreign import javascript unsafe diff --git a/JavaScript/Web/Storage/Internal.hs b/JavaScript/Web/Storage/Internal.hs index 25ac909..956c6e7 100644 --- a/JavaScript/Web/Storage/Internal.hs +++ b/JavaScript/Web/Storage/Internal.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module JavaScript.Web.Storage.Internal where import GHCJS.Types -newtype Storage = Storage (JSRef ()) -newtype StorageEvent = StorageEvent (JSRef ()) +import Data.Typeable + +newtype Storage = Storage JSVal deriving Typeable +newtype StorageEvent = StorageEvent JSVal deriving Typeable diff --git a/JavaScript/Web/StorageEvent.hs b/JavaScript/Web/StorageEvent.hs index e934682..9bc3838 100644 --- a/JavaScript/Web/StorageEvent.hs +++ b/JavaScript/Web/StorageEvent.hs @@ -51,12 +51,12 @@ storageArea se | isNull r = Nothing -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1.key" js_getKey :: StorageEvent -> JSRef () + "$1.key" js_getKey :: StorageEvent -> JSVal foreign import javascript unsafe - "$1.oldValue" js_getOldValue :: StorageEvent -> JSRef () + "$1.oldValue" js_getOldValue :: StorageEvent -> JSVal foreign import javascript unsafe - "$1.newValue" js_getNewValue :: StorageEvent -> JSRef () + "$1.newValue" js_getNewValue :: StorageEvent -> JSVal foreign import javascript unsafe "$1.url" js_getUrl :: StorageEvent -> JSString foreign import javascript unsafe - "$1.storageArea" js_getStorageArea :: StorageEvent -> JSRef () + "$1.storageArea" js_getStorageArea :: StorageEvent -> JSVal diff --git a/JavaScript/Web/WebSocket.hs b/JavaScript/Web/WebSocket.hs index bee5127..c4b906f 100644 --- a/JavaScript/Web/WebSocket.hs +++ b/JavaScript/Web/WebSocket.hs @@ -1,6 +1,12 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DeriveDataTypeable, - InterruptibleFFI, OverloadedStrings, - MagicHash, UnliftedFFITypes, GHCForeignImportPrim, UnboxedTuples #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE UnboxedTuples #-} module JavaScript.Web.WebSocket ( WebSocket , WebSocketRequest(..) @@ -9,7 +15,9 @@ module JavaScript.Web.WebSocket ( WebSocket , connect , close , send - , getBufferedAmount + , sendArrayBuffer + , sendBlob + , getBufferedAmount , getExtensions , getProtocol , getReadyState @@ -38,6 +46,8 @@ import qualified Data.JSString as JSS import JavaScript.Array (JSArray) import qualified JavaScript.Array as JSA +import JavaScript.TypedArray (SomeArrayBuffer) +import JavaScript.Web.Blob (Blob) import JavaScript.Web.MessageEvent import JavaScript.Web.MessageEvent.Internal import JavaScript.Web.CloseEvent @@ -54,7 +64,8 @@ data WebSocketRequest = WebSocketRequest , onMessage :: Maybe (MessageEvent -> IO ()) -- ^ called for each message } -newtype WebSocket = WebSocket (JSRef ()) +newtype WebSocket = WebSocket JSVal +-- instance IsJSVal WebSocket data ReadyState = Closed | Connecting | Connected deriving (Data, Typeable, Enum, Eq, Ord, Show) @@ -62,34 +73,28 @@ data ReadyState = Closed | Connecting | Connected data BinaryType = Blob | ArrayBuffer deriving (Data, Typeable, Enum, Eq, Ord, Show) -{- | create a WebSocket -} +{- | create a WebSocket -} connect :: WebSocketRequest -> IO WebSocket connect req = do mcb <- maybeCallback MessageEvent (onMessage req) ccb <- maybeCallback CloseEvent (onClose req) - synchronously $ do + withoutPreemption $ do ws <- case protocols req of - [] -> js_createStr (url req) JSS.empty - [x] -> js_createStr (url req) x - xs -> js_createArr (url req) (JSA.fromList $ unsafeCoerce xs) -- fixme + [] -> js_createDefault (url req) + [x] -> js_createStr (url req) x (js_open ws mcb ccb >>= handleOpenErr >> return ws) `onException` js_close 1000 "Haskell Exception" ws -maybeCallback :: (JSRef () -> a) -> Maybe (a -> IO ()) -> IO (JSRef ()) +maybeCallback :: (JSVal -> a) -> Maybe (a -> IO ()) -> IO JSVal maybeCallback _ Nothing = return jsNull maybeCallback f (Just g) = do - cb@(Callback cb') <- CB.syncCallback1 CB.ContinueAsync (g . f) - CB.releaseCallback cb - return cb' + Callback cb <- CB.syncCallback1 CB.ContinueAsync (g . f) + return cb -handleOpenErr :: JSRef () -> IO () +handleOpenErr :: JSVal -> IO () handleOpenErr r | isNull r = return () | otherwise = throwIO (userError "WebSocket failed to connect") -- fixme -releaseMessageCallback :: WebSocket -> IO () -releaseMessageCallback ws = js_getOnmessage ws >>= - \cb -> unless (isNull cb) (CB.releaseCallback $ Callback cb) - {- | close a websocket and release the callbacks -} close :: Maybe Int -> Maybe JSString -> WebSocket -> IO () close value reason ws = @@ -100,6 +105,14 @@ send :: JSString -> WebSocket -> IO () send xs ws = js_send xs ws {-# INLINE send #-} +sendBlob :: Blob -> WebSocket -> IO () +sendBlob = js_sendBlob +{-# INLINE sendBlob #-} + +sendArrayBuffer :: SomeArrayBuffer m -> WebSocket -> IO () +sendArrayBuffer = js_sendArrayBuffer +{-# INLINE sendArrayBuffer #-} + getBufferedAmount :: WebSocket -> IO Int getBufferedAmount ws = js_getBufferedAmount ws {-# INLINE getBufferedAmount #-} @@ -132,19 +145,25 @@ getLastError ws = do -- ----------------------------------------------------------------------------- - +foreign import javascript safe + "new WebSocket($1)" js_createDefault :: JSString -> IO WebSocket foreign import javascript safe "new WebSocket($1, $2)" js_createStr :: JSString -> JSString -> IO WebSocket foreign import javascript safe "new WebSocket($1, $2)" js_createArr :: JSString -> JSArray -> IO WebSocket - + foreign import javascript interruptible "h$openWebSocket($1, $2, $3, $c);" - js_open :: WebSocket -> JSRef () -> JSRef () -> IO (JSRef ()) + js_open :: WebSocket -> JSVal -> JSVal -> IO JSVal foreign import javascript safe - "h$closeWebSocket($1, $2);" js_close :: Int -> JSString -> WebSocket -> IO () + "h$closeWebSocket($1, $2, $3);" + js_close :: Int -> JSString -> WebSocket -> IO () foreign import javascript unsafe "$2.send($1);" js_send :: JSString -> WebSocket -> IO () +foreign import javascript unsafe + "$2.send($1);" js_sendBlob :: Blob -> WebSocket -> IO () +foreign import javascript unsafe + "$2.send($1);" js_sendArrayBuffer :: SomeArrayBuffer m -> WebSocket -> IO () foreign import javascript unsafe "$1.bufferedAmount" js_getBufferedAmount :: WebSocket -> IO Int foreign import javascript unsafe @@ -158,16 +177,5 @@ foreign import javascript unsafe foreign import javascript unsafe "$1.binaryType === 'blob' ? 1 : 2" js_getBinaryType :: WebSocket -> IO Int - -foreign import javascript unsafe - "$2.onopen = $1;" js_setOnopen :: Callback a -> WebSocket -> IO () -foreign import javascript unsafe - "$2.onclose = $1;" js_setOnclose :: Callback a -> WebSocket -> IO () -foreign import javascript unsafe - "$2.onopen = $1;" js_setOnerror :: Callback a -> WebSocket -> IO () -foreign import javascript unsafe - "$2.onmessage = $1;" js_setOnmessage :: Callback a -> WebSocket -> IO () -foreign import javascript unsafe - "$1.onmessage" js_getOnmessage :: WebSocket -> IO (JSRef ()) foreign import javascript unsafe - "$1.lastError" js_getLastError :: WebSocket -> IO (JSRef ()) + "$1.lastError" js_getLastError :: WebSocket -> IO JSVal diff --git a/JavaScript/Web/Worker.hs b/JavaScript/Web/Worker.hs index fbfc777..ef5f93d 100644 --- a/JavaScript/Web/Worker.hs +++ b/JavaScript/Web/Worker.hs @@ -7,15 +7,17 @@ module JavaScript.Web.Worker ( Worker ) where import GHCJS.Prim + import Data.JSString +import Data.Typeable -newtype Worker = Worker (JSRef ()) +newtype Worker = Worker JSVal deriving Typeable create :: JSString -> IO Worker create script = js_create script {-# INLINE create #-} -postMessage :: JSRef () -> Worker -> IO () +postMessage :: JSVal -> Worker -> IO () postMessage msg w = js_postMessage msg w {-# INLINE postMessage #-} @@ -28,6 +30,6 @@ terminate w = js_terminate w foreign import javascript unsafe "new Worker($1)" js_create :: JSString -> IO Worker foreign import javascript unsafe - "$2.postMessage($1)" js_postMessage :: JSRef () -> Worker -> IO () + "$2.postMessage($1)" js_postMessage :: JSVal -> Worker -> IO () foreign import javascript unsafe "$1.terminate()" js_terminate :: Worker -> IO () diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs index ad59108..67efef0 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -10,7 +10,10 @@ module JavaScript.Web.XMLHttpRequest ( xhr , xhrString , Method(..) , Request(..) + , RequestData(..) , Response(..) + , ResponseType(..) + , FormDataVal(..) , XHRError(..) ) where @@ -40,9 +43,7 @@ import Data.JSString.Text (textFromJSString) import qualified Data.JSString as JSS import JavaScript.JSON.Types.Internal ( SomeValue(..) ) -import JavaScript.TypedArray.Internal.Types ( SomeTypedArray(..) ) -import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer(..) ) -import JavaScript.TypedArray.ArrayBuffer.Internal ( SomeArrayBuffer(..) ) +import JavaScript.TypedArray import JavaScript.Web.Blob import JavaScript.Web.Blob.Internal @@ -54,7 +55,7 @@ data Method = GET | POST | PUT | DELETE data XHRError = XHRError String | XHRAborted - deriving (Generic, Data, Typeable, Show, Eq) + deriving (Generic, Data, Typeable, Show, Eq) instance Exception XHRError @@ -82,7 +83,7 @@ data Request = Request { reqMethod :: Method data RequestData = NoData | StringData JSString - | TypedArrayData (forall e. SomeTypedArray e Immutable) + | TypedArrayData (forall e. SomeTypedArray Immutable e) | FormData [(JSString, FormDataVal)] deriving (Typeable) @@ -96,7 +97,7 @@ instance Functor Response where fmap f r = r { contents = fmap f (contents r) } class ResponseType a where getResponseTypeString :: Proxy a -> JSString - wrapResponseType :: JSRef () -> a + wrapResponseType :: JSVal -> a instance ResponseType ArrayBuffer where getResponseTypeString _ = "arraybuffer" @@ -114,9 +115,9 @@ instance m ~ Immutable => ResponseType (SomeValue m) where getResponseTypeString _ = "json" wrapResponseType = SomeValue -newtype JSFormData = JSFormData (JSRef ()) +newtype JSFormData = JSFormData JSVal deriving (Typeable) -newtype XHR = XHR (JSRef ()) +newtype XHR = XHR JSVal deriving (Typeable) -- ----------------------------------------------------------------------------- -- main entry point @@ -124,26 +125,26 @@ newtype XHR = XHR (JSRef ()) xhr :: forall a. ResponseType a => Request -> IO (Response a) xhr req = js_createXHR >>= \x -> let doRequest = do - js_setResponseType - (getResponseTypeString (Proxy :: Proxy a)) x case reqLogin req of Nothing -> js_open2 (methodJSString (reqMethod req)) (reqURI req) x Just (user, pass) -> js_open4 (methodJSString (reqMethod req)) (reqURI req) user pass x + js_setResponseType + (getResponseTypeString (Proxy :: Proxy a)) x forM_ (reqHeaders req) (\(n,v) -> js_setRequestHeader n v x) r <- case reqData req of NoData -> js_send0 x StringData str -> - js_send1 (castRef $ pToJSRef str) x + js_send1 (pToJSVal str) x TypedArrayData (SomeTypedArray t) -> js_send1 t x FormData xs -> do fd@(JSFormData fd') <- js_createFormData forM_ xs $ \(name, val) -> case val of StringVal str -> - js_appendFormData2 name (castRef $ pToJSRef str) fd + js_appendFormData2 name (pToJSVal str) fd BlobVal (SomeBlob b) mbFile -> appendFormData name b mbFile fd FileVal (SomeBlob b) mbFile -> @@ -164,7 +165,7 @@ xhr req = js_createXHR >>= \x -> 2 -> throwIO (XHRError "some error") in doRequest `onException` js_abort x -appendFormData :: JSString -> JSRef () +appendFormData :: JSString -> JSVal -> Maybe JSString -> JSFormData -> IO () appendFormData name val Nothing fd = js_appendFormData2 name val fd @@ -214,16 +215,16 @@ foreign import javascript unsafe js_createFormData :: IO JSFormData foreign import javascript unsafe "$3.append($1,$2)" - js_appendFormData2 :: JSString -> JSRef () -> JSFormData -> IO () + js_appendFormData2 :: JSString -> JSVal -> JSFormData -> IO () foreign import javascript unsafe "$4.append($1,$2,$3)" - js_appendFormData3 :: JSString -> JSRef () -> JSString -> JSFormData -> IO () + js_appendFormData3 :: JSString -> JSVal -> JSString -> JSFormData -> IO () foreign import javascript unsafe "$1.status" js_getStatus :: XHR -> IO Int foreign import javascript unsafe "$1.response" - js_getResponse :: XHR -> IO (JSRef ()) + js_getResponse :: XHR -> IO JSVal foreign import javascript unsafe "$1.response ? true : false" js_hasResponse :: XHR -> IO Bool @@ -232,7 +233,7 @@ foreign import javascript unsafe js_getAllResponseHeaders :: XHR -> IO JSString foreign import javascript unsafe "$2.getResponseHeader($1)" - js_getResponseHeader :: JSString -> XHR -> IO (JSRef ()) + js_getResponseHeader :: JSString -> XHR -> IO JSVal -- ----------------------------------------------------------------------------- @@ -241,4 +242,4 @@ foreign import javascript interruptible js_send0 :: XHR -> IO Int foreign import javascript interruptible "h$sendXHR($2, $1, $c);" - js_send1 :: JSRef () -> XHR -> IO Int + js_send1 :: JSVal -> XHR -> IO Int diff --git a/README.md b/README.md index 0dfc8c8..343dd83 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,8 @@ -ghcjs-base +ghcjs-base-alt ========== -minimal low-level base library for GHCJS, used by higher level libraries like JSC \ No newline at end of file +Minimal low-level base library for GHCJS, used by higher level libraries like JSC. + +This is an alternative to standard `ghcjs/ghcjs-base`; +uses different implementation of `TypedArray`. +An idea is to make it easier to program vector math. diff --git a/ghcjs-base.cabal b/ghcjs-base-alt.cabal similarity index 91% rename from ghcjs-base.cabal rename to ghcjs-base-alt.cabal index 5371053..b1b2659 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base-alt.cabal @@ -1,7 +1,7 @@ -name: ghcjs-base -version: 0.2.0.0 +name: ghcjs-base-alt +version: 0.2.0 synopsis: base library for GHCJS -homepage: http://github.com/ghcjs/ghcjs-base +homepage: https://github.com/ghcjs/ghcjs-base license: MIT license-file: LICENSE author: Luite Stegeman @@ -19,6 +19,8 @@ library jsbits/foreign.js jsbits/text.js jsbits/utils.js + jsbits/xhr.js + jsbits/websocket.js other-extensions: DeriveDataTypeable DeriveGeneric ForeignFunctionInterface @@ -44,7 +46,7 @@ library GeneralizedNewtypeDeriving ScopedTypeVariables TypeOperators - + ghc-options: -O exposed-modules: Data.JSString Data.JSString.Int @@ -70,6 +72,7 @@ library GHCJS.Marshal GHCJS.Marshal.Internal GHCJS.Marshal.Pure + GHCJS.Nullable GHCJS.Types JavaScript.Array JavaScript.Array.Internal @@ -86,11 +89,7 @@ library JavaScript.Object.Internal JavaScript.RegExp JavaScript.TypedArray - JavaScript.TypedArray.ArrayBuffer - JavaScript.TypedArray.ArrayBuffer.ST - JavaScript.TypedArray.DataView - JavaScript.TypedArray.DataView.ST - JavaScript.TypedArray.Internal + JavaScript.TypedArray.IO JavaScript.TypedArray.ST JavaScript.Web.AnimationFrame JavaScript.Web.Blob @@ -104,8 +103,11 @@ library JavaScript.Web.ErrorEvent JavaScript.Web.ErrorEvent.Internal JavaScript.Web.File + JavaScript.Web.History + JavaScript.Web.Location JavaScript.Web.MessageEvent JavaScript.Web.MessageEvent.Internal + JavaScript.Web.Performance JavaScript.Web.Storage JavaScript.Web.Storage.Internal JavaScript.Web.StorageEvent @@ -114,9 +116,8 @@ library JavaScript.Web.Worker other-modules: GHCJS.Internal.Types Data.JSString.Internal.Type - JavaScript.TypedArray.Internal.Types - JavaScript.TypedArray.ArrayBuffer.Internal - JavaScript.TypedArray.DataView.Internal + JavaScript.TypedArray.Internal + JavaScript.TypedArray.Types build-depends: base >= 4.7 && < 5, ghc-prim, ghcjs-prim, @@ -167,5 +168,3 @@ test-suite tests test-framework >= 0.4, test-framework-hunit >= 0.2, test-framework-quickcheck2 >= 0.2 - - diff --git a/jsbits/animationFrame.js b/jsbits/animationFrame.js index b6fa96d..7a3e942 100644 --- a/jsbits/animationFrame.js +++ b/jsbits/animationFrame.js @@ -1,18 +1,18 @@ function h$animationFrameCancel(h) { if(h.handle) window.cancelAnimationFrame(h.handle); if(h.callback) { - h$release(h.callback) - h.callback = null; + h$release(h.callback) + h.callback = null; } } function h$animationFrameRequest(h) { - h.handle = window.requestAnimationFrame(function() { - var cb = h.callback; - if(cb) { - h$release(cb); - h.callback = null; - cb(); - } + 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 index e1e051b..bebda10 100644 --- a/jsbits/array.js +++ b/jsbits/array.js @@ -2,12 +2,12 @@ /* convert an array to a Haskell list, wrapping each element in a - JSRef constructor + JSVal constructor */ function h$fromArray(a) { var r = HS_NIL; - for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSREF(a[i]), r); - return a; + for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSVAL(a[i]), r); + return r; } /* @@ -19,19 +19,32 @@ function h$fromArray(a) { 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; + return r; } /* - convert a list of JSRef to an array. the list must have been fully forced, + 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++] = JSREF_VAL(CONS_HEAD(xs)); + a[i++] = JSVAL_VAL(CONS_HEAD(xs)); xs = CONS_TAIL(xs); } return a; } +function h$listToArrayWrap(xs) { + return MK_JSVAL(h$listToArray(xs)); +} + + +function h$fromListPrim(xs) { + var arr = []; + while(IS_CONS(xs)) { + arr.push(CONS_HEAD(xs)); + xs = CONS_TAIL(xs); + } + return arr; +} diff --git a/jsbits/export.js b/jsbits/export.js index 7e09990..cc3043a 100644 --- a/jsbits/export.js +++ b/jsbits/export.js @@ -1,23 +1,26 @@ function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) { - var e = { fp1a: fp1a - , fp1b: fp1b - , fp1c: fp1c - , fp1d: fp1d - , root: o - , _key: -1 - }; - return e; + 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.root) return null; - if(fp1a !== e.fp1a || fp1b !== e.fp1b || - fp2a !== e.fp2a || fp2b !== e.fp2b) return null; - return e.root; + 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.root = null; + h$release(e); + e.released = true; + e.root = null; } diff --git a/jsbits/jsstring.js b/jsbits/jsstring.js index 977bbc5..df07d78 100644 --- a/jsbits/jsstring.js +++ b/jsbits/jsstring.js @@ -26,8 +26,7 @@ #define HI_SURR(cp) ((((cp)-0x10000)>>>10)+0xDC00) #define LO_SURR(cp) (((cp)&0x3FF)+0xD800) - -var h$jsstringEmpty = MK_JSREF(''); +var h$jsstringEmpty = MK_JSVAL(''); var h$jsstringHead, h$jsstringTail, h$jsstringCons, h$jsstringSingleton, h$jsstringSnoc, h$jsstringUncons, @@ -66,9 +65,10 @@ if(String.prototype.codePointAt) { var l = str.length; if(l===0) return null; var ch = str.codePointAt(0); - if(ch === undefined) return null; - h$ret1 = MK_JSREF(str.substr(IS_ASTRAL(ch)?2:1)); - return ch; + if(ch === undefined) { + RETURN_UBX_TUP2(null, 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) { @@ -124,13 +124,13 @@ if(String.prototype.codePointAt) { if(l===0) return -1; var ch = str.charCodeAt(0); if(IS_HI_SURR(ch)) { - if(l > 1) { - h$ret1 = MK_JSREF(str.substr(2)); - return FROM_SURR(ch, str.charCodeAt(1)) - } else return -1; + if(l > 1) { + RETURN_UBX_TUP2(FROM_SURR(ch, str.charCodeAt(1)), str.substr(2)); + } else { + RETURN_UBX_TUP2(-1, null); + } } else { - h$ret1 = MK_JSREF(str.substr(1)); - return ch; + RETURN_UBX_TUP2(ch, str.substr(1)); } } // index is the first part of the character @@ -260,25 +260,21 @@ function h$jsstringDrop(n, str) { } function h$jsstringSplitAt(n, str) { - TRACE_JSSTRING("splitAt: " + n + " '" + str + "'"); - if(n <= 0) { - h$ret1 = MK_JSREF(str); - return h$jsstringEmpty; - } else if(n >= str.length) { - h$ret1 = h$jsstringEmpty; - return MK_JSREF(str); - } - var i = 0, l = str.length, ch; - while(n--) { - ch = str.charCodeAt(i++); - if(IS_HI_SURR(ch)) i++; - if(i >= l) { - h$ret1 = h$jsstringEmpty; - return MK_JSREF(str); - } - } - h$ret1 = MK_JSREF(str.substr(i)); - return MK_JSREF(str.substr(0,i)); + 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) { @@ -310,7 +306,7 @@ function h$jsstringIntercalate(x, ys) { var a = [], i = 0; while(IS_CONS(ys)) { if(i) a[i++] = x; - a[i++] = JSREF_VAL(CONS_HEAD(ys)); + a[i++] = JSVAL_VAL(CONS_HEAD(ys)); ys = CONS_TAIL(ys); } return a.join(''); @@ -345,7 +341,7 @@ function h$jsstringConcat(xs) { TRACE_JSSTRING("concat"); var a = [], i = 0; while(IS_CONS(xs)) { - a[i++] = JSREF_VAL(CONS_HEAD(xs)); + a[i++] = JSVAL_VAL(CONS_HEAD(xs)); xs = CONS_TAIL(xs); } return a.join(''); @@ -358,18 +354,9 @@ if(String.prototype.startsWith) { h$jsstringStripPrefix = function(p, x) { TRACE_JSSTRING("(startsWith) stripPrefix: '" + p + "' '" + x + "'"); if(x.startsWith(p)) { - return MK_JUST(MK_JSREF(x.substr(p.length))); + return MK_JUST(MK_JSVAL(x.substr(p.length))); } else { - return h$nothing; - } - } - - h$jsstringStripSuffix = function(s, x) { - TRACE_JSSTRING("(startsWith) stripSuffix: '" + s + "' '" + x + "'"); - if(x.endsWith(s)) { - return MK_JUST(MK_JSREF(x.substr(0,x.length-s.length))); - } else { - return h$nothing; + return HS_NOTHING; } } @@ -378,38 +365,50 @@ if(String.prototype.startsWith) { return x.startsWith(p); } - h$jsstringIsSuffixOf = function(s, x) { - TRACE_JSSTRING("(startsWith) isSuffixOf: '" + s + "' '" + x + "'"); - return x.endWith(s); - } } 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_JSREF(x.substr(p.length))); + 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 h$nothing; + 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 startsWith) stripSuffix: '" + 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_JSREF(x.substr(0,l))); + return MK_JUST(MK_JSVAL(x.substr(0,l))); } else { - return h$nothing; + 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 - } - - h$jsstringIsSuffixOf = function(s, x) { - TRACE_JSSTRING("(no startsWith) isSuffixOf: '" + s + "' '" + x + "'"); + 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; } @@ -432,7 +431,7 @@ function h$jsstringCommonPrefixes(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 h$nothing; + return HS_NOTHING; } while(++i= 0) r = MK_CONS(a[i], r); @@ -503,17 +498,18 @@ function h$jsstringBreakOnAll(pat, src) { function h$jsstringSplitOn1(n, p, x) { TRACE_JSSTRING("splitOn1: " + n + " '" + p + "' '" + x + "'"); var i = x.indexOf(p, n); - if(i === -1) return -1; - h$ret1 = (i==n) ? h$jsstringEmpty - : MK_JSREF(x.substr(n, i-n)); - return i + p.length; + 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 = h$nil, i = a.length; - while(--i>=0) r = MK_CONS(MK_JSREF(a[i]), r); + var r = HS_NIL, i = a.length; + while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); return r; } @@ -533,22 +529,21 @@ function h$jsstringWords1(n, x) { while(m < l) { if(h$isSpace(x.charCodeAt(m++))) { // found end of word - h$ret1 = (m-s<=1) ? h$jsstringEmpty - : MK_JSREF(x.substr(s,m-s-1)); - return m; + var r1 = (m-s<=1) ? "" : x.substr(s,m-s-1); + RETURN_UBX_TUP2(m, r1); } } // end of string if(s < l) { - h$ret1 = MK_JSREF(s === 0 ? x : x.substr(s)); - return m; + var r1 = s === 0 ? x : x.substr(s); + RETURN_UBX_TUP2(m, r1); } - return -1; + 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 = h$nil; + var a = null, i = 0, n, s = -1, m = 0, w, l = x.length, r = HS_NIL; outer: while(m < l) { // skip leading spaces @@ -561,7 +556,7 @@ function h$jsstringWords(x) { if(h$isSpace(x.charCodeAt(m++))) { // found end of word w = (m-s<=1) ? h$jsstringEmpty - : MK_JSREF(x.substr(s,m-s-1)); + : MK_JSVAL(x.substr(s,m-s-1)); if(i) a[i++] = w; else { a = [w]; i = 1; } s = m; break; @@ -570,7 +565,7 @@ function h$jsstringWords(x) { } // end of string if(s !== -1 && s < l) { - w = MK_JSREF(s === 0 ? x : x.substr(s)); + w = MK_JSVAL(s === 0 ? x : x.substr(s)); if(i) a[i++] = w; else { a = [w]; i = 1; } } // build resulting list @@ -588,31 +583,29 @@ function h$jsstringLines1(n, x) { if(x.charCodeAt(m++) === 10) { // found newline if(n > 0 && n === l-1) return -1; // it was the last character - h$ret1 = (m-n<=1) ? h$jsstringEmpty - : MK_JSREF(x.substr(n,m-n-1)); - return m; + var r1 = (m-n<=1) ? "" : x.substr(n,m-n-1); + RETURN_UBX_TUP2(m, r1); } } // end of string - h$ret1 = MK_JSREF(x.substr(n)); - return m; + 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 = h$nil, w; - if(l === 0) return h$nil; + 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_JSREF(x.substr(s,m-s-1)); + 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_JSREF(x.substr(s)); + 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); @@ -622,8 +615,8 @@ function h$jsstringLines(x) { function h$jsstringGroup(x) { TRACE_JSSTRING("group: '" + x + "'"); var xl = x.length; - if(xl === 0) return h$nil; - var i = xl-1, si, ch, s=xl, r=h$nil; + 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) { @@ -634,11 +627,11 @@ function h$jsstringGroup(x) { } if(ch != tch) { tch = ch; - r = MK_CONS(MK_JSREF(x.substr(si+1,s-si)), r); + r = MK_CONS(MK_JSVAL(x.substr(si+1,s-si)), r); s = si; } } - return MK_CONS(MK_JSREF(x.substr(0,s+1)), r); + return MK_CONS(MK_JSVAL(x.substr(0,s+1)), r); } function h$jsstringChunksOf1(n, s, x) { @@ -649,16 +642,16 @@ function h$jsstringChunksOf1(n, s, x) { ch = x.charCodeAt(m); if(IS_HI_SURR(ch)) ++m; } - h$ret1 = MK_JSREF((m >= l && s === c) ? x : x.substr(s,m-s)); - return m; + 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 h$nil; - if(l <= n) return MK_CONS(MK_JSREF(x), h$nil); - var a = [], i = 0, s = 0, ch, m = 0, c, r = h$nil; + 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; @@ -668,7 +661,7 @@ function h$jsstringChunksOf(n, x) { } if(c) a[i++] = x.substr(s, m-s); } - while(--i>=0) r = MK_CONS(MK_JSREF(a[i]), r); + while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); return r; } @@ -727,7 +720,7 @@ if(Array.from) { function h$jsstringUnpack(str) { TRACE_JSSTRING("unpack: '" + str + "'"); - var r = h$nil, i = str.length-1, c; + 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) @@ -911,7 +904,7 @@ function h$jsstringCompare(x, y) { function h$jsstringUnlines(xs) { var r = ''; while(IS_CONS(xs)) { - r = r + JSREF_VAL(CONS_HEAD(xs)) + '\n'; + r = r + JSVAL_VAL(CONS_HEAD(xs)) + '\n'; xs = CONS_TAIL(xs); } return r; @@ -919,10 +912,10 @@ function h$jsstringUnlines(xs) { function h$jsstringUnwords(xs) { if(IS_NIL(xs)) return ''; - var r = JSREF_VAL(CONS_HEAD(xs)); + var r = JSVAL_VAL(CONS_HEAD(xs)); xs = CONS_TAIL(xs); while(IS_CONS(xs)) { - r = r + ' ' + JSREF_VAL(CONS_HEAD(xs)); + r = r + ' ' + JSVAL_VAL(CONS_HEAD(xs)); xs = CONS_TAIL(xs); } return r; @@ -965,15 +958,15 @@ function h$jsstringLenientReadInt(str) { } 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; + 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) { @@ -981,40 +974,71 @@ function h$jsstringLenientReadDouble(str) { } 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 { + return MK_INTEGER_J(new BigInteger(str, 10)); + } } function h$jsstringReadInt64(str) { -// if(!/^\d + 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 0; - var l = str.length, i = 0; - while(i < l) { - if(str.charCodeAt(i) !== 48) break; - i++; - } - if(i >= l) RETURN_UBX_TUP3(1, 0, 0); // only zeroes - var li = l-i; - if(li > 20) return 0; // too big - if(li < 10) RETURN_UBX_TUP3(1, 0, parseInt(str.substr(i), 10)); - if(li < 18) { - var x1 = parseInt(str.substr(i+9), 10); - var x2 = parseInt(str.substr(i,9), 10); - var x3 = ((x2 % 10) * 1000000000 + x1)|0; - // var x4 = throw "jsstringReadWord64"; - throw "jsstringReadWord64"; // fixme - RETURN_UBX_TUP3(1, x4, x3); - } - + 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 = h$nil; + var a = [], x, j = 1, r = HS_NIL; while(true) { x = m[j]; if(typeof x === 'undefined') break; @@ -1022,8 +1046,8 @@ function h$jsstringExecRE(i, str, re) { j++; } j-=1; - while(--j>=0) r = MK_CONS(MK_JSREF(a[j]), r); - RETURN_UBX_TUP(m.index, m[0], r); + 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) { @@ -1034,6 +1058,6 @@ 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_JSREF(a[i]), r); + while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); return r; } diff --git a/jsbits/jsstringRaw.js b/jsbits/jsstringRaw.js index c936ad0..4d31c3c 100644 --- a/jsbits/jsstringRaw.js +++ b/jsbits/jsstringRaw.js @@ -1,3 +1,5 @@ +#include + /* * Functions that directly access JavaScript strings, ignoring character * widths and surrogate pairs. @@ -5,15 +7,15 @@ function h$jsstringRawChunksOf(k, x) { var l = x.length; - if(l === 0) return h$nil; - if(l <= k) return h$cons(h$jsref(x), h$nil); - var r=h$nil; - for(var i=ls-k;i>=0;i-=k) r = h$cons(h$jsref(x.substr(i,i+k)),r); + 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 h$tup2(h$jsstringEmpty, h$jsref(x)); - if(k >= x.length) return h$tup2(h$jsref(x), h$jsstringEmpty); - return h$tup2(h$jsref(x.substr(0,k)), h$jsref(x.substr(k))); + 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 index d1872d0..7046d36 100644 --- a/jsbits/text.js +++ b/jsbits/text.js @@ -37,11 +37,12 @@ function h$textFromString(s) { function h$lazyTextToString(txt) { var s = ''; - while(CONSTR_TAG(txt) === 2) { - var h = LAZY_TEXT_CHUNK_HEAD(txt); - s += h$textToString(TEXT_ARR(h), TEXT_OFF(h), TEXT_LEN(h)); - txt = LAZY_TEXT_CHUNK_TAIL(txt); + 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) { diff --git a/jsbits/utils.js b/jsbits/utils.js index 55e450a..722b793 100644 --- a/jsbits/utils.js +++ b/jsbits/utils.js @@ -8,13 +8,13 @@ function h$allProps(o) { function h$listProps(o) { var r = HS_NIL; - for(var p in o) { r = MK_CONS(MK_JSREF(p), r); } + 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_JSREF(p), MK_JSREF(o[p])), r); } + for(var p in o) { r = MK_CONS(MK_TUP2(MK_JSVAL(p), MK_JSVAL(o[p])), r); } return r; } @@ -35,6 +35,10 @@ function h$isSymbol(o) { return typeof(o) === 'symbol'; } +function h$isBoolean(o) { + return typeof(o) === 'boolean'; +} + function h$isFunction(o) { return typeof(o) === 'function'; } diff --git a/jsbits/websocket.js b/jsbits/websocket.js index 4919a00..25df07b 100644 --- a/jsbits/websocket.js +++ b/jsbits/websocket.js @@ -1,7 +1,7 @@ #include function h$createWebSocket(url, protocols) { - return new WebSocket(url, protocols); + return new WebSocket(url, protocols); } /* @@ -9,47 +9,50 @@ function h$createWebSocket(url, protocols) { 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.hsListeners = { close: ccb, message: mcb, close: ccb }; - ws.onopen = function() { - if(mcb) { - ws.onmessage = mcb; - h$retain(mcb); - } - if(ccb || mcb) { - ws.onclose = function(ce) { - if(ws.onmessage) { - h$release(ws.onmessage); - ws.onmessage = null; - } - 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(0, ws); + 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.close(); - c(1, 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(); + ws.onerror = null; + if(ws.onmessage) { + h$release(ws.onmessage); + ws.onmessage = null; + } + ws.close(status, reason); } diff --git a/test/Tests/Marshal.hs b/test/Tests/Marshal.hs index 8bb4ef3..020a5a5 100644 --- a/test/Tests/Marshal.hs +++ b/test/Tests/Marshal.hs @@ -5,8 +5,8 @@ module Tests.Marshal ( import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import GHCJS.Marshal.Pure (PFromJSRef(..), PToJSRef(..)) -import GHCJS.Marshal (FromJSRef(..), ToJSRef(..)) +import GHCJS.Marshal.Pure (PFromJSVal(..), PToJSVal(..)) +import GHCJS.Marshal (FromJSVal(..), ToJSVal(..)) import Tests.QuickCheckUtils (eq) import Test.QuickCheck.Monadic (run, monadicIO) import Test.QuickCheck (once, Arbitrary(..), Property) @@ -18,54 +18,54 @@ import Data.JSString (JSString) newtype TypeName a = TypeName String -pure_to_from_jsref' :: (PToJSRef a, PFromJSRef a, Eq a) => a -> Bool -pure_to_from_jsref' a = pFromJSRef (pToJSRef a) == a +pure_to_from_jsval' :: (PToJSVal a, PFromJSVal a, Eq a) => a -> Bool +pure_to_from_jsval' a = pFromJSVal (pToJSVal a) == a -pure_to_from_jsref :: (PToJSRef a, PFromJSRef a, Eq a) => TypeName a -> a -> Bool -pure_to_from_jsref _ = pure_to_from_jsref' +pure_to_from_jsval :: (PToJSVal a, PFromJSVal a, Eq a) => TypeName a -> a -> Bool +pure_to_from_jsval _ = pure_to_from_jsval' -pure_to_from_jsref_maybe :: (PToJSRef a, PFromJSRef a, Eq a) => TypeName a -> Maybe a -> Bool -pure_to_from_jsref_maybe _ = pure_to_from_jsref' +pure_to_from_jsval_maybe :: (PToJSVal a, PFromJSVal a, Eq a) => TypeName a -> Maybe a -> Bool +pure_to_from_jsval_maybe _ = pure_to_from_jsval' -to_from_jsref' :: (ToJSRef a, FromJSRef a, Eq a) => a -> Property -to_from_jsref' a = monadicIO $ do - b <- run $ toJSRef a >>= fromJSRefUnchecked +to_from_jsval' :: (ToJSVal a, FromJSVal a, Eq a) => a -> Property +to_from_jsval' a = monadicIO $ do + b <- run $ toJSVal a >>= fromJSValUnchecked return $ b == a -to_from_jsref :: (ToJSRef a, FromJSRef a, Eq a) => TypeName a -> a -> Property -to_from_jsref _ = to_from_jsref' +to_from_jsval :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> a -> Property +to_from_jsval _ = to_from_jsval' -to_from_jsref_maybe :: (ToJSRef a, FromJSRef a, Eq a) => TypeName a -> Maybe a -> Property -to_from_jsref_maybe _ = to_from_jsref' +to_from_jsval_maybe :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> Maybe a -> Property +to_from_jsval_maybe _ = to_from_jsval' -to_from_jsref_list :: (ToJSRef a, FromJSRef a, Eq a) => TypeName a -> [a] -> Property -to_from_jsref_list _ = to_from_jsref' +to_from_jsval_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [a] -> Property +to_from_jsval_list _ = to_from_jsval' -to_from_jsref_list_maybe :: (ToJSRef a, FromJSRef a, Eq a) => TypeName a -> [Maybe a] -> Property -to_from_jsref_list_maybe _ = to_from_jsref' +to_from_jsval_list_maybe :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [Maybe a] -> Property +to_from_jsval_list_maybe _ = to_from_jsval' -to_from_jsref_list_list :: (ToJSRef a, FromJSRef a, Eq a) => TypeName a -> [[a]] -> Property -to_from_jsref_list_list _ = to_from_jsref' +to_from_jsval_list_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> [[a]] -> Property +to_from_jsval_list_list _ = to_from_jsval' -to_from_jsref_maybe_list :: (ToJSRef a, FromJSRef a, Eq a) => TypeName a -> Maybe [a] -> Property -to_from_jsref_maybe_list _ = to_from_jsref' +to_from_jsval_maybe_list :: (ToJSVal a, FromJSVal a, Eq a) => TypeName a -> Maybe [a] -> Property +to_from_jsval_maybe_list _ = to_from_jsval' -pureMarshalTestGroup :: (PToJSRef a, PFromJSRef a, ToJSRef a, FromJSRef a, Eq a, Show a, Arbitrary a) => TypeName a -> Test +pureMarshalTestGroup :: (PToJSVal a, PFromJSVal a, ToJSVal a, FromJSVal a, Eq a, Show a, Arbitrary a) => TypeName a -> Test pureMarshalTestGroup t@(TypeName n) = testGroup n [ - testProperty "pure_to_from_jsref" (pure_to_from_jsref t), - testProperty "pure_to_from_jsref_maybe" (pure_to_from_jsref_maybe t), - testProperty "to_from_jsref" (to_from_jsref t), - testProperty "to_from_jsref_maybe" (to_from_jsref_maybe t), - testProperty "to_from_jsref_list" (to_from_jsref_list t), - testProperty "to_from_jsref_list_maybe" (to_from_jsref_list_maybe t), - testProperty "to_from_jsref_list_list" (once $ to_from_jsref_list_list t), - testProperty "to_from_jsref_maybe_list" (to_from_jsref_maybe_list t) + testProperty "pure_to_from_jsval" (pure_to_from_jsval t), + testProperty "pure_to_from_jsval_maybe" (pure_to_from_jsval_maybe t), + testProperty "to_from_jsval" (to_from_jsval t), + testProperty "to_from_jsval_maybe" (to_from_jsval_maybe t), + testProperty "to_from_jsval_list" (to_from_jsval_list t), + testProperty "to_from_jsval_list_maybe" (to_from_jsval_list_maybe t), + testProperty "to_from_jsval_list_list" (once $ to_from_jsval_list_list t), + testProperty "to_from_jsval_maybe_list" (to_from_jsval_maybe_list t) ] -marshalTestGroup :: (ToJSRef a, FromJSRef a, Eq a, Show a, Arbitrary a) => TypeName a -> Test +marshalTestGroup :: (ToJSVal a, FromJSVal a, Eq a, Show a, Arbitrary a) => TypeName a -> Test marshalTestGroup t@(TypeName n) = - testGroup n [testProperty "to_from_jsref" (to_from_jsref t)] + testGroup n [testProperty "to_from_jsval" (to_from_jsval t)] instance Arbitrary Text where arbitrary = T.pack <$> arbitrary