From 6d10cb35fca281fa38dd50214dd59eebbe36aefa Mon Sep 17 00:00:00 2001 From: John Lenz Date: Mon, 31 Aug 2015 00:19:12 -0500 Subject: [PATCH 01/36] Fix GHCJS.Foreign.Export - the hs$export function had parameters fp2a fp2b but attempted to read fp1c and fp1d, which did not exist. - Export.hs assumed deref was called hs$derefExportedValue but the actual function is hs$derefValue. - A call to hs$retain was missing from the export. --- GHCJS/Foreign/Export.hs | 2 +- jsbits/export.js | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/GHCJS/Foreign/Export.hs b/GHCJS/Foreign/Export.hs index ed2becb..0e8957c 100644 --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -84,7 +84,7 @@ foreign import javascript unsafe "h$exportValue" js_export :: Word64 -> Word64 -> Any -> IO (Export a) foreign import javascript unsafe - "h$derefExportedValue" + "h$derefExport" js_derefExport :: Word64 -> Word64 -> JSRef a -> IO (JSRef ()) foreign import javascript unsafe "$r = $1;" js_toHeapObject :: JSRef a -> (# b #) diff --git a/jsbits/export.js b/jsbits/export.js index 7e09990..19475f8 100644 --- a/jsbits/export.js +++ b/jsbits/export.js @@ -1,11 +1,12 @@ function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) { var e = { fp1a: fp1a , fp1b: fp1b - , fp1c: fp1c - , fp1d: fp1d + , fp2a: fp2a + , fp2b: fp2b , root: o - , _key: -1 + , _key: -1 }; + h$retain(e); return e; } From 5878a2f819bfd96074ea9ccee46b36db49ea5209 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 1 Sep 2015 14:37:06 -0700 Subject: [PATCH 02/36] drop JSRef phantom --- Data/JSString.hs | 8 +- Data/JSString/Internal/Fusion.hs | 8 +- Data/JSString/Internal/Type.hs | 6 +- Data/JSString/RegExp.hs | 12 ++- Data/JSString/Text.hs | 6 +- GHCJS/Buffer.hs | 6 +- GHCJS/Buffer/Types.hs | 2 +- GHCJS/Foreign.hs | 4 +- GHCJS/Foreign/Callback.hs | 20 ++--- GHCJS/Foreign/Callback/Internal.hs | 10 +-- GHCJS/Foreign/Export.hs | 31 +++---- GHCJS/Foreign/Internal.hs | 62 ++++++------- GHCJS/Internal/Types.hs | 29 +++++- GHCJS/Marshal.hs | 64 ++++++------- GHCJS/Marshal/Internal.hs | 60 ++++++------- GHCJS/Marshal/Pure.hs | 90 +++++++++---------- GHCJS/Types.hs | 60 ++++++------- JavaScript/Array.hs | 18 ++-- JavaScript/Array/Internal.hs | 43 ++++----- JavaScript/Array/ST.hs | 16 ++-- JavaScript/Cast.hs | 10 +-- JavaScript/JSON/Types/Internal.hs | 18 ++-- JavaScript/Object/Internal.hs | 33 ++++--- JavaScript/TypedArray/ArrayBuffer/Internal.hs | 32 ++++--- JavaScript/TypedArray/DataView/Internal.hs | 31 ++++--- JavaScript/TypedArray/Internal.hs | 35 +++++--- JavaScript/TypedArray/Internal/Types.hs | 11 ++- JavaScript/Web/AnimationFrame.hs | 13 +-- JavaScript/Web/Blob/Internal.hs | 11 ++- JavaScript/Web/Canvas.hs | 6 +- JavaScript/Web/Canvas/Internal.hs | 29 +++--- JavaScript/Web/CloseEvent/Internal.hs | 6 +- JavaScript/Web/ErrorEvent.hs | 20 +++-- JavaScript/Web/ErrorEvent/Internal.hs | 6 +- JavaScript/Web/MessageEvent.hs | 2 +- JavaScript/Web/MessageEvent/Internal.hs | 3 +- JavaScript/Web/Storage.hs | 4 +- JavaScript/Web/Storage/Internal.hs | 8 +- JavaScript/Web/StorageEvent.hs | 8 +- JavaScript/Web/WebSocket.hs | 25 ++++-- JavaScript/Web/Worker.hs | 8 +- JavaScript/Web/XMLHttpRequest.hs | 22 ++--- 42 files changed, 492 insertions(+), 404 deletions(-) diff --git a/Data/JSString.hs b/Data/JSString.hs index 7c18fa6..2d05a9f 100644 --- a/Data/JSString.hs +++ b/Data/JSString.hs @@ -166,7 +166,7 @@ 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 -> JSRef getJSRef (JSString x) = x {-# INLINE getJSRef #-} @@ -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 :: JSRef -> Bool foreign import javascript unsafe "$1===$2" js_eq :: JSString -> JSString -> Bool foreign import javascript unsafe @@ -1731,9 +1731,9 @@ 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 -> JSRef -- null for empty string foreign import javascript unsafe - "h$jsstringTail" js_tail :: JSString -> JSRef () -- null for empty string + "h$jsstringTail" js_tail :: JSString -> JSRef -- null for empty string foreign import javascript unsafe "h$jsstringReverse" js_reverse :: JSString -> JSString foreign import javascript unsafe diff --git a/Data/JSString/Internal/Fusion.hs b/Data/JSString/Internal/Fusion.hs index cba4740..33cd775 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 JSRef foreign import javascript unsafe - "$3[$2] = $1;" js_writeArray :: Char -> Int -> (JSRef ()) -> IO () + "$3[$2] = $1;" js_writeArray :: Char -> Int -> JSRef -> IO () foreign import javascript unsafe - "h$jsstringPackArray" js_packString :: (JSRef ()) -> IO JSString + "h$jsstringPackArray" js_packString :: JSRef -> IO JSString foreign import javascript unsafe - "h$jsstringPackArrayReverse" js_packReverse :: (JSRef ()) -> IO JSString + "h$jsstringPackArrayReverse" js_packReverse :: JSRef -> IO JSString diff --git a/Data/JSString/Internal/Type.hs b/Data/JSString/Internal/Type.hs index ac233cf..91177c0 100644 --- a/Data/JSString/Internal/Type.hs +++ b/Data/JSString/Internal/Type.hs @@ -38,9 +38,11 @@ import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#) import GHCJS.Prim (JSRef) +import GHCJS.Internal.Types + -- | A wrapper around a JavaScript string -newtype JSString = JSString { unJSString :: JSRef () } - deriving Typeable +newtype JSString = JSString JSRef +instance IsJSRef JSString instance NFData JSString where rnf !x = () diff --git a/Data/JSString/RegExp.hs b/Data/JSString/RegExp.hs index e132e73..d5b234b 100644 --- a/Data/JSString/RegExp.hs +++ b/Data/JSString/RegExp.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE JavaScriptFFI, ForeignFunctionInterface, GHCForeignImportPrim, - UnliftedFFITypes, UnboxedTuples, MagicHash - #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} module Data.JSString.RegExp ( RegExp , pattern @@ -18,8 +21,9 @@ import GHCJS.Prim import GHC.Exts (Int#, Int(..)) import Data.JSString +import Data.Typeable -newtype RegExp = RegExp (JSRef ()) +newtype RegExp = RegExp JSRef deriving Typeable data REFlags = REFlags { multiline :: !Bool , ignoreCase :: !Bool diff --git a/Data/JSString/Text.hs b/Data/JSString/Text.hs index 8601620..fd8d102 100644 --- a/Data/JSString/Text.hs +++ b/Data/JSString/Text.hs @@ -51,14 +51,14 @@ lazyTextFromJSString = TL.fromStrict . textFromJSString {-# INLINE lazyTextFromJSString #-} -- | returns the empty Text if not a string -textFromJSRef :: JSRef a -> T.Text +textFromJSRef :: JSRef -> T.Text textFromJSRef j = case js_fromString' j of (# _, 0# #) -> T.empty (# ba, length #) -> T.Text (A.Array ba) 0 (I# length) {-# INLINE textFromJSRef #-} -- | returns the empty Text if not a string -lazyTextFromJSRef :: JSRef a -> TL.Text +lazyTextFromJSRef :: JSRef -> TL.Text lazyTextFromJSRef = TL.fromStrict . textFromJSRef {-# INLINE lazyTextFromJSRef #-} @@ -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' :: JSRef -> (# ByteArray#, Int# #) foreign import javascript unsafe "h$lazyTextToString" js_lazyTextToString :: Any -> JSString diff --git a/GHCJS/Buffer.hs b/GHCJS/Buffer.hs index b08a63f..7c0f754 100644 --- a/GHCJS/Buffer.hs +++ b/GHCJS/Buffer.hs @@ -217,11 +217,11 @@ 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 () + "$r = $1;" js_fromByteArray :: ByteArray# -> JSRef foreign import javascript unsafe - "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSRef () + "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSRef foreign import javascript unsafe - "$r = $1;" js_toMutableByteArray :: JSRef () -> MutableByteArray# s + "$r = $1;" js_toMutableByteArray :: JSRef -> 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..903a19f 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 JSRef type Buffer = SomeBuffer Immutable type MutableBuffer = SomeBuffer Mutable diff --git a/GHCJS/Foreign.hs b/GHCJS/Foreign.hs index b26876b..91e9655 100644 --- a/GHCJS/Foreign.hs +++ b/GHCJS/Foreign.hs @@ -88,14 +88,14 @@ import qualified Data.Text as T class ToJSString a where toJSString :: a -> JSString --- toJSString = castRef . ptoJSRef +-- toJSString = ptoJSRef class FromJSString a where fromJSString :: JSString -> a -- default PFromJSRef --- fromJSString = pfromJSRef . castRef +-- fromJSString = pfromJSRef -- {-# INLINE fromJSString #-} {- instance ToJSString [Char] diff --git a/GHCJS/Foreign/Callback.hs b/GHCJS/Foreign/Callback.hs index 97a09b8..5a45f78 100644 --- a/GHCJS/Foreign/Callback.hs +++ b/GHCJS/Foreign/Callback.hs @@ -66,9 +66,9 @@ syncCallback onBlocked x = js_syncCallback (onBlocked == ContinueAsync) (unsafeC 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 + -> (JSRef -> IO ()) -- ^ the Haskell function + -> IO (Callback (JSRef -> IO ())) -- ^ the callback syncCallback1 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 1 (unsafeCoerce x) @@ -79,9 +79,9 @@ syncCallback1 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 1 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 + -> (JSRef -> JSRef -> IO ()) -- ^ the Haskell function + -> IO (Callback (JSRef -> JSRef -> IO ())) -- ^ the callback syncCallback2 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 2 (unsafeCoerce x) @@ -95,12 +95,12 @@ 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 :: (JSRef -> IO ()) -- ^ the function that the callback calls + -> IO (Callback (JSRef -> 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 :: (JSRef -> JSRef -> IO ()) -- ^ the Haskell function that the callback calls + -> IO (Callback (JSRef -> JSRef -> IO ())) -- ^ the callback asyncCallback2 x = js_asyncCallbackApply 2 (unsafeCoerce x) -- ---------------------------------------------------------------------------- diff --git a/GHCJS/Foreign/Callback/Internal.hs b/GHCJS/Foreign/Callback/Internal.hs index 0d02923..27259d4 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 JSRef deriving Typeable +instance IsJSRef (Callback a) -instance ToJSRef (Callback a) where - toJSRef = toJSRef_pure diff --git a/GHCJS/Foreign/Export.hs b/GHCJS/Foreign/Export.hs index 0e8957c..92a6666 100644 --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -1,7 +1,12 @@ -{-# 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 #-} +{-# LANGUAGE CPP #-} {- | Dynamically export Haskell values to JavaScript @@ -25,8 +30,7 @@ import Unsafe.Coerce import GHCJS.Prim -data (Export_ a) -type Export a = JSRef (Export_ a) +type Export a = JSRef {- | Export any Haskell value to a JavaScript reference without evaluating it. @@ -39,17 +43,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,11 +61,7 @@ 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 @@ -85,10 +82,10 @@ foreign import javascript unsafe js_export :: Word64 -> Word64 -> Any -> IO (Export a) foreign import javascript unsafe "h$derefExport" - js_derefExport :: Word64 -> Word64 -> JSRef a -> IO (JSRef ()) + js_derefExport :: Word64 -> Word64 -> JSRef -> IO JSRef foreign import javascript unsafe - "$r = $1;" js_toHeapObject :: JSRef a -> (# b #) + "$r = $1;" js_toHeapObject :: JSRef -> (# b #) foreign import javascript unsafe "h$releaseExport" - js_releaseExport :: JSRef a -> IO () + js_releaseExport :: JSRef -> IO () diff --git a/GHCJS/Foreign/Internal.hs b/GHCJS/Foreign/Internal.hs index 386e8cb..842c44a 100644 --- a/GHCJS/Foreign/Internal.hs +++ b/GHCJS/Foreign/Internal.hs @@ -128,65 +128,65 @@ data JSONType = JSONNull | JSONObject deriving (Show, Eq, Ord, Enum, Typeable) -fromJSBool :: JSRef Bool -> Bool +fromJSBool :: JSRef -> Bool fromJSBool b = js_fromBool b {-# INLINE fromJSBool #-} -toJSBool :: Bool -> JSRef Bool +toJSBool :: Bool -> JSRef toJSBool True = jsTrue toJSBool _ = jsFalse {-# INLINE toJSBool #-} -jsTrue :: JSRef Bool +jsTrue :: JSRef jsTrue = mkRef (js_true 0#) {-# INLINE jsTrue #-} -jsFalse :: JSRef Bool +jsFalse :: JSRef jsFalse = mkRef (js_false 0#) {-# INLINE jsFalse #-} -jsNull :: JSRef a +jsNull :: JSRef jsNull = mkRef (js_null 0#) {-# INLINE jsNull #-} -jsUndefined :: JSRef a +jsUndefined :: JSRef jsUndefined = mkRef (js_undefined 0#) {-# INLINE jsUndefined #-} -- check whether a reference is `truthy' in the JavaScript sense -isTruthy :: JSRef a -> Bool +isTruthy :: JSRef -> Bool isTruthy b = js_isTruthy b {-# INLINE isTruthy #-} --- isUndefined :: JSRef a -> Bool +-- isUndefined :: JSRef -> Bool -- isUndefined o = js_isUndefined o -- {-# INLINE isUndefined #-} --- isNull :: JSRef a -> Bool +-- isNull :: JSRef -> Bool -- isNull o = js_isNull o -- {-# INLINE isNull #-} -isObject :: JSRef a -> Bool +isObject :: JSRef -> Bool isObject o = js_isObject o {-# INLINE isObject #-} -isNumber :: JSRef a -> Bool +isNumber :: JSRef -> Bool isNumber o = js_isNumber o {-# INLINE isNumber #-} -isString :: JSRef a -> Bool +isString :: JSRef -> Bool isString o = js_isString o {-# INLINE isString #-} -isBoolean :: JSRef a -> Bool +isBoolean :: JSRef -> Bool isBoolean o = js_isBoolean o {-# INLINE isBoolean #-} -isFunction :: JSRef a -> Bool +isFunction :: JSRef -> Bool isFunction o = js_isFunction o {-# INLINE isFunction #-} -isSymbol :: JSRef a -> Bool +isSymbol :: JSRef -> Bool isSymbol o = js_isSymbol o {-# INLINE isSymbol #-} @@ -222,7 +222,7 @@ ptr'ToPtr = unsafeCoerce -} {- toArray :: [JSRef a] -> IO (JSArray a) -toArray xs = fmap castRef (Prim.toJSArray xs) +toArray xs = Prim.toJSArray xs {-# INLINE toArray #-} pushArray :: JSRef a -> JSArray a -> IO () @@ -230,7 +230,7 @@ pushArray r arr = js_push r arr {-# INLINE pushArray #-} fromArray :: JSArray (JSRef a) -> IO [JSRef a] -fromArray a = Prim.fromJSArray (castRef a) +fromArray a = Prim.fromJSArray a {-# INLINE fromArray #-} lengthArray :: JSArray a -> IO Int @@ -257,11 +257,11 @@ listProps :: JSRef a -> IO [JSString] listProps o = fmap unsafeCoerce . Prim.fromJSArray =<< js_listProps o {-# INLINE listProps #-} -} -jsTypeOf :: JSRef a -> JSType +jsTypeOf :: JSRef -> JSType jsTypeOf r = tagToEnum# (js_jsTypeOf r) {-# INLINE jsTypeOf #-} -jsonTypeOf :: JSRef a -> JSONType +jsonTypeOf :: JSRef -> JSONType jsonTypeOf r = tagToEnum# (js_jsonTypeOf r) {-# INLINE jsonTypeOf #-} @@ -370,10 +370,10 @@ unsafeMutableByteArrayByteString arr = foreign import javascript unsafe "$r = $1===true;" - js_fromBool :: JSRef a -> Bool + js_fromBool :: JSRef -> Bool foreign import javascript unsafe "$1 ? true : false" - js_isTruthy :: JSRef a -> Bool + js_isTruthy :: JSRef -> 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# @@ -392,26 +392,26 @@ foreign import javascript unsafe "$r = undefined;" js_undefined :: Int# -> Ref# --foreign import javascript unsafe "$2[$1]" -- js_unsafeIndex :: Int -> JSArray a -> IO (JSRef a) foreign import javascript unsafe "$2[$1]" - js_unsafeGetProp :: JSString -> JSRef a -> IO (JSRef b) + js_unsafeGetProp :: JSString -> JSRef -> IO JSRef foreign import javascript unsafe "$3[$1] = $2" - js_unsafeSetProp :: JSString -> JSRef a -> JSRef b -> IO () + js_unsafeSetProp :: JSString -> JSRef -> JSRef -> IO () {- foreign import javascript safe "h$listProps($1)" js_listProps :: JSRef a -> IO (JSArray JSString) -} foreign import javascript unsafe "h$jsTypeOf($1)" - js_jsTypeOf :: JSRef a -> Int# + js_jsTypeOf :: JSRef -> Int# foreign import javascript unsafe "h$jsonTypeOf($1)" - js_jsonTypeOf :: JSRef a -> Int# + js_jsonTypeOf :: JSRef -> 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 +foreign import javascript unsafe "h$isObject" js_isObject :: JSRef -> Bool +foreign import javascript unsafe "h$isBoolean" js_isBoolean :: JSRef -> Bool +foreign import javascript unsafe "h$isNumber" js_isNumber :: JSRef -> Bool +foreign import javascript unsafe "h$isString" js_isString :: JSRef -> Bool +foreign import javascript unsafe "h$isSymbol" js_isSymbol :: JSRef -> Bool +foreign import javascript unsafe "h$isFunction" js_isFunction :: JSRef -> Bool diff --git a/GHCJS/Internal/Types.hs b/GHCJS/Internal/Types.hs index da98330..7aa3f98 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 (JSRef) + +instance NFData JSRef where + rnf x = x `seq` () + +class IsJSRef a where + jsref_ :: a -> JSRef + + default jsref_ :: Coercible a JSRef => a -> JSRef + jsref_ = coerce + {-# INLINE jsref_ #-} + +jsref :: IsJSRef a => a -> JSRef +jsref = jsref_ +{-# INLINE jsref #-} + data MutabilityType s = Mutable | Immutable | STMutable s diff --git a/GHCJS/Marshal.hs b/GHCJS/Marshal.hs index 6960e57..85a97a1 100644 --- a/GHCJS/Marshal.hs +++ b/GHCJS/Marshal.hs @@ -60,10 +60,10 @@ import qualified JavaScript.Object.Internal as OI import GHCJS.Marshal.Internal -instance FromJSRef (JSRef a) where - fromJSRefUnchecked x = return (castRef x) +instance FromJSRef JSRef where + fromJSRefUnchecked x = return x {-# INLINE fromJSRefUnchecked #-} - fromJSRef = return . Just . castRef + fromJSRef = return . Just {-# INLINE fromJSRef #-} instance FromJSRef () where fromJSRefUnchecked = fromJSRefUnchecked_pure @@ -75,10 +75,10 @@ instance FromJSRef a => FromJSRef [a] where {-# INLINE fromJSRef #-} instance FromJSRef a => FromJSRef (Maybe a) where fromJSRefUnchecked x | isUndefined x || isNull x = return Nothing - | otherwise = fromJSRef (castRef x) + | otherwise = fromJSRef x {-# INLINE fromJSRefUnchecked #-} fromJSRef x | isUndefined x || isNull x = return (Just Nothing) - | otherwise = fmap (fmap Just) fromJSRef (castRef x) + | otherwise = fmap (fmap Just) fromJSRef x {-# INLINE fromJSRef #-} instance FromJSRef JSString where fromJSRefUnchecked = fromJSRefUnchecked_pure @@ -95,9 +95,9 @@ instance FromJSRef Char where {-# INLINE fromJSRefUnchecked #-} fromJSRef = fromJSRef_pure {-# INLINE fromJSRef #-} - fromJSRefUncheckedListOf = fromJSRefUnchecked_pure . castRef + fromJSRefUncheckedListOf = fromJSRefUnchecked_pure {-# INLINE fromJSRefListOf #-} - fromJSRefListOf = fromJSRef_pure . castRef + fromJSRefListOf = fromJSRef_pure {-# INLINE fromJSRefUncheckedListOf #-} instance FromJSRef Bool where fromJSRefUnchecked = fromJSRefUnchecked_pure @@ -158,17 +158,17 @@ instance FromJSRef AE.Value where fromJSRef r = case jsonTypeOf r of JSONNull -> return (Just AE.Null) JSONInteger -> liftM (AE.Number . flip scientific 0 . (toInteger :: Int -> Integer)) - <$> (fromJSRef $ castRef r) + <$> fromJSRef 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) + <$> fromJSRef r + JSONBool -> liftM AE.Bool <$> fromJSRef r + JSONString -> liftM AE.String <$> fromJSRef r + JSONArray -> liftM (AE.Array . V.fromList) <$> fromJSRef 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 (fromJSRef =<< OI.getProp p (OI.Object r)) return (JSS.textFromJSString p, v) return (AE.Object (H.fromList propVals)) {-# INLINE fromJSRef #-} @@ -194,14 +194,14 @@ instance (FromJSRef a, FromJSRef b, FromJSRef c, FromJSRef d, FromJSRef e, FromJ 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 #-} -jf :: FromJSRef a => JSRef b -> Int -> MaybeT IO a +jf :: FromJSRef a => JSRef -> 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' -instance ToJSRef (JSRef a) where +instance ToJSRef JSRef where toJSRef = toJSRef_pure {-# INLINE toJSRef #-} instance ToJSRef AE.Value where @@ -256,7 +256,7 @@ instance ToJSRef a => ToJSRef [a] where {-# INLINE toJSRef #-} instance ToJSRef a => ToJSRef (Maybe a) where toJSRef Nothing = return jsNull - toJSRef (Just a) = castRef <$> toJSRef a + toJSRef (Just a) = toJSRef a {-# INLINE toJSRef #-} instance (ToJSRef a, ToJSRef b) => ToJSRef (a,b) where toJSRef (a,b) = join $ arr2 <$> toJSRef a <*> toJSRef b @@ -277,26 +277,26 @@ instance (ToJSRef a, ToJSRef b, ToJSRef c, ToJSRef d, ToJSRef e, ToJSRef f, ToJS 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 #-} -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 :: JSRef -> IO JSRef +foreign import javascript unsafe "[$1,$2]" arr2 :: JSRef -> JSRef -> IO JSRef +foreign import javascript unsafe "[$1,$2,$3]" arr3 :: JSRef -> JSRef -> JSRef -> IO JSRef +foreign import javascript unsafe "[$1,$2,$3,$4]" arr4 :: JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef +foreign import javascript unsafe "[$1,$2,$3,$4,$5]" arr5 :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]" arr6 :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" arr7 :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef -toJSRef_aeson :: AE.ToJSON a => a -> IO (JSRef a) +toJSRef_aeson :: AE.ToJSON a => a -> IO JSRef toJSRef_aeson x = cv (AE.toJSON x) where - cv = fmap castRef . convertValue + cv = convertValue - convertValue :: AE.Value -> IO (JSRef ()) + convertValue :: AE.Value -> IO JSRef 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 (pToJSRef 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) = toJSRef (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..2fbcd55 100644 --- a/GHCJS/Marshal/Internal.hs +++ b/GHCJS/Marshal/Internal.hs @@ -40,41 +40,41 @@ data Purity = PureShared -- ^ conversion is pure even if the original value i class PToJSRef a where -- type PureOut a :: Purity - pToJSRef :: a -> JSRef a + pToJSRef :: a -> JSRef class PFromJSRef a where -- type PureIn a :: Purity - pFromJSRef :: JSRef a -> a + pFromJSRef :: JSRef -> a class ToJSRef a where - toJSRef :: a -> IO (JSRef a) + toJSRef :: a -> IO JSRef - toJSRefListOf :: [a] -> IO (JSRef [a]) - toJSRefListOf = fmap castRef . (Prim.toJSArray <=< mapM toJSRef) + toJSRefListOf :: [a] -> IO JSRef + toJSRefListOf = Prim.toJSArray <=< mapM toJSRef -- default toJSRef :: PToJSRef a => a -> IO (JSRef a) -- toJSRef x = return (pToJSRef x) - default toJSRef :: (Generic a, GToJSRef (Rep a ())) => a -> IO (JSRef a) + default toJSRef :: (Generic a, GToJSRef (Rep a ())) => a -> IO JSRef toJSRef = toJSRef_generic id class FromJSRef a where - fromJSRef :: JSRef a -> IO (Maybe a) + fromJSRef :: JSRef -> IO (Maybe a) - fromJSRefUnchecked :: JSRef a -> IO a + fromJSRefUnchecked :: JSRef -> IO a fromJSRefUnchecked = fmap fromJust . fromJSRef {-# INLINE fromJSRefUnchecked #-} - fromJSRefListOf :: JSRef [a] -> IO (Maybe [a]) - fromJSRefListOf = fmap sequence . (mapM fromJSRef <=< Prim.fromJSArray . castRef) -- fixme should check that it's an array + fromJSRefListOf :: JSRef -> IO (Maybe [a]) + fromJSRefListOf = fmap sequence . (mapM fromJSRef <=< Prim.fromJSArray) -- fixme should check that it's an array - fromJSRefUncheckedListOf :: JSRef [a] -> IO [a] - fromJSRefUncheckedListOf = mapM fromJSRefUnchecked <=< Prim.fromJSArray . castRef + fromJSRefUncheckedListOf :: JSRef -> IO [a] + fromJSRefUncheckedListOf = mapM fromJSRefUnchecked <=< Prim.fromJSArray -- default fromJSRef :: PFromJSRef a => JSRef a -> IO (Maybe a) -- fromJSRef x = return (Just (pFromJSRef x)) - default fromJSRef :: (Generic a, GFromJSRef (Rep a ())) => JSRef a -> IO (Maybe a) + default fromJSRef :: (Generic a, GFromJSRef (Rep a ())) => JSRef -> IO (Maybe a) fromJSRef = fromJSRef_generic id -- default fromJSRefUnchecked :: PFromJSRef a => a -> IO a @@ -83,16 +83,16 @@ class FromJSRef a where -- ----------------------------------------------------------------------------- class GToJSRef a where - gToJSRef :: (String -> String) -> Bool -> a -> IO (JSRef ()) + gToJSRef :: (String -> String) -> Bool -> a -> IO JSRef class GToJSProp a where - gToJSProp :: (String -> String) -> JSRef () -> a -> IO () + gToJSProp :: (String -> String) -> JSRef -> 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 + gToJSRef _ _ (K1 x) = toJSRef x instance GToJSRef p => GToJSRef (Par1 p) where gToJSRef f b (Par1 p) = gToJSRef f b p @@ -123,7 +123,7 @@ instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => G gToJSRef 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 @@ -142,31 +142,31 @@ instance (GToJSArr (a p), GToJSArr (b p)) => GToJSArr ((a :*: b) p) where instance GToJSRef (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 + AI.push r a instance GToJSRef (V1 p) where gToJSRef _ _ _ = return Prim.jsNull instance GToJSRef (U1 p) where - gToJSRef _ _ _ = return (castRef F.jsTrue) + gToJSRef _ _ _ = 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 ()) + => (String -> String) -> a -> IO JSRef +toJSRef_generic f x = gToJSRef f False (from x :: Rep a ()) -- ----------------------------------------------------------------------------- class GFromJSRef a where - gFromJSRef :: (String -> String) -> Bool -> JSRef () -> IO (Maybe a) + gFromJSRef :: (String -> String) -> Bool -> JSRef -> IO (Maybe a) class GFromJSProp a where - gFromJSProp :: (String -> String) -> JSRef () -> IO (Maybe a) + gFromJSProp :: (String -> String) -> JSRef -> 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) + gFromJSRef _ _ r = fmap K1 <$> fromJSRef r instance GFromJSRef p => GFromJSRef (Par1 p) where gFromJSRef f b r = gFromJSRef f b r @@ -228,7 +228,7 @@ instance (GFromJSRef (a p)) => GFromJSArr (M1 S c a p) where 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) <$> gFromJSRef f False r instance GFromJSRef (V1 p) where gFromJSRef _ _ _ = return Nothing @@ -237,20 +237,20 @@ instance GFromJSRef (U1 p) where gFromJSRef _ _ _ = 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 ()))) + => (String -> String) -> JSRef -> IO (Maybe a) +fromJSRef_generic f x = fmap to <$> (gFromJSRef f False x :: IO (Maybe (Rep a ()))) -- ----------------------------------------------------------------------------- -fromJSRef_pure :: PFromJSRef a => JSRef a -> IO (Maybe a) +fromJSRef_pure :: PFromJSRef a => JSRef -> IO (Maybe a) fromJSRef_pure x = return (Just (pFromJSRef x)) {-# INLINE fromJSRef_pure #-} -fromJSRefUnchecked_pure :: PFromJSRef a => JSRef a -> IO a +fromJSRefUnchecked_pure :: PFromJSRef a => JSRef -> IO a fromJSRefUnchecked_pure x = return (pFromJSRef x) {-# INLINE fromJSRefUnchecked_pure #-} -toJSRef_pure :: PToJSRef a => a -> IO (JSRef a) +toJSRef_pure :: PToJSRef a => a -> IO JSRef toJSRef_pure x = return (pToJSRef x) {-# INLINE toJSRef_pure #-} diff --git a/GHCJS/Marshal/Pure.hs b/GHCJS/Marshal/Pure.hs index bd95698..b53f105 100644 --- a/GHCJS/Marshal/Pure.hs +++ b/GHCJS/Marshal/Pure.hs @@ -1,21 +1,21 @@ -{-# 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 -} @@ -56,12 +56,12 @@ 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 JSRef where pFromJSRef = id + {-# INLINE pFromJSRef #-} +instance PFromJSRef () where pFromJSRef _ = () + {-# INLINE pFromJSRef #-} -instance PFromJSRef JSString where pFromJSRef = JSString . castRef +instance PFromJSRef JSString where pFromJSRef = JSString {-# INLINE pFromJSRef #-} instance PFromJSRef [Char] where pFromJSRef = Prim.fromJSString {-# INLINE pFromJSRef #-} @@ -69,7 +69,7 @@ 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 +instance PFromJSRef Bool where pFromJSRef = isTruthy {-# INLINE pFromJSRef #-} instance PFromJSRef Int where pFromJSRef x = I# (jsrefToInt x) {-# INLINE pFromJSRef #-} @@ -94,21 +94,21 @@ instance PFromJSRef Double where pFromJSRef x = D# (jsrefToDouble x) instance PFromJSRef a => PFromJSRef (Maybe a) where pFromJSRef x | isUndefined x || isNull x = Nothing - pFromJSRef x = Just (pFromJSRef (castRef x)) + pFromJSRef x = Just (pFromJSRef x) {-# INLINE pFromJSRef #-} -instance PToJSRef (JSRef a) where pToJSRef = castRef +instance PToJSRef JSRef where pToJSRef = id {-# INLINE pToJSRef #-} -instance PToJSRef JSString where pToJSRef = castRef . unJSString +instance PToJSRef JSString where pToJSRef = jsref {-# INLINE pToJSRef #-} instance PToJSRef [Char] where pToJSRef = Prim.toJSString {-# INLINE pToJSRef #-} -instance PToJSRef Text where pToJSRef = castRef . unJSString . textToJSString +instance PToJSRef Text where pToJSRef = jsref . 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 +instance PToJSRef Bool where pToJSRef True = jsTrue + pToJSRef False = jsFalse {-# INLINE pToJSRef #-} instance PToJSRef Int where pToJSRef (I# x) = intToJSRef x {-# INLINE pToJSRef #-} @@ -133,22 +133,22 @@ instance PToJSRef Double where pToJSRef (D# x) = doubleToJSRef x instance PToJSRef a => PToJSRef (Maybe a) where pToJSRef Nothing = jsNull - pToJSRef (Just a) = castRef (pToJSRef a) + pToJSRef (Just a) = pToJSRef a {-# INLINE pToJSRef #-} -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;" jsrefToWord :: JSRef -> Word# +foreign import javascript unsafe "$r = $1&0xff;" jsrefToWord8 :: JSRef -> Word# +foreign import javascript unsafe "$r = $1&0xffff;" jsrefToWord16 :: JSRef -> Word# +foreign import javascript unsafe "$r = $1|0;" jsrefToInt :: JSRef -> Int# +foreign import javascript unsafe "$r = $1<<24>>24;" jsrefToInt8 :: JSRef -> Int# +foreign import javascript unsafe "$r = $1<<16>>16;" jsrefToInt16 :: JSRef -> Int# +foreign import javascript unsafe "$r = +$1;" jsrefToFloat :: JSRef -> Float# +foreign import javascript unsafe "$r = +$1;" jsrefToDouble :: JSRef -> Double# +foreign import javascript unsafe "$r = $1&0x7fffffff;" jsrefToChar :: JSRef -> 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;" wordToJSRef :: Word# -> JSRef +foreign import javascript unsafe "$r = $1;" intToJSRef :: Int# -> JSRef +foreign import javascript unsafe "$r = $1;" doubleToJSRef :: Double# -> JSRef +foreign import javascript unsafe "$r = $1;" floatToJSRef :: Float# -> JSRef +foreign import javascript unsafe "$r = $1;" charToJSRef :: Char# -> JSRef diff --git a/GHCJS/Types.hs b/GHCJS/Types.hs index 9de3943..90adf9f 100644 --- a/GHCJS/Types.hs +++ b/GHCJS/Types.hs @@ -1,70 +1,60 @@ -{-# LANGUAGE EmptyDataDecls, MagicHash, BangPatterns, - CPP, ForeignFunctionInterface, JavaScriptFFI #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} module GHCJS.Types ( JSRef + , IsJSRef + , jsref , isNull , isUndefined , nullRef - , castRef , JSString --- , JSObject --- , JSBool --- , JSNumber --- , JSFun , mkRef , Ref# + , toPtr + , fromPtr ) 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 :: ByteArray# -> JSRef mkRef x = JSRef x -nullRef :: JSRef a +nullRef :: JSRef nullRef = js_nullRef {-# INLINE nullRef #-} -castRef :: JSRef a -> JSRef b -castRef = unsafeCoerce -{-# INLINE castRef #-} - -toPtr :: JSRef a -> Ptr b +toPtr :: JSRef -> Ptr a toPtr (JSRef 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 -> JSRef +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 :: JSRef + +foreign import javascript unsafe "$r = $1_1;" + js_ptrVal :: Ptr a -> JSRef +foreign import javascript unsafe "$r1 = $1; $r2 = 0;" + js_mkPtr :: JSRef -> Ptr a diff --git a/JavaScript/Array.hs b/JavaScript/Array.hs index 63e1bdd..7b60aa4 100644 --- a/JavaScript/Array.hs +++ b/JavaScript/Array.hs @@ -42,11 +42,11 @@ import JavaScript.Array.Internal -- import qualified JavaScript.Array.Internal as I {- -fromList :: [JSRef a] -> IO (JSArray a) +fromList :: [JSRef] -> IO (JSArray a) fromList xs = fmap JSArray (I.fromList xs) {-# INLINE fromList #-} -toList :: JSArray a -> IO [JSRef a] +toList :: JSArray a -> IO [JSRef] toList (JSArray x) = I.toList x {-# INLINE toList #-} @@ -63,17 +63,17 @@ append (JSArray x) (JSArray y) = fmap JSArray (I.append x y) {-# INLINE append #-} -} -(!) :: JSArray -> Int -> JSRef a +(!) :: JSArray -> Int -> JSRef x ! n = index n x {-# INLINE (!) #-} {- -index :: Int -> JSArray a -> IO (JSRef a) +index :: Int -> JSArray a -> IO JSRef index n (JSArray x) = I.index n x {-# INLINE index #-} -write :: Int -> JSRef a -> JSArray a -> IO () +write :: Int -> JSRef -> JSArray a -> IO () write n e (JSArray x) = I.write n e x {-# INLINE write #-} @@ -89,19 +89,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 :: JSRef -> JSArray a -> IO () push e (JSArray x) = I.push e x {-# INLINE push #-} -pop :: JSArray a -> IO (JSRef a) +pop :: JSArray a -> IO JSRef pop (JSArray x) = I.pop x {-# INLINE pop #-} -unshift :: JSRef a -> JSArray a -> IO () +unshift :: JSRef -> JSArray a -> IO () unshift e (JSArray x) = I.unshift e x {-# INLINE unshift #-} -shift :: JSArray a -> IO (JSRef a) +shift :: JSArray a -> IO JSRef shift (JSArray x) = I.shift x {-# INLINE shift #-} diff --git a/JavaScript/Array/Internal.hs b/JavaScript/Array/Internal.hs index 58aa37b..f151cc8 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 JSRef deriving (Typeable) +instance IsJSRef (SomeJSArray m) type JSArray = SomeJSArray Immutable type MutableJSArray = SomeJSArray Mutable @@ -47,47 +48,47 @@ append :: SomeJSArray m -> SomeJSArray m -> IO (SomeJSArray m1) append x y = IO (js_append x y) {-# INLINE append #-} -fromList :: [JSRef a] -> JSArray +fromList :: [JSRef] -> JSArray fromList xs = rnf xs `seq` js_toJSArrayPure (unsafeCoerce xs) {-# INLINE fromList #-} -fromListIO :: [JSRef a] -> IO (SomeJSArray m) +fromListIO :: [JSRef] -> IO (SomeJSArray m) fromListIO xs = IO (\s -> rnf xs `seq` js_toJSArray (unsafeCoerce xs) s) {-# INLINE fromListIO #-} -toList :: JSArray -> [JSRef a] +toList :: JSArray -> [JSRef] toList x = case js_fromJSArrayPure x of (# xs #) -> xs {-# INLINE toList #-} -toListIO :: SomeJSArray m -> IO [JSRef a] +toListIO :: SomeJSArray m -> IO [JSRef] toListIO x = IO (js_fromJSArray x) {-# INLINE toListIO #-} -index :: Int -> JSArray -> JSRef a +index :: Int -> JSArray -> JSRef index n x = js_indexPure n x {-# INLINE index #-} -read :: Int -> SomeJSArray m -> IO (JSRef a) +read :: Int -> SomeJSArray m -> IO JSRef read n x = IO (js_index n x) {-# INLINE read #-} -write :: Int -> JSRef a -> MutableJSArray -> IO () +write :: Int -> JSRef -> MutableJSArray -> IO () write n e x = IO (js_setIndex n e x) {-# INLINE write #-} -push :: JSRef a -> MutableJSArray -> IO () +push :: JSRef -> MutableJSArray -> IO () push e x = IO (js_push e x) {-# INLINE push #-} -pop :: MutableJSArray -> IO (JSRef a) +pop :: MutableJSArray -> IO JSRef pop x = IO (js_pop x) {-# INLINE pop #-} -unshift :: JSRef a -> MutableJSArray -> IO () +unshift :: JSRef -> MutableJSArray -> IO () unshift e x = IO (js_unshift e x) {-# INLINE unshift #-} -shift :: MutableJSArray -> IO (JSRef a) +shift :: MutableJSArray -> IO JSRef shift x = IO (js_shift x) {-# INLINE shift #-} @@ -144,15 +145,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, JSRef #) foreign import javascript unsafe "$2[$1]" - js_indexPure :: Int -> JSArray -> JSRef a + js_indexPure :: Int -> JSArray -> JSRef 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 -> JSRef -> 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,22 +169,22 @@ 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 :: JSRef -> 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, JSRef #) foreign import javascript unsafe "$2.unshift($1)" - js_unshift :: JSRef a -> SomeJSArray m -> State# s -> (# State# s, () #) + js_unshift :: JSRef -> 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, JSRef #) foreign import javascript unsafe "$1.reverse()" js_reverse :: SomeJSArray m -> State# s -> (# State# s, () #) foreign import javascript unsafe "h$toHsListJSRef($1)" - js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, [JSRef a] #) + js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, [JSRef] #) foreign import javascript unsafe "h$toHsListJSRef($1)" - js_fromJSArrayPure :: JSArray -> (# [JSRef a] #) + js_fromJSArrayPure :: JSArray -> (# [JSRef] #) foreign import javascript unsafe "h$fromHsListJSRef($1)" js_toJSArray :: Exts.Any -> State# s -> (# State# s, SomeJSArray m #) diff --git a/JavaScript/Array/ST.hs b/JavaScript/Array/ST.hs index 8c2e235..134deff 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 :: [JSRef] -> 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 :: STJSArray s -> ST s [JSRef] toList x = ST (I.js_fromJSArray x) {-# INLINE toList #-} -read :: Int -> STJSArray s -> ST s (JSRef a) +read :: Int -> STJSArray s -> ST s (JSRef) read n x = ST (I.js_index n x) {-# INLINE read #-} -write :: Int -> JSRef a -> STJSArray s -> ST s () +write :: Int -> JSRef -> 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 :: JSRef -> 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 JSRef pop x = ST (I.js_pop x) {-# INLINE pop #-} -unshift :: JSRef a -> STJSArray s -> ST s () +unshift :: JSRef -> 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 JSRef shift x = ST (I.js_shift x) {-# INLINE shift #-} diff --git a/JavaScript/Cast.hs b/JavaScript/Cast.hs index ddc8d87..77ab085 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 => JSRef -> 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 => JSRef -> a unsafeCast x = unsafeWrap x {-# INLINE unsafeCast #-} class Cast a where - unsafeWrap :: JSRef () -> a - instanceRef :: a -> JSRef () + unsafeWrap :: JSRef -> a + instanceRef :: a -> JSRef -- ----------------------------------------------------------------------------- foreign import javascript unsafe - "$1 instanceof $2" js_checkCast :: JSRef () -> JSRef () -> Bool + "$1 instanceof $2" js_checkCast :: JSRef -> JSRef -> Bool diff --git a/JavaScript/JSON/Types/Internal.hs b/JavaScript/JSON/Types/Internal.hs index 0b9ce2b..4b1384f 100644 --- a/JavaScript/JSON/Types/Internal.hs +++ b/JavaScript/JSON/Types/Internal.hs @@ -84,7 +84,7 @@ instance Exception JSONException -- any JSON value newtype SomeValue (m :: MutabilityType s) = - SomeValue (JSRef ()) deriving (Typeable) + SomeValue JSRef deriving (Typeable) type Value = SomeValue Immutable type MutableValue = SomeValue Mutable instance NFData (SomeValue (m :: MutabilityType s)) where @@ -92,7 +92,7 @@ instance NFData (SomeValue (m :: MutabilityType s)) where -- a dictionary (object) newtype SomeObject (m :: MutabilityType s) = - SomeObject (JSRef ()) deriving (Typeable) + SomeObject JSRef deriving (Typeable) type Object = SomeObject Immutable type MutableObject = SomeObject Mutable instance NFData (SomeObject (m :: MutabilityType s)) where @@ -276,29 +276,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_jsrefToDouble :: JSRef -> Double foreign import javascript unsafe - "$r = $1;" js_jsrefToBool :: JSRef () -> Bool + "$r = $1;" js_jsrefToBool :: JSRef -> Bool -- ----------------------------------------------------------------------------- -- various lookups foreign import javascript unsafe "$2[$1]" - js_lookupDictPure :: JSString -> Object -> JSRef () + js_lookupDictPure :: JSString -> Object -> JSRef foreign import javascript unsafe "typeof($2)==='object'?$2[$1]:undefined" - js_lookupDictPureSafe :: JSString -> Value -> JSRef () + js_lookupDictPureSafe :: JSString -> Value -> JSRef foreign import javascript unsafe - "$2[$1]" js_lookupArrayPure :: Int -> A.JSArray -> JSRef () + "$2[$1]" js_lookupArrayPure :: Int -> A.JSArray -> JSRef foreign import javascript unsafe "h$isArray($2) ? $2[$1] : undefined" - js_lookupArrayPureSafe :: Int -> Value -> JSRef () + js_lookupArrayPureSafe :: Int -> Value -> JSRef foreign import javascript unsafe "$r = $1;" - js_doubleToJSRef :: Double -> JSRef () + js_doubleToJSRef :: Double -> JSRef foreign import javascript unsafe "JSON.decode(JSON.encode($1))" diff --git a/JavaScript/Object/Internal.hs b/JavaScript/Object/Internal.hs index 2d031e4..a3d040a 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,8 @@ import GHCJS.Types import qualified JavaScript.Array as JA import JavaScript.Array.Internal (JSArray, SomeJSArray(..)) -newtype Object = Object (JSRef ()) deriving (Typeable) +newtype Object = Object JSRef deriving (Typeable) +instance IsJSRef Object -- | create an empty object create :: IO Object @@ -43,23 +48,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 JSRef getProp p o = js_getProp p o {-# INLINE getProp #-} -unsafeGetProp :: JSString -> Object -> IO (JSRef a) +unsafeGetProp :: JSString -> Object -> IO JSRef unsafeGetProp p o = js_unsafeGetProp p o {-# INLINE unsafeGetProp #-} -setProp :: JSString -> JSRef a -> Object -> IO () +setProp :: JSString -> JSRef -> Object -> IO () setProp p v o = js_setProp p v o {-# INLINE setProp #-} -unsafeSetProp :: JSString -> JSRef a -> Object -> IO () +unsafeSetProp :: JSString -> JSRef -> Object -> IO () unsafeSetProp p v o = js_unsafeSetProp p v o {-# INLINE unsafeSetProp #-} -isInstanceOf :: Object -> JSRef a -> Bool +isInstanceOf :: Object -> JSRef -> Bool isInstanceOf o s = js_isInstanceOf o s {-# INLINE isInstanceOf #-} @@ -68,15 +73,15 @@ 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 JSRef foreign import javascript unsafe "$2[$1]" - js_unsafeGetProp :: JSString -> Object -> IO (JSRef b) + js_unsafeGetProp :: JSString -> Object -> IO JSRef foreign import javascript safe "$3[$1] = $2" - js_setProp :: JSString -> JSRef a -> Object -> IO () + js_setProp :: JSString -> JSRef -> Object -> IO () foreign import javascript unsafe "$3[$1] = $2" - js_unsafeSetProp :: JSString -> JSRef a -> Object -> IO () + js_unsafeSetProp :: JSString -> JSRef -> Object -> IO () foreign import javascript unsafe "$1 instanceof $2" - js_isInstanceOf :: Object -> JSRef a -> Bool + js_isInstanceOf :: Object -> JSRef -> Bool foreign import javascript unsafe "h$allProps" js_allProps :: Object -> IO JSArray foreign import javascript unsafe "h$listProps" diff --git a/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/JavaScript/TypedArray/ArrayBuffer/Internal.hs index f2d08fb..d11a87e 100644 --- a/JavaScript/TypedArray/ArrayBuffer/Internal.hs +++ b/JavaScript/TypedArray/ArrayBuffer/Internal.hs @@ -1,7 +1,16 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, UnliftedFFITypes, - GHCForeignImportPrim, MagicHash, UnboxedTuples, MagicHash, - TypeSynonymInstances, FlexibleInstances, DataKinds, PolyKinds - #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + module JavaScript.TypedArray.ArrayBuffer.Internal where import GHCJS.Types @@ -11,26 +20,29 @@ import GHCJS.Marshal.Pure import GHC.Exts (State#) -newtype SomeArrayBuffer (a :: MutabilityType s) = SomeArrayBuffer (JSRef ()) +import Data.Typeable + +newtype SomeArrayBuffer (a :: MutabilityType s) = + SomeArrayBuffer JSRef deriving Typeable +instance IsJSRef (SomeArrayBuffer m) type ArrayBuffer = SomeArrayBuffer Immutable type MutableArrayBuffer = SomeArrayBuffer Mutable type STArrayBuffer s = SomeArrayBuffer (STMutable s) - instance PToJSRef MutableArrayBuffer where - pToJSRef (SomeArrayBuffer b) = castRef b + pToJSRef (SomeArrayBuffer b) = b instance PFromJSRef MutableArrayBuffer where - pFromJSRef = SomeArrayBuffer . castRef + pFromJSRef = SomeArrayBuffer -- ---------------------------------------------------------------------------- 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 () #) + "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 () #) + "$2.slice($1)" js_slice1 :: Int -> JSRef -> State# s -> (# State# s, JSRef #) -- ---------------------------------------------------------------------------- -- immutable non-IO slice diff --git a/JavaScript/TypedArray/DataView/Internal.hs b/JavaScript/TypedArray/DataView/Internal.hs index 9a85a8f..3f210f7 100644 --- a/JavaScript/TypedArray/DataView/Internal.hs +++ b/JavaScript/TypedArray/DataView/Internal.hs @@ -1,8 +1,15 @@ -{-# LANGUAGE CPP, JavaScriptFFI, ForeignFunctionInterface, - UnliftedFFITypes, GHCForeignImportPrim, MagicHash, - UnboxedTuples, DeriveDataTypeable, DataKinds, KindSignatures, - PolyKinds - #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} + module JavaScript.TypedArray.DataView.Internal where import Data.Int @@ -16,8 +23,8 @@ import GHCJS.Internal.Types import JavaScript.TypedArray.ArrayBuffer.Internal -newtype SomeDataView (a :: MutabilityType s) = SomeDataView (JSRef ()) - deriving (Typeable) +newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSRef + deriving Typeable type DataView = SomeDataView Immutable type MutableDataView = SomeDataView Mutable @@ -27,15 +34,15 @@ type STDataView s = SomeDataView (STMutable s) #define JSS foreign import javascript safe JSU "new DataView($1)" - js_dataView1 :: JSRef () -> JSRef () + js_dataView1 :: JSRef -> JSRef JSS "new DataView($2,$1)" - js_dataView2 :: Int -> JSRef () -> SomeDataView m + js_dataView2 :: Int -> JSRef -> SomeDataView m JSU "new DataView($2,$1)" - js_unsafeDataView2 :: Int -> JSRef () -> SomeDataView m + js_unsafeDataView2 :: Int -> JSRef-> SomeDataView m JSS "new DataView($3,$1,$2)" - js_dataView :: Int -> Int -> JSRef () -> SomeDataView m + js_dataView :: Int -> Int -> JSRef -> SomeDataView m JSU "new DataView($3,$1,$2)" - js_unsafeDataView :: Int -> Int -> JSRef () -> JSRef () + js_unsafeDataView :: Int -> Int -> JSRef -> JSRef JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))" js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1) diff --git a/JavaScript/TypedArray/Internal.hs b/JavaScript/TypedArray/Internal.hs index d05d4c2..e69e45e 100644 --- a/JavaScript/TypedArray/Internal.hs +++ b/JavaScript/TypedArray/Internal.hs @@ -1,7 +1,16 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, JavaScriptFFI, ForeignFunctionInterface, - UnliftedFFITypes, GHCForeignImportPrim, EmptyDataDecls, TypeFamilies, - TypeSynonymInstances, FlexibleInstances, DataKinds, PolyKinds, KindSignatures - #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} module JavaScript.TypedArray.Internal where @@ -499,29 +508,29 @@ foreign import javascript unsafe foreign import javascript unsafe "new Int8Array($1)" - js_int8ArrayFromJSRef :: JSRef () -> SomeInt8Array m + js_int8ArrayFromJSRef :: JSRef -> SomeInt8Array m foreign import javascript unsafe "new Int16Array($1)" - js_int16ArrayFromJSRef :: JSRef () -> SomeInt16Array m + js_int16ArrayFromJSRef :: JSRef -> SomeInt16Array m foreign import javascript unsafe "new Int32Array($1)" - js_int32ArrayFromJSRef :: JSRef () -> SomeInt32Array m + js_int32ArrayFromJSRef :: JSRef -> SomeInt32Array m foreign import javascript unsafe "new Uint8ClampedArray($1)" - js_uint8ClampedArrayFromJSRef :: JSRef () -> SomeUint8ClampedArray m + js_uint8ClampedArrayFromJSRef :: JSRef -> SomeUint8ClampedArray m foreign import javascript unsafe "new Uint8Array($1)" - js_uint8ArrayFromJSRef :: JSRef () -> SomeUint8Array m + js_uint8ArrayFromJSRef :: JSRef -> SomeUint8Array m foreign import javascript unsafe "new Uint16Array($1)" - js_uint16ArrayFromJSRef :: JSRef () -> SomeUint16Array m + js_uint16ArrayFromJSRef :: JSRef -> SomeUint16Array m foreign import javascript unsafe "new Uint32Array($1)" - js_uint32ArrayFromJSRef :: JSRef () -> SomeUint32Array m + js_uint32ArrayFromJSRef :: JSRef -> SomeUint32Array m foreign import javascript unsafe "new Float32Array($1)" - js_float32ArrayFromJSRef :: JSRef () -> SomeFloat32Array m + js_float32ArrayFromJSRef :: JSRef -> SomeFloat32Array m foreign import javascript unsafe "new Float64Array($1)" - js_float64ArrayFromJSRef :: JSRef () -> SomeFloat64Array m + js_float64ArrayFromJSRef :: JSRef -> SomeFloat64Array m diff --git a/JavaScript/TypedArray/Internal/Types.hs b/JavaScript/TypedArray/Internal/Types.hs index b752bd0..5e6b6cf 100644 --- a/JavaScript/TypedArray/Internal/Types.hs +++ b/JavaScript/TypedArray/Internal/Types.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE EmptyDataDecls, DeriveDataTypeable, TypeFamilies, DataKinds, PolyKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} module JavaScript.TypedArray.Internal.Types where @@ -10,11 +13,11 @@ import Data.Typeable import Data.Word newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) = - SomeTypedArray (JSRef ()) - deriving (Typeable) + SomeTypedArray JSRef deriving Typeable +instance IsJSRef (SomeTypedArray e m) {- -newtype SomeSTTypedArray s e = SomeSTTypedArray (JSRef ()) +newtype SomeSTTypedArray s e = SomeSTTypedArray JSRef deriving (Typeable) -} diff --git a/JavaScript/Web/AnimationFrame.hs b/JavaScript/Web/AnimationFrame.hs index d5f2c5d..473a419 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,7 +28,7 @@ import GHCJS.Types import Control.Exception (onException) import Data.Typeable -newtype AnimationFrameHandle = AnimationFrameHandle (JSRef ()) +newtype AnimationFrameHandle = AnimationFrameHandle JSRef deriving (Typeable) {- | @@ -49,7 +50,7 @@ inAnimationFrame :: OnBlocked -- ^ what to do when encountering a blocking call -> IO AnimationFrameHandle inAnimationFrame onBlocked x = do cb <- syncCallback onBlocked x - h <- js_makeAnimationFrameHandleCallback (pToJSRef cb) + h <- js_makeAnimationFrameHandleCallback (jsref cb) js_requestAnimationFrame h return h @@ -62,7 +63,7 @@ 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 :: JSRef -> IO AnimationFrameHandle foreign import javascript unsafe "h$animationFrameCancel" js_cancelAnimationFrame :: AnimationFrameHandle -> IO () foreign import javascript interruptible diff --git a/JavaScript/Web/Blob/Internal.hs b/JavaScript/Web/Blob/Internal.hs index 6e61155..78c92e9 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 JSRef deriving Typeable type File = SomeBlob BlobTypeFile type Blob = SomeBlob BlobTypeBlob diff --git a/JavaScript/Web/Canvas.hs b/JavaScript/Web/Canvas.hs index 70903b1..20d08a5 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 :: JSRef -> Canvas +unsafeToCanvas r = Canvas r {-# INLINE unsafeToCanvas #-} -toCanvas :: JSRef () -> Maybe Canvas +toCanvas :: JSRef -> Maybe Canvas toCanvas x = error "toCanvas" -- fixme {-# INLINE toCanvas #-} diff --git a/JavaScript/Web/Canvas/Internal.hs b/JavaScript/Web/Canvas/Internal.hs index 8980e97..53e52a2 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 JSRef +newtype Context = Context JSRef +newtype Gradient = Gradient JSRef +newtype Image = Image JSRef +newtype ImageData = ImageData JSRef +newtype Pattern = Pattern JSRef +newtype TextMetrics = TextMetrics JSRef +instance IsJSRef Canvas +instance IsJSRef Context +instance IsJSRef Gradient +instance IsJSRef Image +instance IsJSRef ImageData +instance IsJSRef Pattern +instance IsJSRef TextMetrics diff --git a/JavaScript/Web/CloseEvent/Internal.hs b/JavaScript/Web/CloseEvent/Internal.hs index 095ac55..062a4b7 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 JSRef deriving Typeable diff --git a/JavaScript/Web/ErrorEvent.hs b/JavaScript/Web/ErrorEvent.hs index 2ef52bc..ad2e542 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 -> JSRef 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 -> JSRef diff --git a/JavaScript/Web/ErrorEvent/Internal.hs b/JavaScript/Web/ErrorEvent/Internal.hs index daf269e..026620a 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 JSRef deriving Typeable diff --git a/JavaScript/Web/MessageEvent.hs b/JavaScript/Web/MessageEvent.hs index 14837a3..ac498a2 100644 --- a/JavaScript/Web/MessageEvent.hs +++ b/JavaScript/Web/MessageEvent.hs @@ -39,5 +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 () #) + js_getData :: MessageEvent -> (# Int#, JSRef #) diff --git a/JavaScript/Web/MessageEvent/Internal.hs b/JavaScript/Web/MessageEvent/Internal.hs index 1dae349..8413ea0 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 JSRef deriving (Typeable) diff --git a/JavaScript/Web/Storage.hs b/JavaScript/Web/Storage.hs index 21a2c99..38b4994 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 JSRef foreign import javascript unsafe - "$2.getItem($1)" js_getItem :: JSString -> Storage -> IO (JSRef ()) + "$2.getItem($1)" js_getItem :: JSString -> Storage -> IO JSRef 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..a0467ee 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 JSRef deriving Typeable +newtype StorageEvent = StorageEvent JSRef deriving Typeable diff --git a/JavaScript/Web/StorageEvent.hs b/JavaScript/Web/StorageEvent.hs index e934682..0358314 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 -> JSRef foreign import javascript unsafe - "$1.oldValue" js_getOldValue :: StorageEvent -> JSRef () + "$1.oldValue" js_getOldValue :: StorageEvent -> JSRef foreign import javascript unsafe - "$1.newValue" js_getNewValue :: StorageEvent -> JSRef () + "$1.newValue" js_getNewValue :: StorageEvent -> JSRef 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 -> JSRef diff --git a/JavaScript/Web/WebSocket.hs b/JavaScript/Web/WebSocket.hs index bee5127..7b498cb 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(..) @@ -54,7 +60,8 @@ data WebSocketRequest = WebSocketRequest , onMessage :: Maybe (MessageEvent -> IO ()) -- ^ called for each message } -newtype WebSocket = WebSocket (JSRef ()) +newtype WebSocket = WebSocket JSRef +-- instance IsJSRef WebSocket data ReadyState = Closed | Connecting | Connected deriving (Data, Typeable, Enum, Eq, Ord, Show) @@ -74,14 +81,14 @@ connect req = do xs -> js_createArr (url req) (JSA.fromList $ unsafeCoerce xs) -- fixme (js_open ws mcb ccb >>= handleOpenErr >> return ws) `onException` js_close 1000 "Haskell Exception" ws -maybeCallback :: (JSRef () -> a) -> Maybe (a -> IO ()) -> IO (JSRef ()) +maybeCallback :: (JSRef -> a) -> Maybe (a -> IO ()) -> IO JSRef maybeCallback _ Nothing = return jsNull maybeCallback f (Just g) = do cb@(Callback cb') <- CB.syncCallback1 CB.ContinueAsync (g . f) CB.releaseCallback cb return cb' -handleOpenErr :: JSRef () -> IO () +handleOpenErr :: JSRef -> IO () handleOpenErr r | isNull r = return () | otherwise = throwIO (userError "WebSocket failed to connect") -- fixme @@ -140,7 +147,7 @@ foreign import javascript safe foreign import javascript interruptible "h$openWebSocket($1, $2, $3, $c);" - js_open :: WebSocket -> JSRef () -> JSRef () -> IO (JSRef ()) + js_open :: WebSocket -> JSRef -> JSRef -> IO JSRef foreign import javascript safe "h$closeWebSocket($1, $2);" js_close :: Int -> JSString -> WebSocket -> IO () foreign import javascript unsafe @@ -168,6 +175,6 @@ foreign import javascript unsafe foreign import javascript unsafe "$2.onmessage = $1;" js_setOnmessage :: Callback a -> WebSocket -> IO () foreign import javascript unsafe - "$1.onmessage" js_getOnmessage :: WebSocket -> IO (JSRef ()) + "$1.onmessage" js_getOnmessage :: WebSocket -> IO JSRef foreign import javascript unsafe - "$1.lastError" js_getLastError :: WebSocket -> IO (JSRef ()) + "$1.lastError" js_getLastError :: WebSocket -> IO JSRef diff --git a/JavaScript/Web/Worker.hs b/JavaScript/Web/Worker.hs index fbfc777..e8be255 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 JSRef deriving Typeable create :: JSString -> IO Worker create script = js_create script {-# INLINE create #-} -postMessage :: JSRef () -> Worker -> IO () +postMessage :: JSRef -> 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 :: JSRef -> 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..bc9e1e3 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -96,7 +96,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 :: JSRef -> a instance ResponseType ArrayBuffer where getResponseTypeString _ = "arraybuffer" @@ -114,9 +114,9 @@ instance m ~ Immutable => ResponseType (SomeValue m) where getResponseTypeString _ = "json" wrapResponseType = SomeValue -newtype JSFormData = JSFormData (JSRef ()) +newtype JSFormData = JSFormData JSRef deriving (Typeable) -newtype XHR = XHR (JSRef ()) +newtype XHR = XHR JSRef deriving (Typeable) -- ----------------------------------------------------------------------------- -- main entry point @@ -136,14 +136,14 @@ xhr req = js_createXHR >>= \x -> NoData -> js_send0 x StringData str -> - js_send1 (castRef $ pToJSRef str) x + js_send1 (pToJSRef 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 (pToJSRef str) fd BlobVal (SomeBlob b) mbFile -> appendFormData name b mbFile fd FileVal (SomeBlob b) mbFile -> @@ -164,7 +164,7 @@ xhr req = js_createXHR >>= \x -> 2 -> throwIO (XHRError "some error") in doRequest `onException` js_abort x -appendFormData :: JSString -> JSRef () +appendFormData :: JSString -> JSRef -> Maybe JSString -> JSFormData -> IO () appendFormData name val Nothing fd = js_appendFormData2 name val fd @@ -214,16 +214,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 -> JSRef -> JSFormData -> IO () foreign import javascript unsafe "$4.append($1,$2,$3)" - js_appendFormData3 :: JSString -> JSRef () -> JSString -> JSFormData -> IO () + js_appendFormData3 :: JSString -> JSRef -> 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 JSRef foreign import javascript unsafe "$1.response ? true : false" js_hasResponse :: XHR -> IO Bool @@ -232,7 +232,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 JSRef -- ----------------------------------------------------------------------------- @@ -241,4 +241,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 :: JSRef -> XHR -> IO Int From b8a9e434dae02cd7a83c9c3c0a013a941c44e266 Mon Sep 17 00:00:00 2001 From: eryx67 Date: Sat, 5 Sep 2015 17:53:22 +0500 Subject: [PATCH 03/36] xhr must be opened before any modification, also add required exports --- JavaScript/Web/XMLHttpRequest.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs index bc9e1e3..6751424 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 @@ -131,6 +134,8 @@ xhr req = js_createXHR >>= \x -> 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 -> From c44e6d1a60591d845705fbc1ede3ac6bad6e5705 Mon Sep 17 00:00:00 2001 From: eryx67 Date: Sat, 5 Sep 2015 17:58:04 +0500 Subject: [PATCH 04/36] correct previous commit --- JavaScript/Web/XMLHttpRequest.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs index 6751424..74062fa 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -127,8 +127,6 @@ newtype XHR = XHR JSRef deriving (Typeable) 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 From fa28889ee7dd6e03b1bd044a7d20be0d79da5a43 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Thu, 17 Sep 2015 18:44:17 -0700 Subject: [PATCH 05/36] updates for adjusted calling convention --- Data/JSString.hs | 40 +++--- Data/JSString/Raw.hs | 6 +- Data/JSString/Read.hs | 7 +- Data/JSString/RegExp.hs | 16 +-- GHCJS/Foreign/Export.hs | 6 +- JavaScript/Array.hs | 1 - JavaScript/Array/Internal.hs | 10 +- JavaScript/Array/ST.hs | 2 +- JavaScript/JSON/Types/Internal.hs | 11 +- JavaScript/Object/Internal.hs | 7 +- jsbits/array.js | 3 + jsbits/jsstring.js | 203 +++++++++++++++--------------- jsbits/jsstringRaw.js | 16 +-- 13 files changed, 167 insertions(+), 161 deletions(-) diff --git a/Data/JSString.hs b/Data/JSString.hs index 2d05a9f..898ad6f 100644 --- a/Data/JSString.hs +++ b/Data/JSString.hs @@ -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. @@ -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 @@ -1737,7 +1737,7 @@ foreign import javascript unsafe 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/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..993ea97 100644 --- a/Data/JSString/Read.hs +++ b/Data/JSString/Read.hs @@ -11,9 +11,10 @@ module Data.JSString.Read ( isInteger , readInteger , readIntegerMaybe ) where -import GHC.Exts (ByteArray#, Int#, Int64#, Word64#, Int(..)) +import GHC.Exts (Any, ByteArray#, Int#, Int64#, Word64#, Int(..)) import GHC.Int (Int64(..)) import GHC.Word (Word64(..)) +import Unsafe.Coerce import Data.Maybe import Data.JSString @@ -130,7 +131,7 @@ readIntegerMaybe j = convertNullMaybe js_readInteger j convertNullMaybe :: (JSString -> ByteArray#) -> JSString -> Maybe a convertNullMaybe f j | js_isNull r = Nothing - | otherwise = case js_toHeapObject r of (# h #) -> Just h + | otherwise = unsafeCoerce (js_toHeapObject r) where r = f j {-# INLINE convertNullMaybe #-} @@ -143,7 +144,7 @@ readError xs = error ("Data.JSString.Read." ++ xs) foreign import javascript unsafe "$1===null" js_isNull :: ByteArray# -> Bool foreign import javascript unsafe - "$r=$1;" js_toHeapObject :: ByteArray# -> (# a #) + "$r=$1;" js_toHeapObject :: ByteArray# -> Any foreign import javascript unsafe "h$jsstringReadInteger" js_readInteger :: JSString -> ByteArray# foreign import javascript unsafe diff --git a/Data/JSString/RegExp.hs b/Data/JSString/RegExp.hs index d5b234b..9f74f76 100644 --- a/Data/JSString/RegExp.hs +++ b/Data/JSString/RegExp.hs @@ -18,7 +18,9 @@ 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 @@ -67,7 +69,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] @@ -77,15 +79,15 @@ 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 #-} -- ---------------------------------------------------------------------------- @@ -96,11 +98,11 @@ 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/GHCJS/Foreign/Export.hs b/GHCJS/Foreign/Export.hs index 92a6666..73d0408 100644 --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -27,6 +27,7 @@ import Data.Typeable import Data.Typeable.Internal (TypeRep(..)) import Data.Word import Unsafe.Coerce +import qualified GHC.Exts as Exts import GHCJS.Prim @@ -65,8 +66,7 @@ derefExport e = do r <- js_derefExport w1 w2 e if isNull r then return Nothing - else case js_toHeapObject r of - (# x #) -> return (Just x) + else unsafeCoerce (js_toHeapObject r) {- | Release all memory associated with the export. Subsequent calls to @@ -84,7 +84,7 @@ foreign import javascript unsafe "h$derefExport" js_derefExport :: Word64 -> Word64 -> JSRef -> IO JSRef foreign import javascript unsafe - "$r = $1;" js_toHeapObject :: JSRef -> (# b #) + "$r = $1;" js_toHeapObject :: JSRef -> Exts.Any foreign import javascript unsafe "h$releaseExport" diff --git a/JavaScript/Array.hs b/JavaScript/Array.hs index 7b60aa4..9c43acc 100644 --- a/JavaScript/Array.hs +++ b/JavaScript/Array.hs @@ -10,7 +10,6 @@ module JavaScript.Array , fromListIO , toList , toListIO - , length , index, (!) , read , write diff --git a/JavaScript/Array/Internal.hs b/JavaScript/Array/Internal.hs index f151cc8..9438dec 100644 --- a/JavaScript/Array/Internal.hs +++ b/JavaScript/Array/Internal.hs @@ -57,11 +57,12 @@ fromListIO xs = IO (\s -> rnf xs `seq` js_toJSArray (unsafeCoerce xs) s) {-# INLINE fromListIO #-} toList :: JSArray -> [JSRef] -toList x = case js_fromJSArrayPure x of (# xs #) -> xs +toList x = unsafeCoerce (js_fromJSArrayPure x) {-# INLINE toList #-} toListIO :: SomeJSArray m -> IO [JSRef] -toListIO x = IO (js_fromJSArray x) +toListIO x = IO $ \s -> case js_fromJSArray x s of + (# s', xs #) -> (# s', unsafeCoerce xs #) {-# INLINE toListIO #-} index :: Int -> JSArray -> JSRef @@ -180,11 +181,10 @@ foreign import javascript unsafe "$1.shift()" foreign import javascript unsafe "$1.reverse()" js_reverse :: SomeJSArray m -> State# s -> (# State# s, () #) - foreign import javascript unsafe "h$toHsListJSRef($1)" - js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, [JSRef] #) + js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, Exts.Any #) foreign import javascript unsafe "h$toHsListJSRef($1)" - js_fromJSArrayPure :: JSArray -> (# [JSRef] #) + js_fromJSArrayPure :: JSArray -> Exts.Any -- [JSRef] foreign import javascript unsafe "h$fromHsListJSRef($1)" js_toJSArray :: Exts.Any -> State# s -> (# State# s, SomeJSArray m #) diff --git a/JavaScript/Array/ST.hs b/JavaScript/Array/ST.hs index 134deff..648f457 100644 --- a/JavaScript/Array/ST.hs +++ b/JavaScript/Array/ST.hs @@ -60,7 +60,7 @@ fromList xs = ST (\s -> rnf xs `seq` I.js_toJSArray (unsafeCoerce xs) s) {-# INLINE fromList #-} toList :: STJSArray s -> ST s [JSRef] -toList x = ST (I.js_fromJSArray x) +toList x = ST (unsafeCoerce (I.js_fromJSArray x)) {-# INLINE toList #-} read :: Int -> STJSArray s -> ST s (JSRef) diff --git a/JavaScript/JSON/Types/Internal.hs b/JavaScript/JSON/Types/Internal.hs index 4b1384f..5e6cddc 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) @@ -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) @@ -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/Internal.hs b/JavaScript/Object/Internal.hs index a3d040a..6b12be1 100644 --- a/JavaScript/Object/Internal.hs +++ b/JavaScript/Object/Internal.hs @@ -27,6 +27,9 @@ import GHCJS.Types import qualified JavaScript.Array as JA import JavaScript.Array.Internal (JSArray, SomeJSArray(..)) +import Unsafe.Coerce +import qualified GHC.Exts as Exts + newtype Object = Object JSRef deriving (Typeable) instance IsJSRef Object @@ -40,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 @@ -85,4 +88,4 @@ foreign import javascript unsafe "$1 instanceof $2" foreign import javascript unsafe "h$allProps" js_allProps :: Object -> IO JSArray foreign import javascript unsafe "h$listProps" - js_listProps :: Object -> (# [JSString] #) + js_listProps :: Object -> Exts.Any -- [JSString] diff --git a/jsbits/array.js b/jsbits/array.js index e1e051b..5f4ef09 100644 --- a/jsbits/array.js +++ b/jsbits/array.js @@ -35,3 +35,6 @@ function h$listToArray(xs) { return a; } +function h$listToArrayWrap(xs) { + return MK_JSREF(h$listToArray(xs)); +} diff --git a/jsbits/jsstring.js b/jsbits/jsstring.js index 977bbc5..4155dc8 100644 --- a/jsbits/jsstring.js +++ b/jsbits/jsstring.js @@ -26,7 +26,6 @@ #define HI_SURR(cp) ((((cp)-0x10000)>>>10)+0xDC00) #define LO_SURR(cp) (((cp)&0x3FF)+0xD800) - var h$jsstringEmpty = MK_JSREF(''); var h$jsstringHead, h$jsstringTail, h$jsstringCons, @@ -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) { @@ -360,16 +356,7 @@ if(String.prototype.startsWith) { if(x.startsWith(p)) { return MK_JUST(MK_JSREF(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))); } 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 + } +} + +if(String.prototype.endsWith) { + h$jsstringStripSuffix = function(s, x) { + TRACE_JSSTRING("(endsWith) stripSuffix: '" + s + "' '" + x + "'"); + if(x.endsWith(s)) { + return MK_JUST(MK_JSREF(x.substr(0,x.length-s.length))); + } else { + return HS_NOTHING; } } + h$jsstringIsSuffixOf = function(s, x) { + TRACE_JSSTRING("(endsWith) isSuffixOf: '" + s + "' '" + x + "'"); + return x.endsWith(s); + } +} else { h$jsstringStripSuffix = function(s, x) { - TRACE_JSSTRING("(no 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))); } 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(MK_JSREF(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 @@ -588,20 +583,18 @@ 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; @@ -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) { @@ -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_JSREF(x), HS_NIL); + var a = [], i = 0, s = 0, ch, m = 0, c, r = HS_NIL; while(m < l) { s = m; c = 0; @@ -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) @@ -981,11 +974,11 @@ function h$jsstringLenientReadDouble(str) { } function h$jsstringReadInteger(str) { - + throw "h$jsstringReadInteger not implemented"; } function h$jsstringReadInt64(str) { -// if(!/^\d + throw "h4JsstringReadInt64 not implemented"; } function h$jsstringReadWord64(str) { @@ -1014,7 +1007,7 @@ 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; @@ -1023,7 +1016,7 @@ function h$jsstringExecRE(i, str, re) { } j-=1; while(--j>=0) r = MK_CONS(MK_JSREF(a[j]), r); - RETURN_UBX_TUP(m.index, m[0], r); + RETURN_UBX_TUP3(m.index, m[0], r); } function h$jsstringReplaceRE(pat, replacement, str) { diff --git a/jsbits/jsstringRaw.js b/jsbits/jsstringRaw.js index c936ad0..6fb034a 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_JSREF(x), HS_NIL); + var r=HS_NIL; + for(var i=ls-k;i>=0;i-=k) r = MK_CONS(MK_JSREF(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_JSREF(x)); + if(k >= x.length) return MK_TUP2(MK_JSREF(x), h$jsstringEmpty); + return MK_TUP2(MK_JSREF(x.substr(0,k)), MK_JSREF(x.substr(k))); } From 2f0365fc48d0b4cd043909913d5f426423d820a0 Mon Sep 17 00:00:00 2001 From: Hamish Mackenzie Date: Mon, 21 Sep 2015 01:22:48 +1200 Subject: [PATCH 06/36] Add Nullable --- GHCJS/Nullable.hs | 19 +++++++++++++++++++ ghcjs-base.cabal | 1 + 2 files changed, 20 insertions(+) create mode 100644 GHCJS/Nullable.hs diff --git a/GHCJS/Nullable.hs b/GHCJS/Nullable.hs new file mode 100644 index 0000000..82780c8 --- /dev/null +++ b/GHCJS/Nullable.hs @@ -0,0 +1,19 @@ +module GHCJS.Nullable ( Nullable(..) + , nullableToMaybe + , maybeToNullable + ) where + +import GHCJS.Prim (JSRef(..)) +import GHCJS.Marshal.Pure (PToJSRef(..), PFromJSRef(..)) + +newtype Nullable a = Nullable JSRef + +nullableToMaybe :: PFromJSRef a => Nullable a -> Maybe a +nullableToMaybe (Nullable r) = pFromJSRef r +{-# INLINE nullableToMaybe #-} + +maybeToNullable :: PToJSRef a => Maybe a -> Nullable a +maybeToNullable = Nullable . pToJSRef +{-# INLINE maybeToNullable #-} + + diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index 5371053..f27a427 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -70,6 +70,7 @@ library GHCJS.Marshal GHCJS.Marshal.Internal GHCJS.Marshal.Pure + GHCJS.Nullable GHCJS.Types JavaScript.Array JavaScript.Array.Internal From 755934b125ea5b32a3ae34765f50d0e728cf4a02 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Thu, 24 Sep 2015 18:32:22 -0600 Subject: [PATCH 07/36] implement missing JSString read functions and fix existing ones --- Data/JSString/Read.hs | 26 ++++++++----- jsbits/jsstring.js | 85 +++++++++++++++++++++++++++++-------------- 2 files changed, 75 insertions(+), 36 deletions(-) diff --git a/Data/JSString/Read.hs b/Data/JSString/Read.hs index 993ea97..745fff1 100644 --- a/Data/JSString/Read.hs +++ b/Data/JSString/Read.hs @@ -6,12 +6,20 @@ module Data.JSString.Read ( isInteger , isNatural , readInt , readIntMaybe + , lenientReadInt + , readInt64 + , readInt64Maybe + , readWord64 + , readWord64Maybe , readDouble , readDoubleMaybe , readInteger , readIntegerMaybe ) where -import GHC.Exts (Any, 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 @@ -128,10 +136,10 @@ readIntegerMaybe j = convertNullMaybe js_readInteger j -- ---------------------------------------------------------------------------- -convertNullMaybe :: (JSString -> ByteArray#) -> JSString -> Maybe a +convertNullMaybe :: (JSString -> JSRef) -> JSString -> Maybe a convertNullMaybe f j | js_isNull r = Nothing - | otherwise = unsafeCoerce (js_toHeapObject r) + | otherwise = Just (unsafeCoerce (js_toHeapObject r)) where r = f j {-# INLINE convertNullMaybe #-} @@ -142,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 :: JSRef -> Bool foreign import javascript unsafe - "$r=$1;" js_toHeapObject :: ByteArray# -> Any + "$r=$1;" js_toHeapObject :: JSRef -> Any foreign import javascript unsafe - "h$jsstringReadInteger" js_readInteger :: JSString -> ByteArray# + "h$jsstringReadInteger" js_readInteger :: JSString -> JSRef foreign import javascript unsafe - "h$jsstringReadInt" js_readInt :: JSString -> ByteArray# + "h$jsstringReadInt" js_readInt :: JSString -> JSRef foreign import javascript unsafe - "h$jsstringLenientReadInt" js_lenientReadInt :: JSString -> ByteArray# + "h$jsstringLenientReadInt" js_lenientReadInt :: JSString -> JSRef 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 -> JSRef foreign import javascript unsafe "h$jsstringIsInteger" js_isInteger :: JSString -> Bool foreign import javascript unsafe diff --git a/jsbits/jsstring.js b/jsbits/jsstring.js index 4155dc8..783b747 100644 --- a/jsbits/jsstring.js +++ b/jsbits/jsstring.js @@ -958,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) { @@ -974,33 +974,64 @@ function h$jsstringLenientReadDouble(str) { } function h$jsstringReadInteger(str) { - throw "h$jsstringReadInteger not implemented"; + 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) { - throw "h4JsstringReadInt64 not implemented"; + 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) { From 6e60f18898c5ae5f44168ef802da04812daa9a7b Mon Sep 17 00:00:00 2001 From: Tavis Rudd Date: Sat, 19 Sep 2015 15:03:45 -0700 Subject: [PATCH 08/36] add h$isBoolean to jsbits. Req'd by GHCJS.Foreign --- jsbits/utils.js | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/jsbits/utils.js b/jsbits/utils.js index 55e450a..1215363 100644 --- a/jsbits/utils.js +++ b/jsbits/utils.js @@ -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'; } From c5f537d60e1d54ec9def238e6e87f2f420fd92a3 Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Tue, 4 Aug 2015 12:17:14 +0100 Subject: [PATCH 09/36] Add JavaScript.Web.Performance --- JavaScript/Web/Performance.hs | 36 +++++++++++++++++++++++++++++++++++ ghcjs-base.cabal | 5 ++--- 2 files changed, 38 insertions(+), 3 deletions(-) create mode 100644 JavaScript/Web/Performance.hs diff --git a/JavaScript/Web/Performance.hs b/JavaScript/Web/Performance.hs new file mode 100644 index 0000000..699e5ef --- /dev/null +++ b/JavaScript/Web/Performance.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, InterruptibleFFI, + DeriveDataTypeable + #-} + +{- | 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 + +newtype AnimationFrameHandle = AnimationFrameHandle (JSRef ()) + deriving (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/ghcjs-base.cabal b/ghcjs-base.cabal index f27a427..75fb69f 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -44,7 +44,7 @@ library GeneralizedNewtypeDeriving ScopedTypeVariables TypeOperators - + ghc-options: -O exposed-modules: Data.JSString Data.JSString.Int @@ -107,6 +107,7 @@ library JavaScript.Web.File JavaScript.Web.MessageEvent JavaScript.Web.MessageEvent.Internal + JavaScript.Web.Performance JavaScript.Web.Storage JavaScript.Web.Storage.Internal JavaScript.Web.StorageEvent @@ -168,5 +169,3 @@ test-suite tests test-framework >= 0.4, test-framework-hunit >= 0.2, test-framework-quickcheck2 >= 0.2 - - From 9eb215ace5a836d8c5c3a6cf789f1c03e8cf00c8 Mon Sep 17 00:00:00 2001 From: Oliver Charles Date: Tue, 4 Aug 2015 12:17:25 +0100 Subject: [PATCH 10/36] Add time stamps to requestAnimationFrame requestAnimationFrame provides its callback with a DOMHighResTimeStamp, measuring a monotonic clock time for each frame. I've extended the bindings such that waitForAnimationFrame and inAnimationFrame provide this value to the caller. --- JavaScript/Web/AnimationFrame.hs | 16 +++++++++------- jsbits/animationFrame.js | 18 +++++++++--------- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/JavaScript/Web/AnimationFrame.hs b/JavaScript/Web/AnimationFrame.hs index 473a419..a5c3da9 100644 --- a/JavaScript/Web/AnimationFrame.hs +++ b/JavaScript/Web/AnimationFrame.hs @@ -34,22 +34,24 @@ newtype AnimationFrameHandle = AnimationFrameHandle JSRef {- | 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 + cb <- syncCallback1 onBlocked (x . pFromJSRef) h <- js_makeAnimationFrameHandleCallback (jsref cb) js_requestAnimationFrame h return h @@ -68,6 +70,6 @@ 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/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); + } }); } From 60276e6b68508da6fa80923a2504c1285fa0beda Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 29 Sep 2015 14:54:35 -0700 Subject: [PATCH 11/36] fix JavaScript.Web.Performance --- JavaScript/Web/Performance.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/JavaScript/Web/Performance.hs b/JavaScript/Web/Performance.hs index 699e5ef..7e32c7a 100644 --- a/JavaScript/Web/Performance.hs +++ b/JavaScript/Web/Performance.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, InterruptibleFFI, - DeriveDataTypeable - #-} +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} {- | The Performance interface represents timing-related performance information for the given page. -} @@ -16,9 +14,6 @@ import GHCJS.Types import Control.Exception (onException) import Data.Typeable -newtype AnimationFrameHandle = AnimationFrameHandle (JSRef ()) - deriving (Typeable) - {- | The 'now' computation returns a high resolution time stamp, measured in milliseconds, accurate to one thousandth of a millisecond. From 89d19578bd6f516f370f40537f7d33166aa85ece Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Tue, 6 Oct 2015 18:09:16 -0700 Subject: [PATCH 12/36] Rename JSRef to JSVal See https://github.com/ghcjs/ghcjs/issues/421 --- Data/JSString.hs | 14 +- Data/JSString/Internal.hs | 4 +- Data/JSString/Internal/Fusion.hs | 8 +- Data/JSString/Internal/Type.hs | 6 +- Data/JSString/Read.hs | 14 +- Data/JSString/RegExp.hs | 2 +- Data/JSString/Text.hs | 18 +- GHCJS/Buffer.hs | 6 +- GHCJS/Buffer/Types.hs | 2 +- GHCJS/Foreign.hs | 42 +- GHCJS/Foreign/Callback.hs | 20 +- GHCJS/Foreign/Callback/Internal.hs | 4 +- GHCJS/Foreign/Export.hs | 8 +- GHCJS/Foreign/Internal.hs | 126 ++--- GHCJS/Internal/Types.hs | 20 +- GHCJS/Marshal.hs | 434 +++++++++--------- GHCJS/Marshal/Internal.hs | 228 ++++----- GHCJS/Marshal/Pure.hs | 182 ++++---- GHCJS/Nullable.hs | 14 +- GHCJS/Types.hs | 24 +- JavaScript/Array.hs | 18 +- JavaScript/Array/Immutable.hs | 2 +- JavaScript/Array/Internal.hs | 50 +- JavaScript/Array/ST.hs | 16 +- JavaScript/Cast.hs | 10 +- JavaScript/JSON/Types/Internal.hs | 26 +- JavaScript/Object.hs | 20 +- JavaScript/Object/Internal.hs | 24 +- JavaScript/TypedArray/ArrayBuffer/Internal.hs | 16 +- JavaScript/TypedArray/DataView/Internal.hs | 12 +- JavaScript/TypedArray/Internal.hs | 18 +- JavaScript/TypedArray/Internal/Types.hs | 6 +- JavaScript/Web/AnimationFrame.hs | 8 +- JavaScript/Web/Blob/Internal.hs | 2 +- JavaScript/Web/Canvas.hs | 6 +- JavaScript/Web/Canvas/Internal.hs | 28 +- JavaScript/Web/CloseEvent/Internal.hs | 2 +- JavaScript/Web/ErrorEvent.hs | 4 +- JavaScript/Web/ErrorEvent/Internal.hs | 2 +- JavaScript/Web/MessageEvent.hs | 2 +- JavaScript/Web/MessageEvent/Internal.hs | 2 +- JavaScript/Web/Storage.hs | 4 +- JavaScript/Web/Storage/Internal.hs | 4 +- JavaScript/Web/StorageEvent.hs | 8 +- JavaScript/Web/WebSocket.hs | 14 +- JavaScript/Web/Worker.hs | 6 +- JavaScript/Web/XMLHttpRequest.hs | 22 +- jsbits/array.js | 10 +- jsbits/jsstring.js | 50 +- jsbits/jsstringRaw.js | 10 +- jsbits/utils.js | 4 +- test/Tests/Marshal.hs | 68 +-- 52 files changed, 825 insertions(+), 825 deletions(-) diff --git a/Data/JSString.hs b/Data/JSString.hs index 898ad6f..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 @@ -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 @@ -1731,9 +1731,9 @@ 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 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 33cd775..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 91177c0..4fff668 100644 --- a/Data/JSString/Internal/Type.hs +++ b/Data/JSString/Internal/Type.hs @@ -36,13 +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 JSRef -instance IsJSRef JSString +newtype JSString = JSString JSVal +instance IsJSVal JSString instance NFData JSString where rnf !x = () diff --git a/Data/JSString/Read.hs b/Data/JSString/Read.hs index 745fff1..2dbbd03 100644 --- a/Data/JSString/Read.hs +++ b/Data/JSString/Read.hs @@ -136,7 +136,7 @@ readIntegerMaybe j = convertNullMaybe js_readInteger j -- ---------------------------------------------------------------------------- -convertNullMaybe :: (JSString -> JSRef) -> JSString -> Maybe a +convertNullMaybe :: (JSString -> JSVal) -> JSString -> Maybe a convertNullMaybe f j | js_isNull r = Nothing | otherwise = Just (unsafeCoerce (js_toHeapObject r)) @@ -150,21 +150,21 @@ readError xs = error ("Data.JSString.Read." ++ xs) -- ---------------------------------------------------------------------------- foreign import javascript unsafe - "$r = $1===null;" js_isNull :: JSRef -> Bool + "$r = $1===null;" js_isNull :: JSVal -> Bool foreign import javascript unsafe - "$r=$1;" js_toHeapObject :: JSRef -> Any + "$r=$1;" js_toHeapObject :: JSVal -> Any foreign import javascript unsafe - "h$jsstringReadInteger" js_readInteger :: JSString -> JSRef + "h$jsstringReadInteger" js_readInteger :: JSString -> JSVal foreign import javascript unsafe - "h$jsstringReadInt" js_readInt :: JSString -> JSRef + "h$jsstringReadInt" js_readInt :: JSString -> JSVal foreign import javascript unsafe - "h$jsstringLenientReadInt" js_lenientReadInt :: JSString -> JSRef + "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 -> JSRef + "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 9f74f76..d61d0a7 100644 --- a/Data/JSString/RegExp.hs +++ b/Data/JSString/RegExp.hs @@ -25,7 +25,7 @@ import Unsafe.Coerce (unsafeCoerce) import Data.JSString import Data.Typeable -newtype RegExp = RegExp JSRef deriving Typeable +newtype RegExp = RegExp JSVal deriving Typeable data REFlags = REFlags { multiline :: !Bool , ignoreCase :: !Bool diff --git a/Data/JSString/Text.hs b/Data/JSString/Text.hs index fd8d102..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 -> 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 -> 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 -> (# 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 7c0f754..b9cc421 100644 --- a/GHCJS/Buffer.hs +++ b/GHCJS/Buffer.hs @@ -217,11 +217,11 @@ 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 + "$r = $1;" js_fromByteArray :: ByteArray# -> JSVal foreign import javascript unsafe - "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSRef + "$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 903a19f..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/Foreign.hs b/GHCJS/Foreign.hs index 91e9655..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 = ptoJSRef +-- toJSString = ptoJSVal class FromJSString a where fromJSString :: JSString -> a --- default PFromJSRef --- fromJSString = pfromJSRef +-- 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 5a45f78..96423c1 100644 --- a/GHCJS/Foreign/Callback.hs +++ b/GHCJS/Foreign/Callback.hs @@ -60,28 +60,28 @@ 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 -> IO ()) -- ^ the Haskell function - -> IO (Callback (JSRef -> IO ())) -- ^ the callback + -> (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 -> JSRef -> IO ()) -- ^ the Haskell function - -> IO (Callback (JSRef -> JSRef -> IO ())) -- ^ the callback + -> (JSVal -> JSVal -> IO ()) -- ^ the Haskell function + -> IO (Callback (JSVal -> JSVal -> IO ())) -- ^ the callback syncCallback2 onBlocked x = js_syncCallbackApply (onBlocked == ContinueAsync) 2 (unsafeCoerce x) @@ -95,12 +95,12 @@ asyncCallback :: IO () -- ^ the action that the callback runs -> IO (Callback (IO ())) -- ^ the callback asyncCallback x = js_asyncCallback (unsafeCoerce x) -asyncCallback1 :: (JSRef -> IO ()) -- ^ the function that the callback calls - -> IO (Callback (JSRef -> 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 -> JSRef -> IO ()) -- ^ the Haskell function that the callback calls - -> IO (Callback (JSRef -> JSRef -> 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) -- ---------------------------------------------------------------------------- diff --git a/GHCJS/Foreign/Callback/Internal.hs b/GHCJS/Foreign/Callback/Internal.hs index 27259d4..ab6dc45 100644 --- a/GHCJS/Foreign/Callback/Internal.hs +++ b/GHCJS/Foreign/Callback/Internal.hs @@ -7,6 +7,6 @@ import GHCJS.Marshal.Internal import Data.Typeable -newtype Callback a = Callback JSRef deriving Typeable -instance IsJSRef (Callback a) +newtype Callback a = Callback JSVal deriving Typeable +instance IsJSVal (Callback a) diff --git a/GHCJS/Foreign/Export.hs b/GHCJS/Foreign/Export.hs index 73d0408..b74f20e 100644 --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -31,7 +31,7 @@ import qualified GHC.Exts as Exts import GHCJS.Prim -type Export a = JSRef +type Export a = JSVal {- | Export any Haskell value to a JavaScript reference without evaluating it. @@ -82,10 +82,10 @@ foreign import javascript unsafe js_export :: Word64 -> Word64 -> Any -> IO (Export a) foreign import javascript unsafe "h$derefExport" - js_derefExport :: Word64 -> Word64 -> JSRef -> IO JSRef + js_derefExport :: Word64 -> Word64 -> JSVal -> IO JSVal foreign import javascript unsafe - "$r = $1;" js_toHeapObject :: JSRef -> Exts.Any + "$r = $1;" js_toHeapObject :: JSVal -> Exts.Any foreign import javascript unsafe "h$releaseExport" - js_releaseExport :: JSRef -> IO () + js_releaseExport :: JSVal -> IO () diff --git a/GHCJS/Foreign/Internal.hs b/GHCJS/Foreign/Internal.hs index 842c44a..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 +fromJSBool :: JSVal -> Bool fromJSBool b = js_fromBool b {-# INLINE fromJSBool #-} -toJSBool :: Bool -> JSRef +toJSBool :: Bool -> JSVal toJSBool True = jsTrue toJSBool _ = jsFalse {-# INLINE toJSBool #-} -jsTrue :: JSRef +jsTrue :: JSVal jsTrue = mkRef (js_true 0#) {-# INLINE jsTrue #-} -jsFalse :: JSRef +jsFalse :: JSVal jsFalse = mkRef (js_false 0#) {-# INLINE jsFalse #-} -jsNull :: JSRef +jsNull :: JSVal jsNull = mkRef (js_null 0#) {-# INLINE jsNull #-} -jsUndefined :: JSRef +jsUndefined :: JSVal jsUndefined = mkRef (js_undefined 0#) {-# INLINE jsUndefined #-} -- check whether a reference is `truthy' in the JavaScript sense -isTruthy :: JSRef -> Bool +isTruthy :: JSVal -> Bool isTruthy b = js_isTruthy b {-# INLINE isTruthy #-} --- isUndefined :: JSRef -> Bool +-- isUndefined :: JSVal -> Bool -- isUndefined o = js_isUndefined o -- {-# INLINE isUndefined #-} --- isNull :: JSRef -> Bool +-- isNull :: JSVal -> Bool -- isNull o = js_isNull o -- {-# INLINE isNull #-} -isObject :: JSRef -> Bool +isObject :: JSVal -> Bool isObject o = js_isObject o {-# INLINE isObject #-} -isNumber :: JSRef -> Bool +isNumber :: JSVal -> Bool isNumber o = js_isNumber o {-# INLINE isNumber #-} -isString :: JSRef -> Bool +isString :: JSVal -> Bool isString o = js_isString o {-# INLINE isString #-} -isBoolean :: JSRef -> Bool +isBoolean :: JSVal -> Bool isBoolean o = js_isBoolean o {-# INLINE isBoolean #-} -isFunction :: JSRef -> Bool +isFunction :: JSVal -> Bool isFunction o = js_isFunction o {-# INLINE isFunction #-} -isSymbol :: JSRef -> Bool +isSymbol :: JSVal -> Bool isSymbol o = js_isSymbol o {-# INLINE isSymbol #-} @@ -221,15 +221,15 @@ ptr'ToPtr :: Ptr' a -> Ptr b ptr'ToPtr = unsafeCoerce -} {- -toArray :: [JSRef a] -> IO (JSArray a) +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 :: JSArray (JSVal a) -> IO [JSVal a] fromArray a = Prim.fromJSArray a {-# INLINE fromArray #-} @@ -237,11 +237,11 @@ 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 -> JSType +jsTypeOf :: JSVal -> JSType jsTypeOf r = tagToEnum# (js_jsTypeOf r) {-# INLINE jsTypeOf #-} -jsonTypeOf :: JSRef -> 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 -> Bool + js_fromBool :: JSVal -> Bool foreign import javascript unsafe "$1 ? true : false" - js_isTruthy :: JSRef -> 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 -> IO JSRef + js_unsafeGetProp :: JSString -> JSVal -> IO JSVal foreign import javascript unsafe "$3[$1] = $2" - js_unsafeSetProp :: JSString -> JSRef -> JSRef -> 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 -> Int# + js_jsTypeOf :: JSVal -> Int# foreign import javascript unsafe "h$jsonTypeOf($1)" - js_jsonTypeOf :: JSRef -> 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 -> Bool -foreign import javascript unsafe "h$isBoolean" js_isBoolean :: JSRef -> Bool -foreign import javascript unsafe "h$isNumber" js_isNumber :: JSRef -> Bool -foreign import javascript unsafe "h$isString" js_isString :: JSRef -> Bool -foreign import javascript unsafe "h$isSymbol" js_isSymbol :: JSRef -> Bool -foreign import javascript unsafe "h$isFunction" js_isFunction :: JSRef -> 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 7aa3f98..754b72e 100644 --- a/GHCJS/Internal/Types.hs +++ b/GHCJS/Internal/Types.hs @@ -13,21 +13,21 @@ import Unsafe.Coerce import Control.DeepSeq -import GHCJS.Prim (JSRef) +import GHCJS.Prim (JSVal) -instance NFData JSRef where +instance NFData JSVal where rnf x = x `seq` () -class IsJSRef a where - jsref_ :: a -> JSRef +class IsJSVal a where + jsval_ :: a -> JSVal - default jsref_ :: Coercible a JSRef => a -> JSRef - jsref_ = coerce - {-# INLINE jsref_ #-} + default jsval_ :: Coercible a JSVal => a -> JSVal + jsval_ = coerce + {-# INLINE jsval_ #-} -jsref :: IsJSRef a => a -> JSRef -jsref = jsref_ -{-# INLINE jsref #-} +jsval :: IsJSVal a => a -> JSVal +jsval = jsval_ +{-# INLINE jsval #-} data MutabilityType s = Mutable | Immutable diff --git a/GHCJS/Marshal.hs b/GHCJS/Marshal.hs index 85a97a1..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,242 +60,242 @@ import qualified JavaScript.Object.Internal as OI import GHCJS.Marshal.Internal -instance FromJSRef JSRef where - fromJSRefUnchecked x = return x - {-# INLINE fromJSRefUnchecked #-} - fromJSRef = return . Just - {-# 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 x - {-# INLINE fromJSRefUnchecked #-} - fromJSRef x | isUndefined x || isNull x = return (Just Nothing) - | otherwise = fmap (fmap Just) fromJSRef 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 - {-# INLINE fromJSRefListOf #-} - fromJSRefListOf = fromJSRef_pure - {-# 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 r + <$> fromJSVal r JSONFloat -> liftM (AE.Number . (fromFloatDigits :: Double -> Scientific)) - <$> fromJSRef r - JSONBool -> liftM AE.Bool <$> fromJSRef r - JSONString -> liftM AE.String <$> fromJSRef r - JSONArray -> liftM (AE.Array . V.fromList) <$> fromJSRef 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 r) runMaybeT $ do propVals <- forM props $ \p -> do - v <- MaybeT (fromJSRef =<< OI.getProp p (OI.Object 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 -> Int -> MaybeT IO a +jf :: FromJSVal a => JSVal -> Int -> MaybeT IO a jf r n = MaybeT $ do r' <- AI.read n (AI.SomeJSArray r) if isUndefined r then return Nothing - else fromJSRef r' + else fromJSVal r' -instance ToJSRef JSRef 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) = 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 -> IO JSRef -foreign import javascript unsafe "[$1,$2]" arr2 :: JSRef -> JSRef -> IO JSRef -foreign import javascript unsafe "[$1,$2,$3]" arr3 :: JSRef -> JSRef -> JSRef -> IO JSRef -foreign import javascript unsafe "[$1,$2,$3,$4]" arr4 :: JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef -foreign import javascript unsafe "[$1,$2,$3,$4,$5]" arr5 :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef -foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]" arr6 :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef -foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" arr7 :: JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> JSRef -> IO JSRef +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 -toJSRef_aeson x = cv (AE.toJSON x) +toJSVal_aeson :: AE.ToJSON a => a -> IO JSVal +toJSVal_aeson x = cv (AE.toJSON x) where cv = convertValue - convertValue :: AE.Value -> IO JSRef + convertValue :: AE.Value -> IO JSVal convertValue AE.Null = return jsNull - convertValue (AE.String t) = return (pToJSRef t) + 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) = toJSRef (realToFrac n :: Double) + 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 diff --git a/GHCJS/Marshal/Internal.hs b/GHCJS/Marshal/Internal.hs index 2fbcd55..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 + pToJSVal :: a -> JSVal -class PFromJSRef a where +class PFromJSVal a where -- type PureIn a :: Purity - pFromJSRef :: JSRef -> a + pFromJSVal :: JSVal -> a -class ToJSRef a where - toJSRef :: a -> IO JSRef +class ToJSVal a where + toJSVal :: a -> IO JSVal - toJSRefListOf :: [a] -> IO JSRef - toJSRefListOf = 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 - toJSRef = toJSRef_generic id + default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> IO JSVal + toJSVal = toJSVal_generic id -class FromJSRef a where - fromJSRef :: JSRef -> IO (Maybe a) +class FromJSVal a where + fromJSVal :: JSVal -> IO (Maybe a) - fromJSRefUnchecked :: JSRef -> IO a - fromJSRefUnchecked = fmap fromJust . fromJSRef - {-# INLINE fromJSRefUnchecked #-} + fromJSValUnchecked :: JSVal -> IO a + fromJSValUnchecked = fmap fromJust . fromJSVal + {-# INLINE fromJSValUnchecked #-} - fromJSRefListOf :: JSRef -> IO (Maybe [a]) - fromJSRefListOf = fmap sequence . (mapM fromJSRef <=< Prim.fromJSArray) -- 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 -> IO [a] - fromJSRefUncheckedListOf = mapM fromJSRefUnchecked <=< Prim.fromJSArray + 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 -> 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) = 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 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 + 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 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 -toJSRef_generic f x = 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 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 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 -> IO (Maybe a) -fromJSRef_generic f x = fmap to <$> (gFromJSRef f False 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 -> 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 -> 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 -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 b53f105..902fa20 100644 --- a/GHCJS/Marshal/Pure.hs +++ b/GHCJS/Marshal/Pure.hs @@ -19,8 +19,8 @@ {- 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,99 @@ type family IsPureExclusive a where IsPureExclusive PureShared = True -} -instance PFromJSRef JSRef where pFromJSRef = id - {-# INLINE pFromJSRef #-} -instance PFromJSRef () where pFromJSRef _ = () - {-# INLINE pFromJSRef #-} +instance PFromJSVal JSVal where pFromJSVal = id + {-# INLINE pFromJSVal #-} +instance PFromJSVal () where pFromJSVal _ = () + {-# INLINE pFromJSVal #-} -instance PFromJSRef JSString where pFromJSRef = JSString - {-# 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 - {-# 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 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 PFromJSRef a => PFromJSRef (Maybe a) where - pFromJSRef x | isUndefined x || isNull x = Nothing - pFromJSRef x = Just (pFromJSRef x) - {-# INLINE pFromJSRef #-} +instance PFromJSVal a => PFromJSVal (Maybe a) where + pFromJSVal x | isUndefined x || isNull x = Nothing + pFromJSVal x = Just (pFromJSVal x) + {-# INLINE pFromJSVal #-} -instance PToJSRef JSRef where pToJSRef = id - {-# INLINE pToJSRef #-} -instance PToJSRef JSString where pToJSRef = jsref - {-# INLINE pToJSRef #-} -instance PToJSRef [Char] where pToJSRef = Prim.toJSString - {-# INLINE pToJSRef #-} -instance PToJSRef Text where pToJSRef = jsref . textToJSString - {-# INLINE pToJSRef #-} -instance PToJSRef Char where pToJSRef (C# c) = charToJSRef c - {-# INLINE pToJSRef #-} -instance PToJSRef Bool where pToJSRef True = jsTrue - pToJSRef False = 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) = 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 -> Word# -foreign import javascript unsafe "$r = $1&0xff;" jsrefToWord8 :: JSRef -> Word# -foreign import javascript unsafe "$r = $1&0xffff;" jsrefToWord16 :: JSRef -> Word# -foreign import javascript unsafe "$r = $1|0;" jsrefToInt :: JSRef -> Int# -foreign import javascript unsafe "$r = $1<<24>>24;" jsrefToInt8 :: JSRef -> Int# -foreign import javascript unsafe "$r = $1<<16>>16;" jsrefToInt16 :: JSRef -> Int# -foreign import javascript unsafe "$r = +$1;" jsrefToFloat :: JSRef -> Float# -foreign import javascript unsafe "$r = +$1;" jsrefToDouble :: JSRef -> Double# -foreign import javascript unsafe "$r = $1&0x7fffffff;" jsrefToChar :: JSRef -> 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 -foreign import javascript unsafe "$r = $1;" intToJSRef :: Int# -> JSRef -foreign import javascript unsafe "$r = $1;" doubleToJSRef :: Double# -> JSRef -foreign import javascript unsafe "$r = $1;" floatToJSRef :: Float# -> JSRef -foreign import javascript unsafe "$r = $1;" charToJSRef :: Char# -> JSRef +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 index 82780c8..bad2c56 100644 --- a/GHCJS/Nullable.hs +++ b/GHCJS/Nullable.hs @@ -3,17 +3,17 @@ module GHCJS.Nullable ( Nullable(..) , maybeToNullable ) where -import GHCJS.Prim (JSRef(..)) -import GHCJS.Marshal.Pure (PToJSRef(..), PFromJSRef(..)) +import GHCJS.Prim (JSVal(..)) +import GHCJS.Marshal.Pure (PToJSVal(..), PFromJSVal(..)) -newtype Nullable a = Nullable JSRef +newtype Nullable a = Nullable JSVal -nullableToMaybe :: PFromJSRef a => Nullable a -> Maybe a -nullableToMaybe (Nullable r) = pFromJSRef r +nullableToMaybe :: PFromJSVal a => Nullable a -> Maybe a +nullableToMaybe (Nullable r) = pFromJSVal r {-# INLINE nullableToMaybe #-} -maybeToNullable :: PToJSRef a => Maybe a -> Nullable a -maybeToNullable = Nullable . pToJSRef +maybeToNullable :: PToJSVal a => Maybe a -> Nullable a +maybeToNullable = Nullable . pToJSVal {-# INLINE maybeToNullable #-} diff --git a/GHCJS/Types.hs b/GHCJS/Types.hs index 90adf9f..06f4db1 100644 --- a/GHCJS/Types.hs +++ b/GHCJS/Types.hs @@ -5,9 +5,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE JavaScriptFFI #-} -module GHCJS.Types ( JSRef - , IsJSRef - , jsref +module GHCJS.Types ( JSVal + , IsJSVal + , jsval , isNull , isUndefined , nullRef @@ -33,28 +33,28 @@ import Unsafe.Coerce type Ref# = ByteArray# -mkRef :: ByteArray# -> JSRef -mkRef x = JSRef x +mkRef :: ByteArray# -> JSVal +mkRef x = JSVal x -nullRef :: JSRef +nullRef :: JSVal nullRef = js_nullRef {-# INLINE nullRef #-} -toPtr :: JSRef -> Ptr a -toPtr (JSRef x) = unsafeCoerce (Ptr' x 0#) +toPtr :: JSVal -> Ptr a +toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#) {-# INLINE toPtr #-} -fromPtr :: Ptr a -> JSRef +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 + js_nullRef :: JSVal foreign import javascript unsafe "$r = $1_1;" - js_ptrVal :: Ptr a -> JSRef + js_ptrVal :: Ptr a -> JSVal foreign import javascript unsafe "$r1 = $1; $r2 = 0;" - js_mkPtr :: JSRef -> Ptr a + js_mkPtr :: JSVal -> Ptr a diff --git a/JavaScript/Array.hs b/JavaScript/Array.hs index 9c43acc..33fd4b9 100644 --- a/JavaScript/Array.hs +++ b/JavaScript/Array.hs @@ -41,11 +41,11 @@ import JavaScript.Array.Internal -- import qualified JavaScript.Array.Internal as I {- -fromList :: [JSRef] -> IO (JSArray a) +fromList :: [JSVal] -> IO (JSArray a) fromList xs = fmap JSArray (I.fromList xs) {-# INLINE fromList #-} -toList :: JSArray a -> IO [JSRef] +toList :: JSArray a -> IO [JSVal] toList (JSArray x) = I.toList x {-# INLINE toList #-} @@ -62,17 +62,17 @@ append (JSArray x) (JSArray y) = fmap JSArray (I.append x y) {-# INLINE append #-} -} -(!) :: JSArray -> Int -> JSRef +(!) :: JSArray -> Int -> JSVal x ! n = index n x {-# INLINE (!) #-} {- -index :: Int -> JSArray a -> IO JSRef +index :: Int -> JSArray a -> IO JSVal index n (JSArray x) = I.index n x {-# INLINE index #-} -write :: Int -> JSRef -> JSArray a -> IO () +write :: Int -> JSVal -> JSArray a -> IO () write n e (JSArray x) = I.write n e x {-# INLINE write #-} @@ -88,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 -> JSArray a -> IO () +push :: JSVal -> JSArray a -> IO () push e (JSArray x) = I.push e x {-# INLINE push #-} -pop :: JSArray a -> IO JSRef +pop :: JSArray a -> IO JSVal pop (JSArray x) = I.pop x {-# INLINE pop #-} -unshift :: JSRef -> JSArray a -> IO () +unshift :: JSVal -> JSArray a -> IO () unshift e (JSArray x) = I.unshift e x {-# INLINE unshift #-} -shift :: JSArray a -> IO JSRef +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 9438dec..135fe5a 100644 --- a/JavaScript/Array/Internal.hs +++ b/JavaScript/Array/Internal.hs @@ -19,9 +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 IsJSRef (SomeJSArray m) +instance IsJSVal (SomeJSArray m) type JSArray = SomeJSArray Immutable type MutableJSArray = SomeJSArray Mutable @@ -48,48 +48,48 @@ append :: SomeJSArray m -> SomeJSArray m -> IO (SomeJSArray m1) append x y = IO (js_append x y) {-# INLINE append #-} -fromList :: [JSRef] -> JSArray +fromList :: [JSVal] -> JSArray fromList xs = rnf xs `seq` js_toJSArrayPure (unsafeCoerce xs) {-# INLINE fromList #-} -fromListIO :: [JSRef] -> 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] +toList :: JSArray -> [JSVal] toList x = unsafeCoerce (js_fromJSArrayPure x) {-# INLINE toList #-} -toListIO :: SomeJSArray m -> IO [JSRef] +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 +index :: Int -> JSArray -> JSVal index n x = js_indexPure n x {-# INLINE index #-} -read :: Int -> SomeJSArray m -> IO JSRef +read :: Int -> SomeJSArray m -> IO JSVal read n x = IO (js_index n x) {-# INLINE read #-} -write :: Int -> JSRef -> MutableJSArray -> IO () +write :: Int -> JSVal -> MutableJSArray -> IO () write n e x = IO (js_setIndex n e x) {-# INLINE write #-} -push :: JSRef -> MutableJSArray -> IO () +push :: JSVal -> MutableJSArray -> IO () push e x = IO (js_push e x) {-# INLINE push #-} -pop :: MutableJSArray -> IO JSRef +pop :: MutableJSArray -> IO JSVal pop x = IO (js_pop x) {-# INLINE pop #-} -unshift :: JSRef -> MutableJSArray -> IO () +unshift :: JSVal -> MutableJSArray -> IO () unshift e x = IO (js_unshift e x) {-# INLINE unshift #-} -shift :: MutableJSArray -> IO JSRef +shift :: MutableJSArray -> IO JSVal shift x = IO (js_shift x) {-# INLINE shift #-} @@ -146,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 #) + js_index :: Int -> SomeJSArray m -> State# s -> (# State# s, JSVal #) foreign import javascript unsafe "$2[$1]" - js_indexPure :: Int -> JSArray -> JSRef + 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 -> 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 #) @@ -170,24 +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 -> 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 #) + js_pop :: SomeJSArray m -> State# s -> (# State# s, JSVal #) foreign import javascript unsafe "$2.unshift($1)" - js_unshift :: JSRef -> 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 #) + 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$toHsListJSRef($1)" +foreign import javascript unsafe "h$toHsListJSVal($1)" js_fromJSArray :: SomeJSArray m -> State# s -> (# State# s, Exts.Any #) -foreign import javascript unsafe "h$toHsListJSRef($1)" - js_fromJSArrayPure :: JSArray -> Exts.Any -- [JSRef] +foreign import javascript unsafe "h$toHsListJSVal($1)" + js_fromJSArrayPure :: JSArray -> Exts.Any -- [JSVal] -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 648f457..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] -> 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] +toList :: STJSArray s -> ST s [JSVal] toList x = ST (unsafeCoerce (I.js_fromJSArray x)) {-# INLINE toList #-} -read :: Int -> STJSArray s -> ST s (JSRef) +read :: Int -> STJSArray s -> ST s (JSVal) read n x = ST (I.js_index n x) {-# INLINE read #-} -write :: Int -> JSRef -> 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 -> 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 +pop :: STJSArray s -> ST s JSVal pop x = ST (I.js_pop x) {-# INLINE pop #-} -unshift :: JSRef -> 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 +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 77ab085..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 5e6cddc..f68689f 100644 --- a/JavaScript/JSON/Types/Internal.hs +++ b/JavaScript/JSON/Types/Internal.hs @@ -86,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 @@ -94,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 @@ -181,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) @@ -234,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 @@ -279,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))" 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 6b12be1..54f935c 100644 --- a/JavaScript/Object/Internal.hs +++ b/JavaScript/Object/Internal.hs @@ -30,8 +30,8 @@ import JavaScript.Array.Internal (JSArray, SomeJSArray(..)) import Unsafe.Coerce import qualified GHC.Exts as Exts -newtype Object = Object JSRef deriving (Typeable) -instance IsJSRef Object +newtype Object = Object JSVal deriving (Typeable) +instance IsJSVal Object -- | create an empty object create :: IO Object @@ -51,23 +51,23 @@ listProps o = unsafeCoerce (js_listProps o) handling code prevents some optimizations in some JS engines, you may want to use unsafeGetProp instead -} -getProp :: JSString -> Object -> IO JSRef +getProp :: JSString -> Object -> IO JSVal getProp p o = js_getProp p o {-# INLINE getProp #-} -unsafeGetProp :: JSString -> Object -> IO JSRef +unsafeGetProp :: JSString -> Object -> IO JSVal unsafeGetProp p o = js_unsafeGetProp p o {-# INLINE unsafeGetProp #-} -setProp :: JSString -> JSRef -> Object -> IO () +setProp :: JSString -> JSVal -> Object -> IO () setProp p v o = js_setProp p v o {-# INLINE setProp #-} -unsafeSetProp :: JSString -> JSRef -> Object -> IO () +unsafeSetProp :: JSString -> JSVal -> Object -> IO () unsafeSetProp p v o = js_unsafeSetProp p v o {-# INLINE unsafeSetProp #-} -isInstanceOf :: Object -> JSRef -> Bool +isInstanceOf :: Object -> JSVal -> Bool isInstanceOf o s = js_isInstanceOf o s {-# INLINE isInstanceOf #-} @@ -76,15 +76,15 @@ 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 + js_getProp :: JSString -> Object -> IO JSVal foreign import javascript unsafe "$2[$1]" - js_unsafeGetProp :: JSString -> Object -> IO JSRef + js_unsafeGetProp :: JSString -> Object -> IO JSVal foreign import javascript safe "$3[$1] = $2" - js_setProp :: JSString -> JSRef -> Object -> IO () + js_setProp :: JSString -> JSVal -> Object -> IO () foreign import javascript unsafe "$3[$1] = $2" - js_unsafeSetProp :: JSString -> JSRef -> Object -> IO () + js_unsafeSetProp :: JSString -> JSVal -> Object -> IO () foreign import javascript unsafe "$1 instanceof $2" - js_isInstanceOf :: Object -> JSRef -> Bool + js_isInstanceOf :: Object -> JSVal -> Bool foreign import javascript unsafe "h$allProps" js_allProps :: Object -> IO JSArray foreign import javascript unsafe "h$listProps" diff --git a/JavaScript/TypedArray/ArrayBuffer/Internal.hs b/JavaScript/TypedArray/ArrayBuffer/Internal.hs index d11a87e..87c93a6 100644 --- a/JavaScript/TypedArray/ArrayBuffer/Internal.hs +++ b/JavaScript/TypedArray/ArrayBuffer/Internal.hs @@ -23,26 +23,26 @@ import GHC.Exts (State#) import Data.Typeable newtype SomeArrayBuffer (a :: MutabilityType s) = - SomeArrayBuffer JSRef deriving Typeable -instance IsJSRef (SomeArrayBuffer m) + SomeArrayBuffer JSVal deriving Typeable +instance IsJSVal (SomeArrayBuffer m) type ArrayBuffer = SomeArrayBuffer Immutable type MutableArrayBuffer = SomeArrayBuffer Mutable type STArrayBuffer s = SomeArrayBuffer (STMutable s) -instance PToJSRef MutableArrayBuffer where - pToJSRef (SomeArrayBuffer b) = b -instance PFromJSRef MutableArrayBuffer where - pFromJSRef = SomeArrayBuffer +instance PToJSVal MutableArrayBuffer where + pToJSVal (SomeArrayBuffer b) = b +instance PFromJSVal MutableArrayBuffer where + pFromJSVal = SomeArrayBuffer -- ---------------------------------------------------------------------------- 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 #) + "new ArrayBuffer($1)" js_create :: Int -> State# s -> (# State# s, JSVal #) foreign import javascript unsafe - "$2.slice($1)" js_slice1 :: Int -> JSRef -> State# s -> (# State# s, JSRef #) + "$2.slice($1)" js_slice1 :: Int -> JSVal -> State# s -> (# State# s, JSVal #) -- ---------------------------------------------------------------------------- -- immutable non-IO slice diff --git a/JavaScript/TypedArray/DataView/Internal.hs b/JavaScript/TypedArray/DataView/Internal.hs index 3f210f7..e304cc6 100644 --- a/JavaScript/TypedArray/DataView/Internal.hs +++ b/JavaScript/TypedArray/DataView/Internal.hs @@ -23,7 +23,7 @@ import GHCJS.Internal.Types import JavaScript.TypedArray.ArrayBuffer.Internal -newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSRef +newtype SomeDataView (a :: MutabilityType s) = SomeDataView JSVal deriving Typeable type DataView = SomeDataView Immutable @@ -34,15 +34,15 @@ type STDataView s = SomeDataView (STMutable s) #define JSS foreign import javascript safe JSU "new DataView($1)" - js_dataView1 :: JSRef -> JSRef + js_dataView1 :: JSVal -> JSVal JSS "new DataView($2,$1)" - js_dataView2 :: Int -> JSRef -> SomeDataView m + js_dataView2 :: Int -> JSVal -> SomeDataView m JSU "new DataView($2,$1)" - js_unsafeDataView2 :: Int -> JSRef-> SomeDataView m + js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m JSS "new DataView($3,$1,$2)" - js_dataView :: Int -> Int -> JSRef -> SomeDataView m + js_dataView :: Int -> Int -> JSVal -> SomeDataView m JSU "new DataView($3,$1,$2)" - js_unsafeDataView :: Int -> Int -> JSRef -> JSRef + js_unsafeDataView :: Int -> Int -> JSVal -> JSVal JSU "new DataView($1.buffer.slice($1.byteOffset, $1.byteLength))" js_cloneDataView :: SomeDataView m -> IO (SomeDataView m1) diff --git a/JavaScript/TypedArray/Internal.hs b/JavaScript/TypedArray/Internal.hs index e69e45e..1118f86 100644 --- a/JavaScript/TypedArray/Internal.hs +++ b/JavaScript/TypedArray/Internal.hs @@ -508,29 +508,29 @@ foreign import javascript unsafe foreign import javascript unsafe "new Int8Array($1)" - js_int8ArrayFromJSRef :: JSRef -> SomeInt8Array m + js_int8ArrayFromJSVal :: JSVal -> SomeInt8Array m foreign import javascript unsafe "new Int16Array($1)" - js_int16ArrayFromJSRef :: JSRef -> SomeInt16Array m + js_int16ArrayFromJSVal :: JSVal -> SomeInt16Array m foreign import javascript unsafe "new Int32Array($1)" - js_int32ArrayFromJSRef :: JSRef -> SomeInt32Array m + js_int32ArrayFromJSVal :: JSVal -> SomeInt32Array m foreign import javascript unsafe "new Uint8ClampedArray($1)" - js_uint8ClampedArrayFromJSRef :: JSRef -> SomeUint8ClampedArray m + js_uint8ClampedArrayFromJSVal :: JSVal -> SomeUint8ClampedArray m foreign import javascript unsafe "new Uint8Array($1)" - js_uint8ArrayFromJSRef :: JSRef -> SomeUint8Array m + js_uint8ArrayFromJSVal :: JSVal -> SomeUint8Array m foreign import javascript unsafe "new Uint16Array($1)" - js_uint16ArrayFromJSRef :: JSRef -> SomeUint16Array m + js_uint16ArrayFromJSVal :: JSVal -> SomeUint16Array m foreign import javascript unsafe "new Uint32Array($1)" - js_uint32ArrayFromJSRef :: JSRef -> SomeUint32Array m + js_uint32ArrayFromJSVal :: JSVal -> SomeUint32Array m foreign import javascript unsafe "new Float32Array($1)" - js_float32ArrayFromJSRef :: JSRef -> SomeFloat32Array m + js_float32ArrayFromJSVal :: JSVal -> SomeFloat32Array m foreign import javascript unsafe "new Float64Array($1)" - js_float64ArrayFromJSRef :: JSRef -> SomeFloat64Array m + js_float64ArrayFromJSVal :: JSVal -> SomeFloat64Array m diff --git a/JavaScript/TypedArray/Internal/Types.hs b/JavaScript/TypedArray/Internal/Types.hs index 5e6b6cf..5759109 100644 --- a/JavaScript/TypedArray/Internal/Types.hs +++ b/JavaScript/TypedArray/Internal/Types.hs @@ -13,11 +13,11 @@ import Data.Typeable import Data.Word newtype SomeTypedArray (e :: TypedArrayElem) (m :: MutabilityType s) = - SomeTypedArray JSRef deriving Typeable -instance IsJSRef (SomeTypedArray e m) + SomeTypedArray JSVal deriving Typeable +instance IsJSVal (SomeTypedArray e m) {- -newtype SomeSTTypedArray s e = SomeSTTypedArray JSRef +newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal deriving (Typeable) -} diff --git a/JavaScript/Web/AnimationFrame.hs b/JavaScript/Web/AnimationFrame.hs index a5c3da9..d03833b 100644 --- a/JavaScript/Web/AnimationFrame.hs +++ b/JavaScript/Web/AnimationFrame.hs @@ -28,7 +28,7 @@ import GHCJS.Types import Control.Exception (onException) import Data.Typeable -newtype AnimationFrameHandle = AnimationFrameHandle JSRef +newtype AnimationFrameHandle = AnimationFrameHandle JSVal deriving (Typeable) {- | @@ -51,8 +51,8 @@ inAnimationFrame :: OnBlocked -- ^ what to do when encountering a blocking -> (Double -> IO ()) -- ^ the action to run -> IO AnimationFrameHandle inAnimationFrame onBlocked x = do - cb <- syncCallback1 onBlocked (x . pFromJSRef) - h <- js_makeAnimationFrameHandleCallback (jsref cb) + cb <- syncCallback1 onBlocked (x . pFromJSVal) + h <- js_makeAnimationFrameHandleCallback (jsval cb) js_requestAnimationFrame h return h @@ -65,7 +65,7 @@ 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 -> IO AnimationFrameHandle + js_makeAnimationFrameHandleCallback :: JSVal -> IO AnimationFrameHandle foreign import javascript unsafe "h$animationFrameCancel" js_cancelAnimationFrame :: AnimationFrameHandle -> IO () foreign import javascript interruptible diff --git a/JavaScript/Web/Blob/Internal.hs b/JavaScript/Web/Blob/Internal.hs index 78c92e9..6004687 100644 --- a/JavaScript/Web/Blob/Internal.hs +++ b/JavaScript/Web/Blob/Internal.hs @@ -14,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 20d08a5..ee18a58 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 :: 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 () diff --git a/JavaScript/Web/Canvas/Internal.hs b/JavaScript/Web/Canvas/Internal.hs index 53e52a2..3c46bdd 100644 --- a/JavaScript/Web/Canvas/Internal.hs +++ b/JavaScript/Web/Canvas/Internal.hs @@ -11,18 +11,18 @@ module JavaScript.Web.Canvas.Internal ( Canvas(..) import GHCJS.Types -newtype Canvas = Canvas JSRef -newtype Context = Context JSRef -newtype Gradient = Gradient JSRef -newtype Image = Image JSRef -newtype ImageData = ImageData JSRef -newtype Pattern = Pattern JSRef -newtype TextMetrics = TextMetrics JSRef +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 IsJSRef Canvas -instance IsJSRef Context -instance IsJSRef Gradient -instance IsJSRef Image -instance IsJSRef ImageData -instance IsJSRef Pattern -instance IsJSRef TextMetrics +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 062a4b7..83e767e 100644 --- a/JavaScript/Web/CloseEvent/Internal.hs +++ b/JavaScript/Web/CloseEvent/Internal.hs @@ -6,5 +6,5 @@ import GHCJS.Types import Data.Typeable -newtype CloseEvent = CloseEvent JSRef deriving Typeable +newtype CloseEvent = CloseEvent JSVal deriving Typeable diff --git a/JavaScript/Web/ErrorEvent.hs b/JavaScript/Web/ErrorEvent.hs index ad2e542..ad95631 100644 --- a/JavaScript/Web/ErrorEvent.hs +++ b/JavaScript/Web/ErrorEvent.hs @@ -33,7 +33,7 @@ colno :: ErrorEvent -> Int colno ee = js_getColno ee {-# INLINE colno #-} -error :: ErrorEvent -> JSRef +error :: ErrorEvent -> JSVal error ee = js_getError ee {-# INLINE error #-} @@ -48,4 +48,4 @@ foreign import javascript unsafe "$1.lineno" foreign import javascript unsafe "$1.colno" js_getColno :: ErrorEvent -> Int foreign import javascript unsafe "$1.error" - js_getError :: ErrorEvent -> JSRef + js_getError :: ErrorEvent -> JSVal diff --git a/JavaScript/Web/ErrorEvent/Internal.hs b/JavaScript/Web/ErrorEvent/Internal.hs index 026620a..db26aa2 100644 --- a/JavaScript/Web/ErrorEvent/Internal.hs +++ b/JavaScript/Web/ErrorEvent/Internal.hs @@ -6,4 +6,4 @@ import GHCJS.Types import Data.Typeable -newtype ErrorEvent = ErrorEvent JSRef deriving Typeable +newtype ErrorEvent = ErrorEvent JSVal deriving Typeable diff --git a/JavaScript/Web/MessageEvent.hs b/JavaScript/Web/MessageEvent.hs index ac498a2..3f2f528 100644 --- a/JavaScript/Web/MessageEvent.hs +++ b/JavaScript/Web/MessageEvent.hs @@ -39,5 +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 #) + js_getData :: MessageEvent -> (# Int#, JSVal #) diff --git a/JavaScript/Web/MessageEvent/Internal.hs b/JavaScript/Web/MessageEvent/Internal.hs index 8413ea0..14b9590 100644 --- a/JavaScript/Web/MessageEvent/Internal.hs +++ b/JavaScript/Web/MessageEvent/Internal.hs @@ -6,4 +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/Storage.hs b/JavaScript/Web/Storage.hs index 38b4994..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 a0467ee..956c6e7 100644 --- a/JavaScript/Web/Storage/Internal.hs +++ b/JavaScript/Web/Storage/Internal.hs @@ -6,5 +6,5 @@ import GHCJS.Types import Data.Typeable -newtype Storage = Storage JSRef deriving Typeable -newtype StorageEvent = StorageEvent JSRef deriving 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 0358314..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 7b498cb..cc800e1 100644 --- a/JavaScript/Web/WebSocket.hs +++ b/JavaScript/Web/WebSocket.hs @@ -60,8 +60,8 @@ data WebSocketRequest = WebSocketRequest , onMessage :: Maybe (MessageEvent -> IO ()) -- ^ called for each message } -newtype WebSocket = WebSocket JSRef --- instance IsJSRef WebSocket +newtype WebSocket = WebSocket JSVal +-- instance IsJSVal WebSocket data ReadyState = Closed | Connecting | Connected deriving (Data, Typeable, Enum, Eq, Ord, Show) @@ -81,14 +81,14 @@ connect req = do xs -> js_createArr (url req) (JSA.fromList $ unsafeCoerce xs) -- fixme (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' -handleOpenErr :: JSRef -> IO () +handleOpenErr :: JSVal -> IO () handleOpenErr r | isNull r = return () | otherwise = throwIO (userError "WebSocket failed to connect") -- fixme @@ -147,7 +147,7 @@ foreign import javascript safe 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 () foreign import javascript unsafe @@ -175,6 +175,6 @@ foreign import javascript unsafe foreign import javascript unsafe "$2.onmessage = $1;" js_setOnmessage :: Callback a -> WebSocket -> IO () foreign import javascript unsafe - "$1.onmessage" js_getOnmessage :: WebSocket -> IO JSRef + "$1.onmessage" js_getOnmessage :: WebSocket -> IO JSVal 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 e8be255..ef5f93d 100644 --- a/JavaScript/Web/Worker.hs +++ b/JavaScript/Web/Worker.hs @@ -11,13 +11,13 @@ import GHCJS.Prim import Data.JSString import Data.Typeable -newtype Worker = Worker JSRef deriving Typeable +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 #-} @@ -30,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 74062fa..009e9a8 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -99,7 +99,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" @@ -117,9 +117,9 @@ instance m ~ Immutable => ResponseType (SomeValue m) where getResponseTypeString _ = "json" wrapResponseType = SomeValue -newtype JSFormData = JSFormData JSRef deriving (Typeable) +newtype JSFormData = JSFormData JSVal deriving (Typeable) -newtype XHR = XHR JSRef deriving (Typeable) +newtype XHR = XHR JSVal deriving (Typeable) -- ----------------------------------------------------------------------------- -- main entry point @@ -139,14 +139,14 @@ xhr req = js_createXHR >>= \x -> NoData -> js_send0 x StringData str -> - js_send1 (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 (pToJSRef str) fd + js_appendFormData2 name (pToJSVal str) fd BlobVal (SomeBlob b) mbFile -> appendFormData name b mbFile fd FileVal (SomeBlob b) mbFile -> @@ -167,7 +167,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 @@ -217,16 +217,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 @@ -235,7 +235,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 -- ----------------------------------------------------------------------------- @@ -244,4 +244,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/jsbits/array.js b/jsbits/array.js index 5f4ef09..8230cdf 100644 --- a/jsbits/array.js +++ b/jsbits/array.js @@ -2,11 +2,11 @@ /* 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); + for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSVAL(a[i]), r); return a; } @@ -23,18 +23,18 @@ function h$fromArrayNoWrap(a) { } /* - 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_JSREF(h$listToArray(xs)); + return MK_JSVAL(h$listToArray(xs)); } diff --git a/jsbits/jsstring.js b/jsbits/jsstring.js index 783b747..df07d78 100644 --- a/jsbits/jsstring.js +++ b/jsbits/jsstring.js @@ -26,7 +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, @@ -306,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(''); @@ -341,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(''); @@ -354,7 +354,7 @@ 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 HS_NOTHING; } @@ -369,7 +369,7 @@ if(String.prototype.startsWith) { 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; } @@ -385,7 +385,7 @@ if(String.prototype.endsWith) { h$jsstringStripSuffix = function(s, x) { TRACE_JSSTRING("(endsWith) stripSuffix: '" + s + "' '" + x + "'"); if(x.endsWith(s)) { - return MK_JUST(MK_JSREF(x.substr(0,x.length-s.length))); + return MK_JUST(MK_JSVAL(x.substr(0,x.length-s.length))); } else { return HS_NOTHING; } @@ -401,7 +401,7 @@ if(String.prototype.endsWith) { 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 HS_NOTHING; } @@ -441,9 +441,9 @@ function h$jsstringCommonPrefixes(x, y) { } } if(i===0) return HS_NOTHING; - return MK_JUST(MK_TUP3( MK_JSREF((i===lx)?x:((i===ly)?y:x.substr(0,i))) - , (i===lx) ? h$jsstringEmpty : MK_JSREF(x.substr(i)) - , (i===ly) ? h$jsstringEmpty : MK_JSREF(y.substr(i)) + return MK_JUST(MK_TUP3( MK_JSVAL((i===lx)?x:((i===ly)?y:x.substr(0,i))) + , (i===lx) ? h$jsstringEmpty : MK_JSVAL(x.substr(i)) + , (i===ly) ? h$jsstringEmpty : MK_JSVAL(y.substr(i)) )); } @@ -488,7 +488,7 @@ function h$jsstringBreakOnAll(pat, src) { while(true) { var x = src.indexOf(pat, n); if(x === -1) break; - a[i++] = MK_TUP2(MK_JSREF(src.substr(0,x)), MK_JSREF(src.substr(x))); + a[i++] = MK_TUP2(MK_JSVAL(src.substr(0,x)), MK_JSVAL(src.substr(x))); n = x + pl; } while(--i >= 0) r = MK_CONS(a[i], r); @@ -509,7 +509,7 @@ function h$jsstringSplitOn(p, x) { TRACE_JSSTRING("splitOn: '" + p + "' '" + x + "'"); var a = x.split(p); var r = HS_NIL, i = a.length; - while(--i>=0) r = MK_CONS(MK_JSREF(a[i]), r); + while(--i>=0) r = MK_CONS(MK_JSVAL(a[i]), r); return r; } @@ -556,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; @@ -565,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 @@ -601,11 +601,11 @@ function h$jsstringLines(x) { 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); @@ -627,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) { @@ -650,7 +650,7 @@ function h$jsstringChunksOf(n, x) { TRACE_JSSTRING("chunksOf: " + n + " '" + x + "'"); var l = x.length; if(l===0 || n <= 0) return HS_NIL; - if(l <= n) return MK_CONS(MK_JSREF(x), 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; @@ -661,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; } @@ -904,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; @@ -912,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; @@ -1046,7 +1046,7 @@ function h$jsstringExecRE(i, str, re) { j++; } j-=1; - while(--j>=0) r = MK_CONS(MK_JSREF(a[j]), r); + while(--j>=0) r = MK_CONS(MK_JSVAL(a[j]), r); RETURN_UBX_TUP3(m.index, m[0], r); } @@ -1058,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 6fb034a..4d31c3c 100644 --- a/jsbits/jsstringRaw.js +++ b/jsbits/jsstringRaw.js @@ -8,14 +8,14 @@ function h$jsstringRawChunksOf(k, x) { var l = x.length; if(l === 0) return HS_NIL; - if(l <= k) return MK_CONS(MK_JSREF(x), 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_JSREF(x.substr(i,i+k)),r); + for(var i=ls-k;i>=0;i-=k) r = MK_CONS(MK_JSVAL(x.substr(i,i+k)),r); return r; } function h$jsstringRawSplitAt(k, x) { - if(k === 0) return MK_TUP2(h$jsstringEmpty, MK_JSREF(x)); - if(k >= x.length) return MK_TUP2(MK_JSREF(x), h$jsstringEmpty); - return MK_TUP2(MK_JSREF(x.substr(0,k)), MK_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/utils.js b/jsbits/utils.js index 1215363..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; } 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 From 7a9cb3c516eafa233fe7f7aab555c5c2ac16685f Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Tue, 6 Oct 2015 18:53:03 -0700 Subject: [PATCH 13/36] Add a JSRef compatibility synonym #421 --- GHCJS/Types.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/GHCJS/Types.hs b/GHCJS/Types.hs index 06f4db1..23f72ce 100644 --- a/GHCJS/Types.hs +++ b/GHCJS/Types.hs @@ -16,6 +16,7 @@ module GHCJS.Types ( JSVal , Ref# , toPtr , fromPtr + , JSRef ) where import Data.JSString.Internal.Type (JSString) @@ -58,3 +59,9 @@ foreign import javascript unsafe "$r = $1_1;" 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 " #-} From 3d07ea6c344c0d5ce9c93fc7785d043a95ff6c9b Mon Sep 17 00:00:00 2001 From: achirkin Date: Mon, 12 Oct 2015 11:27:33 +0200 Subject: [PATCH 14/36] Added Float32/64 Typed array types Seems like someone forgot to re-export Float32Array and Float64Array in JavaScript.TypedArray from JavaScript.TypedArray.Internal.Types. Also I would like to have (TypedArray a => JSRef -> a) interface for my WebGL things: some of the webGL methods return typed arrays of arbitrary type - https://developer.mozilla.org/en-US/docs/Web/API/ArrayBufferView --- JavaScript/TypedArray.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/JavaScript/TypedArray.hs b/JavaScript/TypedArray.hs index 2fb9301..c250bd7 100644 --- a/JavaScript/TypedArray.hs +++ b/JavaScript/TypedArray.hs @@ -2,7 +2,7 @@ module JavaScript.TypedArray ( TypedArray(..) , Int8Array, Int16Array, Int32Array , Uint8Array, Uint16Array, Uint32Array - , Uint8ClampedArray + , Uint8ClampedArray, Float32Array, Float64Array , length , byteLength , byteOffset From e4271f10f7008e92a748baf06620bb69d4c4ba3b Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Thu, 15 Oct 2015 10:16:09 +0100 Subject: [PATCH 15/36] fix type of listProps foreign import --- JavaScript/Object/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/JavaScript/Object/Internal.hs b/JavaScript/Object/Internal.hs index 54f935c..aa05cb3 100644 --- a/JavaScript/Object/Internal.hs +++ b/JavaScript/Object/Internal.hs @@ -88,4 +88,4 @@ foreign import javascript unsafe "$1 instanceof $2" foreign import javascript unsafe "h$allProps" js_allProps :: Object -> IO JSArray foreign import javascript unsafe "h$listProps" - js_listProps :: Object -> Exts.Any -- [JSString] + js_listProps :: Object -> IO Exts.Any -- [JSString] From b37066ed2d3438ec6eb502f5be7a85c364ec08c2 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 16 Oct 2015 21:01:23 +0100 Subject: [PATCH 16/36] remove duplicate OnBlocked data structure and add three-argument callbacks --- GHCJS/Concurrent.hs | 22 +++++++++++++++------- GHCJS/Foreign/Callback.hs | 31 ++++++++++++++++++++----------- 2 files changed, 35 insertions(+), 18 deletions(-) diff --git a/GHCJS/Concurrent.hs b/GHCJS/Concurrent.hs index ea73e2c..56c93a8 100644 --- a/GHCJS/Concurrent.hs +++ b/GHCJS/Concurrent.hs @@ -26,8 +26,8 @@ -} module GHCJS.Concurrent ( isThreadSynchronous - , isContinueAsync - , OnBlock (..) + , isThreadContinueAsync + , OnBlocked(..) , WouldBlockException(..) , synchronously ) where @@ -47,9 +47,17 @@ 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) {- | Runs the action synchronously, which means that the thread will not @@ -80,8 +88,8 @@ 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 syncThreadState :: ThreadId-> IO Int syncThreadState (ThreadId tid) = js_syncThreadState tid diff --git a/GHCJS/Foreign/Callback.hs b/GHCJS/Foreign/Callback.hs index 96423c1..5c74fc1 100644 --- a/GHCJS/Foreign/Callback.hs +++ b/GHCJS/Foreign/Callback.hs @@ -7,11 +7,14 @@ module GHCJS.Foreign.Callback , asyncCallback , asyncCallback1 , asyncCallback2 + , asyncCallback3 , syncCallback , syncCallback1 , syncCallback2 + , syncCallback3 ) where +import GHCJS.Concurrent import GHCJS.Marshal import GHCJS.Marshal.Pure import GHCJS.Foreign.Callback.Internal @@ -24,17 +27,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 @@ -84,6 +76,19 @@ syncCallback2 :: OnBlocked -- ^ what to do when th -> 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 an asynchronous thread when called. @@ -103,6 +108,10 @@ asyncCallback2 :: (JSVal -> JSVal -> IO ()) -- ^ the Haskell function -> 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)" From 29c1c4faa06abc658232bebd34c93eae4d0861f3 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 16 Oct 2015 21:44:25 +0100 Subject: [PATCH 17/36] add missing xhr.js foreign file --- ghcjs-base.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index 75fb69f..c7fd047 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -19,6 +19,7 @@ library jsbits/foreign.js jsbits/text.js jsbits/utils.js + jsbits/xhr.js other-extensions: DeriveDataTypeable DeriveGeneric ForeignFunctionInterface From cf5ea14ec908bb06fae8ffff7b1ce8661b5c8335 Mon Sep 17 00:00:00 2001 From: achirkin Date: Sun, 18 Oct 2015 12:17:34 +0200 Subject: [PATCH 18/36] typed arrays redone --- GHCJS/Buffer.hs | 39 +- JavaScript/TypedArray.hs | 328 ++++++- JavaScript/TypedArray/ArrayBuffer.hs | 48 - JavaScript/TypedArray/ArrayBuffer/Internal.hs | 53 -- JavaScript/TypedArray/ArrayBuffer/ST.hs | 35 - JavaScript/TypedArray/ArrayBuffer/Type.hs | 6 - JavaScript/TypedArray/DataView.hs | 338 ------- JavaScript/TypedArray/DataView/Internal.hs | 147 --- JavaScript/TypedArray/DataView/ST.hs | 232 ----- JavaScript/TypedArray/IO.hs | 253 ++++++ JavaScript/TypedArray/Immutable.hs | 1 - JavaScript/TypedArray/Internal.hs | 846 +++++++----------- JavaScript/TypedArray/Internal/Types.hs | 120 --- JavaScript/TypedArray/ST.hs | 363 +++++--- JavaScript/TypedArray/Types.hs | 75 ++ JavaScript/Web/Canvas/ImageData.hs | 4 +- JavaScript/Web/MessageEvent.hs | 2 +- JavaScript/Web/XMLHttpRequest.hs | 8 +- ghcjs-base.cabal | 11 +- jsbits/array.js | 10 + 20 files changed, 1260 insertions(+), 1659 deletions(-) delete mode 100644 JavaScript/TypedArray/ArrayBuffer.hs delete mode 100644 JavaScript/TypedArray/ArrayBuffer/Internal.hs delete mode 100644 JavaScript/TypedArray/ArrayBuffer/ST.hs delete mode 100644 JavaScript/TypedArray/ArrayBuffer/Type.hs delete mode 100644 JavaScript/TypedArray/DataView.hs delete mode 100644 JavaScript/TypedArray/DataView/Internal.hs delete mode 100644 JavaScript/TypedArray/DataView/ST.hs create mode 100644 JavaScript/TypedArray/IO.hs delete mode 100644 JavaScript/TypedArray/Immutable.hs delete mode 100644 JavaScript/TypedArray/Internal/Types.hs create mode 100644 JavaScript/TypedArray/Types.hs diff --git a/GHCJS/Buffer.hs b/GHCJS/Buffer.hs index b9cc421..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,9 +215,9 @@ 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 +foreign import javascript unsafe "$r = $1;" js_fromByteArray :: ByteArray# -> JSVal foreign import javascript unsafe "$r = $1;" js_fromMutableByteArray :: MutableByteArray# s -> JSVal diff --git a/JavaScript/TypedArray.hs b/JavaScript/TypedArray.hs index c250bd7..65f5278 100644 --- a/JavaScript/TypedArray.hs +++ b/JavaScript/TypedArray.hs @@ -1,19 +1,321 @@ +{-# 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, Float32Array, Float64Array - , 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 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 = show . 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 87c93a6..0000000 --- a/JavaScript/TypedArray/ArrayBuffer/Internal.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module JavaScript.TypedArray.ArrayBuffer.Internal where - -import GHCJS.Types - -import GHCJS.Internal.Types -import GHCJS.Marshal.Pure - -import GHC.Exts (State#) - -import Data.Typeable - -newtype SomeArrayBuffer (a :: MutabilityType s) = - SomeArrayBuffer JSVal deriving Typeable -instance IsJSVal (SomeArrayBuffer m) - -type ArrayBuffer = SomeArrayBuffer Immutable -type MutableArrayBuffer = SomeArrayBuffer Mutable -type STArrayBuffer s = SomeArrayBuffer (STMutable s) - -instance PToJSVal MutableArrayBuffer where - pToJSVal (SomeArrayBuffer b) = b -instance PFromJSVal MutableArrayBuffer where - pFromJSVal = SomeArrayBuffer - --- ---------------------------------------------------------------------------- - -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, JSVal #) -foreign import javascript unsafe - "$2.slice($1)" js_slice1 :: Int -> JSVal -> State# s -> (# State# s, JSVal #) - --- ---------------------------------------------------------------------------- --- immutable non-IO slice - -foreign import javascript unsafe - "$2.slice($1)" js_slice1_imm :: Int -> SomeArrayBuffer any -> SomeArrayBuffer any -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 e304cc6..0000000 --- a/JavaScript/TypedArray/DataView/Internal.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE 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 JSVal - 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 :: JSVal -> JSVal -JSS "new DataView($2,$1)" - js_dataView2 :: Int -> JSVal -> SomeDataView m -JSU "new DataView($2,$1)" - js_unsafeDataView2 :: Int -> JSVal-> SomeDataView m -JSS "new DataView($3,$1,$2)" - js_dataView :: Int -> Int -> JSVal -> SomeDataView m -JSU "new DataView($3,$1,$2)" - js_unsafeDataView :: Int -> Int -> JSVal -> JSVal -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 1118f86..d124981 100644 --- a/JavaScript/TypedArray/Internal.hs +++ b/JavaScript/TypedArray/Internal.hs @@ -1,536 +1,350 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples, JavaScriptFFI, GHCForeignImportPrim, UnliftedFFITypes #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE KindSignatures #-} +----------------------------------------------------------------------------- +-- | +-- 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_int8ArrayFromJSVal :: JSVal -> SomeInt8Array m -foreign import javascript unsafe - "new Int16Array($1)" - js_int16ArrayFromJSVal :: JSVal -> SomeInt16Array m -foreign import javascript unsafe - "new Int32Array($1)" - js_int32ArrayFromJSVal :: JSVal -> SomeInt32Array m -foreign import javascript unsafe - "new Uint8ClampedArray($1)" - js_uint8ClampedArrayFromJSVal :: JSVal -> SomeUint8ClampedArray m -foreign import javascript unsafe - "new Uint8Array($1)" - js_uint8ArrayFromJSVal :: JSVal -> SomeUint8Array m -foreign import javascript unsafe - "new Uint16Array($1)" - js_uint16ArrayFromJSVal :: JSVal -> SomeUint16Array m -foreign import javascript unsafe - "new Uint32Array($1)" - js_uint32ArrayFromJSVal :: JSVal -> SomeUint32Array m -foreign import javascript unsafe - "new Float32Array($1)" - js_float32ArrayFromJSVal :: JSVal -> SomeFloat32Array m -foreign import javascript unsafe - "new Float64Array($1)" - js_float64ArrayFromJSVal :: JSVal -> 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 "JSArray.from(h$fromListPrim($1))" js_fromListM/**/T/**/Array :: Exts.Any -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromListM/**/T/**/Array #-};\ +foreign import javascript unsafe "JSArray.from($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 "JSArray.from(h$fromListPrim($1))" js_fromList/**/T/**/Array :: Exts.Any -> SomeTypedArray m T; {-# INLINE js_fromList/**/T/**/Array #-};\ +foreign import javascript unsafe "JSArray.from($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 5759109..0000000 --- a/JavaScript/TypedArray/Internal/Types.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE 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 JSVal deriving Typeable -instance IsJSVal (SomeTypedArray e m) - -{- -newtype SomeSTTypedArray s e = SomeSTTypedArray JSVal - 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/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/MessageEvent.hs b/JavaScript/Web/MessageEvent.hs index 3f2f528..e4d547f 100644 --- a/JavaScript/Web/MessageEvent.hs +++ b/JavaScript/Web/MessageEvent.hs @@ -16,7 +16,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(..)) diff --git a/JavaScript/Web/XMLHttpRequest.hs b/JavaScript/Web/XMLHttpRequest.hs index 009e9a8..67efef0 100644 --- a/JavaScript/Web/XMLHttpRequest.hs +++ b/JavaScript/Web/XMLHttpRequest.hs @@ -43,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 @@ -57,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 @@ -85,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) diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index c7fd047..2ce618e 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -88,11 +88,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 @@ -117,9 +113,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, diff --git a/jsbits/array.js b/jsbits/array.js index 8230cdf..1931b75 100644 --- a/jsbits/array.js +++ b/jsbits/array.js @@ -38,3 +38,13 @@ function h$listToArray(xs) { 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; +} From b56ae2178935b116c71f60cdc263c3cf01b33a30 Mon Sep 17 00:00:00 2001 From: Rhys ! Date: Sun, 25 Oct 2015 14:51:47 +1100 Subject: [PATCH 19/36] Fix RegExp constructor --- Data/JSString/RegExp.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Data/JSString/RegExp.hs b/Data/JSString/RegExp.hs index d61d0a7..186211f 100644 --- a/Data/JSString/RegExp.hs +++ b/Data/JSString/RegExp.hs @@ -38,9 +38,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 $ pack $ + if multiline flags then "m" else "" + ++ + if ignoreCase flags then "i" else "" +{-# INLINE create #-} pattern :: RegExp -> JSString pattern re = js_pattern re @@ -51,8 +53,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 #-} @@ -93,7 +93,7 @@ splitN (I# k) x r = unsafeCoerce (js_split k x r) -- ---------------------------------------------------------------------------- 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 From 18afd4769723cd8f0364d9f3011c45f230851112 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 27 Oct 2015 12:21:40 +0000 Subject: [PATCH 20/36] avoid unneccessary String -> JSString packing for RegExp constructor --- Data/JSString/RegExp.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Data/JSString/RegExp.hs b/Data/JSString/RegExp.hs index 186211f..0ec8e1c 100644 --- a/Data/JSString/RegExp.hs +++ b/Data/JSString/RegExp.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MagicHash #-} module Data.JSString.RegExp ( RegExp @@ -38,10 +39,10 @@ data Match = Match { matched :: !JSString -- ^ the matched string } create :: REFlags -> JSString -> RegExp -create flags pat = js_createRE pat $ pack $ - if multiline flags then "m" else "" - ++ - if ignoreCase flags then "i" else "" +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 From 619edd034785dd85a3cde77e1327567604412bea Mon Sep 17 00:00:00 2001 From: Kamil Figiela Date: Tue, 20 Oct 2015 11:44:46 +0200 Subject: [PATCH 21/36] Fix Data.Text.Lazy macros --- jsbits/text.js | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) 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) { From 9601c2b2bbe31daeb625d3ff665d9f62898e95a8 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Thu, 29 Oct 2015 11:06:24 +0000 Subject: [PATCH 22/36] make Export newtype and fix unsafeCoerce bug when dereferencing exports --- GHCJS/Foreign/Export.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/GHCJS/Foreign/Export.hs b/GHCJS/Foreign/Export.hs index b74f20e..6224215 100644 --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -30,8 +30,10 @@ import Unsafe.Coerce import qualified GHC.Exts as Exts import GHCJS.Prim +import GHCJS.Types -type Export a = JSVal +newtype Export a = Export JSVal +instance IsJSVal (Export a) {- | Export any Haskell value to a JavaScript reference without evaluating it. @@ -66,7 +68,7 @@ derefExport e = do r <- js_derefExport w1 w2 e if isNull r then return Nothing - else unsafeCoerce (js_toHeapObject r) + else unsafeCoerce <$> js_toHeapObject r {- | Release all memory associated with the export. Subsequent calls to @@ -82,10 +84,10 @@ foreign import javascript unsafe js_export :: Word64 -> Word64 -> Any -> IO (Export a) foreign import javascript unsafe "h$derefExport" - js_derefExport :: Word64 -> Word64 -> JSVal -> IO JSVal + js_derefExport :: Word64 -> Word64 -> Export a -> IO JSVal foreign import javascript unsafe - "$r = $1;" js_toHeapObject :: JSVal -> Exts.Any + "$r = $1;" js_toHeapObject :: JSVal -> IO Exts.Any foreign import javascript unsafe "h$releaseExport" - js_releaseExport :: JSVal -> IO () + js_releaseExport :: Export a -> IO () From a19de476e804e29b487216e87d7ded79daa0d406 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 30 Oct 2015 22:20:21 +0000 Subject: [PATCH 23/36] fix Export and support Callbacks that return a value --- GHCJS/Foreign/Callback.hs | 32 ++++++++++++++++++++++++++++++++ GHCJS/Foreign/Export.hs | 6 ++---- GHCJS/Types.hs | 2 ++ 3 files changed, 36 insertions(+), 4 deletions(-) diff --git a/GHCJS/Foreign/Callback.hs b/GHCJS/Foreign/Callback.hs index 5c74fc1..7e8e846 100644 --- a/GHCJS/Foreign/Callback.hs +++ b/GHCJS/Foreign/Callback.hs @@ -4,14 +4,21 @@ 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 @@ -88,7 +95,27 @@ syncCallback3 :: OnBlocked -- ^ what to do when th -> 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. @@ -118,11 +145,16 @@ 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/Export.hs b/GHCJS/Foreign/Export.hs index 6224215..502b5c2 100644 --- a/GHCJS/Foreign/Export.hs +++ b/GHCJS/Foreign/Export.hs @@ -6,7 +6,6 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE CPP #-} {- | Dynamically export Haskell values to JavaScript @@ -68,7 +67,7 @@ derefExport e = do r <- js_derefExport w1 w2 e if isNull r then return Nothing - else unsafeCoerce <$> js_toHeapObject r + else Just . unsafeCoerce <$> js_toHeapObject r {- | Release all memory associated with the export. Subsequent calls to @@ -86,8 +85,7 @@ foreign import javascript unsafe "h$derefExport" js_derefExport :: Word64 -> Word64 -> Export a -> IO JSVal foreign import javascript unsafe - "$r = $1;" js_toHeapObject :: JSVal -> IO Exts.Any - + "$r = $1;" js_toHeapObject :: JSVal -> IO Any foreign import javascript unsafe "h$releaseExport" js_releaseExport :: Export a -> IO () diff --git a/GHCJS/Types.hs b/GHCJS/Types.hs index 23f72ce..564ab59 100644 --- a/GHCJS/Types.hs +++ b/GHCJS/Types.hs @@ -6,6 +6,8 @@ {-# LANGUAGE JavaScriptFFI #-} module GHCJS.Types ( JSVal + , WouldBlockException(..) + , JSException(..) , IsJSVal , jsval , isNull From 6f801f6488421412c037e6bd3e5c1ae94b435b02 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 30 Oct 2015 22:44:19 +0000 Subject: [PATCH 24/36] make fewer assumptions about exported items, falsy values can now be exported --- jsbits/export.js | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/jsbits/export.js b/jsbits/export.js index 19475f8..cc3043a 100644 --- a/jsbits/export.js +++ b/jsbits/export.js @@ -1,24 +1,26 @@ function h$exportValue(fp1a,fp1b,fp2a,fp2b,o) { - var e = { fp1a: fp1a - , fp1b: fp1b - , fp2a: fp2a - , fp2b: fp2b - , root: o - , _key: -1 - }; - h$retain(e); - 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; } From 41f53449688e5c4b78f5748206b79345918544c8 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 30 Oct 2015 22:53:36 +0000 Subject: [PATCH 25/36] export getData for MessageEvent --- JavaScript/Web/MessageEvent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/JavaScript/Web/MessageEvent.hs b/JavaScript/Web/MessageEvent.hs index 3f2f528..f043211 100644 --- a/JavaScript/Web/MessageEvent.hs +++ b/JavaScript/Web/MessageEvent.hs @@ -4,6 +4,7 @@ #-} module JavaScript.Web.MessageEvent ( MessageEvent + , getData , MessageEventData(..) ) where From bdd8bc39a34c89de345fb5a2b43499e456a7e7b3 Mon Sep 17 00:00:00 2001 From: Tomas Carnecky Date: Sat, 31 Oct 2015 15:50:51 +0100 Subject: [PATCH 26/36] Fix typo in JavaScript.Web.MessageEvent.js_getData --- JavaScript/Web/MessageEvent.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/JavaScript/Web/MessageEvent.hs b/JavaScript/Web/MessageEvent.hs index f043211..95d30f8 100644 --- a/JavaScript/Web/MessageEvent.hs +++ b/JavaScript/Web/MessageEvent.hs @@ -39,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" + \$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 2 : 3)" js_getData :: MessageEvent -> (# Int#, JSVal #) - From 85552b52ed6712d2f85797c19629ae345a65c315 Mon Sep 17 00:00:00 2001 From: achirkin Date: Tue, 3 Nov 2015 16:34:52 +0100 Subject: [PATCH 27/36] small fixes to arrays --- JavaScript/TypedArray.hs | 3 ++- jsbits/array.js | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/JavaScript/TypedArray.hs b/JavaScript/TypedArray.hs index 65f5278..ddd00be 100644 --- a/JavaScript/TypedArray.hs +++ b/JavaScript/TypedArray.hs @@ -44,6 +44,7 @@ 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) @@ -86,7 +87,7 @@ unsafeDataView' byteOffset mbyteLength (SomeArrayBuffer b) = ----------------------------------------------------------------------------- instance Show (SomeTypedArray m t) where - show = show . js_show + show = unpack' . js_show diff --git a/jsbits/array.js b/jsbits/array.js index 1931b75..bebda10 100644 --- a/jsbits/array.js +++ b/jsbits/array.js @@ -7,7 +7,7 @@ function h$fromArray(a) { var r = HS_NIL; for(var i=a.length-1;i>=0;i--) r = MK_CONS(MK_JSVAL(a[i]), r); - return a; + return r; } /* @@ -19,7 +19,7 @@ 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; } /* From 04aac2a84b4c57ba5e50680150072bcabc638ce9 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 6 Nov 2015 13:39:54 +0000 Subject: [PATCH 28/36] add non-preemptible threads, fix race condition in GHCJS.Concurrent.synchronously, fix websocket, add bindings for Location object --- GHCJS/Concurrent.hs | 49 +++++++--- JavaScript/Web/History.hs | 3 + JavaScript/Web/Location.hs | 172 ++++++++++++++++++++++++++++++++++++ JavaScript/Web/WebSocket.hs | 55 ++++++------ ghcjs-base.cabal | 3 + jsbits/websocket.js | 81 +++++++++-------- 6 files changed, 284 insertions(+), 79 deletions(-) create mode 100644 JavaScript/Web/History.hs create mode 100644 JavaScript/Web/Location.hs diff --git a/GHCJS/Concurrent.hs b/GHCJS/Concurrent.hs index 56c93a8..fa9650c 100644 --- a/GHCJS/Concurrent.hs +++ b/GHCJS/Concurrent.hs @@ -29,6 +29,7 @@ module GHCJS.Concurrent ( isThreadSynchronous , isThreadContinueAsync , OnBlocked(..) , WouldBlockException(..) + , withoutPreemption , synchronously ) where @@ -60,25 +61,39 @@ data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocke deriving (Data, Typeable, Enum, Show, Eq, Ord) {- | - Runs the action synchronously, which means that the thread will not + 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 #-} + + +{- | + 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 @@ -91,6 +106,13 @@ isThreadSynchronous = fmap (`testBit` 0) . 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 @@ -99,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/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/WebSocket.hs b/JavaScript/Web/WebSocket.hs index cc800e1..76d68df 100644 --- a/JavaScript/Web/WebSocket.hs +++ b/JavaScript/Web/WebSocket.hs @@ -15,7 +15,9 @@ module JavaScript.Web.WebSocket ( WebSocket , connect , close , send - , getBufferedAmount + , sendArrayBuffer + , sendBlob + , getBufferedAmount , getExtensions , getProtocol , getReadyState @@ -44,6 +46,8 @@ import qualified Data.JSString as JSS import JavaScript.Array (JSArray) import qualified JavaScript.Array as JSA +import JavaScript.TypedArray.ArrayBuffer (ArrayBuffer) +import JavaScript.Web.Blob (Blob) import JavaScript.Web.MessageEvent import JavaScript.Web.MessageEvent.Internal import JavaScript.Web.CloseEvent @@ -74,29 +78,23 @@ 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 :: (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 :: 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 = @@ -107,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 :: ArrayBuffer -> WebSocket -> IO () +sendArrayBuffer = js_sendArrayBuffer +{-# INLINE sendArrayBuffer #-} + getBufferedAmount :: WebSocket -> IO Int getBufferedAmount ws = js_getBufferedAmount ws {-# INLINE getBufferedAmount #-} @@ -139,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 -> JSVal -> JSVal -> IO JSVal + 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 :: ArrayBuffer -> WebSocket -> IO () foreign import javascript unsafe "$1.bufferedAmount" js_getBufferedAmount :: WebSocket -> IO Int foreign import javascript unsafe @@ -165,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 JSVal foreign import javascript unsafe "$1.lastError" js_getLastError :: WebSocket -> IO JSVal diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index c7fd047..73d2e77 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -20,6 +20,7 @@ library jsbits/text.js jsbits/utils.js jsbits/xhr.js + jsbits/websocket.js other-extensions: DeriveDataTypeable DeriveGeneric ForeignFunctionInterface @@ -106,6 +107,8 @@ 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 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); } From 6328c2dc1befae3b675a44660516cc9dff9fef0d Mon Sep 17 00:00:00 2001 From: achirkin Date: Wed, 11 Nov 2015 16:41:32 +0100 Subject: [PATCH 29/36] Removed PFromJSRef (Maybe a) instance --- GHCJS/Marshal/Pure.hs | 5 ----- GHCJS/Nullable.hs | 5 ++++- ghcjs-base.cabal | 2 +- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/GHCJS/Marshal/Pure.hs b/GHCJS/Marshal/Pure.hs index 902fa20..e043516 100644 --- a/GHCJS/Marshal/Pure.hs +++ b/GHCJS/Marshal/Pure.hs @@ -92,11 +92,6 @@ instance PFromJSVal Float where pFromJSVal x = F# (jsvalToFloat x) instance PFromJSVal Double where pFromJSVal x = D# (jsvalToDouble x) {-# INLINE pFromJSVal #-} -instance PFromJSVal a => PFromJSVal (Maybe a) where - pFromJSVal x | isUndefined x || isNull x = Nothing - pFromJSVal x = Just (pFromJSVal x) - {-# INLINE pFromJSVal #-} - instance PToJSVal JSVal where pToJSVal = id {-# INLINE pToJSVal #-} instance PToJSVal JSString where pToJSVal = jsval diff --git a/GHCJS/Nullable.hs b/GHCJS/Nullable.hs index bad2c56..a573755 100644 --- a/GHCJS/Nullable.hs +++ b/GHCJS/Nullable.hs @@ -3,13 +3,16 @@ module GHCJS.Nullable ( Nullable(..) , 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) = pFromJSVal r +nullableToMaybe (Nullable r) = if (isTruthy r) + then Just $ pFromJSVal r + else Nothing {-# INLINE nullableToMaybe #-} maybeToNullable :: PToJSVal a => Maybe a -> Nullable a diff --git a/ghcjs-base.cabal b/ghcjs-base.cabal index 2ce618e..aec2d67 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base.cabal @@ -1,5 +1,5 @@ name: ghcjs-base -version: 0.2.0.0 +version: 0.2.0.1 synopsis: base library for GHCJS homepage: http://github.com/ghcjs/ghcjs-base license: MIT From 4e9c20f2202259db8eddf6229a2c689dad81cddf Mon Sep 17 00:00:00 2001 From: achirkin Date: Tue, 17 Nov 2015 17:24:35 +0100 Subject: [PATCH 30/36] Move Array.from into Array['from'] for closure compiler --- JavaScript/TypedArray/Internal.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/JavaScript/TypedArray/Internal.hs b/JavaScript/TypedArray/Internal.hs index d124981..f46e33c 100644 --- a/JavaScript/TypedArray/Internal.hs +++ b/JavaScript/TypedArray/Internal.hs @@ -129,8 +129,8 @@ foreign import javascript unsafe "new DataView($1.buffer.slice($1.byteOffset, $1 #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 "JSArray.from(h$fromListPrim($1))" js_fromListM/**/T/**/Array :: Exts.Any -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromListM/**/T/**/Array #-};\ -foreign import javascript unsafe "JSArray.from($1)" js_fromArrayM/**/T/**/Array :: SomeTypedArray m0 t -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromArrayM/**/T/**/Array #-};\ +foreign import javascript unsafe "JSArray['from'](h$fromListPrim($1))" js_fromListM/**/T/**/Array :: Exts.Any -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromListM/**/T/**/Array #-};\ +foreign import javascript unsafe "JSArray['from']($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 #-}; @@ -259,8 +259,8 @@ CREATECONVERTERS(Word8Clamped,uc,Uint8Clamped,Uint8ClampedArray,1) #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 "JSArray.from(h$fromListPrim($1))" js_fromList/**/T/**/Array :: Exts.Any -> SomeTypedArray m T; {-# INLINE js_fromList/**/T/**/Array #-};\ -foreign import javascript unsafe "JSArray.from($1)" js_fromArray/**/T/**/Array :: SomeTypedArray m0 t -> SomeTypedArray m T; {-# INLINE js_fromArray/**/T/**/Array #-};\ +foreign import javascript unsafe "JSArray['from'](h$fromListPrim($1))" js_fromList/**/T/**/Array :: Exts.Any -> SomeTypedArray m T; {-# INLINE js_fromList/**/T/**/Array #-};\ +foreign import javascript unsafe "JSArray['from']($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 #-};\ From f8b853fa9d8a64d19453d6988fb79340da76d472 Mon Sep 17 00:00:00 2001 From: achirkin Date: Wed, 18 Nov 2015 10:13:03 +0100 Subject: [PATCH 31/36] Replaced JSArray.from for browser compatibility --- JavaScript/TypedArray/Internal.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/JavaScript/TypedArray/Internal.hs b/JavaScript/TypedArray/Internal.hs index f46e33c..7571759 100644 --- a/JavaScript/TypedArray/Internal.hs +++ b/JavaScript/TypedArray/Internal.hs @@ -129,8 +129,8 @@ foreign import javascript unsafe "new DataView($1.buffer.slice($1.byteOffset, $1 #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 "JSArray['from'](h$fromListPrim($1))" js_fromListM/**/T/**/Array :: Exts.Any -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromListM/**/T/**/Array #-};\ -foreign import javascript unsafe "JSArray['from']($1)" js_fromArrayM/**/T/**/Array :: SomeTypedArray m0 t -> State# s -> (# State# s, SomeTypedArray m T #); {-# INLINE js_fromArrayM/**/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 #-}; @@ -259,8 +259,8 @@ CREATECONVERTERS(Word8Clamped,uc,Uint8Clamped,Uint8ClampedArray,1) #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 "JSArray['from'](h$fromListPrim($1))" js_fromList/**/T/**/Array :: Exts.Any -> SomeTypedArray m T; {-# INLINE js_fromList/**/T/**/Array #-};\ -foreign import javascript unsafe "JSArray['from']($1)" js_fromArray/**/T/**/Array :: SomeTypedArray m0 t -> SomeTypedArray m T; {-# INLINE js_fromArray/**/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 #-};\ From 3bf1ab66e52ceab52dac4b899f6f76ec5abdd69d Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 25 Dec 2015 12:33:20 -0500 Subject: [PATCH 32/36] implement js_setLineDash and js_lineDashOffSet simple FFI wrappers in the Canvas module --- JavaScript/Web/Canvas.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/JavaScript/Web/Canvas.hs b/JavaScript/Web/Canvas.hs index ee18a58..b256d69 100644 --- a/JavaScript/Web/Canvas.hs +++ b/JavaScript/Web/Canvas.hs @@ -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 () From 3ce3a1e7c44b9f27192bd4c533c3259fa30af96c Mon Sep 17 00:00:00 2001 From: achirkin Date: Fri, 11 Mar 2016 16:18:19 +0100 Subject: [PATCH 33/36] Adapted last merge (Websockets type compatibility) --- JavaScript/Web/WebSocket.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/JavaScript/Web/WebSocket.hs b/JavaScript/Web/WebSocket.hs index 76d68df..c4b906f 100644 --- a/JavaScript/Web/WebSocket.hs +++ b/JavaScript/Web/WebSocket.hs @@ -46,7 +46,7 @@ import qualified Data.JSString as JSS import JavaScript.Array (JSArray) import qualified JavaScript.Array as JSA -import JavaScript.TypedArray.ArrayBuffer (ArrayBuffer) +import JavaScript.TypedArray (SomeArrayBuffer) import JavaScript.Web.Blob (Blob) import JavaScript.Web.MessageEvent import JavaScript.Web.MessageEvent.Internal @@ -73,7 +73,7 @@ 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) @@ -109,7 +109,7 @@ sendBlob :: Blob -> WebSocket -> IO () sendBlob = js_sendBlob {-# INLINE sendBlob #-} -sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO () +sendArrayBuffer :: SomeArrayBuffer m -> WebSocket -> IO () sendArrayBuffer = js_sendArrayBuffer {-# INLINE sendArrayBuffer #-} @@ -163,7 +163,7 @@ foreign import javascript unsafe foreign import javascript unsafe "$2.send($1);" js_sendBlob :: Blob -> WebSocket -> IO () foreign import javascript unsafe - "$2.send($1);" js_sendArrayBuffer :: ArrayBuffer -> WebSocket -> IO () + "$2.send($1);" js_sendArrayBuffer :: SomeArrayBuffer m -> WebSocket -> IO () foreign import javascript unsafe "$1.bufferedAmount" js_getBufferedAmount :: WebSocket -> IO Int foreign import javascript unsafe From f61860dca20b3cf05cb045a819a02bcd9427b00a Mon Sep 17 00:00:00 2001 From: achirkin Date: Mon, 14 Mar 2016 20:55:35 +0100 Subject: [PATCH 34/36] Update README.md --- README.md | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) 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. From 0549b7dcf7df423fb0c564f671528e1966243300 Mon Sep 17 00:00:00 2001 From: achirkin Date: Mon, 14 Mar 2016 21:06:35 +0100 Subject: [PATCH 35/36] naming changes --- ghcjs-base.cabal => ghcjs-base-alt.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) rename ghcjs-base.cabal => ghcjs-base-alt.cabal (98%) diff --git a/ghcjs-base.cabal b/ghcjs-base-alt.cabal similarity index 98% rename from ghcjs-base.cabal rename to ghcjs-base-alt.cabal index e76dc26..b1b2659 100644 --- a/ghcjs-base.cabal +++ b/ghcjs-base-alt.cabal @@ -1,7 +1,7 @@ -name: ghcjs-base -version: 0.2.0.1 +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 From a2f662a86016c555540449b0b3e5fb8c631d212b Mon Sep 17 00:00:00 2001 From: achirkin Date: Mon, 14 Mar 2016 22:01:26 +0100 Subject: [PATCH 36/36] modified gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 2e38caf..a6e13ef 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *~ *# /dist +.stack-work/