4555d2e · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Many changes and bug fixes

4555d2eHamish Mackenzie11 years ago

jsaddle.cabal+77−50

compare with master

unifiedsplit

@@ -1,87 +1,114 @@

1name: jsaddle

2version: 0.3.0.0

3cabal-version: >=1.10

4+build-type: Simple

4license: MIT

5license: MIT

5license-file: LICENSE

6license-file: LICENSE

6maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

7maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

7synopsis: High level interface for webkit-javascriptcore

8synopsis: High level interface for webkit-javascriptcore

9+description:

8−description: This package provides an EDSL for calling JavaScript code using

10+ This package provides an EDSL for calling JavaScript code using

9− the JavaScriptCore engine and low level Haskell bindings

11+ the JavaScriptCore engine and low level Haskell bindings

10− in the webkit-javascriptcore library <https://github.com/ghcjs/webkit-javascriptcore>.

12+ in the webkit-javascriptcore library <https://github.com/ghcjs/webkit-javascriptcore>.

11−author: Hamish Mackenzie

12−data-dir: ""

13category: Web, Javascript

14−build-type: Simple

14+author: Hamish Mackenzie

16−Source-Repository head

16+source-repository head

17− type: git

17+ type: git

18− location: https://github.com/ghcjs/jsaddle

18+ location: https://github.com/ghcjs/jsaddle

20flag gtk3

21+ description:

21− Description: Use GTK3 rather than GTK2

22+ Use GTK3 rather than GTK2

22− Default: True

24flag jsffi

25+ description:

25− description: Use JavaScriptFFI extension for GHCJS JavaScript output

26+ Use JavaScriptFFI extension for GHCJS JavaScript output

26− default: True

28flag webkit

29+ description:

29− description: Use WebKitGtk and JavaScriptCore for GHCJS output

30+ Use WebKitGtk and JavaScriptCore for GHCJS output

30 default: False

31 default: False

32library

33library

34+

33− if impl(ghcjs) && flag(jsffi)

35+ if (impl(ghcjs -any) && flag(jsffi))

36+ build-depends:

37+ ghcjs-base -any,

38+ ghcjs-prim -any

34 cpp-options: -DUSE_JAVASCRIPTFFI

39 cpp-options: -DUSE_JAVASCRIPTFFI

35− build-depends: ghcjs-base,

36− ghcjs-prim

38− if !impl(ghcjs) || flag(webkit)

41+ if (!impl(ghcjs -any) || flag(webkit))

39− cpp-options: -DUSE_WEBKIT

42+

40 if flag(gtk3)

43 if flag(gtk3)

44+ build-depends:

45+ gtk3 >=0.14.2 && <0.15,

41− build-depends: webkitgtk3 >=0.13.0.0 && <0.15,

46+ webkitgtk3 >=0.13.0.0 && <0.15,

42− webkitgtk3-javascriptcore >=0.13.0.0 && <0.14

47+ webkitgtk3-javascriptcore >=0.13.0.0 && <0.14

43 else

48 else

49+ build-depends:

50+ gtk >=0.14.2 && <0.15,

44− build-depends: webkit >=0.13.0.0 && <0.15,

51+ webkit >=0.13.0.0 && <0.15,

45− webkit-javascriptcore >=0.13.0.0 && <0.14

52+ webkit-javascriptcore >=0.13.0.0 && <0.14

46−

53+ cpp-options: -DUSE_WEBKIT

47− build-depends: template-haskell -any, base <5, lens >=3.8.5 && <4.14,

54+ exposed-modules:

48− text >=0.11.2.3 && <1.3, transformers >=0.3.0.0 && <0.5

49−

50− exposed-modules: Language.Javascript.JSaddle

55+ Language.Javascript.JSaddle

51− Language.Javascript.JSaddle.Arguments Language.Javascript.JSaddle.Classes

56+ Language.Javascript.JSaddle.Arguments

57+ Language.Javascript.JSaddle.Classes

58+ Language.Javascript.JSaddle.Evaluate

52− Language.Javascript.JSaddle.Evaluate Language.Javascript.JSaddle.Exception

59+ Language.Javascript.JSaddle.Exception

53− Language.Javascript.JSaddle.Monad

60+ Language.Javascript.JSaddle.Monad

61+ Language.Javascript.JSaddle.Native

62+ Language.Javascript.JSaddle.Object

54− Language.Javascript.JSaddle.Object Language.Javascript.JSaddle.Properties

63+ Language.Javascript.JSaddle.Properties

55− Language.Javascript.JSaddle.String Language.Javascript.JSaddle.Value

64+ Language.Javascript.JSaddle.String

65+ Language.Javascript.JSaddle.Value

56− Language.Javascript.JSaddle.Types

66+ Language.Javascript.JSaddle.Types

57− exposed: True

67+ build-depends:

58− buildable: True

68+ template-haskell -any,

69+ base <5,

70+ lens >=3.8.5 && <4.14,

71+ text >=0.11.2.3 && <1.3,

72+ transformers >=0.3.0.0 && <0.5

59 default-language: Haskell2010

73 default-language: Haskell2010

60 hs-source-dirs: src

74 hs-source-dirs: src

61 ghc-options: -ferror-spans

75 ghc-options: -ferror-spans

63test-suite test-tool

77test-suite test-tool

78+

64− if !impl(ghcjs) || flag(webkit)

79+ if (impl(ghcjs -any) && !flag(webkit))

65− buildable: True

66− else

67 buildable: False

80 buildable: False

69− if impl(ghcjs) && flag(jsffi)

82+ if (impl(ghcjs -any) && flag(jsffi))

83+ build-depends:

84+ ghcjs-base -any,

85+ ghcjs-prim -any

70 cpp-options: -DUSE_JAVASCRIPTFFI

86 cpp-options: -DUSE_JAVASCRIPTFFI

71− build-depends: ghcjs-base,

72− ghcjs-prim

74− if !impl(ghcjs) || flag(webkit)

88+ if (!impl(ghcjs -any) || flag(webkit))

75− cpp-options: -DUSE_WEBKIT

89+

76− build-depends: glib

77 if flag(gtk3)

90 if flag(gtk3)

91+ build-depends:

92+ gtk3 -any,

93+ webkitgtk3 -any,

78− build-depends: gtk3, webkitgtk3, webkitgtk3-javascriptcore

94+ webkitgtk3-javascriptcore -any

79 else

95 else

96+ build-depends:

97+ gtk -any,

98+ webkit -any,

80− build-depends: gtk, webkit, webkit-javascriptcore

99+ webkit-javascriptcore -any

81−

82− build-depends: template-haskell, base, lens, text,

100+ build-depends:

83− transformers, hslogger, jsaddle

101+ glib -any

102+ cpp-options: -DUSE_WEBKIT

84 type: exitcode-stdio-1.0

103 type: exitcode-stdio-1.0

85 main-is: TestJSaddle.hs

104 main-is: TestJSaddle.hs

105+ build-depends:

106+ template-haskell -any,

107+ base -any,

108+ lens -any,

109+ text -any,

110+ transformers -any,

111+ hslogger -any,

112+ jsaddle -any

86 default-language: Haskell2010

113 default-language: Haskell2010

87 hs-source-dirs: tests

114 hs-source-dirs: tests

src/Language/Javascript/JSaddle.hs+2

@@ -52,6 +52,8 @@ module Language.Javascript.JSaddle (

52 module JSaddle

53) where

55+import Language.Javascript.JSaddle.Types as JSaddle

56+import Language.Javascript.JSaddle.Classes as JSaddle

55import Language.Javascript.JSaddle.Monad as JSaddle

57import Language.Javascript.JSaddle.Monad as JSaddle

56import Language.Javascript.JSaddle.Exception as JSaddle

58import Language.Javascript.JSaddle.Exception as JSaddle

57import Language.Javascript.JSaddle.Value as JSaddle

59import Language.Javascript.JSaddle.Value as JSaddle

src/Language/Javascript/JSaddle/Arguments.hs+34−28

@@ -17,60 +17,66 @@ module Language.Javascript.JSaddle.Arguments (

17) where

19import Language.Javascript.JSaddle.Classes

20− (MakeVal(..), MakeArgs(..))

20+ (ToJSVal(..))

21import Language.Javascript.JSaddle.Monad (JSM)

22+import Language.Javascript.JSaddle.Types (JSVal)

23+

24+-- | Anything that can be used to make a list of JavaScript value

25+-- references for use as function arguments

26+class MakeArgs this where

27+ makeArgs :: this -> JSM [JSVal]

23instance MakeArgs arg => MakeArgs (JSM arg) where

29instance MakeArgs arg => MakeArgs (JSM arg) where

24 makeArgs arg = arg >>= makeArgs

30 makeArgs arg = arg >>= makeArgs

25 {-# INLINE makeArgs #-}

31 {-# INLINE makeArgs #-}

27−instance MakeVal arg => MakeArgs [arg] where

33+instance ToJSVal arg => MakeArgs [arg] where

28− makeArgs = mapM makeVal

34+ makeArgs = mapM toJSVal

29 {-# INLINE makeArgs #-}

35 {-# INLINE makeArgs #-}

31−instance (MakeVal arg1, MakeVal arg2) => MakeArgs (arg1, arg2) where

37+instance (ToJSVal arg1, ToJSVal arg2) => MakeArgs (arg1, arg2) where

32 makeArgs (arg1, arg2) = do

38 makeArgs (arg1, arg2) = do

33− rarg1 <- makeVal arg1

39+ rarg1 <- toJSVal arg1

34− rarg2 <- makeVal arg2

40+ rarg2 <- toJSVal arg2

35 return [rarg1, rarg2]

41 return [rarg1, rarg2]

36 {-# INLINE makeArgs #-}

42 {-# INLINE makeArgs #-}

38−instance (MakeVal arg1, MakeVal arg2, MakeVal arg3) => MakeArgs (arg1, arg2, arg3) where

44+instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3) => MakeArgs (arg1, arg2, arg3) where

39 makeArgs (arg1, arg2, arg3) = do

45 makeArgs (arg1, arg2, arg3) = do

40− rarg1 <- makeVal arg1

46+ rarg1 <- toJSVal arg1

41− rarg2 <- makeVal arg2

47+ rarg2 <- toJSVal arg2

42− rarg3 <- makeVal arg3

48+ rarg3 <- toJSVal arg3

43 return [rarg1, rarg2, rarg3]

49 return [rarg1, rarg2, rarg3]

44 {-# INLINE makeArgs #-}

50 {-# INLINE makeArgs #-}

46−instance (MakeVal arg1, MakeVal arg2, MakeVal arg3, MakeVal arg4) => MakeArgs (arg1, arg2, arg3, arg4) where

52+instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3, ToJSVal arg4) => MakeArgs (arg1, arg2, arg3, arg4) where

47 makeArgs (arg1, arg2, arg3, arg4) = do

53 makeArgs (arg1, arg2, arg3, arg4) = do

48− rarg1 <- makeVal arg1

54+ rarg1 <- toJSVal arg1

49− rarg2 <- makeVal arg2

55+ rarg2 <- toJSVal arg2

50− rarg3 <- makeVal arg3

56+ rarg3 <- toJSVal arg3

51− rarg4 <- makeVal arg4

57+ rarg4 <- toJSVal arg4

52 return [rarg1, rarg2, rarg3, rarg4]

58 return [rarg1, rarg2, rarg3, rarg4]

53 {-# INLINE makeArgs #-}

59 {-# INLINE makeArgs #-}

55−instance (MakeVal arg1, MakeVal arg2, MakeVal arg3, MakeVal arg4, MakeVal arg5) => MakeArgs (arg1, arg2, arg3, arg4, arg5) where

61+instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3, ToJSVal arg4, ToJSVal arg5) => MakeArgs (arg1, arg2, arg3, arg4, arg5) where

56 makeArgs (arg1, arg2, arg3, arg4, arg5) = do

62 makeArgs (arg1, arg2, arg3, arg4, arg5) = do

57− rarg1 <- makeVal arg1

63+ rarg1 <- toJSVal arg1

58− rarg2 <- makeVal arg2

64+ rarg2 <- toJSVal arg2

59− rarg3 <- makeVal arg3

65+ rarg3 <- toJSVal arg3

60− rarg4 <- makeVal arg4

66+ rarg4 <- toJSVal arg4

61− rarg5 <- makeVal arg5

67+ rarg5 <- toJSVal arg5

62 return [rarg1, rarg2, rarg3, rarg4, rarg5]

68 return [rarg1, rarg2, rarg3, rarg4, rarg5]

63 {-# INLINE makeArgs #-}

69 {-# INLINE makeArgs #-}

66−instance (MakeVal arg1, MakeVal arg2, MakeVal arg3, MakeVal arg4, MakeVal arg5, MakeVal arg6) => MakeArgs (arg1, arg2, arg3, arg4, arg5, arg6) where

72+instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3, ToJSVal arg4, ToJSVal arg5, ToJSVal arg6) => MakeArgs (arg1, arg2, arg3, arg4, arg5, arg6) where

67 makeArgs (arg1, arg2, arg3, arg4, arg5, arg6) = do

73 makeArgs (arg1, arg2, arg3, arg4, arg5, arg6) = do

68− rarg1 <- makeVal arg1

74+ rarg1 <- toJSVal arg1

69− rarg2 <- makeVal arg2

75+ rarg2 <- toJSVal arg2

70− rarg3 <- makeVal arg3

76+ rarg3 <- toJSVal arg3

71− rarg4 <- makeVal arg4

77+ rarg4 <- toJSVal arg4

72− rarg5 <- makeVal arg5

78+ rarg5 <- toJSVal arg5

73− rarg6 <- makeVal arg6

79+ rarg6 <- toJSVal arg6

74 return [rarg1, rarg2, rarg3, rarg4, rarg5, rarg6]

80 return [rarg1, rarg2, rarg3, rarg4, rarg5, rarg6]

75 {-# INLINE makeArgs #-}

81 {-# INLINE makeArgs #-}

src/Language/Javascript/JSaddle/Classes.hs+18−18

@@ -1,3 +1,5 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE TypeSynonymInstances #-}

1-----------------------------------------------------------------------------

3-----------------------------------------------------------------------------

2--

4--

3-- Module : Language.Javascript.JSaddle.Classes

5-- Module : Language.Javascript.JSaddle.Classes

@@ -14,34 +16,32 @@

15module Language.Javascript.JSaddle.Classes (

17module Language.Javascript.JSaddle.Classes (

16 -- * Type classes to convert Haskell data to JavaScript

18 -- * Type classes to convert Haskell data to JavaScript

17− MakeVal(..)

19+ ToJSVal(..)

18− , MakeString(..)

20+ , ToJSString(..)

19− , MakeArgs(..)

20 , MakeObject(..)

21 , MakeObject(..)

21) where

22) where

23−import Control.Monad.IO.Class (MonadIO)

24import Language.Javascript.JSaddle.Types

25− (Object(..), JSString, JSVal(..))

25+ (JSM, Object(..), JSString, JSVal)

26−import Language.Javascript.JSaddle.Monad (JSM)

28-- | Anything that can be used to make a JavaScript value reference

27-- | Anything that can be used to make a JavaScript value reference

29−class MakeVal a where

28+class ToJSVal a where

30− makeVal :: a -> JSM JSVal

29+ toJSVal :: a -> JSM JSVal

32-- | Anything that can be used to make a JavaScript string reference

31-- | Anything that can be used to make a JavaScript string reference

33−class MakeString a where

32+class ToJSVal a => ToJSString a where

34− makeString :: a -> JSString

33+ toJSString :: a -> JSString

35−

36−-- | Anything that can be used to make a list of JavaScript value

37−-- references for use as function arguments

38−class MakeArgs this where

39− makeArgs :: this -> JSM [JSVal]

41-- | Anything that can be used to make a JavaScript object reference

35-- | Anything that can be used to make a JavaScript object reference

42class MakeObject this where

36class MakeObject this where

43 makeObject :: this -> JSM Object

37 makeObject :: this -> JSM Object

45−instance MakeVal Object where

39+instance ToJSVal Object where

46− makeVal (Object r) = return r

40+ toJSVal (Object r) = return r

47− {-# INLINE makeVal #-}

41+ {-# INLINE toJSVal #-}

42+

43+-- | If we already have a Object we are fine

44+instance MakeObject Object where

45+ makeObject = return

46+ {-# INLINE makeObject #-}

47+

src/Language/Javascript/JSaddle/Evaluate.hs+18−18

@@ -23,22 +23,22 @@ module Language.Javascript.JSaddle.Evaluate (

24import Control.Monad.Trans.Reader (ask)

25import Control.Monad.IO.Class (MonadIO(..))

26−import Language.Javascript.JSaddle.Types

26+import Language.Javascript.JSaddle.Types (JSVal)

27− (JSString, JSVal, Object(..),

28− MutableJSArray)

29#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

27#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

30import GHCJS.Types (nullRef)

28import GHCJS.Types (nullRef)

31import GHCJS.Marshal.Pure (pFromJSVal)

29import GHCJS.Marshal.Pure (pFromJSVal)

30+import Language.Javascript.JSaddle.Types (JSString)

32#else

31#else

33import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

32import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

34 (jsevaluatescript)

33 (jsevaluatescript)

35−import Foreign (nullPtr)

34+import Language.Javascript.JSaddle.Native

35+ (makeNewJSVal, withObject, withJSString)

36#endif

37import Language.Javascript.JSaddle.Exception (rethrow)

38−import Language.Javascript.JSaddle.Value ()

38+import Language.Javascript.JSaddle.String (nullJSString)

39−import Language.Javascript.JSaddle.Object ()

39+import Language.Javascript.JSaddle.Object (nullObject)

40import Language.Javascript.JSaddle.Classes

41− (MakeObject(..), MakeString(..))

41+ (MakeObject(..), ToJSString(..))

42import Language.Javascript.JSaddle.Monad (JSM)

44-- | Evaluates a script (like eval in java script). Unlike 'eval' this function lets you

@@ -46,22 +46,27 @@ import Language.Javascript.JSaddle.Monad (JSM)

46--

47-- >>> testJSaddle $ (evaluateScript "\n\n{" global "FileName" 53 >>= valToText) `catch` \(JSException e) -> array (e,e!"sourceURL", e!"line") >>= valToText

48-- SyntaxError: Expected token '}',FileName,55

49−evaluateScript :: (MakeString script, MakeObject this, MakeString url)

49+evaluateScript :: (ToJSString script, MakeObject this, ToJSString url)

50 => script -- ^ JavaScript to evaluate

51 -> this

52 -> url

53 -> Int -- ^ The Line number of the first line of the script

54 -> JSM JSVal

55#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

56−evaluateScript script this url line = liftIO $ js_eval (makeString script)

56+evaluateScript script this url line = liftIO $ js_eval (toJSString script)

57{-# INLINE evaluateScript #-}

58foreign import javascript unsafe "$r = eval($1);"

59 js_eval :: JSString -> IO JSVal

60#elif defined(USE_WEBKIT)

61evaluateScript script this url line = do

62 gctxt <- ask

63− (Object thisr) <- makeObject this

63+ rthis <- makeObject this

64+ result <-

65+ withJSString (toJSString script) $ \script' ->

66+ withObject rthis $ \this' ->

67+ withJSString (toJSString url) $ \url' ->

64− rethrow $ liftIO . jsevaluatescript gctxt (makeString script) thisr (makeString url) line

68+ rethrow $ liftIO . jsevaluatescript gctxt script' this' url' line

69+ makeNewJSVal result

65{-# INLINE evaluateScript #-}

70{-# INLINE evaluateScript #-}

66#else

71#else

67evaluateScript = undefined

72evaluateScript = undefined

@@ -71,13 +76,8 @@ evaluateScript = undefined

71--

76--

72-- >>> testJSaddle $ eval "1+1"

77-- >>> testJSaddle $ eval "1+1"

73-- 2

78-- 2

74−eval :: MakeString script

79+eval :: ToJSString script

75 => script -- ^ JavaScript to evaluate

80 => script -- ^ JavaScript to evaluate

76 -> JSM JSVal

81 -> JSM JSVal

77−#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

78−eval script = evaluateScript script (Object nullRef) (pFromJSVal nullRef::JSString) 1

82+eval script = evaluateScript script nullObject nullJSString 1

79−{-# INLINE eval #-}

80−#else

81−eval script = evaluateScript script (Object nullPtr) (nullPtr::JSString) 1

82{-# INLINE eval #-}

83{-# INLINE eval #-}

83−#endif

src/Language/Javascript/JSaddle/Exception.hs−1

@@ -22,7 +22,6 @@ import Language.Javascript.JSaddle.Types

22import Data.Typeable (Typeable)

23import Language.Javascript.JSaddle.Monad (catchval, JSM)

24import Control.Monad.IO.Class (MonadIO(..))

25−import Data.Text (Text)

27newtype JSException = JSException JSVal deriving (Typeable)

26newtype JSException = JSException JSVal deriving (Typeable)

src/Language/Javascript/JSaddle/Monad.hs+42−18

@@ -13,27 +13,32 @@

14module Language.Javascript.JSaddle.Monad (

15 -- * Types

16− JSM(..)

16+ JSM

17 , JSContextRef

19 -- * Running JSaddle given a DOM Window

20 , runJSaddle

21− , runJSaddle_

23 -- * Exception Handling

22 -- * Exception Handling

24 , catchval

23 , catchval

25 , catch

24 , catch

25+ , bracket

26+

27+ -- * GUI thread support

28+ , postGUIAsyncJS

29+ , postGUISyncJS

26) where

30) where

28import Prelude hiding (catch, read)

32import Prelude hiding (catch, read)

29import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))

33import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))

30import Language.Javascript.JSaddle.Types

34import Language.Javascript.JSaddle.Types

31− (JSVal(..), MutableJSArray(..), JSContextRef)

35+ (JSM, JSVal, MutableJSArray, JSContextRef)

32import Control.Monad.IO.Class (MonadIO(..))

36import Control.Monad.IO.Class (MonadIO(..))

33#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

37#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

34import GHCJS.Types (isUndefined, isNull)

38import GHCJS.Types (isUndefined, isNull)

35import qualified JavaScript.Array as Array (create, read)

39import qualified JavaScript.Array as Array (create, read)

36#else

40#else

41+import Language.Javascript.JSaddle.Native (makeNewJSVal)

37import Foreign (nullPtr, alloca)

42import Foreign (nullPtr, alloca)

38import Foreign.Storable (Storable(..))

43import Foreign.Storable (Storable(..))

39import Graphics.UI.Gtk.WebKit.Types

44import Graphics.UI.Gtk.WebKit.Types

@@ -42,19 +47,9 @@ import Graphics.UI.Gtk.WebKit.WebView

42 (webViewGetMainFrame)

47 (webViewGetMainFrame)

43import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

48import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

44 (webFrameGetGlobalContext)

49 (webFrameGetGlobalContext)

50+import Graphics.UI.Gtk.General.General (postGUIAsync, postGUISync)

45#endif

51#endif

46−import qualified Control.Exception as E (Exception, catch)

52+import qualified Control.Exception as E (Exception, catch, bracket)

47−import Control.Monad (void)

48−

49−-- | The @JSM@ monad keeps track of the JavaScript context.

50−--

51−-- Given a @JSM@ function and a 'JSContextRef' you can run the

52−-- function like this...

53−--

54−-- > runReaderT jsmFunction javaScriptContext

55−--

56−-- For an example of how to set up WebKitGTK+ see tests/TestJSaddle.hs

57−type JSM = ReaderT JSContextRef IO

59-- | Wrapped version of 'E.catch' that runs in a MonadIO that works

54-- | Wrapped version of 'E.catch' that runs in a MonadIO that works

60-- a bit better with 'JSM'

55-- a bit better with 'JSM'

@@ -67,6 +62,17 @@ t `catch` c = do

67 liftIO (runReaderT t r `E.catch` \e -> runReaderT (c e) r)

62 liftIO (runReaderT t r `E.catch` \e -> runReaderT (c e) r)

68{-# INLINE catch #-}

63{-# INLINE catch #-}

65+-- | Wrapped version of 'E.bracket' that runs in a MonadIO that works

66+-- a bit better with 'JSM'

67+bracket :: MonadIO m => ReaderT r IO a -> (a -> ReaderT r IO b) -> (a -> ReaderT r IO c) -> ReaderT r m c

68+bracket aquire release f = do

69+ r <- ask

70+ liftIO $ E.bracket

71+ (runReaderT aquire r)

72+ (\x -> runReaderT (release x) r)

73+ (\x -> runReaderT (f x) r)

74+{-# INLINE bracket #-}

75+

70-- | Handle JavaScriptCore functions that take a MutableJSArray in order

76-- | Handle JavaScriptCore functions that take a MutableJSArray in order

71-- to throw exceptions.

77-- to throw exceptions.

72catchval :: (MutableJSArray -> JSM a) -> (JSVal -> JSM a) -> JSM a

78catchval :: (MutableJSArray -> JSM a) -> (JSVal -> JSM a) -> JSM a

@@ -86,7 +92,7 @@ catchval f catcher = do

86 exc <- liftIO $ peek pexc

92 exc <- liftIO $ peek pexc

87 if exc == nullPtr

93 if exc == nullPtr

88 then return result

94 then return result

89− else catcher exc

95+ else makeNewJSVal exc >>= catcher

90#endif

96#endif

92#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

98#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

@@ -100,5 +106,23 @@ runJSaddle webView f = do

100#endif

106#endif

101{-# INLINE runJSaddle #-}

107{-# INLINE runJSaddle #-}

102

108

103−runJSaddle_ w f = void $ runJSaddle w f

109+postGUIAsyncJS :: JSM () -> JSM ()

104−{-# INLINE runJSaddle_ #-}

110+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

111+postGUIAsyncJS = id

112+#else

113+postGUIAsyncJS f = do

114+ r <- ask

115+ liftIO . postGUIAsync $ runReaderT f r

116+#endif

117+{-# INLINE postGUIAsyncJS #-}

118+

119+postGUISyncJS :: JSM a -> JSM a

120+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

121+postGUISyncJS = id

122+#else

123+postGUISyncJS f = do

124+ r <- ask

125+ liftIO . postGUISync $ runReaderT f r

126+#endif

127+{-# INLINE postGUISyncJS #-}

128+

src/Language/Javascript/JSaddle/Native.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# LANGUAGE CPP #-}

2+-----------------------------------------------------------------------------

3+--

4+-- Module : Language.Javascript.JSaddle.Native

5+-- Copyright : (c) Hamish Mackenzie

6+-- License : MIT

7+--

8+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

9+--

10+-- |

11+--

12+-----------------------------------------------------------------------------

13+

14+module Language.Javascript.JSaddle.Native (

15+#if !defined(ghcjs_HOST_OS) || !defined(USE_JAVASCRIPTFFI)

16+ makeNewJSVal

17+ , makeNewJSString

18+ , wrapJSString

19+ , withJSVal

20+ , withJSVals

21+ , withObject

22+ , withJSString

23+ , withToJSVal

24+#endif

25+) where

26+

27+#if !defined(ghcjs_HOST_OS) || !defined(USE_JAVASCRIPTFFI)

28+import Control.Monad.Trans.Reader (ask)

29+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

30+ (JSObjectRef, OpaqueJSString, JSStringRef, OpaqueJSContext,

31+ OpaqueJSValue, JSValueRef)

32+import Foreign.ForeignPtr

33+ (touchForeignPtr, FinalizerPtr, newForeignPtr, FinalizerEnvPtr,

34+ newForeignPtrEnv, ForeignPtr)

35+import Control.Monad.IO.Class (MonadIO, MonadIO(..))

36+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

37+ (jsvalueprotect)

38+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

39+ (jsstringretain)

40+import Language.Javascript.JSaddle.Types

41+ (JSM, JSString, Object(..), JSVal)

42+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

43+import Language.Javascript.JSaddle.Classes (ToJSVal(..), ToJSVal)

44+

45+makeNewJSVal :: JSValueRef -> JSM (ForeignPtr OpaqueJSValue)

46+makeNewJSVal val = do

47+ ctx <- ask

48+ liftIO $ do

49+ jsvalueprotect ctx val

50+ newForeignPtrEnv jsValueUnprotect ctx val

51+

52+foreign import ccall unsafe "&JSValueUnprotect"

53+ jsValueUnprotect :: FinalizerEnvPtr OpaqueJSContext OpaqueJSValue

54+

55+makeNewJSString :: MonadIO m => JSStringRef -> m (ForeignPtr OpaqueJSString)

56+makeNewJSString s =

57+ liftIO $ do

58+ s' <- jsstringretain s

59+ newForeignPtr jsStringRelease s'

60+

61+wrapJSString :: MonadIO m => JSStringRef -> m (ForeignPtr OpaqueJSString)

62+wrapJSString s = liftIO $ newForeignPtr jsStringRelease s

63+

64+foreign import ccall unsafe "&JSStringRelease"

65+ jsStringRelease :: FinalizerPtr OpaqueJSString

66+

67+withJSVal :: MonadIO m => JSVal -> (JSValueRef -> m a) -> m a

68+withJSVal v f =

69+ do result <- f (unsafeForeignPtrToPtr v)

70+ liftIO $ touchForeignPtr v

71+ return result

72+

73+withJSVals :: MonadIO m => [JSVal] -> ([JSValueRef] -> m a) -> m a

74+withJSVals v f =

75+ do result <- f (map unsafeForeignPtrToPtr v)

76+ liftIO $ mapM_ touchForeignPtr v

77+ return result

78+

79+withObject :: MonadIO m => Object -> (JSObjectRef -> m a) -> m a

80+withObject (Object o) f = do

81+ result <- f (unsafeForeignPtrToPtr o)

82+ liftIO $ touchForeignPtr o

83+ return result

84+

85+withJSString :: MonadIO m => JSString -> (JSStringRef -> m a) -> m a

86+withJSString v f =

87+ do result <- f (unsafeForeignPtrToPtr v)

88+ liftIO $ touchForeignPtr v

89+ return result

90+

91+withToJSVal :: ToJSVal val => val -> (JSValueRef -> JSM a) -> JSM a

92+withToJSVal val f = do

93+ v <- toJSVal val

94+ withJSVal v f

95+{-# INLINE withToJSVal #-}

96+#endif

97+

src/Language/Javascript/JSaddle/Object.hs+173−90

@@ -3,10 +3,11 @@

3{-# LANGUAGE TypeSynonymInstances #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE Rank2Types #-}

6−{-# LANGUAGE ForeignFunctionInterface #-}

7#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

6#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

7+{-# LANGUAGE ForeignFunctionInterface #-}

8{-# LANGUAGE JavaScriptFFI #-}

9#endif

10+{-# OPTIONS_GHC -fno-warn-orphans #-}

10-----------------------------------------------------------------------------

11-----------------------------------------------------------------------------

11--

12--

12-- Module : Language.Javascript.JSaddle.Object

13-- Module : Language.Javascript.JSaddle.Object

@@ -28,7 +29,7 @@ module Language.Javascript.JSaddle.Object (

28 , (!!)

29 , (!!)

29 , js

30 , js

30 , jss

31 , jss

31− , JSF(..)

32+ , JSF

32 , jsf

33 , jsf

33 , js0

34 , js0

34 , js1

35 , js1

@@ -57,9 +58,11 @@ module Language.Javascript.JSaddle.Object (

57 , obj

58 , obj

59 -- * Calling Haskell From JavaScript

60 -- * Calling Haskell From JavaScript

61+ , Function(..)

60 , function

62 , function

63+ , freeFunction

61 , fun

64 , fun

62− , JSCallAsFunction(..)

65+ , JSCallAsFunction

63 -- ** Object Constructors

66 -- ** Object Constructors

65 -- | There is no good way to support calling haskell code as a JavaScript

68 -- | There is no good way to support calling haskell code as a JavaScript

@@ -78,20 +81,23 @@ module Language.Javascript.JSaddle.Object (

79 -- * Enumerating Properties

82 -- * Enumerating Properties

80 , propertyNames

83 , propertyNames

84+ , properties

82 -- * Low level

86 -- * Low level

83 , objCallAsFunction

87 , objCallAsFunction

84 , objCallAsConstructor

88 , objCallAsConstructor

89+ , nullObject

85) where

90) where

87import Prelude hiding ((!!))

92import Prelude hiding ((!!))

88import Language.Javascript.JSaddle.Types

93import Language.Javascript.JSaddle.Types

89 (JSPropertyNameArray, JSString, Object(..), MutableJSArray,

94 (JSPropertyNameArray, JSString, Object(..), MutableJSArray,

90 JSVal, Index)

95 JSVal, Index)

91−import Foreign.C.Types (CSize(..), CULong(..), CUInt(..), CULLong(..))

96+import Foreign.C.Types (CSize(..), CULong(..))

92#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

97#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

93import GHCJS.Types (nullRef, jsval)

98import GHCJS.Types (nullRef, jsval)

94−import GHCJS.Foreign.Callback (syncCallback2, OnBlocked(..), Callback)

99+import GHCJS.Foreign.Callback

100+ (releaseCallback, syncCallback2, OnBlocked(..), Callback)

95import GHCJS.Marshal.Pure (pFromJSVal)

101import GHCJS.Marshal.Pure (pFromJSVal)

96import JavaScript.Array (JSArray)

102import JavaScript.Array (JSArray)

97import qualified JavaScript.Array as Array (toListIO, fromListIO)

103import qualified JavaScript.Array as Array (toListIO, fromListIO)

@@ -104,39 +110,39 @@ import Data.Coerce (coerce)

104import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

110import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

105 (jsobjectmake, jspropertynamearraygetnameatindex,

111 (jsobjectmake, jspropertynamearraygetnameatindex,

106 jspropertynamearraygetcount, jsobjectcopypropertynames,

112 jspropertynamearraygetcount, jsobjectcopypropertynames,

107− jsobjectsetpropertyatindex, jsobjectgetpropertyatindex,

108 jsobjectcallasconstructor, jsobjectmakearray,

113 jsobjectcallasconstructor, jsobjectmakearray,

109− jsobjectcallasfunction, jsobjectgetproperty, jsobjectsetproperty,

114+ jsobjectcallasfunction,

110− JSPropertyAttributes, JSObjectCallAsFunctionCallback,

115+ JSObjectCallAsFunctionCallback,

111 jsobjectmakefunctionwithcallback, JSObjectCallAsFunctionCallback')

116 jsobjectmakefunctionwithcallback, JSObjectCallAsFunctionCallback')

112import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

117import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

113 (jsvaluemakeundefined)

118 (jsvaluemakeundefined)

114import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef

119import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef

115 (jscontextgetglobalobject)

120 (jscontextgetglobalobject)

116import Foreign (peekArray, nullPtr, withArrayLen)

121import Foreign (peekArray, nullPtr, withArrayLen)

122+import Foreign.Ptr (freeHaskellFunPtr)

123+import Language.Javascript.JSaddle.Native

124+ (makeNewJSVal, wrapJSString, withJSVals, withObject, withJSString,

125+ withToJSVal)

126+import System.IO.Unsafe (unsafePerformIO)

127+import Foreign.ForeignPtr (newForeignPtr_)

117#endif

128#endif

118import Language.Javascript.JSaddle.Exception (rethrow)

129import Language.Javascript.JSaddle.Exception (rethrow)

119import Language.Javascript.JSaddle.Value

130import Language.Javascript.JSaddle.Value

120− (JSUndefined, valMakeUndefined, valToObject)

131+ (JSUndefined, valToObject)

121import Language.Javascript.JSaddle.Classes

132import Language.Javascript.JSaddle.Classes

122− (MakeVal(..), MakeString(..), MakeArgs(..), MakeObject(..))

133+ (ToJSVal(..), ToJSString(..), MakeObject(..))

134+import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

123import Language.Javascript.JSaddle.Monad

135import Language.Javascript.JSaddle.Monad

124 (JSM)

136 (JSM)

125import Control.Monad.Trans.Reader (runReaderT, ask)

137import Control.Monad.Trans.Reader (runReaderT, ask)

126import Control.Monad.IO.Class (MonadIO(..))

138import Control.Monad.IO.Class (MonadIO(..))

127import qualified Control.Exception as E (catch)

139import qualified Control.Exception as E (catch)

128import Control.Exception (SomeException)

140import Control.Exception (SomeException)

129−import qualified Data.Text as T (pack)

130import Foreign.Storable (Storable(..))

141import Foreign.Storable (Storable(..))

131import Language.Javascript.JSaddle.Properties

142import Language.Javascript.JSaddle.Properties

132−import Control.Lens

133− (IndexPreservingGetter, to, (^.))

143+import Control.Lens (IndexPreservingGetter, to)

134−import Language.Javascript.JSaddle.String (textToStr)

144+import Language.Javascript.JSaddle.String (nullJSString)

135−

145+import Data.Text (Text)

136−-- | If we already have a Object we are fine

137−instance MakeObject Object where

138− makeObject = return

139− {-# INLINE makeObject #-}

140

146

141-- | Object can be made by evaluating a function in 'JSM' as long

147-- | Object can be made by evaluating a function in 'JSM' as long

142-- as it returns something we can make into a Object.

148-- as it returns something we can make into a Object.

@@ -149,7 +155,7 @@ instance MakeObject v => MakeObject (JSM v) where

149-- >>> testJSaddle $ eval "'Hello World'.length"

155-- >>> testJSaddle $ eval "'Hello World'.length"

150-- >>> testJSaddle $ val "Hello World" ! "length"

156-- >>> testJSaddle $ val "Hello World" ! "length"

151-- 11

157-- 11

152−(!) :: (MakeObject this, MakeString name)

158+(!) :: (MakeObject this, ToJSString name)

153 => this -- ^ Object to look on

159 => this -- ^ Object to look on

154 -> name -- ^ Name of the property to find

160 -> name -- ^ Name of the property to find

155 -> JSM JSVal -- ^ Property reference

161 -> JSM JSVal -- ^ Property reference

@@ -157,7 +163,7 @@ this ! name = do

157 rthis <- makeObject this

163 rthis <- makeObject this

158 rethrow $ objGetPropertyByName rthis rname

164 rethrow $ objGetPropertyByName rthis rname

159 where

165 where

160− rname = makeString name

166+ rname = toJSString name

161{-# INLINE (!) #-}

167{-# INLINE (!) #-}

162

168

163-- | Lookup a property based on its index.

169-- | Lookup a property based on its index.

@@ -181,7 +187,7 @@ this !! index = do

181-- >>> testJSaddle $ eval "'Hello World'.length"

187-- >>> testJSaddle $ eval "'Hello World'.length"

182-- >>> testJSaddle $ val "Hello World" ^. js "length"

188-- >>> testJSaddle $ val "Hello World" ^. js "length"

183-- 11

189-- 11

184−js :: (MakeObject s, MakeString name)

190+js :: (MakeObject s, ToJSString name)

185 => name -- ^ Name of the property to find

191 => name -- ^ Name of the property to find

186 -> IndexPreservingGetter s (JSM JSVal)

192 -> IndexPreservingGetter s (JSM JSVal)

187js name = to (!name)

193js name = to (!name)

@@ -194,7 +200,7 @@ js name = to (!name)

194-- >>> testJSaddle $ eval "'Hello World'.length"

200-- >>> testJSaddle $ eval "'Hello World'.length"

195-- >>> testJSaddle $ val "Hello World" ^. js "length"

201-- >>> testJSaddle $ val "Hello World" ^. js "length"

196-- 11

202-- 11

197−jss :: (MakeString name, MakeVal val)

203+jss :: (ToJSString name, ToJSVal val)

198 => name -- ^ Name of the property to find

204 => name -- ^ Name of the property to find

199 -> val

205 -> val

200 -> forall o . MakeObject o => IndexPreservingGetter o (JSM ())

206 -> forall o . MakeObject o => IndexPreservingGetter o (JSM ())

@@ -207,7 +213,7 @@ jss name val = to (\o -> o <# name $ val)

207--

213--

208-- >>> testJSaddle $ val "Hello World" ^. jsf "indexOf" ["World"]

214-- >>> testJSaddle $ val "Hello World" ^. jsf "indexOf" ["World"]

209-- 6

215-- 6

210−jsf :: (MakeString name, MakeArgs args) => name -> args -> JSF

216+jsf :: (ToJSString name, MakeArgs args) => name -> args -> JSF

211jsf name args = to (\o -> o # name $ args)

217jsf name args = to (\o -> o # name $ args)

212{-# INLINE jsf #-}

218{-# INLINE jsf #-}

213

219

@@ -220,7 +226,7 @@ type JSF = forall o . MakeObject o => IndexPreservingGetter o (JSM JSVal)

220--

226--

221-- >>> testJSaddle $ val "Hello World" ^. js0 "toLowerCase"

227-- >>> testJSaddle $ val "Hello World" ^. js0 "toLowerCase"

222-- hello world

228-- hello world

223−js0 :: (MakeString name) => name -> JSF

229+js0 :: (ToJSString name) => name -> JSF

224js0 name = jsf name ()

230js0 name = jsf name ()

225{-# INLINE js0 #-}

231{-# INLINE js0 #-}

226

232

@@ -230,31 +236,31 @@ js0 name = jsf name ()

230--

236--

231-- >>> testJSaddle $ val "Hello World" ^. js1 "indexOf" "World"

237-- >>> testJSaddle $ val "Hello World" ^. js1 "indexOf" "World"

232-- 6

238-- 6

233−js1 :: (MakeString name, MakeVal a0) => name -> a0 -> JSF

239+js1 :: (ToJSString name, ToJSVal a0) => name -> a0 -> JSF

234js1 name a0 = jsf name [a0]

240js1 name a0 = jsf name [a0]

235{-# INLINE js1 #-}

241{-# INLINE js1 #-}

236

242

237-- | Handy way to call a function that expects two arguments

243-- | Handy way to call a function that expects two arguments

238−js2 :: (MakeString name, MakeVal a0, MakeVal a1) => name -> a0 -> a1 -> JSF

244+js2 :: (ToJSString name, ToJSVal a0, ToJSVal a1) => name -> a0 -> a1 -> JSF

239js2 name a0 a1 = jsf name (a0, a1)

245js2 name a0 a1 = jsf name (a0, a1)

240{-# INLINE js2 #-}

246{-# INLINE js2 #-}

241

247

242-- | Handy way to call a function that expects three arguments

248-- | Handy way to call a function that expects three arguments

243−js3 :: (MakeString name, MakeVal a0, MakeVal a1, MakeVal a2)

249+js3 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2)

244 => name -> a0 -> a1 -> a2 -> JSF

250 => name -> a0 -> a1 -> a2 -> JSF

245js3 name a0 a1 a2 = jsf name (a0, a1, a2)

251js3 name a0 a1 a2 = jsf name (a0, a1, a2)

246{-# INLINE js3 #-}

252{-# INLINE js3 #-}

247

253

248-- | Handy way to call a function that expects four arguments

254-- | Handy way to call a function that expects four arguments

249−js4 :: (MakeString name, MakeVal a0, MakeVal a1, MakeVal a2,

255+js4 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,

250− MakeVal a3)

256+ ToJSVal a3)

251 => name -> a0 -> a1 -> a2 -> a3 -> JSF

257 => name -> a0 -> a1 -> a2 -> a3 -> JSF

252js4 name a0 a1 a2 a3 = jsf name (a0, a1, a2, a3)

258js4 name a0 a1 a2 a3 = jsf name (a0, a1, a2, a3)

253{-# INLINE js4 #-}

259{-# INLINE js4 #-}

254

260

255-- | Handy way to call a function that expects five arguments

261-- | Handy way to call a function that expects five arguments

256−js5 :: (MakeString name, MakeVal a0, MakeVal a1, MakeVal a2,

262+js5 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,

257− MakeVal a3, MakeVal a4)

263+ ToJSVal a3, ToJSVal a4)

258 => name -> a0 -> a1 -> a2 -> a3 -> a4 -> JSF

264 => name -> a0 -> a1 -> a2 -> a3 -> a4 -> JSF

259js5 name a0 a1 a2 a3 a4 = jsf name (a0, a1, a2, a3, a4)

265js5 name a0 a1 a2 a3 a4 = jsf name (a0, a1, a2, a3, a4)

260{-# INLINE js5 #-}

266{-# INLINE js5 #-}

@@ -265,7 +271,7 @@ js5 name a0 a1 a2 a3 a4 = jsf name (a0, a1, a2, a3, a4)

265-- >>> testJSaddle $ eval "w = console; w.log('Hello World')"

271-- >>> testJSaddle $ eval "w = console; w.log('Hello World')"

266-- >>> testJSaddle $ do w <- jsg "console"; w ^. js "log" # ["Hello World"]

272-- >>> testJSaddle $ do w <- jsg "console"; w ^. js "log" # ["Hello World"]

267-- 11

273-- 11

268−jsg :: MakeString a => a -> JSM JSVal

274+jsg :: ToJSString a => a -> JSM JSVal

269jsg name = global ! name

275jsg name = global ! name

270{-# INLINE jsg #-}

276{-# INLINE jsg #-}

271

277

@@ -275,7 +281,7 @@ jsg name = global ! name

275--

281--

276-- >>> testJSaddle $ jsf "globalFunc" ["World"]

282-- >>> testJSaddle $ jsf "globalFunc" ["World"]

277-- 6

283-- 6

278−jsgf :: (MakeString name, MakeArgs args) => name -> args -> JSM JSVal

284+jsgf :: (ToJSString name, MakeArgs args) => name -> args -> JSM JSVal

279jsgf name = global # name

285jsgf name = global # name

280{-# INLINE jsgf #-}

286{-# INLINE jsgf #-}

281

287

@@ -285,7 +291,7 @@ jsgf name = global # name

285--

291--

286-- >>> testJSaddle $ js0 "globalFunc"

292-- >>> testJSaddle $ js0 "globalFunc"

287-- hello world

293-- hello world

288−jsg0 :: (MakeString name) => name -> JSM JSVal

294+jsg0 :: (ToJSString name) => name -> JSM JSVal

289jsg0 name = jsgf name ()

295jsg0 name = jsgf name ()

290{-# INLINE jsg0 #-}

296{-# INLINE jsg0 #-}

291

297

@@ -295,31 +301,31 @@ jsg0 name = jsgf name ()

295--

301--

296-- >>> testJSaddle $ jsg1 "globalFunc" "World"

302-- >>> testJSaddle $ jsg1 "globalFunc" "World"

297-- 6

303-- 6

298−jsg1 :: (MakeString name, MakeVal a0) => name -> a0 -> JSM JSVal

304+jsg1 :: (ToJSString name, ToJSVal a0) => name -> a0 -> JSM JSVal

299jsg1 name a0 = jsgf name [a0]

305jsg1 name a0 = jsgf name [a0]

300{-# INLINE jsg1 #-}

306{-# INLINE jsg1 #-}

301

307

302-- | Handy way to call a function that expects two arguments

308-- | Handy way to call a function that expects two arguments

303−jsg2 :: (MakeString name, MakeVal a0, MakeVal a1) => name -> a0 -> a1 -> JSM JSVal

309+jsg2 :: (ToJSString name, ToJSVal a0, ToJSVal a1) => name -> a0 -> a1 -> JSM JSVal

304jsg2 name a0 a1 = jsgf name (a0, a1)

310jsg2 name a0 a1 = jsgf name (a0, a1)

305{-# INLINE jsg2 #-}

311{-# INLINE jsg2 #-}

306

312

307-- | Handy way to call a function that expects three arguments

313-- | Handy way to call a function that expects three arguments

308−jsg3 :: (MakeString name, MakeVal a0, MakeVal a1, MakeVal a2)

314+jsg3 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2)

309 => name -> a0 -> a1 -> a2 -> JSM JSVal

315 => name -> a0 -> a1 -> a2 -> JSM JSVal

310jsg3 name a0 a1 a2 = jsgf name (a0, a1, a2)

316jsg3 name a0 a1 a2 = jsgf name (a0, a1, a2)

311{-# INLINE jsg3 #-}

317{-# INLINE jsg3 #-}

312

318

313-- | Handy way to call a function that expects four arguments

319-- | Handy way to call a function that expects four arguments

314−jsg4 :: (MakeString name, MakeVal a0, MakeVal a1, MakeVal a2,

320+jsg4 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,

315− MakeVal a3)

321+ ToJSVal a3)

316 => name -> a0 -> a1 -> a2 -> a3 -> JSM JSVal

322 => name -> a0 -> a1 -> a2 -> a3 -> JSM JSVal

317jsg4 name a0 a1 a2 a3 = jsgf name (a0, a1, a2, a3)

323jsg4 name a0 a1 a2 a3 = jsgf name (a0, a1, a2, a3)

318{-# INLINE jsg4 #-}

324{-# INLINE jsg4 #-}

319

325

320-- | Handy way to call a function that expects five arguments

326-- | Handy way to call a function that expects five arguments

321−jsg5 :: (MakeString name, MakeVal a0, MakeVal a1, MakeVal a2,

327+jsg5 :: (ToJSString name, ToJSVal a0, ToJSVal a1, ToJSVal a2,

322− MakeVal a3, MakeVal a4)

328+ ToJSVal a3, ToJSVal a4)

323 => name -> a0 -> a1 -> a2 -> a3 -> a4 -> JSM JSVal

329 => name -> a0 -> a1 -> a2 -> a3 -> a4 -> JSM JSVal

324jsg5 name a0 a1 a2 a3 a4 = jsgf name (a0, a1, a2, a3, a4)

330jsg5 name a0 a1 a2 a3 a4 = jsgf name (a0, a1, a2, a3, a4)

325{-# INLINE jsg5 #-}

331{-# INLINE jsg5 #-}

@@ -330,7 +336,7 @@ jsg5 name a0 a1 a2 a3 a4 = jsgf name (a0, a1, a2, a3, a4)

330-- >>> testJSaddle $ val "Hello World" # "indexOf" $ ["World"]

336-- >>> testJSaddle $ val "Hello World" # "indexOf" $ ["World"]

331-- 6

337-- 6

332infixr 2 #

338infixr 2 #

333−(#) :: (MakeObject this, MakeString name, MakeArgs args)

339+(#) :: (MakeObject this, ToJSString name, MakeArgs args)

334 => this -> name -> args -> JSM JSVal

340 => this -> name -> args -> JSM JSVal

335(#) this name args = do

341(#) this name args = do

336 rthis <- makeObject this

342 rthis <- makeObject this

@@ -359,7 +365,7 @@ infixr 2 ##

359-- >>> testJSaddle $ do {j <- eval "({})"; j <# "x" 1; j!"x"}

365-- >>> testJSaddle $ do {j <- eval "({})"; j <# "x" 1; j!"x"}

360-- 1

366-- 1

361infixr 1 <#

367infixr 1 <#

362−(<#) :: (MakeObject this, MakeString name, MakeVal val)

368+(<#) :: (MakeObject this, ToJSString name, ToJSVal val)

363 => this -- ^ Object to set the property on

369 => this -- ^ Object to set the property on

364 -> name -- ^ Name of the property to set

370 -> name -- ^ Name of the property to set

365 -> val -- ^ Value to set it to

371 -> val -- ^ Value to set it to

@@ -375,7 +381,7 @@ infixr 1 <#

375-- >>> testJSaddle $ do {j <- eval "({})"; j <## 6 1; j!!6}

381-- >>> testJSaddle $ do {j <- eval "({})"; j <## 6 1; j!!6}

376-- 1

382-- 1

377infixr 1 <##

383infixr 1 <##

378−(<##) :: (MakeObject this, MakeVal val)

384+(<##) :: (MakeObject this, ToJSVal val)

379 => this -- ^ Object to set the property on

385 => this -- ^ Object to set the property on

380 -> Index -- ^ Index of the property to set

386 -> Index -- ^ Index of the property to set

381 -> val -- ^ Value to set it to

387 -> val -- ^ Value to set it to

@@ -406,10 +412,10 @@ new constructor args = do

406-- >>> testJSaddle $ eval "(function(){return this;}).apply('Hello', [])"

412-- >>> testJSaddle $ eval "(function(){return this;}).apply('Hello', [])"

407-- >>> testJSaddle $ do { test <- eval "(function(){return this;})"; call test (val "Hello") () }

413-- >>> testJSaddle $ do { test <- eval "(function(){return this;})"; call test (val "Hello") () }

408-- Hello

414-- Hello

409−call :: (MakeObject function, MakeObject this, MakeArgs args)

415+call :: (MakeObject f, MakeObject this, MakeArgs args)

410− => function -> this -> args -> JSM JSVal

416+ => f -> this -> args -> JSM JSVal

411−call function this args = do

417+call f this args = do

412− rfunction <- makeObject function

418+ rfunction <- makeObject f

413 rthis <- makeObject this

419 rthis <- makeObject this

414 rethrow $ objCallAsFunction rfunction rthis args

420 rethrow $ objCallAsFunction rfunction rthis args

415{-# INLINE call #-}

421{-# INLINE call #-}

@@ -425,7 +431,7 @@ obj = liftIO Object.create

425#else

431#else

426obj = do

432obj = do

427 gctxt <- ask

433 gctxt <- ask

428− liftIO $ Object <$> jsobjectmake gctxt nullPtr nullPtr

434+ Object <$> ((liftIO $ jsobjectmake gctxt nullPtr nullPtr) >>= makeNewJSVal)

429#endif

435#endif

430{-# INLINE obj #-}

436{-# INLINE obj #-}

431

437

@@ -455,56 +461,74 @@ foreign import ccall "wrapper"

455 mkJSObjectCallAsFunctionCallback :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback

461 mkJSObjectCallAsFunctionCallback :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback

456#endif

462#endif

457

463

464+#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) || !defined(USE_WEBKIT)

465+type HaskellCallback = Callback (JSVal -> JSVal -> IO ())

466+#else

467+type HaskellCallback = JSObjectCallAsFunctionCallback

468+#endif

469+

470+data Function = Function {functionCallback :: HaskellCallback, functionObject :: Object}

471+

458-- ^ Make a JavaScript function object that wraps a Haskell function.

472-- ^ Make a JavaScript function object that wraps a Haskell function.

459−function :: MakeString name

473+function :: ToJSString name

460 => name -- ^ Name of the function

474 => name -- ^ Name of the function

461 -> JSCallAsFunction -- ^ Haskell function to call

475 -> JSCallAsFunction -- ^ Haskell function to call

462− -> JSM Object -- ^ Returns a JavaScript function object that will

476+ -> JSM Function -- ^ Returns a JavaScript function object that will

463 -- call the Haskell one when it is called

477 -- call the Haskell one when it is called

464#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

478#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

465function name f = liftIO $ do

479function name f = liftIO $ do

466 callback <- syncCallback2 ContinueAsync $ \this args -> do

480 callback <- syncCallback2 ContinueAsync $ \this args -> do

467 rargs <- Array.toListIO (coerce args)

481 rargs <- Array.toListIO (coerce args)

468 runReaderT (f this this rargs) () -- TODO pass function object through

482 runReaderT (f this this rargs) () -- TODO pass function object through

469− makeFunctionWithCallback (makeString name) callback

483+ Function callback <$> makeFunctionWithCallback (toJSString name) callback

470foreign import javascript unsafe "$r = function () { $2(this, arguments); }"

484foreign import javascript unsafe "$r = function () { $2(this, arguments); }"

471 makeFunctionWithCallback :: JSString -> Callback (JSVal -> JSVal -> IO ()) -> IO Object

485 makeFunctionWithCallback :: JSString -> Callback (JSVal -> JSVal -> IO ()) -> IO Object

472#elif defined(USE_WEBKIT)

486#elif defined(USE_WEBKIT)

473function name f = do

487function name f = do

474 gctxt <- ask

488 gctxt <- ask

475− callback <- liftIO $ mkJSObjectCallAsFunctionCallback wrap

489+ callback <- liftIO $ mkJSObjectCallAsFunctionCallback (wrap gctxt)

490+ withJSString (toJSString name) $ \name' ->

491+ Function callback . Object <$>

476− liftIO $ Object <$> jsobjectmakefunctionwithcallback gctxt (makeString name) callback

492+ ((liftIO $ jsobjectmakefunctionwithcallback gctxt name' callback) >>= makeNewJSVal)

477 where

493 where

478− wrap ctx fobj this argc argv exception = do

494+ wrap gctxt _ctx fobj' this' argc argv exception = do

479− args <- peekArray (fromIntegral argc) argv

495+ args' <- peekArray (fromIntegral argc) argv

480− (`runReaderT` ctx) $

496+ (`runReaderT` gctxt) $ do

497+ fobj <- makeNewJSVal fobj'

498+ this <- makeNewJSVal this'

499+ args <- mapM makeNewJSVal args'

481− f fobj this args >>= makeVal

500+ f fobj this args

501+ liftIO $ jsvaluemakeundefined gctxt

482 `E.catch` \(e :: SomeException) -> do

502 `E.catch` \(e :: SomeException) -> do

483− str <- runReaderT (makeVal . T.pack $ show e) ctx

503+ (`runReaderT` gctxt) $ do

484− poke exception str

504+ withToJSVal (show e) $ liftIO . poke exception

485− jsvaluemakeundefined ctx

505+ liftIO $ jsvaluemakeundefined gctxt

486#else

506#else

487function = undefined

507function = undefined

488#endif

508#endif

489

509

510+freeFunction :: MonadIO m => Function -> m ()

511+freeFunction (Function callback _) = liftIO $

512+#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI) || !defined(USE_WEBKIT)

513+ releaseCallback callback

514+#else

515+ freeHaskellFunPtr callback

516+#endif

517+

518+instance ToJSVal Function where

519+ toJSVal (Function _ f) = toJSVal f

520+ {-# INLINE toJSVal #-}

521+

490-- | A callback to Haskell can be used as a JavaScript value. This will create

522-- | A callback to Haskell can be used as a JavaScript value. This will create

491-- an anonymous JavaScript function object. Use 'function' to create one with

523-- an anonymous JavaScript function object. Use 'function' to create one with

492-- a name.

524-- a name.

493−instance MakeVal JSCallAsFunction where

525+instance ToJSVal JSCallAsFunction where

494−#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

526+ toJSVal f = functionObject <$> function nullJSString f >>= toJSVal

495− makeVal f = jsval <$> function (pFromJSVal nullRef :: JSString) f

496−#else

497− makeVal f = function (nullPtr :: JSString) f >>= makeVal

498−#endif

499− {-# INLINE makeVal #-}

527+ {-# INLINE toJSVal #-}

500

528

501instance MakeArgs JSCallAsFunction where

529instance MakeArgs JSCallAsFunction where

502 makeArgs f = do

530 makeArgs f = do

503−#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

531+ rarg <- functionObject <$> function nullJSString f >>= toJSVal

504− rarg <- jsval <$> function (pFromJSVal nullRef :: JSString) f

505−#else

506− rarg <- function (nullPtr:: JSString) f >>= makeVal

507−#endif

508 return [rarg]

532 return [rarg]

509 {-# INLINE makeArgs #-}

533 {-# INLINE makeArgs #-}

510

534

@@ -517,8 +541,11 @@ makeArray args exceptions = do

517makeArray args exceptions = do

541makeArray args exceptions = do

518 gctxt <- ask

542 gctxt <- ask

519 rargs <- makeArgs args

543 rargs <- makeArgs args

544+ result <-

545+ withJSVals rargs $ \rargs' ->

520− liftIO $ withArrayLen rargs $ \ len ptr ->

546+ liftIO $ withArrayLen rargs' $ \ len ptr ->

521− Object <$> jsobjectmakearray gctxt (fromIntegral len) ptr exceptions

547+ jsobjectmakearray gctxt (fromIntegral len) ptr exceptions

548+ Object <$> makeNewJSVal result

522#endif

549#endif

523{-# INLINE makeArray #-}

550{-# INLINE makeArray #-}

524

551

@@ -533,6 +560,43 @@ makeArray args exceptions = do

533array :: MakeArgs args => args -> JSM Object

560array :: MakeArgs args => args -> JSM Object

534array = rethrow . makeArray

561array = rethrow . makeArray

535

562

563+-- Make an array out of various lists

564+instance ToJSVal [JSVal] where

565+ toJSVal = toJSVal . array

566+ {-# INLINE toJSVal #-}

567+

568+instance ToJSVal [JSM JSVal] where

569+ toJSVal = toJSVal . array

570+ {-# INLINE toJSVal #-}

571+

572+instance ToJSVal [Double] where

573+ toJSVal = toJSVal . array

574+ {-# INLINE toJSVal #-}

575+

576+instance ToJSVal [Float] where

577+ toJSVal = toJSVal . array

578+ {-# INLINE toJSVal #-}

579+

580+instance ToJSVal [Int] where

581+ toJSVal = toJSVal . array

582+ {-# INLINE toJSVal #-}

583+

584+instance ToJSVal [JSString] where

585+ toJSVal = toJSVal . array

586+ {-# INLINE toJSVal #-}

587+

588+instance ToJSVal [String] where

589+ toJSVal = toJSVal . array

590+ {-# INLINE toJSVal #-}

591+

592+instance ToJSVal [Text] where

593+ toJSVal = toJSVal . array

594+ {-# INLINE toJSVal #-}

595+

596+instance ToJSVal [Bool] where

597+ toJSVal = toJSVal . array

598+ {-# INLINE toJSVal #-}

599+

536-- | JavaScript's global object

600-- | JavaScript's global object

537global :: JSM Object

601global :: JSM Object

538#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

602#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

@@ -541,7 +605,10 @@ global = liftIO js_window

541foreign import javascript unsafe "$r = window"

605foreign import javascript unsafe "$r = window"

542 js_window :: IO Object

606 js_window :: IO Object

543#elif defined(USE_WEBKIT)

607#elif defined(USE_WEBKIT)

544−global = ask >>= (liftIO . fmap Object . jscontextgetglobalobject)

608+global = do

609+ gctxt <- ask

610+ result <- liftIO $ jscontextgetglobalobject gctxt

611+ Object <$> makeNewJSVal result

545{-# INLINE global #-}

612{-# INLINE global #-}

546#else

613#else

547global = undefined

614global = undefined

@@ -552,8 +619,9 @@ global = undefined

552copyPropertyNames :: MakeObject this => this -> JSM JSPropertyNameArray

619copyPropertyNames :: MakeObject this => this -> JSM JSPropertyNameArray

553copyPropertyNames this = do

620copyPropertyNames this = do

554 gctxt <- ask

621 gctxt <- ask

555− Object rthis <- makeObject this

622+ this' <- makeObject this

623+ withObject this' $ \rthis ->

556− liftIO $ jsobjectcopypropertynames gctxt rthis

624+ liftIO $ jsobjectcopypropertynames gctxt rthis

557{-# INLINE copyPropertyNames #-}

625{-# INLINE copyPropertyNames #-}

558

626

559-- | Get the number of names in a property name array

627-- | Get the number of names in a property name array

@@ -563,7 +631,7 @@ propertyNamesCount names = liftIO $ jspropertynamearraygetcount names

563

631

564-- | Get a name out of a property name array

632-- | Get a name out of a property name array

565propertyNamesAt :: MonadIO m => JSPropertyNameArray -> CSize -> m JSString

633propertyNamesAt :: MonadIO m => JSPropertyNameArray -> CSize -> m JSString

566−propertyNamesAt names index = liftIO $ jspropertynamearraygetnameatindex names index

634+propertyNamesAt names index = liftIO $ jspropertynamearraygetnameatindex names index >>= wrapJSString

567{-# INLINE propertyNamesAt #-}

635{-# INLINE propertyNamesAt #-}

568

636

569-- | Convert property array to a list

637-- | Convert property array to a list

@@ -600,18 +668,23 @@ objCallAsFunction :: MakeArgs args

600 -> MutableJSArray

668 -> MutableJSArray

601 -> JSM JSVal

669 -> JSM JSVal

602#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

670#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

603−objCallAsFunction function this args exceptions = do

671+objCallAsFunction f this args exceptions = do

604 rargs <- makeArgs args >>= liftIO . Array.fromListIO

672 rargs <- makeArgs args >>= liftIO . Array.fromListIO

605− liftIO $ js_apply function this rargs exceptions

673+ liftIO $ js_apply f this rargs exceptions

606{-# INLINE objCallAsFunction #-}

674{-# INLINE objCallAsFunction #-}

607foreign import javascript unsafe "try { $r = $1.apply($2, $3) } catch(e) { $4[0] = e }"

675foreign import javascript unsafe "try { $r = $1.apply($2, $3) } catch(e) { $4[0] = e }"

608 js_apply :: Object -> Object -> MutableJSArray -> MutableJSArray -> IO JSVal

676 js_apply :: Object -> Object -> MutableJSArray -> MutableJSArray -> IO JSVal

609#elif defined(USE_WEBKIT)

677#elif defined(USE_WEBKIT)

610−objCallAsFunction (Object function) (Object this) args exceptions = do

678+objCallAsFunction f this args exceptions = do

611 gctxt <- ask

679 gctxt <- ask

612 rargs <- makeArgs args

680 rargs <- makeArgs args

681+ result <-

682+ withObject f $ \rfunction ->

683+ withObject this $ \rthis ->

684+ withJSVals rargs $ \rargs' ->

613− liftIO $ withArrayLen rargs $ \ largs pargs ->

685+ liftIO $ withArrayLen rargs' $ \ largs pargs ->

614− jsobjectcallasfunction gctxt function this (fromIntegral largs) pargs exceptions

686+ jsobjectcallasfunction gctxt rfunction rthis (fromIntegral largs) pargs exceptions

687+ makeNewJSVal result

615{-# INLINE objCallAsFunction #-}

688{-# INLINE objCallAsFunction #-}

616#else

689#else

617objCallAsFunction = undefined

690objCallAsFunction = undefined

@@ -627,9 +700,9 @@ objCallAsConstructor :: MakeArgs args

627 -> MutableJSArray

700 -> MutableJSArray

628 -> JSM JSVal

701 -> JSM JSVal

629#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

702#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

630−objCallAsConstructor function args exceptions = do

703+objCallAsConstructor f args exceptions = do

631 rargs <- makeArgs args >>= liftIO . Array.fromListIO

704 rargs <- makeArgs args >>= liftIO . Array.fromListIO

632− liftIO $ js_new function rargs exceptions

705+ liftIO $ js_new f rargs exceptions

633foreign import javascript unsafe "\

706foreign import javascript unsafe "\

634 try {\

707 try {\

635 switch($2.length) {\

708 switch($2.length) {\

@@ -659,15 +732,25 @@ foreign import javascript unsafe "\

659 }"

732 }"

660 js_new :: Object -> MutableJSArray -> MutableJSArray -> IO JSVal

733 js_new :: Object -> MutableJSArray -> MutableJSArray -> IO JSVal

661#elif defined(USE_WEBKIT)

734#elif defined(USE_WEBKIT)

662−objCallAsConstructor (Object function) args exceptions = do

735+objCallAsConstructor f args exceptions = do

663 gctxt <- ask

736 gctxt <- ask

664 rargs <- makeArgs args

737 rargs <- makeArgs args

738+ result <-

739+ withObject f $ \rfunction ->

740+ withJSVals rargs $ \rargs' ->

665− liftIO $ withArrayLen rargs $ \ largs pargs ->

741+ liftIO $ withArrayLen rargs' $ \ largs pargs ->

666− jsobjectcallasconstructor gctxt function (fromIntegral largs) pargs exceptions

742+ jsobjectcallasconstructor gctxt rfunction (fromIntegral largs) pargs exceptions

743+ makeNewJSVal result

667#else

744#else

668objCallAsConstructor = undefined

745objCallAsConstructor = undefined

669#endif

746#endif

670

747

748+nullObject :: Object

749+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

750+nullObject = Object nullRef

751+#else

752+nullObject = Object . unsafePerformIO $ newForeignPtr_ nullPtr

753+#endif

671

754

672

755

673

756

src/Language/Javascript/JSaddle/Properties.hs+37−40

@@ -29,46 +29,45 @@ module Language.Javascript.JSaddle.Properties (

29 , objSetPropertyAtIndex

30) where

32−import Control.Applicative ((<$>))

33import Language.Javascript.JSaddle.Classes

32import Language.Javascript.JSaddle.Classes

34− (MakeObject(..), MakeVal(..),

33+ (ToJSVal(..), ToJSString(..))

35− MakeArgs(..), MakeString(..))

36import Language.Javascript.JSaddle.Monad (JSM)

34import Language.Javascript.JSaddle.Monad (JSM)

37import Language.Javascript.JSaddle.Types

35import Language.Javascript.JSaddle.Types

38 (MutableJSArray, Object(..), JSPropertyAttributes,

36 (MutableJSArray, Object(..), JSPropertyAttributes,

39− Index(..), JSString)

37+ Index)

40#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

38#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

39+import Language.Javascript.JSaddle.Types (JSString)

41#else

40#else

42import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

41import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

43 (jsobjectgetpropertyatindex, jsobjectgetproperty,

42 (jsobjectgetpropertyatindex, jsobjectgetproperty,

44− jsobjectsetpropertyatindex, jsobjectsetproperty,

43+ jsobjectsetpropertyatindex, jsobjectsetproperty)

45− JSPropertyAttributes)

44+import Language.Javascript.JSaddle.Native

45+ (makeNewJSVal, withObject, withJSString, withToJSVal)

46#endif

47import Control.Monad.Trans.Reader (ask)

48import Control.Monad.IO.Class (MonadIO(..))

49−import Language.Javascript.JSaddle.Exception (rethrow)

50import Language.Javascript.JSaddle.Value (JSVal)

49import Language.Javascript.JSaddle.Value (JSVal)

51import Language.Javascript.JSaddle.Arguments ()

50import Language.Javascript.JSaddle.Arguments ()

52import Language.Javascript.JSaddle.String ()

51import Language.Javascript.JSaddle.String ()

54-- | Get a property value given the object and the name of the property.

53-- | Get a property value given the object and the name of the property.

55−objGetPropertyByName :: MakeString name

54+objGetPropertyByName :: ToJSString name

56 => Object -- ^ object to find the property on.

55 => Object -- ^ object to find the property on.

57 -> name -- ^ name of the property.

56 -> name -- ^ name of the property.

58 -> MutableJSArray -- ^ exception if one is raised.

57 -> MutableJSArray -- ^ exception if one is raised.

59 -> JSM JSVal -- ^ returns the property value.

58 -> JSM JSVal -- ^ returns the property value.

60−#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

59+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

61−objGetPropertyByName this name = liftIO . js_tryGetProp (makeString name) this

60+objGetPropertyByName this name = liftIO . js_tryGetProp (toJSString name) this

62{-# INLINE objGetPropertyByName #-}

61{-# INLINE objGetPropertyByName #-}

63foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }"

62foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }"

64 js_tryGetProp :: JSString -> Object -> MutableJSArray -> IO JSVal

63 js_tryGetProp :: JSString -> Object -> MutableJSArray -> IO JSVal

65−#elif defined(USE_WEBKIT)

64+#else

66−objGetPropertyByName (Object this) name exceptions = do

65+objGetPropertyByName this name exceptions = do

67 gctxt <- ask

66 gctxt <- ask

67+ withObject this $ \rthis ->

68+ withJSString (toJSString name) $ \name' ->

68− liftIO $ jsobjectgetproperty gctxt this (makeString name) exceptions

69+ (liftIO $ jsobjectgetproperty gctxt rthis name' exceptions) >>= makeNewJSVal

69{-# INLINE objGetPropertyByName #-}

70{-# INLINE objGetPropertyByName #-}

70−#else

71−objGetPropertyByName = undefined

72#endif

71#endif

74-- | Get a property value given the object and the index of the property.

73-- | Get a property value given the object and the index of the property.

@@ -76,66 +75,64 @@ objGetPropertyAtIndex :: Object -- ^ object to find the property on.

76 -> Index -- ^ index of the property.

75 -> Index -- ^ index of the property.

77 -> MutableJSArray -- ^ exception if one is raised.

76 -> MutableJSArray -- ^ exception if one is raised.

78 -> JSM JSVal -- ^ returns the property value.

77 -> JSM JSVal -- ^ returns the property value.

79−#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

78+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

80objGetPropertyAtIndex this index = liftIO . js_tryIndex index this

79objGetPropertyAtIndex this index = liftIO . js_tryIndex index this

81{-# INLINE objGetPropertyAtIndex #-}

80{-# INLINE objGetPropertyAtIndex #-}

82foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }"

81foreign import javascript unsafe "try { $r=$2[$1] } catch(e) { $3[0] = e }"

83 js_tryIndex :: Index -> Object -> MutableJSArray -> IO JSVal

82 js_tryIndex :: Index -> Object -> MutableJSArray -> IO JSVal

84−#elif defined(USE_WEBKIT)

83+#else

85−objGetPropertyAtIndex (Object this) index exceptions = do

84+objGetPropertyAtIndex this index exceptions = do

86 gctxt <- ask

85 gctxt <- ask

86+ withObject this $ \rthis ->

87− liftIO $ jsobjectgetpropertyatindex gctxt this index exceptions

87+ (liftIO $ jsobjectgetpropertyatindex gctxt rthis index exceptions) >>= makeNewJSVal

88{-# INLINE objGetPropertyAtIndex #-}

89−#else

90−objGetPropertyAtIndex = undefined

91#endif

89#endif

93-- | Set a property value given the object and the name of the property.

91-- | Set a property value given the object and the name of the property.

94−objSetPropertyByName :: (MakeString name, MakeVal val)

92+objSetPropertyByName :: (ToJSString name, ToJSVal val)

95 => Object -- ^ object to set the property on.

93 => Object -- ^ object to set the property on.

96 -> name -- ^ name of the property.

94 -> name -- ^ name of the property.

97 -> val -- ^ new value to set the property to.

95 -> val -- ^ new value to set the property to.

98 -> JSPropertyAttributes -- ^ property attributes to give the property.

96 -> JSPropertyAttributes -- ^ property attributes to give the property.

99 -> MutableJSArray -- ^ exception if one is raised.

97 -> MutableJSArray -- ^ exception if one is raised.

100 -> JSM ()

98 -> JSM ()

101−#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

99+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

102objSetPropertyByName this name val attributes exceptions = do

100objSetPropertyByName this name val attributes exceptions = do

103− vref <- makeVal val

101+ vref <- toJSVal val

104− liftIO $ js_trySetProp (makeString name) this vref exceptions

102+ liftIO $ js_trySetProp (toJSString name) this vref exceptions

105{-# INLINE objSetPropertyByName #-}

103{-# INLINE objSetPropertyByName #-}

106foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }"

104foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }"

107 js_trySetProp :: JSString -> Object -> JSVal -> MutableJSArray -> IO ()

105 js_trySetProp :: JSString -> Object -> JSVal -> MutableJSArray -> IO ()

108−#elif defined(USE_WEBKIT)

106+#else

109−objSetPropertyByName (Object this) name val attributes exceptions = do

107+objSetPropertyByName this name val attributes exceptions = do

110 gctxt <- ask

108 gctxt <- ask

111− vref <- makeVal val

109+ withObject this $ \rthis ->

110+ withJSString (toJSString name) $ \name' ->

111+ withToJSVal val $ \rval ->

112− liftIO $ jsobjectsetproperty gctxt this (makeString name) vref attributes exceptions

112+ liftIO $ jsobjectsetproperty gctxt rthis name' rval attributes exceptions

113{-# INLINE objSetPropertyByName #-}

114−#else

115−objSetPropertyByName = undefined

116#endif

114#endif

117

115

118-- | Set a property value given the object and the index of the property.

116-- | Set a property value given the object and the index of the property.

119−objSetPropertyAtIndex :: (MakeVal val)

117+objSetPropertyAtIndex :: (ToJSVal val)

120 => Object -- ^ object to find property on.

118 => Object -- ^ object to find property on.

121 -> Index -- ^ index of the property.

119 -> Index -- ^ index of the property.

122 -> val -- ^ new value to set the property to.

120 -> val -- ^ new value to set the property to.

123 -> MutableJSArray -- ^ exception if one is raised.

121 -> MutableJSArray -- ^ exception if one is raised.

124 -> JSM ()

122 -> JSM ()

125−#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

123+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

126objSetPropertyAtIndex this index val exceptions = do

124objSetPropertyAtIndex this index val exceptions = do

127− vref <- makeVal val

125+ vref <- toJSVal val

128 liftIO $ js_trySetAtIndex index this vref exceptions

126 liftIO $ js_trySetAtIndex index this vref exceptions

129{-# INLINE objSetPropertyAtIndex #-}

127{-# INLINE objSetPropertyAtIndex #-}

130foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }"

128foreign import javascript unsafe "try { $2[$1]=$3 } catch(e) { $4[0] = e }"

131 js_trySetAtIndex :: Index -> Object -> JSVal -> MutableJSArray -> IO ()

129 js_trySetAtIndex :: Index -> Object -> JSVal -> MutableJSArray -> IO ()

132−#elif defined(USE_WEBKIT)

130+#else

133−objSetPropertyAtIndex (Object this) index val exceptions = do

131+objSetPropertyAtIndex this index val exceptions = do

134 gctxt <- ask

132 gctxt <- ask

135− vref <- makeVal val

133+ withObject this $ \rthis ->

134+ withToJSVal val $ \rval ->

136− liftIO $ jsobjectsetpropertyatindex gctxt this index vref exceptions

135+ liftIO $ jsobjectsetpropertyatindex gctxt rthis index rval exceptions

137{-# INLINE objSetPropertyAtIndex #-}

136{-# INLINE objSetPropertyAtIndex #-}

138−#else

139−objSetPropertyAtIndex = undefined

140#endif

137#endif

141

138

src/Language/Javascript/JSaddle/String.hs+19−22

@@ -15,49 +15,41 @@

16module Language.Javascript.JSaddle.String (

17 JSString

18− , MakeString(..)

18+ , ToJSString(..)

20 -- * Data.Text helpers

21 , strToText

22 , textToStr

23+ , nullJSString

23) where

24) where

25import Data.Text (Text)

26import Data.Text (Text)

26−import qualified Data.Text as T (unpack, pack)

27import Control.Monad.IO.Class (MonadIO(..))

28import Language.Javascript.JSaddle.Types (JSString)

29#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

30import Data.JSString.Text (textFromJSString, textToJSString)

31+import GHCJS.Marshal.Internal (PFromJSVal(..))

32+import GHCJS.Types (nullRef)

31#else

33#else

32import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

34import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

33 (jsstringcreatewithcharacters, jsstringgetcharactersptr,

35 (jsstringcreatewithcharacters, jsstringgetcharactersptr,

34− jsstringgetlength, jsstringcreatewithutf8cstring)

36+ jsstringgetlength)

35−#endif

37+import Language.Javascript.JSaddle.Native (makeNewJSString, withJSString)

38+import System.IO.Unsafe (unsafePerformIO)

39+import Foreign.ForeignPtr (newForeignPtr_)

40+import Foreign.Ptr (nullPtr)

36import qualified Data.Text.Foreign as T (fromPtr)

41import qualified Data.Text.Foreign as T (fromPtr)

37import Foreign (castPtr)

42import Foreign (castPtr)

38import Data.Text.Foreign (useAsPtr)

43import Data.Text.Foreign (useAsPtr)

44+#endif

39−import Language.Javascript.JSaddle.Classes (MakeString(..))

45+import Language.Javascript.JSaddle.Classes (ToJSString(..))

40−import System.IO.Unsafe (unsafePerformIO)

41−

42−-- | If we already have a JSStringRef we are fine

43−instance MakeString JSString where

44− makeString = id

45− {-# INLINE makeString #-}

46−

47−instance MakeString Text where

48− makeString = textToStr

49− {-# INLINE makeString #-}

50−

51−instance MakeString String where

52− makeString = textToStr . T.pack

53− {-# INLINE makeString #-}

55-- | Convert a JavaScript string to a Haskell 'Text'

47-- | Convert a JavaScript string to a Haskell 'Text'

56strToText :: MonadIO m => JSString -> m Text

48strToText :: MonadIO m => JSString -> m Text

57#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

49#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

58strToText = return . textFromJSString

50strToText = return . textFromJSString

59#else

51#else

60−strToText jsstring = liftIO $ do

52+strToText jsstring' = liftIO $ withJSString jsstring' $ \jsstring -> do

61 l <- jsstringgetlength jsstring

53 l <- jsstringgetlength jsstring

62 p <- jsstringgetcharactersptr jsstring

54 p <- jsstringgetcharactersptr jsstring

63 T.fromPtr (castPtr p) (fromIntegral l)

55 T.fromPtr (castPtr p) (fromIntegral l)

@@ -71,9 +63,14 @@ textToStr = textToJSString

71#else

63#else

72textToStr text = unsafePerformIO $

64textToStr text = unsafePerformIO $

73 useAsPtr text $ \p l ->

65 useAsPtr text $ \p l ->

74− jsstringcreatewithcharacters (castPtr p) (fromIntegral l)

66+ jsstringcreatewithcharacters (castPtr p) (fromIntegral l) >>= makeNewJSString

75#endif

67#endif

76{-# INLINE textToStr #-}

68{-# INLINE textToStr #-}

78−

70+nullJSString :: JSString

71+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

72+nullJSString = pFromJSVal nullRef

73+#else

74+nullJSString = unsafePerformIO $ newForeignPtr_ nullPtr

75+#endif

src/Language/Javascript/JSaddle/Types.hs+30−12

@@ -13,25 +13,30 @@

13-----------------------------------------------------------------------------

15module Language.Javascript.JSaddle.Types (

16− JSVal(..)

16+ JSVal

17− , MutableJSArray(..)

17+ , MutableJSArray

18 , Object(..)

19− , JSPropertyNameArray(..)

19+ , JSPropertyNameArray

20− , JSPropertyAttributes(..)

20+ , JSPropertyAttributes

21− , JSContextRef(..)

21+ , JSContextRef

22− , JSString(..)

22+ , JSString

23− , Index(..)

23+ , Index

24+ , Nullable(..)

25+ , JSM

24) where

26) where

28+import Control.Monad.Trans.Reader (ReaderT(..))

26#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

29#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

27import GHCJS.Types

30import GHCJS.Types

28import JavaScript.Object.Internal (Object(..))

31import JavaScript.Object.Internal (Object(..))

29import JavaScript.Array (MutableJSArray)

32import JavaScript.Array (MutableJSArray)

30import Data.Word (Word(..))

33import Data.Word (Word(..))

34+import GHCJS.Nullable (Nullable(..))

31#else

35#else

36+import Foreign.ForeignPtr (ForeignPtr)

32import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

37import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

33− (JSValueRef, JSValueRefRef, JSObjectRef, JSStringRef,

38+ (OpaqueJSString, JSValueRefRef,

34− JSContextRef, JSPropertyNameArrayRef)

39+ JSContextRef, JSPropertyNameArrayRef, OpaqueJSValue)

35import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef (JSPropertyAttributes)

40import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef (JSPropertyAttributes)

36import Foreign.C (CUInt(..))

41import Foreign.C (CUInt(..))

37#endif

42#endif

@@ -42,10 +47,23 @@ type JSPropertyAttributes = Word

42type JSContextRef = ()

47type JSContextRef = ()

43type Index = Int

48type Index = Int

44#else

49#else

45−type JSVal = JSValueRef

50+type JSVal = ForeignPtr OpaqueJSValue

46type MutableJSArray = JSValueRefRef

51type MutableJSArray = JSValueRefRef

47type JSPropertyNameArray = JSPropertyNameArrayRef

52type JSPropertyNameArray = JSPropertyNameArrayRef

48type Index = CUInt

53type Index = CUInt

49−newtype Object = Object JSObjectRef

54+newtype Object = Object (ForeignPtr OpaqueJSValue)

50−type JSString = JSStringRef

55+type JSString = ForeignPtr OpaqueJSString

56+newtype Nullable a = Nullable a

51#endif

57#endif

58+

59+-- | The @JSM@ monad keeps track of the JavaScript context.

60+--

61+-- Given a @JSM@ function and a 'JSContextRef' you can run the

62+-- function like this...

63+--

64+-- > runReaderT jsmFunction javaScriptContext

65+--

66+-- For an example of how to set up WebKitGTK+ see tests/TestJSaddle.hs

67+type JSM = ReaderT JSContextRef IO

68+

69+

src/Language/Javascript/JSaddle/Value.hs+252−121

@@ -6,6 +6,7 @@

6#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

7{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}

8#endif

9+{-# OPTIONS_GHC -fno-warn-orphans #-}

9-----------------------------------------------------------------------------

10-----------------------------------------------------------------------------

10--

11--

11-- Module : Language.Javascript.JSaddle.Value

12-- Module : Language.Javascript.JSaddle.Value

@@ -33,12 +34,12 @@

33module Language.Javascript.JSaddle.Value (

34module Language.Javascript.JSaddle.Value (

34 -- * JavaScript value references

35 -- * JavaScript value references

35 JSVal

36 JSVal

36− , MakeVal(..)

37+ , ToJSVal(..)

38 -- * Haskell types for JavaScript values

39 -- * Haskell types for JavaScript values

39 , JSNull(..)

40 , JSNull(..)

40− , JSUndefined(..)

41+ , JSUndefined

41− , JSString(..)

42+ , JSString

42 , JSValue(..)

43 , JSValue(..)

44 -- * Converting JavaScript values

45 -- * Converting JavaScript values

@@ -56,51 +57,53 @@ module Language.Javascript.JSaddle.Value (

56 , valMakeUndefined

57 , valMakeUndefined

57 , valIsUndefined

58 , valIsUndefined

58 , maybeNullOrUndefined

59 , maybeNullOrUndefined

60+ , maybeNullOrUndefined'

59 , valMakeBool

61 , valMakeBool

60 , valMakeNumber

62 , valMakeNumber

61 , valMakeString

63 , valMakeString

63− -- * Conver to and from JSValue

65+ -- * Convert to and from JSValue

64 , deRefVal

66 , deRefVal

65 , valMakeRef

67 , valMakeRef

68+ , strictEqual

69+ , instanceOf

66) where

70) where

68import Prelude hiding (catch)

72import Prelude hiding (catch)

69import Language.Javascript.JSaddle.Types

73import Language.Javascript.JSaddle.Types

70− (MutableJSArray, Object(..), JSString, JSVal(..))

74+ (Object(..), JSString, JSVal)

71#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

75#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

76+import Language.Javascript.JSaddle.Types

77+ (MutableJSArray)

72import GHCJS.Types (JSVal(..), isNull, isUndefined)

78import GHCJS.Types (JSVal(..), isNull, isUndefined)

73import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined)

79import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined)

74−import GHCJS.Marshal (toJSVal)

80+import qualified GHCJS.Marshal as GHCJS (toJSVal)

75import GHCJS.Marshal.Pure (pToJSVal)

81import GHCJS.Marshal.Pure (pToJSVal)

76import Data.JSString.Text (textToJSString)

82import Data.JSString.Text (textToJSString)

77#else

83#else

78import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

84import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

79− (jsvaluecreatejsonstring, JSType(..), jsvaluegettype,

85+ (jsvalueisinstanceofconstructor, jsvaluecreatejsonstring,

80− jsvaluemakestring, jsvaluemakenumber, jsvaluemakeboolean,

86+ JSType(..), jsvaluegettype, jsvaluemakestring, jsvaluemakenumber,

81− jsvaluemakeundefined, jsvaluemakenull, jsvaluetoobject,

87+ jsvaluemakeboolean, jsvaluemakeundefined, jsvaluemakenull,

82− jsvaluetostringcopy, jsvaluetonumber, jsvaluetoboolean,

88+ jsvaluetoobject, jsvaluetostringcopy, jsvaluetonumber,

83− jsvalueisnull, jsvalueisundefined)

89+ jsvaluetoboolean, jsvalueisnull, jsvalueisundefined,

84−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSString

90+ jsvalueisstrictequal)

85− (jsstringgetcharactersptr, jsstringgetlength)

91+import Language.Javascript.JSaddle.Native

86−import System.IO.Unsafe (unsafePerformIO)

92+ (makeNewJSVal, wrapJSString, withJSVal, withObject, withJSString,

93+ withToJSVal)

87#endif

94#endif

88−import Language.Javascript.JSaddle.Monad (JSM, catchval)

95+import Language.Javascript.JSaddle.Monad (JSM)

89import Language.Javascript.JSaddle.Exception (rethrow)

96import Language.Javascript.JSaddle.Exception (rethrow)

90import Control.Monad.Trans.Reader (ask)

97import Control.Monad.Trans.Reader (ask)

91−import Control.Monad.IO.Class (MonadIO, MonadIO(..))

98+import Control.Monad.IO.Class (MonadIO(..))

92−import qualified Data.Text.Foreign as T (fromPtr)

93−import Foreign (castPtr)

94−import Data.Text.Foreign (useAsPtr)

95−import Control.Applicative ((<$>))

96import Data.Text (Text)

99import Data.Text (Text)

97import qualified Data.Text as T (pack)

100import qualified Data.Text as T (pack)

98import Language.Javascript.JSaddle.Classes

101import Language.Javascript.JSaddle.Classes

99− (MakeObject(..), MakeString(..), MakeVal(..),

102+ (MakeObject(..), ToJSString(..), ToJSVal(..))

100− MakeArgs(..))

101import Language.Javascript.JSaddle.String (strToText, textToStr)

103import Language.Javascript.JSaddle.String (strToText, textToStr)

102−import Language.Javascript.JSaddle.Arguments ()

104+import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

103−import Data.Word (Word)

105+import Data.Word (Word32, Word64)

106+import Data.Int (Int32, Int64)

104

107

105data JSNull = JSNull -- ^ Type that represents a value that can only be null.

108data JSNull = JSNull -- ^ Type that represents a value that can only be null.

106 -- Haskell of course has no null so we are adding this type.

109 -- Haskell of course has no null so we are adding this type.

@@ -140,14 +143,14 @@ data JSValue = ValNull -- ^ null

140-- false

143-- false

141-- >>> testJSaddle $ valToBool "1"

144-- >>> testJSaddle $ valToBool "1"

142-- true

145-- true

143−valToBool :: MakeVal val => val -> JSM Bool

146+valToBool :: ToJSVal value => value -> JSM Bool

144#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

147#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

145−valToBool val = isTruthy <$> makeVal val

148+valToBool value = isTruthy <$> toJSVal value

146#else

149#else

147−valToBool val = do

150+valToBool value = do

148 gctxt <- ask

151 gctxt <- ask

149− rval <- makeVal val

152+ withToJSVal value $ \rval ->

150− liftIO $ jsvaluetoboolean gctxt rval

153+ liftIO $ jsvaluetoboolean gctxt rval

151#endif

154#endif

152{-# INLINE valToBool #-}

155{-# INLINE valToBool #-}

153

156

@@ -170,16 +173,16 @@ valToBool val = do

170-- 0.0

173-- 0.0

171-- >>> testJSaddle $ show <$> valToNumber "1"

174-- >>> testJSaddle $ show <$> valToNumber "1"

172-- 1.0

175-- 1.0

173−valToNumber :: MakeVal val => val -> JSM Double

176+valToNumber :: ToJSVal value => value -> JSM Double

174#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

177#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

175−valToNumber val = jsrefToNumber <$> makeVal val

178+valToNumber value = jsrefToNumber <$> toJSVal value

176{-# INLINE valToNumber #-}

179{-# INLINE valToNumber #-}

177foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double

180foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Double

178#elif defined(USE_WEBKIT)

181#elif defined(USE_WEBKIT)

179−valToNumber val = do

182+valToNumber value = do

180 gctxt <- ask

183 gctxt <- ask

181− rval <- makeVal val

184+ withToJSVal value $ \rval ->

182− rethrow $ liftIO . jsvaluetonumber gctxt rval

185+ rethrow $ liftIO . jsvaluetonumber gctxt rval

183{-# INLINE valToNumber #-}

186{-# INLINE valToNumber #-}

184#else

187#else

185valToNumber = undefined

188valToNumber = undefined

@@ -204,16 +207,16 @@ valToNumber = undefined

204--

207--

205-- >>> testJSaddle $ valToStr "1" >>= strToText

208-- >>> testJSaddle $ valToStr "1" >>= strToText

206-- 1

209-- 1

207−valToStr :: MakeVal val => val -> JSM JSString

210+valToStr :: ToJSVal value => value -> JSM JSString

208#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

211#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

209−valToStr val = jsrefToString <$> makeVal val

212+valToStr value = jsrefToString <$> toJSVal value

210{-# INLINE valToStr #-}

213{-# INLINE valToStr #-}

211foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString

214foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal -> JSString

212#elif defined(USE_WEBKIT)

215#elif defined(USE_WEBKIT)

213−valToStr val = do

216+valToStr value = do

214 gctxt <- ask

217 gctxt <- ask

215− rval <- makeVal val

218+ withToJSVal value $ \rval ->

216− rethrow $ liftIO . jsvaluetostringcopy gctxt rval

219+ (rethrow $ liftIO . jsvaluetostringcopy gctxt rval) >>= wrapJSString

217{-# INLINE valToStr #-}

220{-# INLINE valToStr #-}

218#else

221#else

219valToStr = undefined

222valToStr = undefined

@@ -238,7 +241,7 @@ valToStr = undefined

238-- ""

241-- ""

239-- >>> testJSaddle $ show <$> valToText "1"

242-- >>> testJSaddle $ show <$> valToText "1"

240-- "1"

243-- "1"

241−valToText :: MakeVal val => val -> JSM Text

244+valToText :: ToJSVal value => value -> JSM Text

242valToText jsvar = valToStr jsvar >>= strToText

245valToText jsvar = valToStr jsvar >>= strToText

243{-# INLINE valToText #-}

246{-# INLINE valToText #-}

244

247

@@ -263,16 +266,16 @@ valToText jsvar = valToStr jsvar >>= strToText

263-- "1"

266-- "1"

264-- >>> testJSaddle $ obj >>= valToJSON 0 >>= strToText

267-- >>> testJSaddle $ obj >>= valToJSON 0 >>= strToText

265-- {}

268-- {}

266−valToJSON :: MakeVal val => Word -> val -> JSM JSString

269+valToJSON :: ToJSVal value => Word -> value -> JSM JSString

267#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

270#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

268−valToJSON indent val = jsrefToJSON <$> makeVal val

271+valToJSON indent value = jsrefToJSON <$> toJSVal value

269{-# INLINE valToJSON #-}

272{-# INLINE valToJSON #-}

270foreign import javascript unsafe "$r = JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString

273foreign import javascript unsafe "$r = JSON.stringify($1);" jsrefToJSON :: JSVal -> JSString

271#elif defined(USE_WEBKIT)

274#elif defined(USE_WEBKIT)

272−valToJSON indent val = do

275+valToJSON indent value = do

273 gctxt <- ask

276 gctxt <- ask

274− rval <- makeVal val

277+ withToJSVal value $ \rval ->

275− rethrow $ liftIO . jsvaluecreatejsonstring gctxt rval (fromIntegral indent)

278+ (rethrow $ liftIO . jsvaluecreatejsonstring gctxt rval (fromIntegral indent)) >>= wrapJSString

276{-# INLINE valToJSON #-}

279{-# INLINE valToJSON #-}

277#else

280#else

278valToJSON = undefined

281valToJSON = undefined

@@ -297,14 +300,14 @@ valToJSON = undefined

297--

300--

298-- >>> testJSaddle $ valToObject "1"

301-- >>> testJSaddle $ valToObject "1"

299-- 1

302-- 1

300−valToObject :: MakeVal val => val -> JSM Object

303+valToObject :: ToJSVal value => value -> JSM Object

301−valToObject val = Object <$>

304+valToObject value = Object <$>

302#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

305#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

303− makeVal val

306+ toJSVal value

304#else

307#else

305 do gctxt <- ask

308 do gctxt <- ask

306− rval <- makeVal val

309+ withToJSVal value $ \rval ->

307− rethrow $ liftIO . jsvaluetoobject gctxt rval

310+ (rethrow $ liftIO . jsvaluetoobject gctxt rval) >>= makeNewJSVal

308#endif

311#endif

309{-# INLINE valToObject #-}

312{-# INLINE valToObject #-}

310

313

@@ -312,17 +315,17 @@ instance MakeObject JSVal where

312 makeObject = valToObject

315 makeObject = valToObject

313 {-# INLINE makeObject #-}

316 {-# INLINE makeObject #-}

314

317

315−-- | Convert to a JavaScript value (just an alias for 'makeVal')

318+-- | Convert to a JavaScript value (just an alias for 'toJSVal')

316−val :: MakeVal value

319+val :: ToJSVal value

317 => value -- ^ value to convert to a JavaScript value

320 => value -- ^ value to convert to a JavaScript value

318 -> JSM JSVal

321 -> JSM JSVal

319−val = makeVal

322+val = toJSVal

320{-# INLINE val #-}

323{-# INLINE val #-}

321

324

322-- | If we already have a JSVal we are fine

325-- | If we already have a JSVal we are fine

323−instance MakeVal JSVal where

326+instance ToJSVal JSVal where

324− makeVal = return

327+ toJSVal = return

325− {-# INLINE makeVal #-}

328+ {-# INLINE toJSVal #-}

326

329

327-- | A single JSVal can be used as the argument list

330-- | A single JSVal can be used as the argument list

328instance MakeArgs JSVal where

331instance MakeArgs JSVal where

@@ -331,9 +334,9 @@ instance MakeArgs JSVal where

331

334

332-- | JSVal can be made by evaluating a function in 'JSM' as long

335-- | JSVal can be made by evaluating a function in 'JSM' as long

333-- as it returns something we can make into a JSVal.

336-- as it returns something we can make into a JSVal.

334−instance MakeVal v => MakeVal (JSM v) where

337+instance ToJSVal v => ToJSVal (JSM v) where

335− makeVal v = v >>= makeVal

338+ toJSVal v = v >>= toJSVal

336− {-# INLINE makeVal #-}

339+ {-# INLINE toJSVal #-}

337

340

338----------- null ---------------

341----------- null ---------------

339-- | Make a @null@ JavaScript value

342-- | Make a @null@ JavaScript value

@@ -341,29 +344,35 @@ valMakeNull :: JSM JSVal

341#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

344#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

342valMakeNull = return jsNull

345valMakeNull = return jsNull

343#else

346#else

344−valMakeNull = ask >>= (liftIO . jsvaluemakenull)

347+valMakeNull = ask >>= (liftIO . jsvaluemakenull) >>= makeNewJSVal

345#endif

348#endif

346{-# INLINE valMakeNull #-}

349{-# INLINE valMakeNull #-}

347

350

348-- | Makes a @null@ JavaScript value

351-- | Makes a @null@ JavaScript value

349−instance MakeVal JSNull where

352+instance ToJSVal JSNull where

350− makeVal = const valMakeNull

353+ toJSVal = const valMakeNull

351− {-# INLINE makeVal #-}

354+ {-# INLINE toJSVal #-}

352

355

353-- | Makes an argument list with just a single @null@ JavaScript value

356-- | Makes an argument list with just a single @null@ JavaScript value

354instance MakeArgs JSNull where

357instance MakeArgs JSNull where

355 makeArgs _ = valMakeNull >>= (\ref -> return [ref])

358 makeArgs _ = valMakeNull >>= (\ref -> return [ref])

356 {-# INLINE makeArgs #-}

359 {-# INLINE makeArgs #-}

357

360

361+-- | Makes a JSVal or @null@ JavaScript value

362+instance ToJSVal a => ToJSVal (Maybe a) where

363+ toJSVal Nothing = valMakeNull

364+ toJSVal (Just a) = toJSVal a

365+ {-# INLINE toJSVal #-}

366+

358-- | Test a JavaScript value to see if it is @null@

367-- | Test a JavaScript value to see if it is @null@

359−valIsNull :: MakeVal val => val -> JSM Bool

368+valIsNull :: ToJSVal value => value -> JSM Bool

360#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

369#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

361−valIsNull val = isNull <$> makeVal val

370+valIsNull value = isNull <$> toJSVal value

362#else

371#else

363−valIsNull val = do

372+valIsNull value = do

364 gctxt <- ask

373 gctxt <- ask

365− rval <- makeVal val

374+ withToJSVal value $ \rval ->

366− liftIO $ jsvalueisnull gctxt rval

375+ liftIO $ jsvalueisnull gctxt rval

367#endif

376#endif

368{-# INLINE valIsNull #-}

377{-# INLINE valIsNull #-}

369

378

@@ -373,14 +382,14 @@ valMakeUndefined :: JSM JSVal

373#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

382#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

374valMakeUndefined = return jsUndefined

383valMakeUndefined = return jsUndefined

375#else

384#else

376−valMakeUndefined = ask >>= (liftIO . jsvaluemakeundefined)

385+valMakeUndefined = ask >>= (liftIO . jsvaluemakeundefined) >>= makeNewJSVal

377#endif

386#endif

378{-# INLINE valMakeUndefined #-}

387{-# INLINE valMakeUndefined #-}

379

388

380-- | Makes an @undefined@ JavaScript value

389-- | Makes an @undefined@ JavaScript value

381−instance MakeVal JSUndefined where

390+instance ToJSVal JSUndefined where

382− makeVal = const valMakeUndefined

391+ toJSVal = const valMakeUndefined

383− {-# INLINE makeVal #-}

392+ {-# INLINE toJSVal #-}

384

393

385--We can't allow this if JSUndefined is () as () is no args not "(null)".

394--We can't allow this if JSUndefined is () as () is no args not "(null)".

386--Use [()] instead.

395--Use [()] instead.

@@ -393,21 +402,21 @@ instance MakeArgs () where

393 {-# INLINE makeArgs #-}

402 {-# INLINE makeArgs #-}

394

403

395-- | Test a JavaScript value to see if it is @undefined@

404-- | Test a JavaScript value to see if it is @undefined@

396−valIsUndefined :: MakeVal val => val -> JSM Bool

405+valIsUndefined :: ToJSVal value => value -> JSM Bool

397#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

406#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

398−valIsUndefined val = isUndefined <$> makeVal val

407+valIsUndefined value = isUndefined <$> toJSVal value

399#else

408#else

400−valIsUndefined val = do

409+valIsUndefined value = do

401 gctxt <- ask

410 gctxt <- ask

402− rval <- makeVal val

411+ withToJSVal value $ \rval ->

403− liftIO $ jsvalueisundefined gctxt rval

412+ liftIO $ jsvalueisundefined gctxt rval

404#endif

413#endif

405{-# INLINE valIsUndefined #-}

414{-# INLINE valIsUndefined #-}

406

415

407-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)

416-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)

408−maybeNullOrUndefined :: MakeVal val => val -> JSM (Maybe JSVal)

417+maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)

409−maybeNullOrUndefined val = do

418+maybeNullOrUndefined value = do

410− rval <- makeVal val

419+ rval <- toJSVal value

411 valIsNull rval >>= \case

420 valIsNull rval >>= \case

412 True -> return Nothing

421 True -> return Nothing

413 _ ->

422 _ ->

@@ -416,6 +425,17 @@ maybeNullOrUndefined val = do

416 _ -> return (Just rval)

425 _ -> return (Just rval)

417{-# INLINE maybeNullOrUndefined #-}

426{-# INLINE maybeNullOrUndefined #-}

418

427

428+maybeNullOrUndefined' :: ToJSVal value => (JSVal -> JSM a) -> value -> JSM (Maybe a)

429+maybeNullOrUndefined' f value = do

430+ rval <- toJSVal value

431+ valIsNull rval >>= \case

432+ True -> return Nothing

433+ _ ->

434+ valIsUndefined rval >>= \case

435+ True -> return Nothing

436+ _ -> Just <$> f rval

437+{-# INLINE maybeNullOrUndefined' #-}

438+

419----------- booleans ---------------

439----------- booleans ---------------

420-- | Make a JavaScript boolean value

440-- | Make a JavaScript boolean value

421valMakeBool :: Bool -> JSM JSVal

441valMakeBool :: Bool -> JSM JSVal

@@ -424,14 +444,14 @@ valMakeBool b = return $ toJSBool b

424#else

444#else

425valMakeBool b = do

445valMakeBool b = do

426 gctxt <- ask

446 gctxt <- ask

427− liftIO $ jsvaluemakeboolean gctxt b

447+ (liftIO $ jsvaluemakeboolean gctxt b) >>= makeNewJSVal

428#endif

448#endif

429{-# INLINE valMakeBool #-}

449{-# INLINE valMakeBool #-}

430

450

431-- | Make a JavaScript boolean value

451-- | Make a JavaScript boolean value

432−instance MakeVal Bool where

452+instance ToJSVal Bool where

433− makeVal = valMakeBool

453+ toJSVal = valMakeBool

434− {-# INLINE makeVal #-}

454+ {-# INLINE toJSVal #-}

435

455

436-- | Makes an argument list with just a single JavaScript boolean value

456-- | Makes an argument list with just a single JavaScript boolean value

437instance MakeArgs Bool where

457instance MakeArgs Bool where

@@ -442,50 +462,108 @@ instance MakeArgs Bool where

442-- | Make a JavaScript number

462-- | Make a JavaScript number

443valMakeNumber :: Double -> JSM JSVal

463valMakeNumber :: Double -> JSM JSVal

444#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

464#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

445−valMakeNumber n = liftIO $ toJSVal n

465+valMakeNumber n = liftIO $ GHCJS.toJSVal n

446#else

466#else

447valMakeNumber n = do

467valMakeNumber n = do

448 gctxt <- ask

468 gctxt <- ask

449− liftIO $ jsvaluemakenumber gctxt n

469+ (liftIO $ jsvaluemakenumber gctxt n) >>= makeNewJSVal

450#endif

470#endif

451{-# INLINE valMakeNumber #-}

471{-# INLINE valMakeNumber #-}

452

472

453-- | Makes a JavaScript number

473-- | Makes a JavaScript number

454−instance MakeVal Double where

474+instance ToJSVal Double where

475+ toJSVal = valMakeNumber

476+ {-# INLINE toJSVal #-}

477+

478+instance ToJSVal Float where

479+ toJSVal = valMakeNumber . realToFrac

480+ {-# INLINE toJSVal #-}

481+

482+instance ToJSVal Word where

455− makeVal = valMakeNumber

483+ toJSVal = valMakeNumber . fromIntegral

456− {-# INLINE makeVal #-}

484+ {-# INLINE toJSVal #-}

485+

486+instance ToJSVal Word32 where

487+ toJSVal = valMakeNumber . fromIntegral

488+ {-# INLINE toJSVal #-}

489+

490+instance ToJSVal Word64 where

491+ toJSVal = valMakeNumber . fromIntegral

492+ {-# INLINE toJSVal #-}

493+

494+instance ToJSVal Int where

495+ toJSVal = valMakeNumber . fromIntegral

496+ {-# INLINE toJSVal #-}

497+

498+instance ToJSVal Int32 where

499+ toJSVal = valMakeNumber . fromIntegral

500+ {-# INLINE toJSVal #-}

501+

502+instance ToJSVal Int64 where

503+ toJSVal = valMakeNumber . fromIntegral

504+ {-# INLINE toJSVal #-}

457

505

458-- | Makes an argument list with just a single JavaScript number

506-- | Makes an argument list with just a single JavaScript number

459instance MakeArgs Double where

507instance MakeArgs Double where

460 makeArgs n = valMakeNumber n >>= (\ref -> return [ref])

508 makeArgs n = valMakeNumber n >>= (\ref -> return [ref])

461 {-# INLINE makeArgs #-}

509 {-# INLINE makeArgs #-}

462

510

463−----------- numbers ---------------

511+-- | Make a JavaScript string from `Text`

512+valMakeText :: Text -> JSM JSVal

513+#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

514+valMakeText = return . pToJSVal . textToJSString

515+#else

516+valMakeText text = do

517+ gctxt <- ask

518+ withJSString (textToStr text) $ \s ->

519+ (liftIO $ jsvaluemakestring gctxt s) >>= makeNewJSVal

520+#endif

521+{-# INLINE valMakeText #-}

522+

464−-- | Make a JavaScript string

523+-- | Make a JavaScript string from `JSString`

465−valMakeString :: Text -> JSM JSVal

524+valMakeString :: JSString -> JSM JSVal

466#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

525#if (defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)) || !defined(USE_WEBKIT)

467−valMakeString = return . pToJSVal . textToJSString

526+valMakeString = return . pToJSVal

468#else

527#else

469−valMakeString text = do

528+valMakeString str = do

470 gctxt <- ask

529 gctxt <- ask

530+ withJSString str $ \s ->

471− liftIO $ jsvaluemakestring gctxt (textToStr text)

531+ (liftIO $ jsvaluemakestring gctxt s) >>= makeNewJSVal

472#endif

532#endif

473{-# INLINE valMakeString #-}

533{-# INLINE valMakeString #-}

474

534

475-- | Makes a JavaScript string

535-- | Makes a JavaScript string

476−instance MakeVal Text where

536+instance ToJSVal Text where

477− makeVal = valMakeString

537+ toJSVal = valMakeText

478− {-# INLINE makeVal #-}

538+ {-# INLINE toJSVal #-}

479

539

480-- | Makes an argument list with just a single JavaScript string

540-- | Makes an argument list with just a single JavaScript string

481instance MakeArgs Text where

541instance MakeArgs Text where

482− makeArgs t = valMakeString t >>= (\ref -> return [ref])

542+ makeArgs t = valMakeText t >>= (\ref -> return [ref])

483 {-# INLINE makeArgs #-}

543 {-# INLINE makeArgs #-}

484

544

485-- | Makes a JavaScript string

545-- | Makes a JavaScript string

486−instance MakeVal String where

546+instance ToJSVal String where

547+ toJSVal = valMakeText . T.pack

548+ {-# INLINE toJSVal #-}

549+

550+-- | Makes a JavaScript string

551+instance ToJSVal JSString where

487− makeVal = valMakeString . T.pack

552+ toJSVal = valMakeString

553+ {-# INLINE toJSVal #-}

554+

555+-- | If we already have a JSString we are fine

556+instance ToJSString JSString where

557+ toJSString = id

558+ {-# INLINE toJSString #-}

559+

560+instance ToJSString Text where

561+ toJSString = textToStr

562+ {-# INLINE toJSString #-}

563+

564+instance ToJSString String where

565+ toJSString = textToStr . T.pack

488− {-# INLINE makeVal #-}

566+ {-# INLINE toJSString #-}

489

567

490-- | Derefernce a value reference.

568-- | Derefernce a value reference.

491--

569--

@@ -507,10 +585,10 @@ instance MakeVal String where

507-- ValString "1"

585-- ValString "1"

508-- >>> testJSaddle $ show <$> valToObject True >>= deRefVal

586-- >>> testJSaddle $ show <$> valToObject True >>= deRefVal

509-- ValObject 0x...

587-- ValObject 0x...

510−deRefVal :: MakeVal val => val -> JSM JSValue

588+deRefVal :: ToJSVal value => value -> JSM JSValue

511#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

589#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

512−deRefVal val = do

590+deRefVal value = do

513− valref <- makeVal val

591+ valref <- toJSVal value

514 case (jsrefGetType valref :: Int) of

592 case (jsrefGetType valref :: Int) of

515 0 -> return ValUndefined

593 0 -> return ValUndefined

516 1 -> return ValNull

594 1 -> return ValNull

@@ -525,17 +603,17 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\

525 (typeof $1===\"string\")?4:\

603 (typeof $1===\"string\")?4:\

526 (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int

604 (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int

527#elif defined(USE_WEBKIT)

605#elif defined(USE_WEBKIT)

528−deRefVal val = do

606+deRefVal value = do

529 gctxt <- ask

607 gctxt <- ask

530− valref <- makeVal val

608+ v <- toJSVal value

609+ withJSVal v $ \rval ->

531− t <- liftIO $ jsvaluegettype gctxt valref

610+ (liftIO $ jsvaluegettype gctxt rval) >>= \case

532− case t of

533− Kjstypenull -> return ValNull

611+ Kjstypenull -> return ValNull

534− Kjstypeundefined -> return ValUndefined

612+ Kjstypeundefined -> return ValUndefined

535− Kjstypeboolean -> ValBool <$> valToBool valref

613+ Kjstypeboolean -> ValBool <$> valToBool v

536− Kjstypenumber -> ValNumber <$> valToNumber valref

614+ Kjstypenumber -> ValNumber <$> valToNumber v

537− Kjstypestring -> ValString <$> valToText valref

615+ Kjstypestring -> ValString <$> valToText v

538− Kjstypeobject -> ValObject <$> valToObject valref

616+ Kjstypeobject -> ValObject <$> valToObject v

539#else

617#else

540deRefVal = undefined

618deRefVal = undefined

541#endif

619#endif

@@ -553,19 +631,19 @@ deRefVal = undefined

553-- >>> testJSaddle $ valMakeRef (ValString $ pack "Hello")

631-- >>> testJSaddle $ valMakeRef (ValString $ pack "Hello")

554-- "Hello"

632-- "Hello"

555valMakeRef :: JSValue -> JSM JSVal

633valMakeRef :: JSValue -> JSM JSVal

556−valMakeRef val =

634+valMakeRef value =

557− case val of

635+ case value of

558 ValNull -> valMakeNull

636 ValNull -> valMakeNull

559 ValUndefined -> valMakeUndefined

637 ValUndefined -> valMakeUndefined

560 ValBool b -> valMakeBool b

638 ValBool b -> valMakeBool b

561 ValNumber n -> valMakeNumber n

639 ValNumber n -> valMakeNumber n

562− ValString s -> valMakeString s

640+ ValString s -> valMakeText s

563 ValObject (Object o) -> return o

641 ValObject (Object o) -> return o

564

642

565-- | Makes a JavaScript value from a 'JSValue' ADT.

643-- | Makes a JavaScript value from a 'JSValue' ADT.

566−instance MakeVal JSValue where

644+instance ToJSVal JSValue where

567− makeVal = valMakeRef

645+ toJSVal = valMakeRef

568− {-# INLINE makeVal #-}

646+ {-# INLINE toJSVal #-}

569

647

570-- | Makes an argument list with just a single JavaScript value from a 'JSValue' ADT.

648-- | Makes an argument list with just a single JavaScript value from a 'JSValue' ADT.

571instance MakeArgs JSValue where

649instance MakeArgs JSValue where

@@ -576,3 +654,56 @@ instance MakeArgs JSValue where

576-- makeObjectRef _ = Object <$> valMakeNull

654-- makeObjectRef _ = Object <$> valMakeNull

577-- {-# INLINE makeObjectRef #-}

655-- {-# INLINE makeObjectRef #-}

578

656

657+#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

658+foreign import javascript unsafe

659+ "$1===$2" jsvalueisstrictequal :: JSVal -> JSVal -> Bool

660+#endif

661+

662+strictEqual :: (ToJSVal a, ToJSVal b) => a -> b -> JSM Bool

663+strictEqual a b = do

664+ aval <- toJSVal a

665+ bval <- toJSVal b

666+#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

667+ return $ jsvalueisstrictequal aval bval

668+#else

669+ gctxt <- ask

670+ withJSVal aval $ \aref ->

671+ withJSVal bval $ \bref ->

672+ liftIO $ jsvalueisstrictequal gctxt aref bref

673+#endif

674+

675+#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

676+foreign import javascript unsafe "\

677+ try {\

678+ $r = $1 instanceof $2\

679+ }\

680+ catch(e) {\

681+ $3[0] = e;\

682+ }"

683+ js_isInstanceOf :: JSVal -> Object -> MutableJSArray -> Bool

684+#endif

685+

686+instanceOf :: (ToJSVal value, MakeObject constructor) => value -> constructor -> JSM Bool

687+instanceOf value constructor = do

688+ v <- toJSVal value

689+ c <- makeObject constructor

690+#if defined(ghcjs_HOST_OS) && defined(USE_JAVASCRIPTFFI)

691+ rethrow $ return . js_isInstanceOf v c

692+#else

693+ gctxt <- ask

694+ withJSVal v $ \rval ->

695+ withObject c $ \c' ->

696+ rethrow $ liftIO . jsvalueisinstanceofconstructor gctxt rval c'

697+#endif

698+

699+

700+

701+

702+

703+

704+

705+

706+

707+

708+

709+

tests/TestJSaddle.hs+22−14

@@ -13,6 +13,8 @@

14module Main (

15 main

16+ , showJSaddle

17+ , listWindowProperties

16) where

18) where

18import Prelude hiding((!!), catch)

20import Prelude hiding((!!), catch)

@@ -30,38 +32,42 @@ import Graphics.UI.Gtk.WebKit.WebView

30 (webViewGetMainFrame, webViewNew)

32 (webViewGetMainFrame, webViewNew)

31import System.IO.Unsafe (unsafePerformIO)

33import System.IO.Unsafe (unsafePerformIO)

32import Control.Monad.Trans.Reader (runReaderT)

34import Control.Monad.Trans.Reader (runReaderT)

33−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase (JSContextRef)

34import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

35import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

35 (webFrameGetGlobalContext)

36 (webFrameGetGlobalContext)

36import Language.Javascript.JSaddle

37import Language.Javascript.JSaddle

37−import Data.Text (Text)

38import qualified Data.Text as T

39−import Control.Applicative

40import Control.Monad.IO.Class (MonadIO(..))

39import Control.Monad.IO.Class (MonadIO(..))

41import Control.Monad (forM, when)

40import Control.Monad (forM, when)

42import System.Log.Logger (debugM)

41import System.Log.Logger (debugM)

43import Control.Lens.Getter ((^.))

42import Control.Lens.Getter ((^.))

44import Data.Monoid ((<>))

43import Data.Monoid ((<>))

44+import Control.Concurrent.MVar (MVar)

46data TestState = TestState { jsContext :: JSContextRef, window :: Window }

48+state :: MVar (Maybe TestState)

48state = unsafePerformIO $ newMVar Nothing

49state = unsafePerformIO $ newMVar Nothing

50+{-# NOINLINE state #-}

51+

52+done :: MVar ()

49−done = unsafePerformIO $ newEmptyMVar

53+done = unsafePerformIO newEmptyMVar

54+{-# NOINLINE done #-}

51-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])

56-- >>> testJSaddle $ ((global ^. js "console" . js "log") # ["Hello"])

52−testJSaddle :: MakeVal val => JSM val -> IO ()

57+testJSaddle :: ToJSVal val => JSM val -> IO ()

53testJSaddle = testJSaddle' False

58testJSaddle = testJSaddle' False

55-- >>> showJSaddle $ eval "document.body.innerHTML = 'Test'"

60-- >>> showJSaddle $ eval "document.body.innerHTML = 'Test'"

56−showJSaddle :: MakeVal val => JSM val -> IO ()

61+showJSaddle :: ToJSVal val => JSM val -> IO ()

57showJSaddle = testJSaddle' True

62showJSaddle = testJSaddle' True

64+debugLog :: String -> IO ()

59debugLog = debugM "jsaddle"

65debugLog = debugM "jsaddle"

61−testJSaddle' :: MakeVal val => Bool -> JSM val -> IO ()

67+testJSaddle' :: ToJSVal val => Bool -> JSM val -> IO ()

62testJSaddle' showWindow f = do

68testJSaddle' showWindow f = do

63 debugLog "taking done"

69 debugLog "taking done"

64− tryTakeMVar done

70+ _ <- tryTakeMVar done

65 debugLog "taking state"

71 debugLog "taking state"

66 mbState <- takeMVar state

72 mbState <- takeMVar state

67 TestState {..} <- case mbState of

73 TestState {..} <- case mbState of

@@ -69,22 +75,22 @@ testJSaddle' showWindow f = do

69 debugLog "newState"

75 debugLog "newState"

70 newState <- newEmptyMVar

76 newState <- newEmptyMVar

71 debugLog "fork"

77 debugLog "fork"

72− forkIO $ do

78+ _ <- forkIO $ do

73 debugLog "initGUI"

79 debugLog "initGUI"

74− initGUI

80+ _ <- initGUI

75 debugLog "windowNew"

81 debugLog "windowNew"

76 window <- windowNew

82 window <- windowNew

77 debugLog "timeoutAdd"

83 debugLog "timeoutAdd"

78− timeoutAddFull (yield >> return True) priorityLow 10

84+ _ <- timeoutAddFull (yield >> return True) priorityLow 10

79 windowSetDefaultSize window 900 600

85 windowSetDefaultSize window 900 600

80 windowSetPosition window WinPosCenter

86 windowSetPosition window WinPosCenter

81 scrollWin <- scrolledWindowNew Nothing Nothing

87 scrollWin <- scrolledWindowNew Nothing Nothing

82 webView <- webViewNew

88 webView <- webViewNew

83 window `containerAdd` scrollWin

89 window `containerAdd` scrollWin

84 scrollWin `containerAdd` webView

90 scrollWin `containerAdd` webView

85− on window objectDestroy $ do

91+ _ <- on window objectDestroy $ do

86 debugLog "onDestroy"

92 debugLog "onDestroy"

87− tryTakeMVar state

93+ _ <- tryTakeMVar state

88 debugLog "put state"

94 debugLog "put state"

89 putMVar state Nothing

95 putMVar state Nothing

90 debugLog "mainQuit"

96 debugLog "mainQuit"

@@ -112,12 +118,14 @@ testJSaddle' showWindow f = do

112 putMVar state $ Just TestState {..}

118 putMVar state $ Just TestState {..}

113 return x

119 return x

114

120

121+main :: IO ()

115main = do

122main = do

116 testJSaddle $ return ()

123 testJSaddle $ return ()

117 Just TestState{..} <- takeMVar state

124 Just TestState{..} <- takeMVar state

118 postGUIAsync $ widgetDestroy window

125 postGUIAsync $ widgetDestroy window

119 takeMVar done

126 takeMVar done

120

127

128+listWindowProperties :: IO ()

121listWindowProperties = testJSaddle $ T.pack . show <$> do

129listWindowProperties = testJSaddle $ T.pack . show <$> do

122 window <- jsg "window"

130 window <- jsg "window"

123 names <- propertyNames window

131 names <- propertyNames window

@@ -129,7 +137,7 @@ listWindowProperties = testJSaddle $ T.pack . show <$> do

129 \(JSException e) -> do

137 \(JSException e) -> do

130 n <- strToText name

138 n <- strToText name

131 msg <- valToText e

139 msg <- valToText e

132− return (n, (T.pack $ " error ") <> msg)

140+ return (n, T.pack " error " <> msg)

133

141

134

142

135

143