9ea9b91 · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Include ghcjs-base compatible modules

9ea9b91Hamish Mackenzie10 years ago

.gitignore+1

compare with master

unifiedsplit

@@ -8,3 +8,4 @@ cabal-dev

8*.lkshf

9/dist-newstyle/

10/.stack-work/

11+*.project.local

jsaddle-warp/jsaddle-warp.cabal+2−2

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

1name: jsaddle-warp

2−version: 0.6.0.1

2+version: 0.7.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -27,7 +27,7 @@ library

27 aeson >=0.8.0.2 && <1.1,

28 containers >=0.5.6.2 && <0.6,

29 http-types >=0.8.6 && <0.10,

30− jsaddle >=0.6.0.0 && <0.7,

30+ jsaddle >=0.7.0.0 && <0.8,

31 stm >=2.4.4 && <2.5,

32 text >=1.2.1.3 && <1.3,

33 time >=1.5.0.1 && <1.7,

jsaddle-wkwebview/jsaddle-wkwebview.cabal+2−2

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

1name: jsaddle-wkwebview

2−version: 0.6.0.0

2+version: 0.7.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -25,7 +25,7 @@ library

25 aeson >=0.8.0.2 && <1.1,

26 base <5,

27 bytestring >=0.10.6.0 && <0.11,

28− jsaddle >= 0.6.0.0 && <0.7

28+ jsaddle >= 0.7.0.0 && <0.8

29 default-language: Haskell2010

30 hs-source-dirs: src

31 ghc-options: -ferror-spans -Wall

jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView.hs+2−2

@@ -18,7 +18,7 @@ import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)

19import Language.Javascript.JSaddle (Result, JSM)

20import Language.Javascript.JSaddle.Run (runJavaScript)

21−import Language.Javascript.JSaddle.Run.Files (initState, runBatch)

21+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

23newtype WKWebView = WKWebView (Ptr WKWebView)

@@ -54,7 +54,7 @@ jsaddleResult ptrHandler s = do

54 Just r -> processResult r

56jsaddleJs :: ByteString

57−jsaddleJs = "\

57+jsaddleJs = ghcjsHelpers <> "\

58 \runJSaddleBatch = (function() {\n\

59 \ " <> initState <> "\n\

60 \ return function(batch) {\n\

jsaddle/jsaddle.cabal+22−4

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

1name: jsaddle

2−version: 0.6.0.1

2+version: 0.7.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -26,22 +26,39 @@ library

26 ghcjs-prim -any

27 else

28 build-depends:

29− aeson >=0.8.0.2 && <1.1,

29+ attoparsec >=0.11 && <0.14,

30 containers >=0.5.6.2 && <0.6,

31+ deepseq >=1.3 && < 1.5,

31 filepath >=1.4.0.0 && <1.5,

32 filepath >=1.4.0.0 && <1.5,

33+ ghc-prim,

32 http-types >=0.8.6 && <0.10,

34 http-types >=0.8.6 && <0.10,

33 process >=1.2.3.0 && <1.5,

35 process >=1.2.3.0 && <1.5,

34 ref-tf >=0.4.0.1 && <0.5,

36 ref-tf >=0.4.0.1 && <0.5,

37+ scientific >=0.3 && <0.4,

35 stm >=2.4.4 && <2.5,

38 stm >=2.4.4 && <2.5,

36− time >=1.5.0.1 && <1.7

39+ time >=1.5.0.1 && <1.7,

40+ unordered-containers >=0.2 && <0.3,

41+ vector >=0.10 && <0.12

42+ exposed-modules:

43+ GHCJS.Marshal

44+ GHCJS.Marshal.Internal

45+ GHCJS.Marshal.Pure

46+ JavaScript.Array.Internal

47+ JavaScript.Object.Internal

48+ Language.Javascript.JSaddle.Native

49+ Language.Javascript.JSaddle.Native.Internal

50+ hs-source-dirs: src-ghc

37 exposed-modules:

51 exposed-modules:

38 Language.Javascript.JSaddle

52 Language.Javascript.JSaddle

53+ Language.Javascript.JSaddle.Array

39 Language.Javascript.JSaddle.Arguments

54 Language.Javascript.JSaddle.Arguments

40 Language.Javascript.JSaddle.Classes

55 Language.Javascript.JSaddle.Classes

56+ Language.Javascript.JSaddle.Classes.Internal

41 Language.Javascript.JSaddle.Evaluate

57 Language.Javascript.JSaddle.Evaluate

42 Language.Javascript.JSaddle.Exception

58 Language.Javascript.JSaddle.Exception

59+ Language.Javascript.JSaddle.Foreign

60+ Language.Javascript.JSaddle.Marshal.String

43 Language.Javascript.JSaddle.Monad

61 Language.Javascript.JSaddle.Monad

44− Language.Javascript.JSaddle.Native

45 Language.Javascript.JSaddle.Object

62 Language.Javascript.JSaddle.Object

46 Language.Javascript.JSaddle.Properties

63 Language.Javascript.JSaddle.Properties

47 Language.Javascript.JSaddle.Run

64 Language.Javascript.JSaddle.Run

@@ -50,6 +67,7 @@ library

50 Language.Javascript.JSaddle.Value

67 Language.Javascript.JSaddle.Value

51 Language.Javascript.JSaddle.Types

68 Language.Javascript.JSaddle.Types

52 build-depends:

69 build-depends:

70+ aeson >=0.8.0.2 && <1.1,

53 base <5,

71 base <5,

54 bytestring >=0.10.6.0 && <0.11,

72 bytestring >=0.10.6.0 && <0.11,

55 lens >=3.8.5 && <4.16,

73 lens >=3.8.5 && <4.16,

jsaddle/src-ghc/GHCJS/Marshal.hsnew file+168

@@ -0,0 +1,168 @@

1+{-# LANGUAGE ScopedTypeVariables,

2+ FlexibleContexts,

3+ FlexibleInstances,

4+ OverloadedStrings,

5+ TupleSections,

6+ LambdaCase #-}

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

9+module GHCJS.Marshal ( FromJSVal(..)

10+ , ToJSVal(..)

11+ , toJSVal_aeson

12+ , toJSVal_pure

13+ ) where

14+

15+import Control.Monad (join)

16+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

17+

18+import qualified Data.Aeson as AE

19+import Data.Int (Int8, Int16, Int32)

20+import Data.Word (Word8, Word16, Word32, Word)

21+

22+import GHC.Prim

23+

24+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), Command(ValueToJSONValue), Result(ValueToJSONValueResult))

25+import Language.Javascript.JSaddle.Native (withToJSVal)

26+import Language.Javascript.JSaddle.Run(sendCommand)

27+import GHCJS.Marshal.Internal

28+import GHCJS.Marshal.Pure ()

29+import Language.Javascript.JSaddle.Value (isUndefinedIO, valToNumber,

30+ valToBool, valMakeJSON)

31+import Language.Javascript.JSaddle.Array (fromListIO)

32+import qualified Language.Javascript.JSaddle.Array as A (read)

33+

34+instance FromJSVal JSVal where

35+ fromJSValUnchecked x = return x

36+ {-# INLINE fromJSValUnchecked #-}

37+ fromJSVal = return . Just

38+ {-# INLINE fromJSVal #-}

39+instance FromJSVal () where

40+ fromJSValUnchecked = fromJSValUnchecked_pure

41+ {-# INLINE fromJSValUnchecked #-}

42+ fromJSVal = fromJSVal_pure

43+-- {-# INLINE fromJSVal #-}

44+instance FromJSVal Bool where

45+ fromJSValUnchecked = valToBool

46+ {-# INLINE fromJSValUnchecked #-}

47+ fromJSVal = fmap Just . valToBool

48+ {-# INLINE fromJSVal #-}

49+instance FromJSVal Int where

50+ fromJSValUnchecked = fmap round . valToNumber

51+ {-# INLINE fromJSValUnchecked #-}

52+ fromJSVal = fmap (Just . round) . valToNumber

53+ {-# INLINE fromJSVal #-}

54+instance FromJSVal Int8 where

55+ fromJSValUnchecked = fmap round . valToNumber

56+ {-# INLINE fromJSValUnchecked #-}

57+ fromJSVal = fmap (Just . round) . valToNumber

58+ {-# INLINE fromJSVal #-}

59+instance FromJSVal Int16 where

60+ fromJSValUnchecked = fmap round . valToNumber

61+ {-# INLINE fromJSValUnchecked #-}

62+ fromJSVal = fmap (Just . round) . valToNumber

63+ {-# INLINE fromJSVal #-}

64+instance FromJSVal Int32 where

65+ fromJSValUnchecked = fmap round . valToNumber

66+ {-# INLINE fromJSValUnchecked #-}

67+ fromJSVal = fmap (Just . round) . valToNumber

68+ {-# INLINE fromJSVal #-}

69+instance FromJSVal Word where

70+ fromJSValUnchecked = fmap round . valToNumber

71+ {-# INLINE fromJSValUnchecked #-}

72+ fromJSVal = fmap (Just . round) . valToNumber

73+ {-# INLINE fromJSVal #-}

74+instance FromJSVal Word8 where

75+ fromJSValUnchecked = fmap round . valToNumber

76+ {-# INLINE fromJSValUnchecked #-}

77+ fromJSVal = fmap (Just . round) . valToNumber

78+ {-# INLINE fromJSVal #-}

79+instance FromJSVal Word16 where

80+ fromJSValUnchecked = fmap round . valToNumber

81+ {-# INLINE fromJSValUnchecked #-}

82+ fromJSVal = fmap (Just . round) . valToNumber

83+ {-# INLINE fromJSVal #-}

84+instance FromJSVal Word32 where

85+ fromJSValUnchecked = fmap round . valToNumber

86+ {-# INLINE fromJSValUnchecked #-}

87+ fromJSVal = fmap (Just . round) . valToNumber

88+ {-# INLINE fromJSVal #-}

89+instance FromJSVal Float where

90+ fromJSValUnchecked = fmap realToFrac . valToNumber

91+ {-# INLINE fromJSValUnchecked #-}

92+ fromJSVal = fmap (Just . realToFrac) . valToNumber

93+ {-# INLINE fromJSVal #-}

94+instance FromJSVal Double where

95+ fromJSValUnchecked = valToNumber

96+ {-# INLINE fromJSValUnchecked #-}

97+ fromJSVal = fmap Just . valToNumber

98+ {-# INLINE fromJSVal #-}

99+instance FromJSVal AE.Value where

100+ fromJSVal r =

101+ withToJSVal r $ \rval -> do

102+ ValueToJSONValueResult result <- sendCommand (ValueToJSONValue rval)

103+ return $ Just result

104+ {-# INLINE fromJSVal #-}

105+instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where

106+ fromJSVal r = runMaybeT $ (,) <$> jf r 0 <*> jf r 1

107+ {-# INLINE fromJSVal #-}

108+instance (FromJSVal a, FromJSVal b, FromJSVal c) => FromJSVal (a,b,c) where

109+ fromJSVal r = runMaybeT $ (,,) <$> jf r 0 <*> jf r 1 <*> jf r 2

110+ {-# INLINE fromJSVal #-}

111+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d) => FromJSVal (a,b,c,d) where

112+ fromJSVal r = runMaybeT $ (,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3

113+ {-# INLINE fromJSVal #-}

114+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e) => FromJSVal (a,b,c,d,e) where

115+ fromJSVal r = runMaybeT $ (,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4

116+ {-# INLINE fromJSVal #-}

117+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f) => FromJSVal (a,b,c,d,e,f) where

118+ fromJSVal r = runMaybeT $ (,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5

119+ {-# INLINE fromJSVal #-}

120+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g) => FromJSVal (a,b,c,d,e,f,g) where

121+ fromJSVal r = runMaybeT $ (,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6

122+ {-# INLINE fromJSVal #-}

123+instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g, FromJSVal h) => FromJSVal (a,b,c,d,e,f,g,h) where

124+ fromJSVal r = runMaybeT $ (,,,,,,,) <$> jf r 0 <*> jf r 1 <*> jf r 2 <*> jf r 3 <*> jf r 4 <*> jf r 5 <*> jf r 6 <*> jf r 7

125+ {-# INLINE fromJSVal #-}

126+

127+jf :: FromJSVal a => JSVal -> Int -> MaybeT JSM a

128+jf r n = MaybeT $ do

129+ r' <- A.read n (SomeJSArray r)

130+ isUndefinedIO r >>= \case

131+ True -> return Nothing

132+ False -> fromJSVal r'

133+

134+instance (ToJSVal a, ToJSVal b) => ToJSVal (a,b) where

135+ toJSVal (a,b) = join $ arr2 <$> toJSVal a <*> toJSVal b

136+ {-# INLINE toJSVal #-}

137+instance (ToJSVal a, ToJSVal b, ToJSVal c) => ToJSVal (a,b,c) where

138+ toJSVal (a,b,c) = join $ arr3 <$> toJSVal a <*> toJSVal b <*> toJSVal c

139+ {-# INLINE toJSVal #-}

140+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d) => ToJSVal (a,b,c,d) where

141+ toJSVal (a,b,c,d) = join $ arr4 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d

142+ {-# INLINE toJSVal #-}

143+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e) => ToJSVal (a,b,c,d,e) where

144+ toJSVal (a,b,c,d,e) = join $ arr5 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e

145+ {-# INLINE toJSVal #-}

146+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f) => ToJSVal (a,b,c,d,e,f) where

147+ toJSVal (a,b,c,d,e,f) = join $ arr6 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f

148+ {-# INLINE toJSVal #-}

149+instance (ToJSVal a, ToJSVal b, ToJSVal c, ToJSVal d, ToJSVal e, ToJSVal f, ToJSVal g) => ToJSVal (a,b,c,d,e,f,g) where

150+ toJSVal (a,b,c,d,e,f,g) = join $ arr7 <$> toJSVal a <*> toJSVal b <*> toJSVal c <*> toJSVal d <*> toJSVal e <*> toJSVal f <*> toJSVal g

151+ {-# INLINE toJSVal #-}

152+

153+arr2 :: JSVal -> JSVal -> JSM JSVal

154+arr2 a b = coerce <$> fromListIO [a,b]

155+arr3 :: JSVal -> JSVal -> JSVal -> JSM JSVal

156+arr3 a b c = coerce <$> fromListIO [a,b,c]

157+arr4 :: JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal

158+arr4 a b c d = coerce <$> fromListIO [a,b,c,d]

159+arr5 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal

160+arr5 a b c d e = coerce <$> fromListIO [a,b,c,d,e]

161+arr6 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal

162+arr6 a b c d e f = coerce <$> fromListIO [a,b,c,d,e,f]

163+arr7 :: JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSVal -> JSM JSVal

164+arr7 a b c d e f g = coerce <$> fromListIO [a,b,c,d,e,f,g]

165+

166+toJSVal_aeson :: AE.ToJSON a => a -> JSM JSVal

167+toJSVal_aeson = valMakeJSON . AE.toJSON

168+

jsaddle/src-ghc/GHCJS/Marshal/Internal.hsnew file+248

@@ -0,0 +1,248 @@

1+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,

2+ TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,

3+ LambdaCase

4+ #-}

6+module GHCJS.Marshal.Internal (

7+ FromJSVal(..)

8+ , ToJSVal(..)

9+ , PToJSVal(..)

10+ , PFromJSVal(..)

11+ , Purity(..)

12+ , toJSVal_generic

13+ , fromJSVal_generic

14+ , toJSVal_pure

15+ , fromJSVal_pure

16+ , fromJSValUnchecked_pure

17+ ) where

18+

19+import Control.Monad

20+

21+import Data.Data

22+import Data.Maybe

23+import Data.Coerce (coerce)

24+import qualified Data.Text as T (pack)

25+

26+import GHC.Generics

27+

28+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, JSString)

29+import Language.Javascript.JSaddle.Foreign (jsNull, jsTrue, isUndefinedIO)

30+import Language.Javascript.JSaddle.String (textToStr)

31+import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)

32+import qualified JavaScript.Array.Internal as AI (create, push, read, fromListIO, toListIO)

33+

34+data Purity = PureShared -- ^ conversion is pure even if the original value is shared

35+ | PureExclusive -- ^ conversion is pure if the we only convert once

36+ deriving (Eq, Ord, Typeable, Data)

37+

38+class PToJSVal a where

39+-- type PureOut a :: Purity

40+ pToJSVal :: a -> JSVal

41+

42+class PFromJSVal a where

43+-- type PureIn a :: Purity

44+ pFromJSVal :: JSVal -> a

45+

46+class ToJSVal a where

47+ toJSVal :: a -> JSM JSVal

48+

49+ toJSValListOf :: [a] -> JSM JSVal

50+ toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal

51+

52+ default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal

53+ toJSVal = toJSVal_generic id

54+

55+class FromJSVal a where

56+ fromJSVal :: JSVal -> JSM (Maybe a)

57+

58+ fromJSValUnchecked :: JSVal -> JSM a

59+ fromJSValUnchecked = fmap fromJust . fromJSVal

60+ {-# INLINE fromJSValUnchecked #-}

61+

62+ fromJSValListOf :: JSVal -> JSM (Maybe [a])

63+ fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array

64+

65+ fromJSValUncheckedListOf :: JSVal -> JSM [a]

66+ fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce

67+

68+ default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)

69+ fromJSVal = fromJSVal_generic id

70+

71+-- -----------------------------------------------------------------------------

72+

73+class GToJSVal a where

74+ gToJSVal :: (String -> String) -> Bool -> a -> JSM JSVal

75+

76+class GToJSProp a where

77+ gToJSProp :: (String -> String) -> JSVal -> a -> JSM ()

78+

79+class GToJSArr a where

80+ gToJSArr :: (String -> String) -> MutableJSArray -> a -> JSM ()

81+

82+instance (ToJSVal b) => GToJSVal (K1 a b c) where

83+ gToJSVal _ _ (K1 x) = toJSVal x

84+

85+instance GToJSVal p => GToJSVal (Par1 p) where

86+ gToJSVal f b (Par1 p) = gToJSVal f b p

87+

88+instance GToJSVal (f p) => GToJSVal (Rec1 f p) where

89+ gToJSVal f b (Rec1 x) = gToJSVal f b x

90+

91+instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where

92+ gToJSVal f _ (L1 x) = gToJSVal f True x

93+ gToJSVal f _ (R1 x) = gToJSVal f True x

94+

95+instance (GToJSVal (a p)) => GToJSVal (M1 D c a p) where

96+ gToJSVal f b (M1 x) = gToJSVal f b x

97+

98+instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where

99+ gToJSVal f True m@(M1 x) = do

100+ obj@(OI.Object obj') <- OI.create

101+ v <- gToJSVal f (conIsRecord m) x

102+ OI.setProp (packJSS . f $ conName m) v obj

103+ return obj'

104+ gToJSVal f _ m@(M1 x) = gToJSVal f (conIsRecord m) x

105+

106+instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => GToJSVal ((a :*: b) p) where

107+ gToJSVal f True xy = do

108+ (OI.Object obj') <- OI.create

109+ gToJSProp f obj' xy

110+ return obj'

111+ gToJSVal f False xy = do

112+ arr@(SomeJSArray arr') <- AI.create

113+ gToJSArr f arr xy

114+ return arr'

115+

116+instance GToJSVal (a p) => GToJSVal (M1 S c a p) where

117+ gToJSVal f b (M1 x) = gToJSVal f b x

118+

119+instance (GToJSProp (a p), GToJSProp (b p)) => GToJSProp ((a :*: b) p) where

120+ gToJSProp f o (x :*: y) = gToJSProp f o x >> gToJSProp f o y

121+

122+instance (Selector c, GToJSVal (a p)) => GToJSProp (M1 S c a p) where

123+ gToJSProp f o m@(M1 x) = do

124+ r <- gToJSVal f False x

125+ OI.setProp (packJSS . f $ selName m) r (OI.Object o)

126+

127+instance (GToJSArr (a p), GToJSArr (b p)) => GToJSArr ((a :*: b) p) where

128+ gToJSArr f a (x :*: y) = gToJSArr f a x >> gToJSArr f a y

129+

130+instance GToJSVal (a p) => GToJSArr (M1 S c a p) where

131+ gToJSArr f a (M1 x) = do

132+ r <- gToJSVal f False x

133+ AI.push r a

134+

135+instance GToJSVal (V1 p) where

136+ gToJSVal _ _ _ = return jsNull

137+

138+instance GToJSVal (U1 p) where

139+ gToJSVal _ _ _ = return jsTrue

140+

141+toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))

142+ => (String -> String) -> a -> JSM JSVal

143+toJSVal_generic f x = gToJSVal f False (from x :: Rep a ())

144+

145+-- -----------------------------------------------------------------------------

146+

147+class GFromJSVal a where

148+ gFromJSVal :: (String -> String) -> Bool -> JSVal -> JSM (Maybe a)

149+

150+class GFromJSProp a where

151+ gFromJSProp :: (String -> String) -> JSVal -> JSM (Maybe a)

152+

153+class GFromJSArr a where

154+ gFromJSArr :: (String -> String) -> MutableJSArray -> Int -> JSM (Maybe (a,Int))

155+

156+instance FromJSVal b => GFromJSVal (K1 a b c) where

157+ gFromJSVal _ _ r = fmap K1 <$> fromJSVal r

158+

159+instance GFromJSVal p => GFromJSVal (Par1 p) where

160+ gFromJSVal f b r = gFromJSVal f b r

161+

162+instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where

163+ gFromJSVal f b r = gFromJSVal f b r

164+

165+instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where

166+ gFromJSVal f _b r = do

167+ l <- gFromJSVal f True r

168+ case l of

169+ Just x -> return (L1 <$> Just x)

170+ Nothing -> fmap R1 <$> gFromJSVal f True r

171+

172+instance GFromJSVal (a p) => GFromJSVal (M1 D c a p) where

173+ gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r

174+

175+instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where

176+ gFromJSVal f True r = do

177+ r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)

178+ isUndefinedIO r' >>= \case

179+ True -> return Nothing

180+ False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'

181+ gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r

182+

183+instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where

184+ gFromJSVal f True r = gFromJSProp f r

185+ gFromJSVal f False r = fmap fst <$> gFromJSArr f (SomeJSArray r) 0

186+

187+instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where

188+ gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r

189+

190+instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) where

191+ gFromJSProp f r = do

192+ a <- gFromJSProp f r

193+ case a of

194+ Nothing -> return Nothing

195+ Just a' -> fmap (a':*:) <$> gFromJSProp f r

196+

197+instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where

198+ gFromJSProp f o = do

199+ p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)

200+ isUndefinedIO p >>= \case

201+ True -> return Nothing

202+ False -> fmap M1 <$> gFromJSVal f False p

203+

204+instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where

205+ gFromJSArr f r _n = do

206+ a <- gFromJSArr f r 0

207+ case a of

208+ Just (a',an) -> do

209+ b <- gFromJSArr f r an

210+ case b of

211+ Just (b',bn) -> return (Just (a' :*: b',bn))

212+ _ -> return Nothing

213+

214+instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where

215+ gFromJSArr f o n = do

216+ r <- AI.read n o

217+ isUndefinedIO r >>= \case

218+ True -> return Nothing

219+ False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r

220+

221+instance GFromJSVal (V1 p) where

222+ gFromJSVal _ _ _ = return Nothing

223+

224+instance GFromJSVal (U1 p) where

225+ gFromJSVal _ _ _ = return (Just U1)

226+

227+fromJSVal_generic :: forall a . (Generic a, GFromJSVal (Rep a ()))

228+ => (String -> String) -> JSVal -> JSM (Maybe a)

229+fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: JSM (Maybe (Rep a ())))

230+

231+-- -----------------------------------------------------------------------------

232+

233+fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)

234+fromJSVal_pure x = return (Just (pFromJSVal x))

235+{-# INLINE fromJSVal_pure #-}

236+

237+fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a

238+fromJSValUnchecked_pure x = return (pFromJSVal x)

239+{-# INLINE fromJSValUnchecked_pure #-}

240+

241+toJSVal_pure :: PToJSVal a => a -> JSM JSVal

242+toJSVal_pure x = return (pToJSVal x)

243+{-# INLINE toJSVal_pure #-}

244+

245+-- -----------------------------------------------------------------------------

246+

247+packJSS :: String -> JSString

248+packJSS = textToStr . T.pack

jsaddle/src-ghc/GHCJS/Marshal/Pure.hsnew file+20

@@ -0,0 +1,20 @@

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

2+module GHCJS.Marshal.Pure

3+ ( PFromJSVal(..)

4+ , PToJSVal(..)

5+ ) where

7+import GHCJS.Marshal.Internal

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

9+import Language.Javascript.JSaddle.Foreign (jsFalse, jsTrue)

10+

11+instance PFromJSVal JSVal where pFromJSVal = id

12+ {-# INLINE pFromJSVal #-}

13+instance PFromJSVal () where pFromJSVal _ = ()

14+ {-# INLINE pFromJSVal #-}

15+

16+instance PToJSVal JSVal where pToJSVal = id

17+ {-# INLINE pToJSVal #-}

18+instance PToJSVal Bool where pToJSVal True = jsTrue

19+ pToJSVal False = jsFalse

20+ {-# INLINE pToJSVal #-}

jsaddle/src-ghc/JavaScript/Array/Internal.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module JavaScript.Array.Internal

3+ ( create

4+ , fromListIO

5+ , toListIO

6+ , read

7+ , push

8+ ) where

10+import Prelude hiding(read)

11+import Control.Monad (void)

12+import Language.Javascript.JSaddle.Types (JSM, JSVal, SomeJSArray(..), MutableJSArray, Object(..), JSString(..))

13+import Language.Javascript.JSaddle.Native.Internal

14+ (withObject, withJSVal, withJSString, withJSVals)

15+import Language.Javascript.JSaddle.Run

16+ (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)

17+

18+create :: JSM MutableJSArray

19+create = SomeJSArray <$> sendLazyCommand (NewArray [])

20+{-# INLINE create #-}

21+

22+fromListIO :: [JSVal] -> JSM (SomeJSArray m)

23+fromListIO xs = withJSVals xs $ \xs' -> SomeJSArray <$> sendLazyCommand (NewArray xs')

24+{-# INLINE fromListIO #-}

25+

26+toListIO :: SomeJSArray m -> JSM [JSVal]

27+toListIO (SomeJSArray x) =

28+ withObject (Object x) $ \this -> do

29+ l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this

30+ withJSVal l $ \l' -> do

31+ ValueToNumberResult len <- sendCommand (ValueToNumber l')

32+ mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1]

33+{-# INLINE toListIO #-}

34+

35+read :: Int -> SomeJSArray m -> JSM JSVal

36+read n (SomeJSArray x) =

37+ withObject (Object x) $ \this -> sendLazyCommand $ GetPropertyAtIndex this n

38+{-# INLINE read #-}

39+

40+push :: JSVal -> MutableJSArray -> JSM ()

41+push e (SomeJSArray x) =

42+ void $ withJSVal e $ \e' ->

43+ withObject (Object x) $ \this -> do

44+ f <- withJSString (JSString "push") $ sendLazyCommand . GetPropertyByName this

45+ withObject (Object f) $ \f' -> sendLazyCommand $ CallAsFunction f' this [e']

46+{-# INLINE push #-}

jsaddle/src-ghc/JavaScript/Object/Internal.hsnew file+49

@@ -0,0 +1,49 @@

1+module JavaScript.Object.Internal

2+ ( Object(..)

3+ , create

4+-- , allProps

5+ , listProps

6+ , getProp

7+ , unsafeGetProp

8+ , setProp

9+ , unsafeSetProp

10+-- , isInstanceOfIO

11+ ) where

12+

13+import Language.Javascript.JSaddle.Types (JSM, JSVal, Object(..), JSString)

14+import Language.Javascript.JSaddle.Native.Internal

15+ (withObject, withJSString, withJSVal, wrapJSString)

16+import Language.Javascript.JSaddle.Run

17+ (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand, sendAsyncCommand)

18+

19+create :: JSM Object

20+create = Object <$> sendLazyCommand NewEmptyObject

21+

22+listProps :: Object -> JSM [JSString]

23+listProps this =

24+ withObject this $ \rthis -> do

25+ PropertyNamesResult result <- sendCommand $ PropertyNames rthis

26+ mapM wrapJSString result

27+{-# INLINE listProps #-}

28+

29+unsafeGetProp :: JSString -> Object -> JSM JSVal

30+unsafeGetProp name this =

31+ withObject this $ \rthis ->

32+ withJSString name $ sendLazyCommand . GetPropertyByName rthis

33+{-# INLINE unsafeGetProp #-}

34+

35+getProp :: JSString -> Object -> JSM JSVal

36+getProp = unsafeGetProp

37+{-# INLINE getProp #-}

38+

39+unsafeSetProp :: JSString -> JSVal -> Object -> JSM ()

40+unsafeSetProp name val this =

41+ withObject this $ \rthis ->

42+ withJSString name $ \rname ->

43+ withJSVal val $ \rval ->

44+ sendAsyncCommand $ SetPropertyByName rthis rname rval

45+{-# INLINE unsafeSetProp #-}

46+

47+setProp :: JSString -> JSVal -> Object -> JSM ()

48+setProp = unsafeSetProp

49+{-# INLINE setProp #-}

jsaddle/src/Language/Javascript/JSaddle.hs+3−1

@@ -64,12 +64,14 @@ module Language.Javascript.JSaddle (

64 module JSaddle

65) where

67+import GHCJS.Marshal as JSaddle

67import Language.Javascript.JSaddle.Types as JSaddle

68import Language.Javascript.JSaddle.Types as JSaddle

68import Language.Javascript.JSaddle.Classes as JSaddle

69import Language.Javascript.JSaddle.Classes as JSaddle

70+import Language.Javascript.JSaddle.Marshal.String as JSaddle ()

69import Language.Javascript.JSaddle.Monad as JSaddle

71import Language.Javascript.JSaddle.Monad as JSaddle

70import Language.Javascript.JSaddle.Exception as JSaddle

72import Language.Javascript.JSaddle.Exception as JSaddle

71import Language.Javascript.JSaddle.Value as JSaddle

73import Language.Javascript.JSaddle.Value as JSaddle

72−import Language.Javascript.JSaddle.Arguments as JSaddle

74+import Language.Javascript.JSaddle.Arguments as JSaddle ()

73import Language.Javascript.JSaddle.Properties as JSaddle

75import Language.Javascript.JSaddle.Properties as JSaddle

74import Language.Javascript.JSaddle.Object as JSaddle

76import Language.Javascript.JSaddle.Object as JSaddle

75import Language.Javascript.JSaddle.Evaluate as JSaddle

77import Language.Javascript.JSaddle.Evaluate as JSaddle

jsaddle/src/Language/Javascript/JSaddle/Arguments.hs+3−13

@@ -1,5 +1,6 @@

1{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE TypeSynonymInstances #-}

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

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

4-----------------------------------------------------------------------------

4--

5--

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

6-- Module : Language.Javascript.JSaddle.Arguments

@@ -16,18 +17,8 @@ module Language.Javascript.JSaddle.Arguments (

16 MakeArgs(..)

17 MakeArgs(..)

17) where

18) where

19−import Language.Javascript.JSaddle.Classes

20+import Language.Javascript.JSaddle.Classes (MakeArgs(..))

20− (ToJSVal(..))

21+import GHCJS.Marshal.Internal (ToJSVal(..))

21−import 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]

28−

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

30− makeArgs arg = arg >>= makeArgs

32instance ToJSVal arg => MakeArgs [arg] where

23instance ToJSVal arg => MakeArgs [arg] where

33 makeArgs = mapM toJSVal

24 makeArgs = mapM toJSVal

@@ -62,7 +53,6 @@ instance (ToJSVal arg1, ToJSVal arg2, ToJSVal arg3, ToJSVal arg4, ToJSVal arg5)

62 rarg5 <- toJSVal arg5

53 rarg5 <- toJSVal arg5

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

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

65−

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

56instance (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

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

68 rarg1 <- toJSVal arg1

58 rarg1 <- toJSVal arg1

jsaddle/src/Language/Javascript/JSaddle/Array.hsnew file+121

@@ -0,0 +1,121 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE TypeSynonymInstances #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE Rank2Types #-}

6+#ifdef ghcjs_HOST_OS

7+{-# LANGUAGE ForeignFunctionInterface #-}

8+{-# LANGUAGE JavaScriptFFI #-}

9+{-# OPTIONS_GHC -Wno-dodgy-exports -Wno-dodgy-imports #-}

10+#endif

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

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

13+--

14+-- Module : Language.Javascript.JSaddle.Object

15+-- Copyright : (c) Hamish Mackenzie

16+-- License : MIT

17+--

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

19+--

20+-- | Interface to JavaScript array

21+--

22+-----------------------------------------------------------------------------

23+

24+module Language.Javascript.JSaddle.Array

25+ ( SomeJSArray(..)

26+ , JSArray

27+ , MutableJSArray

28+ , create

29+ , length

30+ , lengthIO

31+ , nullIO

32+ , fromListIO

33+ , toListIO

34+ , read

35+ , write

36+ , append

37+ , push

38+ , pop

39+ , unshift

40+ , shift

41+ , reverse

42+ , takeIO

43+ , dropIO

44+ , sliceIO

45+ , freeze

46+ , unsafeFreeze

47+ , thaw

48+ , unsafeThaw

49+ ) where

50+

51+import Prelude hiding (read, reverse, null)

52+import Control.Monad (void)

53+import Language.Javascript.JSaddle.Types

54+ (JSM, JSVal, SomeJSArray(..), JSArray,

55+ MutableJSArray)

56+import Control.Lens.Operators ((^.))

57+import Language.Javascript.JSaddle.Object (js2, js0, (##), js1, js)

58+import Language.Javascript.JSaddle.Value (valToNumber)

59+import JavaScript.Array.Internal (create, fromListIO, toListIO, read, push)

60+

61+lengthIO :: SomeJSArray m -> JSM Int

62+lengthIO (SomeJSArray x) = round <$> (x ^. js "length" >>= valToNumber)

63+{-# INLINE lengthIO #-}

64+

65+nullIO :: SomeJSArray m -> JSM Bool

66+nullIO = fmap (== 0) . lengthIO

67+{-# INLINE nullIO #-}

68+

69+append :: SomeJSArray m -> SomeJSArray m -> JSM (SomeJSArray m1)

70+append (SomeJSArray x) (SomeJSArray y) = SomeJSArray <$> x ^. js1 "concat" y

71+{-# INLINE append #-}

72+

73+write :: Int -> JSVal -> MutableJSArray -> JSM ()

74+write n e (SomeJSArray x) = void $ (x ## n) e

75+{-# INLINE write #-}

76+

77+pop :: MutableJSArray -> JSM JSVal

78+pop (SomeJSArray x) = x ^. js0 "pop"

79+{-# INLINE pop #-}

80+

81+unshift :: JSVal -> MutableJSArray -> JSM ()

82+unshift e (SomeJSArray x) = void $ x ^. js1 "unshift" e

83+{-# INLINE unshift #-}

84+

85+shift :: MutableJSArray -> JSM JSVal

86+shift (SomeJSArray x) = x ^. js0 "shift"

87+{-# INLINE shift #-}

88+

89+reverse :: MutableJSArray -> JSM ()

90+reverse (SomeJSArray x) = void $ x ^. js0 "reverse"

91+{-# INLINE reverse #-}

92+

93+takeIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)

94+takeIO n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" (0::Int) n

95+{-# INLINE takeIO #-}

96+

97+dropIO :: Int -> SomeJSArray m -> JSM (SomeJSArray m1)

98+dropIO n (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice1" n

99+{-# INLINE dropIO #-}

100+

101+sliceIO :: Int -> Int -> JSArray -> JSM (SomeJSArray m1)

102+sliceIO s n (SomeJSArray x) = SomeJSArray <$> x ^. js2 "slice" s n

103+{-# INLINE sliceIO #-}

104+

105+freeze :: MutableJSArray -> JSM JSArray

106+freeze (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice" (0::Int)

107+{-# INLINE freeze #-}

108+

109+unsafeFreeze :: MutableJSArray -> JSM JSArray

110+unsafeFreeze (SomeJSArray x) = pure (SomeJSArray x)

111+{-# INLINE unsafeFreeze #-}

112+

113+thaw :: JSArray -> JSM MutableJSArray

114+thaw (SomeJSArray x) = SomeJSArray <$> x ^. js1 "slice" (0::Int)

115+{-# INLINE thaw #-}

116+

117+unsafeThaw :: JSArray -> JSM MutableJSArray

118+unsafeThaw (SomeJSArray x) = pure (SomeJSArray x)

119+{-# INLINE unsafeThaw #-}

120+

121+

jsaddle/src/Language/Javascript/JSaddle/Classes.hs+15−23

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE TypeSynonymInstances #-}

3{-# LANGUAGE TypeSynonymInstances #-}

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

4-----------------------------------------------------------------------------

@@ -16,30 +17,21 @@

17module Language.Javascript.JSaddle.Classes (

18module Language.Javascript.JSaddle.Classes (

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

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

20+ PToJSVal(..)

21+ , PFromJSVal(..)

19− ToJSVal(..)

22+ , ToJSVal(..)

23+ , FromJSVal(..)

20 , ToJSString(..)

24 , ToJSString(..)

25+ , FromJSString(..)

21 , MakeObject(..)

26 , MakeObject(..)

27+ , MakeArgs(..)

22) where

28) where

24−import Language.Javascript.JSaddle.Types

30+#ifdef ghcjs_HOST_OS

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

31+import GHCJS.Marshal (ToJSVal(..), FromJSVal(..))

26−

32+#else

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

33+import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))

28−class ToJSVal a where

34+#endif

29− toJSVal :: a -> JSM JSVal

35+import GHCJS.Marshal.Pure (PToJSVal(..), PFromJSVal(..))

30−

36+import Language.Javascript.JSaddle.Classes.Internal (MakeObject(..), MakeArgs(..))

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

37+import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))

32−class ToJSVal a => ToJSString a where

33− toJSString :: a -> JSString

34−

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

36−class MakeObject this where

37− makeObject :: this -> JSM Object

38−

39−instance ToJSVal Object where

40− toJSVal (Object r) = return r

41−

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

43−instance MakeObject Object where

44− makeObject = return

45−

jsaddle/src/Language/Javascript/JSaddle/Classes/Internal.hsnew file+41

@@ -0,0 +1,41 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE TypeSynonymInstances #-}

3+-----------------------------------------------------------------------------

4+--

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

6+-- Copyright : (c) Hamish Mackenzie

7+-- License : MIT

8+--

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

10+--

11+-- | These classes are used to make various JavaScript types

12+-- out of whatever we have. Functions in jsaddle take these as inputs.

13+-- This alows implicit casting and eager evaluation.

14+--

15+-----------------------------------------------------------------------------

16+

17+module Language.Javascript.JSaddle.Classes.Internal (

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

19+ MakeObject(..)

20+ , MakeArgs(..)

21+) where

22+

23+import Language.Javascript.JSaddle.Types

24+ (JSM, Object(..), JSVal)

25+

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

27+class MakeObject this where

28+ makeObject :: this -> JSM Object

29+

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

31+instance MakeObject Object where

32+ makeObject = return

33+

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

35+-- references for use as function arguments

36+class MakeArgs this where

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

38+

39+instance MakeArgs arg => MakeArgs (JSM arg) where

40+ makeArgs arg = arg >>= makeArgs

41+

jsaddle/src/Language/Javascript/JSaddle/Evaluate.hs+2−3

@@ -26,13 +26,12 @@ import Language.Javascript.JSaddle.Types (JSVal)

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

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

28#else

29−import Language.Javascript.JSaddle.Native

29+import Language.Javascript.JSaddle.Native.Internal

30 (withJSString)

31import Language.Javascript.JSaddle.Run

32 (AsyncCommand(..), sendLazyCommand)

33#endif

34−import Language.Javascript.JSaddle.Classes

34+import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))

35− (ToJSString(..))

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

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

38-- $setup

37-- $setup

jsaddle/src/Language/Javascript/JSaddle/Foreign.hsnew file+99

@@ -0,0 +1,99 @@

1+{-# LANGUAGE CPP #-}

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

3+--

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

5+-- Copyright : (c) Hamish Mackenzie

6+-- License : MIT

7+--

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

9+--

10+-- | This module is like `GHCJS.Foreign` but some functions are in

11+--

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

13+module Language.Javascript.JSaddle.Foreign (

14+ jsTrue

15+ , jsFalse

16+ , jsNull

17+ , toJSBool

18+-- , fromJSBoolIO

19+ , jsUndefined

20+ , isTruthyIO

21+ , isNullIO

22+ , isUndefinedIO

23+-- , isObjectIO

24+-- , isFunctionIO

25+-- , isStringIO

26+-- , isBooleanIO

27+-- , isSymbolIO

28+-- , isNumberIO

29+) where

30+

31+#ifdef ghcjs_HOST_OS

32+import Language.Javascript.JSaddle.Types (JSM, JSVal)

33+import GHCJS.Foreign (toJSBool, isTruthy, jsNull, jsUndefined, jsTrue, jsFalse, isNull, isUndefined)

34+#else

35+import Language.Javascript.JSaddle.Types (JSM, JSVal(..))

36+import Language.Javascript.JSaddle.Native.Internal

37+ (withJSVal)

38+import Language.Javascript.JSaddle.Run

39+ (Command(..), Result(..), sendCommand)

40+#endif

41+

42+#ifndef ghcjs_HOST_OS

43+jsTrue :: JSVal

44+jsTrue = JSVal 3

45+{-# INLINE jsTrue #-}

46+

47+jsFalse :: JSVal

48+jsFalse = JSVal 2

49+{-# INLINE jsFalse #-}

50+

51+jsNull :: JSVal

52+jsNull = JSVal 0

53+{-# INLINE jsNull #-}

54+

55+toJSBool :: Bool -> JSVal

56+toJSBool b = JSVal $ if b then 3 else 2

57+{-# INLINE toJSBool #-}

58+

59+jsUndefined :: JSVal

60+jsUndefined = JSVal 1

61+{-# INLINE jsUndefined #-}

62+#endif

63+

64+isTruthyIO :: JSVal -> JSM Bool

65+#ifdef ghcjs_HOST_OS

66+isTruthyIO = return . isTruthy

67+#else

68+isTruthyIO (JSVal 0) = return False -- null

69+isTruthyIO (JSVal 1) = return False -- undefined

70+isTruthyIO (JSVal 2) = return False -- false

71+isTruthyIO (JSVal 3) = return True -- true

72+isTruthyIO v = withJSVal v $ \rval -> do

73+ ValueToBoolResult result <- sendCommand (ValueToBool rval)

74+ return result

75+#endif

76+{-# INLINE isTruthyIO #-}

77+

78+isNullIO :: JSVal -> JSM Bool

79+#ifdef ghcjs_HOST_OS

80+isNullIO = return . isNull

81+#else

82+isNullIO (JSVal 0) = return True

83+isNullIO v = withJSVal v $ \rval -> do

84+ IsNullResult result <- sendCommand $ IsNull rval

85+ return result

86+#endif

87+{-# INLINE isNullIO #-}

88+

89+isUndefinedIO :: JSVal -> JSM Bool

90+#ifdef ghcjs_HOST_OS

91+isUndefinedIO = return . isUndefined

92+#else

93+isUndefinedIO (JSVal 1) = return True

94+isUndefinedIO v = withJSVal v $ \rval -> do

95+ IsUndefinedResult result <- sendCommand $ IsUndefined rval

96+ return result

97+#endif

98+{-# INLINE isUndefinedIO #-}

99+

jsaddle/src/Language/Javascript/JSaddle/Marshal/String.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE TypeSynonymInstances #-}

3+-----------------------------------------------------------------------------

4+--

5+-- Module : Language.Javascript.JSaddle.Marshal.String

6+-- Copyright : (c) Hamish Mackenzie

7+-- License : MIT

8+--

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

10+--

11+-- | `JSStrings` in JSaddle (when compiled with GHC) is not a `JSVal` instead it

12+-- is implemented with a `Text`.

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.Javascript.JSaddle.Marshal.String (

17+ -- * Type class to convert Haskell to JavaScript string

18+ ToJSString(..)

19+ , FromJSString(..)

20+) where

21+

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

23+import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))

24+

25+-- | Anything that can be used to make a JavaScript string

26+class ToJSVal a => ToJSString a where

27+ toJSString :: a -> JSString

28+

29+-- | Anything that can be constructed from a JavaScript string

30+class FromJSVal a => FromJSString a where

31+ fromJSString :: JSString -> a

32+

jsaddle/src/Language/Javascript/JSaddle/Native.hs+3−47

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

2-----------------------------------------------------------------------------

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

3--

2--

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

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

@@ -12,7 +11,6 @@

12-----------------------------------------------------------------------------

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

14module Language.Javascript.JSaddle.Native (

13module Language.Javascript.JSaddle.Native (

15−#if !defined(ghcjs_HOST_OS)

16 wrapJSVal

14 wrapJSVal

17 , wrapJSString

15 , wrapJSString

18 , withJSVal

16 , withJSVal

@@ -20,57 +18,15 @@ module Language.Javascript.JSaddle.Native (

20 , withObject

18 , withObject

21 , withJSString

19 , withJSString

22 , withToJSVal

20 , withToJSVal

23−#endif

24) where

21) where

26−#if !defined(ghcjs_HOST_OS)

23+import GHCJS.Marshal.Internal (ToJSVal(..))

27−import Control.Monad.Trans.Reader (ask)

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

29import Language.Javascript.JSaddle.Types

24import Language.Javascript.JSaddle.Types

30− (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..),

31− Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),

25+ (JSM(..), JSValueForSend(..))

32− JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))

33−import Language.Javascript.JSaddle.Classes (ToJSVal(..))

26+import Language.Javascript.JSaddle.Native.Internal

34−import System.Mem.Weak (addFinalizer)

35−import Control.Monad.Primitive (touch)

36−import Control.Monad (when)

37−

38−wrapJSVal :: JSValueReceived -> JSM JSVal

39−wrapJSVal (JSValueReceived ref) = do

40− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

41− let result = JSVal ref

42− when (ref >= 5) $ do

43− ctx <- JSM ask

44− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref

45− return result

46−

47−wrapJSString :: MonadIO m => JSStringReceived -> m JSString

48−wrapJSString (JSStringReceived ref) = return $ JSString ref

49−

50−withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a

51−withJSVal v@(JSVal ref) f =

52− do result <- f (JSValueForSend ref)

53− liftIO $ touch v

54− return result

55−

56−withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

57−withJSVals v f =

58− do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)

59− liftIO $ mapM_ touch v

60− return result

61−

62−withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a

63−withObject (Object o) f = withJSVal o (f . JSObjectForSend)

64−

65−withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a

66−withJSString v@(JSString ref) f =

67− do result <- f (JSStringForSend ref)

68− liftIO $ touch v

69− return result

71withToJSVal :: ToJSVal val => val -> (JSValueForSend -> JSM a) -> JSM a

28withToJSVal :: ToJSVal val => val -> (JSValueForSend -> JSM a) -> JSM a

72withToJSVal val f = do

29withToJSVal val f = do

73 v <- toJSVal val

30 v <- toJSVal val

74 withJSVal v f

31 withJSVal v f

75−#endif

jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hsnew file+64

@@ -0,0 +1,64 @@

1+-----------------------------------------------------------------------------

2+--

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

4+-- Copyright : (c) Hamish Mackenzie

5+-- License : MIT

6+--

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

8+--

9+-- |

10+--

11+-----------------------------------------------------------------------------

12+

13+module Language.Javascript.JSaddle.Native.Internal (

14+ wrapJSVal

15+ , wrapJSString

16+ , withJSVal

17+ , withJSVals

18+ , withObject

19+ , withJSString

20+) where

21+

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

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

24+import Language.Javascript.JSaddle.Types

25+ (JSContextRef(..), AsyncCommand(..), JSM(..), JSString(..),

26+ Object(..), JSVal(..), JSValueReceived(..), JSValueForSend(..),

27+ JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))

28+import System.Mem.Weak (addFinalizer)

29+import Control.Monad.Primitive (touch)

30+import Control.Monad (when)

31+

32+wrapJSVal :: JSValueReceived -> JSM JSVal

33+wrapJSVal (JSValueReceived ref) = do

34+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

35+ let result = JSVal ref

36+ when (ref >= 5) $ do

37+ ctx <- JSM ask

38+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref

39+ return result

40+

41+wrapJSString :: MonadIO m => JSStringReceived -> m JSString

42+wrapJSString (JSStringReceived ref) = return $ JSString ref

43+

44+withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a

45+withJSVal v@(JSVal ref) f =

46+ do result <- f (JSValueForSend ref)

47+ liftIO $ touch v

48+ return result

49+

50+withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

51+withJSVals v f =

52+ do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)

53+ liftIO $ mapM_ touch v

54+ return result

55+

56+withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a

57+withObject (Object o) f = withJSVal o (f . JSObjectForSend)

58+

59+withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a

60+withJSString v@(JSString ref) f =

61+ do result <- f (JSStringForSend ref)

62+ liftIO $ touch v

63+ return result

64+

jsaddle/src/Language/Javascript/JSaddle/Object.hs+25−64

@@ -22,7 +22,7 @@

22-----------------------------------------------------------------------------

24module Language.Javascript.JSaddle.Object (

25− Object

25+ Object(..)

26 , MakeObject(..)

28 -- * Property lookup

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

57 , new

58 , call

59 , obj

60+ , create

61+ , getProp

62+ , unsafeGetProp

63+ , setProp

64+ , unsafeSetProp

61 -- * Calling Haskell From JavaScript

66 -- * Calling Haskell From JavaScript

62 , Function(..)

67 , Function(..)

@@ -75,12 +80,14 @@ module Language.Javascript.JSaddle.Object (

75 -- and pass it to the continuation.

80 -- and pass it to the continuation.

77 -- * Arrays

82 -- * Arrays

83+ , fromListIO

78 , array

84 , array

80 -- * Global Object

86 -- * Global Object

81 , global

87 , global

83 -- * Enumerating Properties

89 -- * Enumerating Properties

90+ , listProps

84 , propertyNames

91 , propertyNames

85 , properties

92 , properties

@@ -90,40 +97,42 @@ module Language.Javascript.JSaddle.Object (

90 , nullObject

97 , nullObject

91) where

98) where

93−import Control.Applicative

94import Prelude hiding ((!!))

100import Prelude hiding ((!!))

101+import Data.Coerce (coerce)

95#ifdef ghcjs_HOST_OS

102#ifdef ghcjs_HOST_OS

96−import GHCJS.Types (nullRef, jsval)

103+import GHCJS.Types (nullRef)

97import GHCJS.Foreign.Callback

104import GHCJS.Foreign.Callback

98 (releaseCallback, syncCallback2, OnBlocked(..), Callback)

105 (releaseCallback, syncCallback2, OnBlocked(..), Callback)

99−import GHCJS.Marshal.Pure (pFromJSVal)

106+import GHCJS.Marshal (ToJSVal(..))

100−import JavaScript.Array (JSArray, MutableJSArray)

107+import JavaScript.Array (MutableJSArray)

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

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

102import JavaScript.Array.Internal (SomeJSArray(..))

109import JavaScript.Array.Internal (SomeJSArray(..))

103−import qualified JavaScript.Object as Object (create)

110+import JavaScript.Object (create, listProps)

104−import Data.Coerce (coerce)

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

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

106import Language.Javascript.JSaddle.Types

112import Language.Javascript.JSaddle.Types

107 (JSString, Object(..),

113 (JSString, Object(..),

108 JSVal(..), JSCallAsFunction)

114 JSVal(..), JSCallAsFunction)

109#else

115#else

116+import Data.Text (Text)

117+import GHCJS.Marshal.Internal (ToJSVal(..))

110import Language.Javascript.JSaddle.Native

118import Language.Javascript.JSaddle.Native

111− (wrapJSString, withJSVals, withObject)

119+ (withJSVals, withObject)

112import Language.Javascript.JSaddle.Run

120import Language.Javascript.JSaddle.Run

113− (Command(..), AsyncCommand(..), Result(..), sendCommand, sendLazyCommand)

121+ (AsyncCommand(..), sendLazyCommand)

114import Language.Javascript.JSaddle.Monad (askJSM, JSM)

122import Language.Javascript.JSaddle.Monad (askJSM, JSM)

115import Language.Javascript.JSaddle.Types

123import Language.Javascript.JSaddle.Types

116− (JSString, Object(..),

124+ (JSString, Object(..), SomeJSArray(..),

117 JSVal(..), JSCallAsFunction, JSContextRef(..))

125 JSVal(..), JSCallAsFunction, JSContextRef(..))

126+import JavaScript.Object.Internal (create, listProps)

118#endif

127#endif

128+import JavaScript.Array.Internal (fromListIO)

119import Language.Javascript.JSaddle.Value (valToObject)

129import Language.Javascript.JSaddle.Value (valToObject)

120−import Language.Javascript.JSaddle.Classes

130+import Language.Javascript.JSaddle.Classes (MakeObject(..))

121− (ToJSVal(..), ToJSString(..), MakeObject(..))

131+import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))

122import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

132import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

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

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

124import Language.Javascript.JSaddle.Properties

134import Language.Javascript.JSaddle.Properties

125import Control.Lens (IndexPreservingGetter, to)

135import Control.Lens (IndexPreservingGetter, to)

126−import Data.Text (Text)

127

136

128-- $setup

137-- $setup

129-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

138-- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

@@ -402,11 +411,7 @@ call f this args = do

402-- >>> testJSaddle $ do { a <- obj; (a <# "x") "Hello"; a ^. js "x" }

411-- >>> testJSaddle $ do { a <- obj; (a <# "x") "Hello"; a ^. js "x" }

403-- Hello

412-- Hello

404obj :: JSM Object

413obj :: JSM Object

405−#ifdef ghcjs_HOST_OS

406−obj = liftIO Object.create

414+obj = create

407−#else

408−obj = Object <$> sendLazyCommand NewEmptyObject

409−#endif

410

415

411-- | Short hand @::JSCallAsFunction@ so a haskell function can be passed to

416-- | Short hand @::JSCallAsFunction@ so a haskell function can be passed to

412-- a to a JavaScipt one.

417-- a to a JavaScipt one.

@@ -487,43 +492,9 @@ instance MakeArgs JSCallAsFunction where

487-- >>> testJSaddle $ array ("Hello", JSNull, (), True, 1.0::Double)

492-- >>> testJSaddle $ array ("Hello", JSNull, (), True, 1.0::Double)

488-- Hello,,,true,1

493-- Hello,,,true,1

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

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

490−#ifdef ghcjs_HOST_OS

491−array args = do

492− rargs <- makeArgs args

493− liftIO $ Object . jsval <$> Array.fromListIO rargs

494−#else

495array args = do

496 rargs <- makeArgs args

497− withJSVals rargs $ \rargs' -> Object <$> sendLazyCommand (NewArray rargs')

497+ Object . coerce <$> fromListIO rargs

498−#endif

499−

500−-- Make an array out of various lists

501−instance ToJSVal [JSVal] where

502− toJSVal = toJSVal . array

503−

504−instance ToJSVal [JSM JSVal] where

505− toJSVal = toJSVal . array

506−

507−instance ToJSVal [Double] where

508− toJSVal = toJSVal . array

509−

510−instance ToJSVal [Float] where

511− toJSVal = toJSVal . array

512−

513−instance ToJSVal [Int] where

514− toJSVal = toJSVal . array

515−

516−instance ToJSVal [JSString] where

517− toJSVal = toJSVal . array

518−

519−instance ToJSVal [String] where

520− toJSVal = toJSVal . array

521−

522−instance ToJSVal [Text] where

523− toJSVal = toJSVal . array

524−

525−instance ToJSVal [Bool] where

526− toJSVal = toJSVal . array

527

498

528-- | JavaScript's global object

499-- | JavaScript's global object

529global :: Object

500global :: Object

@@ -541,17 +512,7 @@ global = Object (JSVal 4)

541-- >>> testJSaddle $ show . map strToText <$> propertyNames (eval "({x:1, y:2})")

512-- >>> testJSaddle $ show . map strToText <$> propertyNames (eval "({x:1, y:2})")

542-- ["x","y"]

513-- ["x","y"]

543propertyNames :: MakeObject this => this -> JSM [JSString]

514propertyNames :: MakeObject this => this -> JSM [JSString]

544−#ifdef ghcjs_HOST_OS

545−propertyNames this = makeObject this >>= liftIO . js_propertyNames >>= liftIO . (fmap (map pFromJSVal)) . Array.toListIO

515+propertyNames this = makeObject this >>= listProps

546−foreign import javascript unsafe "$r = []; h$forIn($1, function(n){$r.push(n);})"

547− js_propertyNames :: Object -> IO JSArray

548−#else

549−propertyNames this = do

550− this' <- makeObject this

551− withObject this' $ \rthis -> do

552− PropertyNamesResult result <- sendCommand $ PropertyNames rthis

553− mapM wrapJSString result

554−#endif

555

516

556-- | Get a list containing references to all the properties present on a given object

517-- | Get a list containing references to all the properties present on a given object

557properties :: MakeObject this => this -> JSM [JSVal]

518properties :: MakeObject this => this -> JSM [JSVal]

jsaddle/src/Language/Javascript/JSaddle/Properties.hs+11−29

@@ -22,44 +22,37 @@

23module Language.Javascript.JSaddle.Properties (

24 -- * Getting Property Values

25+ getProp, unsafeGetProp

25− objGetPropertyByName

26+ , objGetPropertyByName

26 , objGetPropertyAtIndex

27 , objGetPropertyAtIndex

27 -- * Setting Property Values

28 -- * Setting Property Values

29+ , setProp, unsafeSetProp

28 , objSetPropertyByName

30 , objSetPropertyByName

29 , objSetPropertyAtIndex

31 , objSetPropertyAtIndex

30) where

32) where

32−import Language.Javascript.JSaddle.Classes

33− (ToJSVal(..), ToJSString(..))

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

35−import Language.Javascript.JSaddle.Types (Object(..))

35+import Language.Javascript.JSaddle.Types (JSVal, Object(..))

36+import JavaScript.Object.Internal (getProp, unsafeGetProp, setProp, unsafeSetProp)

36#ifdef ghcjs_HOST_OS

37#ifdef ghcjs_HOST_OS

37−import Language.Javascript.JSaddle.Types (JSString)

38+import GHCJS.Marshal (ToJSVal(..))

38#else

39#else

40+import GHCJS.Marshal.Internal (ToJSVal(..))

39import Language.Javascript.JSaddle.Native

41import Language.Javascript.JSaddle.Native

40− (withObject, withJSString, withToJSVal)

42+ (withObject, withToJSVal)

41import Language.Javascript.JSaddle.Run

43import Language.Javascript.JSaddle.Run

42 (AsyncCommand(..), sendLazyCommand, sendAsyncCommand)

44 (AsyncCommand(..), sendLazyCommand, sendAsyncCommand)

43#endif

45#endif

44−import Language.Javascript.JSaddle.Value (JSVal)

45import Language.Javascript.JSaddle.Arguments ()

46import Language.Javascript.JSaddle.Arguments ()

46import Language.Javascript.JSaddle.String ()

47import Language.Javascript.JSaddle.String ()

48+import Language.Javascript.JSaddle.Marshal.String (ToJSString(..))

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

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

49objGetPropertyByName :: ToJSString name

51objGetPropertyByName :: ToJSString name

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

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

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

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

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

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

53−#ifdef ghcjs_HOST_OS

54−objGetPropertyByName this name = js_tryGetProp (toJSString name) this

55+objGetPropertyByName this name = unsafeGetProp (toJSString name) this

55−foreign import javascript unsafe "$r=$2[$1]"

56− js_tryGetProp :: JSString -> Object -> IO JSVal

57−#else

58−objGetPropertyByName this name =

59− withObject this $ \rthis ->

60− withJSString (toJSString name) $

61− sendLazyCommand . GetPropertyByName rthis

62−#endif

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

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

65objGetPropertyAtIndex :: Object -- ^ object to find the property on.

58objGetPropertyAtIndex :: Object -- ^ object to find the property on.

@@ -80,20 +73,9 @@ objSetPropertyByName :: (ToJSString name, ToJSVal val)

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

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

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

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

82 -> JSM ()

75 -> JSM ()

83−#ifdef ghcjs_HOST_OS

84objSetPropertyByName this name val = do

76objSetPropertyByName this name val = do

85 vref <- toJSVal val

77 vref <- toJSVal val

86− js_trySetProp (toJSString name) this vref

78+ unsafeSetProp (toJSString name) vref this

87−foreign import javascript unsafe "$2[$1]=$3"

88− js_trySetProp :: JSString -> Object -> JSVal -> IO ()

89−#else

90−objSetPropertyByName this name val = do

91− let name' = toJSString name

92− withObject this $ \rthis ->

93− withJSString name' $ \rname ->

94− withToJSVal val $ \rval ->

95− sendAsyncCommand $ SetPropertyByName rthis rname rval

96−#endif

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

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

99objSetPropertyAtIndex :: (ToJSVal val)

81objSetPropertyAtIndex :: (ToJSVal val)

jsaddle/src/Language/Javascript/JSaddle/Run.hs+1−1

@@ -58,7 +58,7 @@ import Language.Javascript.JSaddle.Types

58 (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),

59 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

60import Language.Javascript.JSaddle.Exception (JSException(..))

61−import Language.Javascript.JSaddle.Native (wrapJSVal)

61+import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

62#endif

64-- | Forces execution of pending asyncronous code

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+75

@@ -16,6 +16,7 @@ module Language.Javascript.JSaddle.Run.Files (

16 , jsaddleJs

17 , initState

18 , runBatch

19+ , ghcjsHelpers

19) where

20) where

21import Data.ByteString.Lazy (ByteString)

22import Data.ByteString.Lazy (ByteString)

@@ -166,6 +167,9 @@ runBatch send = "\

166 \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\

167 \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\

167 \ " <> send "{\"tag\": \"ValueToJSONResult\", \"contents\": s}" <> "\n\

168 \ " <> send "{\"tag\": \"ValueToJSONResult\", \"contents\": s}" <> "\n\

168 \ break;\n\

169 \ break;\n\

170+ \ case \"ValueToJSONValue\":\n\

171+ \ " <> send "{\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)}" <> "\n\

172+ \ break;\n\

169 \ case \"DeRefVal\":\n\

173 \ case \"DeRefVal\":\n\

170 \ var n = d.contents;\n\

174 \ var n = d.contents;\n\

171 \ var v = jsaddle_values.get(n);\n\

175 \ var v = jsaddle_values.get(n);\n\

@@ -247,5 +251,76 @@ jsaddleJs = "\

247 \ };\n\

251 \ };\n\

248 \}\n\

252 \}\n\

249 \\n\

253 \\n\

254+ \ " <> ghcjsHelpers <> "\

250 \connect();\n\

255 \connect();\n\

251 \"

256 \"

257+

258+ghcjsHelpers :: ByteString

259+ghcjsHelpers = "\

260+ \function h$isNumber(o) {\

261+ \ return typeof(o) === 'number';\n\

262+ \}\n\

263+ \\n\

264+ \// returns true for null, but not for functions and host objects\n\

265+ \function h$isObject(o) {\n\

266+ \ return typeof(o) === 'object';\n\

267+ \}\n\

268+ \\n\

269+ \function h$isString(o) {\n\

270+ \ return typeof(o) === 'string';\n\

271+ \}\n\

272+ \\n\

273+ \function h$isSymbol(o) {\n\

274+ \ return typeof(o) === 'symbol';\n\

275+ \}\n\

276+ \\n\

277+ \function h$isBoolean(o) {\n\

278+ \ return typeof(o) === 'boolean';\n\

279+ \}\n\

280+ \\n\

281+ \function h$isFunction(o) {\n\

282+ \ return typeof(o) === 'function';\n\

283+ \}\n\

284+ \\n\

285+ \function h$jsTypeOf(o) {\n\

286+ \ var t = typeof(o);\n\

287+ \ if(t === 'undefined') return 0;\n\

288+ \ if(t === 'object') return 1;\n\

289+ \ if(t === 'boolean') return 2;\n\

290+ \ if(t === 'number') return 3;\n\

291+ \ if(t === 'string') return 4;\n\

292+ \ if(t === 'symbol') return 5;\n\

293+ \ if(t === 'function') return 6;\n\

294+ \ return 7; // other, host object etc\n\

295+ \}\n\

296+ \\n\

297+ \function h$jsonTypeOf(o) {\n\

298+ \ if (!(o instanceof Object)) {\n\

299+ \ if (o == null) {\n\

300+ \ return 0;\n\

301+ \ } else if (typeof o == 'number') {\n\

302+ \ if (h$isInteger(o)) {\n\

303+ \ return 1;\n\

304+ \ } else {\n\

305+ \ return 2;\n\

306+ \ }\n\

307+ \ } else if (typeof o == 'boolean') {\n\

308+ \ return 3;\n\

309+ \ } else {\n\

310+ \ return 4;\n\

311+ \ }\n\

312+ \ } else {\n\

313+ \ if (Object.prototype.toString.call(o) == '[object Array]') {\n\

314+ \ // it's an array\n\

315+ \ return 5;\n\

316+ \ } else if (!o) {\n\

317+ \ // null \n\

318+ \ return 0;\n\

319+ \ } else {\n\

320+ \ // it's an object\n\

321+ \ return 6;\n\

322+ \ }\n\

323+ \ }\n\

324+ \\n\

325+ \}\n\

326+ \"

jsaddle/src/Language/Javascript/JSaddle/String.hs+10−11

@@ -18,9 +18,10 @@

19module Language.Javascript.JSaddle.String (

20 JSString

21− , ToJSString(..)

23 -- * Data.Text helpers

22 -- * Data.Text helpers

23+ , textFromJSString

24+ , textToJSString

24 , strToText

25 , strToText

25 , textToStr

26 , textToStr

26) where

27) where

@@ -30,21 +31,19 @@ import Language.Javascript.JSaddle.Types (JSString(..))

30#ifdef ghcjs_HOST_OS

31#ifdef ghcjs_HOST_OS

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

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

32#endif

33#endif

33−import Language.Javascript.JSaddle.Classes (ToJSString(..))

34+

35+#ifndef ghcjs_HOST_OS

36+textFromJSString :: JSString -> Text

37+textFromJSString (JSString text) = text

38+

39+textToJSString :: Text -> JSString

40+textToJSString = JSString

41+#endif

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

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

36strToText :: JSString -> Text

44strToText :: JSString -> Text

37−#ifdef ghcjs_HOST_OS

38strToText = textFromJSString

45strToText = textFromJSString

39−#else

40−strToText (JSString text) = text

41−#endif

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

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

44textToStr :: Text -> JSString

48textToStr :: Text -> JSString

45−#ifdef ghcjs_HOST_OS

46textToStr = textToJSString

49textToStr = textToJSString

47−#else

48−textToStr = JSString

49−#endif

50−

jsaddle/src/Language/Javascript/JSaddle/Types.hs+51−4

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

7{-# LANGUAGE UndecidableInstances #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE DeriveGeneric #-}

10+{-# LANGUAGE DefaultSignatures #-}

11+{-# LANGUAGE DataKinds #-}

12+{-# LANGUAGE KindSignatures #-}

13+{-# LANGUAGE PolyKinds #-}

14+{-# LANGUAGE FlexibleContexts #-}

10#endif

15#endif

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

16-----------------------------------------------------------------------------

12--

17--

@@ -31,7 +36,9 @@ module Language.Javascript.JSaddle.Types (

32 -- * JavaScript Value Types

37 -- * JavaScript Value Types

33 , JSVal(..)

38 , JSVal(..)

34− , MutableJSArray(..)

39+ , SomeJSArray(..)

40+ , JSArray

41+ , MutableJSArray

35 , Object(..)

42 , Object(..)

36 , JSString(..)

43 , JSString(..)

37 , Nullable(..)

44 , Nullable(..)

@@ -55,9 +62,10 @@ import Control.Monad.IO.Class (MonadIO(..))

55#ifdef ghcjs_HOST_OS

62#ifdef ghcjs_HOST_OS

56import GHCJS.Types

63import GHCJS.Types

57import JavaScript.Object.Internal (Object(..))

64import JavaScript.Object.Internal (Object(..))

58−import JavaScript.Array (MutableJSArray)

65+import JavaScript.Array.Internal (SomeJSArray(..), JSArray, MutableJSArray)

59import GHCJS.Nullable (Nullable(..))

66import GHCJS.Nullable (Nullable(..))

60#else

67#else

68+import Control.DeepSeq (NFData(..))

61import Control.Monad.Trans.Reader (ReaderT(..))

69import Control.Monad.Trans.Reader (ReaderT(..))

62import Control.Monad.Trans.State.Lazy (StateT(..))

70import Control.Monad.Trans.State.Lazy (StateT(..))

63import qualified Control.Monad.Trans.State.Strict as Strict

71import qualified Control.Monad.Trans.State.Strict as Strict

@@ -66,11 +74,13 @@ import Control.Monad.Trans.Class (MonadTrans(..))

66import Control.Monad.Fix (MonadFix)

74import Control.Monad.Fix (MonadFix)

67import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

75import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

68import Control.Concurrent.STM.TVar (TVar)

76import Control.Concurrent.STM.TVar (TVar)

77+import Data.Coerce (Coercible, coerce)

69import Data.Int (Int64)

78import Data.Int (Int64)

70import Data.Text (Text)

79import Data.Text (Text)

71import Data.Time.Clock (UTCTime(..))

80import Data.Time.Clock (UTCTime(..))

81+import Data.Typeable (Typeable)

72import Data.Aeson

82import Data.Aeson

73− (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..))

83+ (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value)

74import GHC.Generics (Generic)

84import GHC.Generics (Generic)

75#endif

85#endif

@@ -168,8 +178,42 @@ type JSValueRef = Int64

168-- | See 'GHCJS.Prim.JSVal'

178-- | See 'GHCJS.Prim.JSVal'

169newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)

179newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)

170

180

181+instance NFData JSVal where

182+ rnf x = x `seq` ()

183+

184+class IsJSVal a where

185+ jsval_ :: a -> JSVal

186+

187+ default jsval_ :: Coercible a JSVal => a -> JSVal

188+ jsval_ = coerce

189+ {-# INLINE jsval_ #-}

190+

191+jsval :: IsJSVal a => a -> JSVal

192+jsval = jsval_

193+{-# INLINE jsval #-}

194+

195+data MutabilityType s = Mutable_ s

196+ | Immutable_ s

197+ | STMutable s

198+

199+type Mutable = Mutable_ ()

200+type Immutable = Immutable_ ()

201+

202+data IsItMutable = IsImmutable

203+ | IsMutable

204+

205+type family Mutability (a :: MutabilityType s) :: IsItMutable where

206+ Mutability Immutable = IsImmutable

207+ Mutability Mutable = IsMutable

208+ Mutability (STMutable s) = IsMutable

209+

210+newtype SomeJSArray (m :: MutabilityType s) = SomeJSArray JSVal

211+ deriving (Typeable)

212+

213+-- | See 'JavaScript.Array.Internal.JSArray'

214+type JSArray = SomeJSArray Immutable

171-- | See 'JavaScript.Array.Internal.MutableJSArray'

215-- | See 'JavaScript.Array.Internal.MutableJSArray'

172−newtype MutableJSArray = MutableJSArray JSValueRef deriving(Show, ToJSON, FromJSON)

216+type MutableJSArray = SomeJSArray Mutable

173

217

174-- | See 'JavaScript.Object.Internal.Object'

218-- | See 'JavaScript.Object.Internal.Object'

175newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)

219newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)

@@ -201,6 +245,7 @@ data AsyncCommand = FreeRef JSValueForSend

201 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

245 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

202 | StringToValue JSStringForSend JSValueForSend

246 | StringToValue JSStringForSend JSValueForSend

203 | NumberToValue Double JSValueForSend

247 | NumberToValue Double JSValueForSend

248+ | JSONValueToValue Value JSValueForSend

204 | GetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

249 | GetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

205 | GetPropertyAtIndex JSObjectForSend Int JSValueForSend

250 | GetPropertyAtIndex JSObjectForSend Int JSValueForSend

206 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend

251 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend

@@ -223,6 +268,7 @@ data Command = DeRefVal JSValueForSend

223 | ValueToNumber JSValueForSend

268 | ValueToNumber JSValueForSend

224 | ValueToString JSValueForSend

269 | ValueToString JSValueForSend

225 | ValueToJSON JSValueForSend

270 | ValueToJSON JSValueForSend

271+ | ValueToJSONValue JSValueForSend

226 | IsNull JSValueForSend

272 | IsNull JSValueForSend

227 | IsUndefined JSValueForSend

273 | IsUndefined JSValueForSend

228 | StrictEqual JSValueForSend JSValueForSend

274 | StrictEqual JSValueForSend JSValueForSend

@@ -251,6 +297,7 @@ data Result = DeRefValResult JSValueRef Text

251 | ValueToNumberResult Double

297 | ValueToNumberResult Double

252 | ValueToStringResult JSStringReceived

298 | ValueToStringResult JSStringReceived

253 | ValueToJSONResult JSStringReceived

299 | ValueToJSONResult JSStringReceived

300+ | ValueToJSONValueResult Value

254 | IsNullResult Bool

301 | IsNullResult Bool

255 | IsUndefinedResult Bool

302 | IsUndefinedResult Bool

256 | StrictEqualResult Bool

303 | StrictEqualResult Bool

jsaddle/src/Language/Javascript/JSaddle/Value.hs+160−76

@@ -45,6 +45,7 @@ module Language.Javascript.JSaddle.Value (

45 , showJSValue

47 -- * Converting JavaScript values

48+ , isTruthyIO

48 , valToBool

49 , valToBool

49 , valToNumber

50 , valToNumber

50 , valToStr

51 , valToStr

@@ -54,15 +55,24 @@ module Language.Javascript.JSaddle.Value (

55 -- * Make JavaScript values from Haskell ones

56 -- * Make JavaScript values from Haskell ones

56 , val

57 , val

58+ , jsNull

57 , valNull

59 , valNull

60+ , isNullIO

58 , valIsNull

61 , valIsNull

62+ , jsUndefined

59 , valUndefined

63 , valUndefined

64+ , isUndefinedIO

60 , valIsUndefined

65 , valIsUndefined

61 , maybeNullOrUndefined

66 , maybeNullOrUndefined

62 , maybeNullOrUndefined'

67 , maybeNullOrUndefined'

68+ , toJSBool

69+ , jsTrue

70+ , jsFalse

63 , valBool

71 , valBool

64 , valMakeNumber

72 , valMakeNumber

65 , valMakeString

73 , valMakeString

74+ , valMakeText

75+ , valMakeJSON

67 -- * Convert to and from JSValue

77 -- * Convert to and from JSValue

68 , deRefVal

78 , deRefVal

@@ -71,33 +81,35 @@ module Language.Javascript.JSaddle.Value (

71 , instanceOf

81 , instanceOf

72) where

82) where

84+import Data.Text (Text)

85+import qualified Data.Text as T (pack, unpack)

86+import Data.Aeson (Value)

87+

88+#ifdef ghcjs_HOST_OS

74import Language.Javascript.JSaddle.Types

89import Language.Javascript.JSaddle.Types

75 (Object(..), JSString(..), JSVal(..))

90 (Object(..), JSString(..), JSVal(..))

76−#ifdef ghcjs_HOST_OS

91+import GHCJS.Marshal (ToJSVal(..))

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

78−import GHCJS.Types (isNull, isUndefined)

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

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

81import GHCJS.Marshal.Pure (pToJSVal)

92import GHCJS.Marshal.Pure (pToJSVal)

82import Data.JSString.Text (textToJSString)

93import Data.JSString.Text (textToJSString)

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

84#else

94#else

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

95+import Data.Char (chr, ord)

96+import Data.Word (Word, Word8, Word16, Word32)

97+import Data.Int (Int8, Int16, Int32)

98+import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))

99+import Language.Javascript.JSaddle.Types

100+ (Object(..), JSString(..), JSVal(..), JSValueForSend(..))

86import Language.Javascript.JSaddle.Native

101import Language.Javascript.JSaddle.Native

87− (wrapJSString, withJSVal, withObject, withJSString,

102+ (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)

88− withToJSVal)

89import Language.Javascript.JSaddle.Run

103import Language.Javascript.JSaddle.Run

90 (Command(..), AsyncCommand(..), Result(..), sendCommand,

104 (Command(..), AsyncCommand(..), Result(..), sendCommand,

91 sendLazyCommand)

105 sendLazyCommand)

92#endif

106#endif

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

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

94−import Data.Text (Text)

95import Language.Javascript.JSaddle.Classes

108import Language.Javascript.JSaddle.Classes

96− (MakeObject(..), ToJSString(..), ToJSVal(..))

109+ (MakeObject(..), MakeArgs(..))

110+import Language.Javascript.JSaddle.Marshal.String (ToJSString(..), FromJSString(..))

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

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

98−import Language.Javascript.JSaddle.Arguments (MakeArgs(..))

112+import Language.Javascript.JSaddle.Foreign (jsTrue, jsFalse, jsNull, toJSBool, jsUndefined, isTruthyIO, isNullIO, isUndefinedIO)

99−import Data.Word (Word32, Word, Word64)

100−import Data.Int (Int32, Int64)

101

113

102-- $setup

114-- $setup

103-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)

115-- >>> import Language.Javascript.JSaddle.Test (testJSaddle)

@@ -154,20 +166,7 @@ showJSValue (ValObject _) = "object"

154-- >>> testJSaddle $ valToBool "1"

166-- >>> testJSaddle $ valToBool "1"

155-- true

167-- true

156valToBool :: ToJSVal value => value -> JSM Bool

168valToBool :: ToJSVal value => value -> JSM Bool

157−#ifdef ghcjs_HOST_OS

158−valToBool value = isTruthy <$> toJSVal value

159−#else

160−valToBool value =

161− toJSVal value >>= \case

169+valToBool value = toJSVal value >>= isTruthyIO

162− (JSVal 0) -> return False -- null

163− (JSVal 1) -> return False -- undefined

164− (JSVal 2) -> return False -- false

165− (JSVal 3) -> return True -- true

166− v ->

167− withJSVal v $ \rval -> do

168− ValueToBoolResult result <- sendCommand (ValueToBool rval)

169− return result

170−#endif

171

170

172-- | Given a JavaScript value get its numeric value.

171-- | Given a JavaScript value get its numeric value.

173-- May throw JSException.

172-- May throw JSException.

@@ -308,15 +307,21 @@ valToObject value = Object <$> toJSVal value

308instance MakeObject JSVal where

307instance MakeObject JSVal where

309 makeObject = valToObject

308 makeObject = valToObject

310

309

310+instance ToJSVal Object where

311+ toJSVal (Object r) = return r

312+

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

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

312val :: ToJSVal value

314val :: ToJSVal value

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

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

314 -> JSM JSVal

316 -> JSM JSVal

315val = toJSVal

317val = toJSVal

316

318

319+#ifndef ghcjs_HOST_OS

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

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

318instance ToJSVal JSVal where

321instance ToJSVal JSVal where

319 toJSVal = return

322 toJSVal = return

323+ {-# INLINE toJSVal #-}

324+#endif

320

325

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

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

322instance MakeArgs JSVal where

327instance MakeArgs JSVal where

@@ -326,55 +331,68 @@ instance MakeArgs JSVal where

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

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

327instance ToJSVal v => ToJSVal (JSM v) where

332instance ToJSVal v => ToJSVal (JSM v) where

328 toJSVal v = v >>= toJSVal

333 toJSVal v = v >>= toJSVal

334+ {-# INLINE toJSVal #-}

329

335

330----------- null ---------------

336----------- null ---------------

331-- | A @null@ JavaScript value

337-- | A @null@ JavaScript value

332valNull :: JSVal

338valNull :: JSVal

333−#ifdef ghcjs_HOST_OS

334valNull = jsNull

339valNull = jsNull

335−#else

336−valNull = JSVal 0

340+{-# INLINE valNull #-}

337−#endif

338

341

339-- | Makes a @null@ JavaScript value

342-- | Makes a @null@ JavaScript value

340instance ToJSVal JSNull where

343instance ToJSVal JSNull where

341− toJSVal = const (return valNull)

344+ toJSVal = const (return jsNull)

345+ {-# INLINE toJSVal #-}

342

346

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

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

344instance MakeArgs JSNull where

348instance MakeArgs JSNull where

345− makeArgs _ = return [valNull]

349+ makeArgs _ = return [jsNull]

346

350

351+#ifndef ghcjs_HOST_OS

347-- | Makes a JSVal or @null@ JavaScript value

352-- | Makes a JSVal or @null@ JavaScript value

348instance ToJSVal a => ToJSVal (Maybe a) where

353instance ToJSVal a => ToJSVal (Maybe a) where

349− toJSVal Nothing = return valNull

354+ toJSVal Nothing = return jsNull

350 toJSVal (Just a) = toJSVal a

355 toJSVal (Just a) = toJSVal a

356+ {-# INLINE toJSVal #-}

357+instance FromJSVal a => FromJSVal (Maybe a) where

358+ fromJSValUnchecked x =

359+ isUndefinedIO x >>= \case

360+ True -> return Nothing

361+ False -> isNullIO x >>= \case

362+ True -> return Nothing

363+ False -> fromJSVal x

364+ {-# INLINE fromJSValUnchecked #-}

365+ fromJSVal x =

366+ isUndefinedIO x >>= \case

367+ True -> return (Just Nothing)

368+ False -> isNullIO x >>= \case

369+ True -> return (Just Nothing)

370+ False -> fmap (fmap Just) fromJSVal x

371+ {-# INLINE fromJSVal #-}

372+

373+-- Make an array out of various lists

374+instance ToJSVal a => ToJSVal [a] where

375+ toJSVal = toJSValListOf

376+ {-# INLINE toJSVal #-}

377+

378+instance FromJSVal a => FromJSVal [a] where

379+ fromJSVal = fromJSValListOf

380+ {-# INLINE fromJSVal #-}

381+#endif

351

382

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

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

353valIsNull :: ToJSVal value => value -> JSM Bool

384valIsNull :: ToJSVal value => value -> JSM Bool

354−#ifdef ghcjs_HOST_OS

355−valIsNull value = isNull <$> toJSVal value

356−#else

357−valIsNull value =

358− toJSVal value >>= \case

385+valIsNull value = toJSVal value >>= isNullIO

359− JSVal 0 -> return True

360− v ->

361− withJSVal v $ \rval -> do

362− IsNullResult result <- sendCommand $ IsNull rval

363− return result

364−#endif

365

386

366----------- undefined ---------------

387----------- undefined ---------------

367-- | An @undefined@ JavaScript value

388-- | An @undefined@ JavaScript value

368valUndefined :: JSVal

389valUndefined :: JSVal

369−#ifdef ghcjs_HOST_OS

370valUndefined = jsUndefined

390valUndefined = jsUndefined

371−#else

372−valUndefined = JSVal 1

391+{-# INLINE valUndefined #-}

373−#endif

374

392

375-- | Makes an @undefined@ JavaScript value

393-- | Makes an @undefined@ JavaScript value

376instance ToJSVal JSUndefined where

394instance ToJSVal JSUndefined where

377− toJSVal = const (return valUndefined)

395+ toJSVal = const (return jsUndefined)

378

396

379--We can't allow this if JSUndefined is () as () is no args not "(null)".

397--We can't allow this if JSUndefined is () as () is no args not "(null)".

380--Use [()] instead.

398--Use [()] instead.

@@ -387,16 +405,7 @@ instance MakeArgs () where

387

405

388-- | Test a JavaScript value to see if it is @undefined@

406-- | Test a JavaScript value to see if it is @undefined@

389valIsUndefined :: ToJSVal value => value -> JSM Bool

407valIsUndefined :: ToJSVal value => value -> JSM Bool

390−#ifdef ghcjs_HOST_OS

391−valIsUndefined value = isUndefined <$> toJSVal value

392−#else

393−valIsUndefined value = toJSVal value >>= \case

408+valIsUndefined value = toJSVal value >>= isUndefinedIO

394− JSVal 1 -> return True

395− v ->

396− withJSVal v $ \rval -> do

397− IsUndefinedResult result <- sendCommand $ IsUndefined rval

398− return result

399−#endif

400

409

401-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)

410-- | Convert a JSVal to a Maybe JSVal (converting null and undefined to Nothing)

402maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)

411maybeNullOrUndefined :: ToJSVal value => value -> JSM (Maybe JSVal)

@@ -422,15 +431,15 @@ maybeNullOrUndefined' f value = do

422----------- booleans ---------------

431----------- booleans ---------------

423-- | A JavaScript boolean value

432-- | A JavaScript boolean value

424valBool :: Bool -> JSVal

433valBool :: Bool -> JSVal

425−#ifdef ghcjs_HOST_OS

426−valBool b = toJSBool b

434+valBool = toJSBool

427−#else

435+{-# INLINE valBool #-}

428−valBool b = JSVal $ if b then 3 else 2

429−#endif

430

436

437+#ifndef ghcjs_HOST_OS

431-- | Make a JavaScript boolean value

438-- | Make a JavaScript boolean value

432instance ToJSVal Bool where

439instance ToJSVal Bool where

433 toJSVal = return . valBool

440 toJSVal = return . valBool

441+ {-# INLINE toJSVal #-}

442+#endif

434

443

435-- | Makes an argument list with just a single JavaScript boolean value

444-- | Makes an argument list with just a single JavaScript boolean value

436instance MakeArgs Bool where

445instance MakeArgs Bool where

@@ -440,35 +449,53 @@ instance MakeArgs Bool where

440-- | Make a JavaScript number

449-- | Make a JavaScript number

441valMakeNumber :: Double -> JSM JSVal

450valMakeNumber :: Double -> JSM JSVal

442#ifdef ghcjs_HOST_OS

451#ifdef ghcjs_HOST_OS

443−valMakeNumber n = liftIO $ GHCJS.toJSVal n

452+valMakeNumber n = toJSVal n

444#else

453#else

445valMakeNumber = sendLazyCommand . NumberToValue

454valMakeNumber = sendLazyCommand . NumberToValue

446#endif

455#endif

447

456

457+#ifndef ghcjs_HOST_OS

448-- | Makes a JavaScript number

458-- | Makes a JavaScript number

449instance ToJSVal Double where

459instance ToJSVal Double where

450 toJSVal = valMakeNumber

460 toJSVal = valMakeNumber

461+ {-# INLINE toJSVal #-}

451

462

452instance ToJSVal Float where

463instance ToJSVal Float where

453 toJSVal = valMakeNumber . realToFrac

464 toJSVal = valMakeNumber . realToFrac

465+ {-# INLINE toJSVal #-}

454

466

455instance ToJSVal Word where

467instance ToJSVal Word where

456 toJSVal = valMakeNumber . fromIntegral

468 toJSVal = valMakeNumber . fromIntegral

469+ {-# INLINE toJSVal #-}

457

470

458−instance ToJSVal Word32 where

471+instance ToJSVal Word8 where

472+ toJSVal = valMakeNumber . fromIntegral

473+ {-# INLINE toJSVal #-}

474+

475+instance ToJSVal Word16 where

459 toJSVal = valMakeNumber . fromIntegral

476 toJSVal = valMakeNumber . fromIntegral

477+ {-# INLINE toJSVal #-}

460

478

461−instance ToJSVal Word64 where

479+instance ToJSVal Word32 where

462 toJSVal = valMakeNumber . fromIntegral

480 toJSVal = valMakeNumber . fromIntegral

481+ {-# INLINE toJSVal #-}

463

482

464instance ToJSVal Int where

483instance ToJSVal Int where

465 toJSVal = valMakeNumber . fromIntegral

484 toJSVal = valMakeNumber . fromIntegral

485+ {-# INLINE toJSVal #-}

466

486

467−instance ToJSVal Int32 where

487+instance ToJSVal Int8 where

468 toJSVal = valMakeNumber . fromIntegral

488 toJSVal = valMakeNumber . fromIntegral

489+ {-# INLINE toJSVal #-}

469

490

470−instance ToJSVal Int64 where

491+instance ToJSVal Int16 where

471 toJSVal = valMakeNumber . fromIntegral

492 toJSVal = valMakeNumber . fromIntegral

493+ {-# INLINE toJSVal #-}

494+

495+instance ToJSVal Int32 where

496+ toJSVal = valMakeNumber . fromIntegral

497+ {-# INLINE toJSVal #-}

498+#endif

472

499

473-- | Makes an argument list with just a single JavaScript number

500-- | Makes an argument list with just a single JavaScript number

474instance MakeArgs Double where

501instance MakeArgs Double where

@@ -491,21 +518,33 @@ valMakeString s =

491 withJSString s $ sendLazyCommand . StringToValue

518 withJSString s $ sendLazyCommand . StringToValue

492#endif

519#endif

493

520

521+#ifndef ghcjs_HOST_OS

494-- | Makes a JavaScript string

522-- | Makes a JavaScript string

495instance ToJSVal Text where

523instance ToJSVal Text where

496 toJSVal = valMakeText

524 toJSVal = valMakeText

525+ {-# INLINE toJSVal #-}

526+instance FromJSVal Text where

527+ fromJSValUnchecked = valToText

528+ {-# INLINE fromJSValUnchecked #-}

529+ fromJSVal = fmap Just . valToText

530+ {-# INLINE fromJSVal #-}

531+#endif

497

532

498-- | Makes an argument list with just a single JavaScript string

533-- | Makes an argument list with just a single JavaScript string

499instance MakeArgs Text where

534instance MakeArgs Text where

500 makeArgs t = valMakeText t >>= (\ref -> return [ref])

535 makeArgs t = valMakeText t >>= (\ref -> return [ref])

501

536

502−-- | Makes a JavaScript string

537+#ifndef ghcjs_HOST_OS

503−instance ToJSVal String where

504− toJSVal = valMakeText . T.pack

505−

506-- | Makes a JavaScript string

538-- | Makes a JavaScript string

507instance ToJSVal JSString where

539instance ToJSVal JSString where

508 toJSVal = valMakeString

540 toJSVal = valMakeString

541+ {-# INLINE toJSVal #-}

542+instance FromJSVal JSString where

543+ fromJSValUnchecked = valToStr

544+ {-# INLINE fromJSValUnchecked #-}

545+ fromJSVal = fmap Just . valToStr

546+ {-# INLINE fromJSVal #-}

547+#endif

509

548

510-- | If we already have a JSString we are fine

549-- | If we already have a JSString we are fine

511instance ToJSString JSString where

550instance ToJSString JSString where

@@ -517,6 +556,51 @@ instance ToJSString Text where

517instance ToJSString String where

556instance ToJSString String where

518 toJSString = textToStr . T.pack

557 toJSString = textToStr . T.pack

519

558

559+instance FromJSString Text where

560+ fromJSString = strToText

561+

562+instance FromJSString String where

563+ fromJSString v = T.unpack $ strToText v

564+

565+instance FromJSString JSString where

566+ fromJSString = id

567+

568+#ifndef ghcjs_HOST_OS

569+instance ToJSVal Char where

570+ toJSVal = valMakeNumber . fromIntegral . ord

571+ {-# INLINE toJSVal #-}

572+ toJSValListOf = valMakeText . T.pack

573+ {-# INLINE toJSValListOf #-}

574+instance FromJSVal Char where

575+ fromJSValUnchecked = fmap (chr . round) . valToNumber

576+ {-# INLINE fromJSValUnchecked #-}

577+ fromJSVal = fmap (Just . chr . round) . valToNumber

578+ {-# INLINE fromJSVal #-}

579+ fromJSValUncheckedListOf = fmap (T.unpack . strToText) . valToStr

580+ {-# INLINE fromJSValListOf #-}

581+ fromJSValListOf = fmap (Just . T.unpack . strToText) . valToStr

582+ {-# INLINE fromJSValUncheckedListOf #-}

583+#endif

584+

585+-- | Make a JavaScript string from AESON `Value`

586+valMakeJSON :: Value -> JSM JSVal

587+#ifdef ghcjs_HOST_OS

588+valMakeJSON = toJSVal

589+#else

590+valMakeJSON = sendLazyCommand . JSONValueToValue

591+#endif

592+

593+#ifndef ghcjs_HOST_OS

594+-- | Makes a JSON value

595+instance ToJSVal Value where

596+ toJSVal = valMakeJSON

597+ {-# INLINE toJSVal #-}

598+#endif

599+

600+-- | Makes an argument list with just a single JSON value

601+instance MakeArgs Value where

602+ makeArgs t = valMakeJSON t >>= (\ref -> return [ref])

603+

520-- | Derefernce a value reference.

604-- | Derefernce a value reference.

521--

605--

522-- >>> testJSaddle $ showJSValue <$> deRefVal JSNull

606-- >>> testJSaddle $ showJSValue <$> deRefVal JSNull

@@ -597,6 +681,7 @@ valMakeRef value =

597-- | Makes a JavaScript value from a 'JSValue' ADT.

681-- | Makes a JavaScript value from a 'JSValue' ADT.

598instance ToJSVal JSValue where

682instance ToJSVal JSValue where

599 toJSVal = valMakeRef

683 toJSVal = valMakeRef

684+ {-# INLINE toJSVal #-}

600

685

601-- | Makes an argument list with just a single JavaScript value from a 'JSValue' ADT.

686-- | Makes an argument list with just a single JavaScript value from a 'JSValue' ADT.

602instance MakeArgs JSValue where

687instance MakeArgs JSValue where

@@ -664,4 +749,3 @@ instanceOf value constructor = do

664

749

665

750

666

751

667−