2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE ForeignFunctionInterface #-}
7{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE StandaloneDeriving #-}
12{-# LANGUAGE TemplateHaskell #-}
13{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
17{-# LANGUAGE JavaScriptFFI #-}
19module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
24import Reflex.DynamicWriter
25import Reflex.PerformEvent.Base
26import Reflex.PerformEvent.Class
27import Reflex.PostBuild.Class
28import Reflex.Host.Class
30import Language.Haskell.TH
33import qualified GHCJS.Buffer as JS
35import GHCJS.DOM.Types hiding (Text, fromJSString)
36import qualified GHCJS.DOM.Types as JS
37import qualified GHCJS.Foreign as JS
38import qualified GHCJS.Foreign.Callback as JS
39import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
40import qualified GHCJS.Marshal as JS
41import qualified GHCJS.Marshal.Pure as JS
42import qualified GHCJS.Types as JS
43import qualified JavaScript.Array as JS
44import qualified JavaScript.Array.Internal (SomeJSArray (..))
45import qualified JavaScript.Object as JS
46import qualified JavaScript.Object.Internal (Object (..))
47import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
56import Graphics.UI.Gtk.WebKit.DOM.Node
57import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
58import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
59import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
60import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
61import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
62import Graphics.UI.Gtk.WebKit.WebView
66import Control.Concurrent
68import Control.Monad.Exception
69import Control.Monad.Fix
70import Control.Monad.IO.Class
71import Control.Monad.Primitive
72import Control.Monad.Reader
73import Control.Monad.Ref
74import Control.Monad.State
75import qualified Control.Monad.State.Strict as Strict
76import Control.Monad.Trans.Control
77import Data.ByteString (ByteString)
78import qualified Data.ByteString as BS
81import Data.Text (Text)
82import qualified Data.Text as T
86class Monad m => HasWebView m where
87 type WebViewPhantom m :: *
88 askWebView :: m (WebViewSingleton (WebViewPhantom m))
90instance HasWebView m => HasWebView (ReaderT r m) where
91 type WebViewPhantom (ReaderT r m) = WebViewPhantom m
92 askWebView = lift askWebView
94instance HasWebView m => HasWebView (StateT r m) where
95 type WebViewPhantom (StateT r m) = WebViewPhantom m
96 askWebView = lift askWebView
98instance HasWebView m => HasWebView (Strict.StateT r m) where
99 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m
100 askWebView = lift askWebView
102instance HasWebView m => HasWebView (PostBuildT t m) where
103 type WebViewPhantom (PostBuildT t m) = WebViewPhantom m
104 askWebView = lift askWebView
106instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where
107 type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)
108 askWebView = PerformEventT $ lift askWebView
110instance HasWebView m => HasWebView (DynamicWriterT t w m) where
111 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
112 askWebView = lift askWebView
114instance HasWebView m => HasWebView (RequestT t request response m) where
115 type WebViewPhantom (RequestT t request response m) = WebViewPhantom m
116 askWebView = lift askWebView
118newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
120instance PrimMonad m => PrimMonad (WithWebView x m) where
121 type PrimState (WithWebView x m) = PrimState m
122 primitive = lift . primitive
124instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where
125 sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (unsafeCoerce dm')
127instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
128 {-# INLINABLE newEventWithTrigger #-}
129 newEventWithTrigger = lift . newEventWithTrigger
130 {-# INLINABLE newFanEventWithTrigger #-}
131 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
133instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
134 {-# INLINABLE subscribeEvent #-}
135 subscribeEvent = lift . subscribeEvent
137instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
138 type ReadPhase (WithWebView x m) = ReadPhase m
139 {-# INLINABLE fireEventsAndRead #-}
140 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
141 {-# INLINABLE runHostFrame #-}
142 runHostFrame = lift . runHostFrame
144instance MonadSample t m => MonadSample t (WithWebView x m) where
145 {-# INLINABLE sample #-}
146 sample = lift . sample
148instance MonadHold t m => MonadHold t (WithWebView x m) where
149 {-# INLINABLE hold #-}
150 hold v0 = lift . hold v0
151 {-# INLINABLE holdDyn #-}
152 holdDyn v0 = lift . holdDyn v0
153 {-# INLINABLE holdIncremental #-}
154 holdIncremental v0 = lift . holdIncremental v0
156instance MonadTransControl (WithWebView x) where
157 type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
158 {-# INLINABLE liftWith #-}
159 liftWith = defaultLiftWith WithWebView unWithWebView
160 {-# INLINABLE restoreT #-}
161 restoreT = defaultRestoreT WithWebView
163instance PerformEvent t m => PerformEvent t (WithWebView x m) where
164 type Performable (WithWebView x m) = WithWebView x (Performable m)
165 {-# INLINABLE performEvent_ #-}
166 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
167 {-# INLINABLE performEvent #-}
168 performEvent e = liftWith $ \run -> performEvent $ fmap run e
170runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
171runWithWebView = runReaderT . unWithWebView
173instance (Monad m) => HasWebView (WithWebView x m) where
174 type WebViewPhantom (WithWebView x m) = x
175 askWebView = WithWebView ask
177instance MonadRef m => MonadRef (WithWebView x m) where
178 type Ref (WithWebView x m) = Ref m
179 newRef = lift . newRef
180 readRef = lift . readRef
181 writeRef r = lift . writeRef r
183instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
184 atomicModifyRef r = lift . atomicModifyRef r
186withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
187withWebViewSingleton wv f = f $ WebViewSingleton wv
189-- | A singleton type for a given WebView; we use this to statically guarantee that different WebViews (and thus different javscript contexts) don't get mixed up
190newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
193type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
194newtype JSFFI = JSFFI JSFFI_Internal
196newtype JSFFI = JSFFI String
199newtype JSFun x = JSFun { unJSFun :: JSRef x }
201instance ToJS x (JSFun x) where
202 withJS (JSFun r) f = f r
204instance FromJS x (JSFun x) where
205 fromJS = return . JSFun
207class IsJSContext x where
210class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
212 liftJS :: JSM m a -> m a
214instance HasJS x m => HasJS x (ReaderT r m) where
215 type JSM (ReaderT r m) = JSM m
216 liftJS = lift . liftJS
218instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
219 type JSM (PostBuildT t m) = JSM m
220 liftJS = lift . liftJS
222instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
223 type JSM (PerformEventT t m) = JSM (HostFrame t)
224 liftJS = PerformEventT . lift . liftJS
226instance HasJS x m => HasJS x (DynamicWriterT t w m) where
227 type JSM (DynamicWriterT t w m) = JSM m
228 liftJS = lift . liftJS
230instance HasJS x m => HasJS x (RequestT t request response m) where
231 type JSM (RequestT t request response m) = JSM m
232 liftJS = lift . liftJS
234-- | A Monad that is capable of executing JavaScript
235class Monad m => MonadJS x m | m -> x where
236 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
237 forkJS :: m () -> m ThreadId
238 mkJSUndefined :: m (JSRef x)
239 isJSNull :: JSRef x -> m Bool
240 isJSUndefined :: JSRef x -> m Bool
241 fromJSBool :: JSRef x -> m Bool
242 fromJSString :: JSRef x -> m String
243 fromJSArray :: JSRef x -> m [JSRef x]
244 fromJSUint8Array :: JSRef x -> m ByteString
245 fromJSNumber :: JSRef x -> m Double
246 withJSBool :: Bool -> (JSRef x -> m r) -> m r
247 withJSString :: String -> (JSRef x -> m r) -> m r
248 withJSNumber :: Double -> (JSRef x -> m r) -> m r
249 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
250 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
251 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
252 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
253 freeJSFun :: JSFun x -> m ()
254 setJSProp :: String -> JSRef x -> JSRef x -> m ()
255 getJSProp :: String -> JSRef x -> m (JSRef x)
256 withJSNode :: Node -> (JSRef x -> m r) -> m r
262instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
263 type JSM (WithWebView x m) = IO
266instance IsJSContext JSCtx_IO where
267 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
269instance MonadJS JSCtx_IO IO where
270 runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)
272 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
273 isJSNull (JSRef_IO r) = return $ JS.isNull r
274 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
275 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
276 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
277 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
278 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
279 fromJSNumber (JSRef_IO r) = do
280 Just n <- JS.fromJSVal r
282 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
283 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
284 withJSNumber n f = do
288 r <- JS.fromListIO $ coerce l
289 f $ JSRef_IO $ coerce r
290 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
291 ba <- extractByteArray cStr $ BS.length payload
292 f $ JSUint8Array $ JSRef_IO ba
294 cb <- JS.syncCallback1' $ \args -> do
295 l <- JS.toListIO $ coerce args
296 JSRef_IO result <- f $ coerce l
298 fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
299 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
300 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
301 getJSProp s (JSRef_IO o) = do
302 r <- JS.getProp (JS.toJSString s) $ coerce o
304 withJSNode n f = f $ JSRef_IO $ unNode n
306foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
308foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
312-- | Make a JS string available that is not wrapped up as a JSValueRef
313withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
314withJSStringRaw str a = do
315 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
318fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double
319fromJSNumberRaw val = do
320 jsContext <- askJSContext
321 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
324data JSCtx_JavaScriptCore x
326instance IsJSContext (JSCtx_JavaScriptCore x) where
327 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
329instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
330 type JSM (WithWebView x m) = WithWebView x IO
333 liftIO $ runWithWebView a wv
335newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
337runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
338runWithJSContext = runReaderT . unWithJSContext
340class Monad m => HasJSContext m where
341 askJSContext :: m JSContextRef
343instance MonadIO m => HasJSContext (WithWebView x m) where
346 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
348instance Monad m => HasJSContext (WithJSContext x m) where
349 askJSContext = WithJSContext ask
351lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
352lowerWithJSContext a = do
354 liftIO $ runWithJSContext a c
356liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
357 => ((t1 -> t m1 a) -> WithJSContext x IO b)
358 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
360liftWithWebViewThroughWithJSContext f a = do
362 lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv
364instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
367 liftIO $ forkIO $ runWithWebView a wv
370 lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv
371 runJS expr args = lowerWithJSContext $ runJS expr args
372 mkJSUndefined = lowerWithJSContext mkJSUndefined
373 isJSNull = lowerWithJSContext . isJSNull
374 isJSUndefined = lowerWithJSContext . isJSUndefined
375 fromJSBool = lowerWithJSContext . fromJSBool
376 fromJSString = lowerWithJSContext . fromJSString
377 fromJSArray = lowerWithJSContext . fromJSArray
378 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
379 fromJSNumber = lowerWithJSContext . fromJSNumber
380 freeJSFun = lowerWithJSContext . freeJSFun
381 withJSBool = liftWithWebViewThroughWithJSContext . withJSBool
382 withJSString = liftWithWebViewThroughWithJSContext . withJSString
383 withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber
384 withJSArray = liftWithWebViewThroughWithJSContext . withJSArray
385 withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array
386 withJSNode = liftWithWebViewThroughWithJSContext . withJSNode
387 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
388 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
390instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
391 runJS (JSFFI body) args = do
392 jsContext <- askJSContext
393 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
394 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
395 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
398 liftIO $ forkIO $ runWithJSContext a c
400 jsContext <- askJSContext
401 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
402 isJSNull (JSRef_JavaScriptCore r) = do
403 jsContext <- askJSContext
404 liftIO $ jsvalueisnull jsContext r
405 isJSUndefined (JSRef_JavaScriptCore r) = do
406 jsContext <- askJSContext
407 liftIO $ jsvalueisundefined jsContext r
408 fromJSBool (JSRef_JavaScriptCore r) = do
409 jsContext <- askJSContext
410 liftIO $ jsvaluetoboolean jsContext r
411 fromJSString (JSRef_JavaScriptCore r) = do
412 jsContext <- askJSContext
414 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
415 l <- jsstringgetmaximumutf8cstringsize s
416 allocaBytes (fromIntegral l) $ \ps -> do
417 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
420 jsContext <- askJSContext
421 valRef <- liftIO $ jsvaluemakeboolean jsContext b
422 a $ JSRef_JavaScriptCore valRef
423 withJSString str a = do
424 jsContext <- askJSContext
425 withJSStringRaw str $ \strRef -> do
426 valRef <- liftIO $ jsvaluemakestring jsContext strRef
427 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
428 withJSNumber n a = do
429 jsContext <- askJSContext
430 valRef <- liftIO $ jsvaluemakenumber jsContext n
431 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
432 withJSArray elems a = do
433 jsContext <- askJSContext
434 let numElems = length elems
435 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
436 liftIO $ pokeArray elemsArr $ coerce elems
437 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
438 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
439 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
440 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
441 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
442 f $ JSUint8Array payloadRef
443 fromJSArray (JSRef_JavaScriptCore a) = do
444 jsContext <- askJSContext
445 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
446 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
447 lenDouble <- fromJSNumberRaw lenRef
448 let len = round lenDouble
449 liftIO $ forM [0..len-1] $ \i -> do
450 JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
451 fromJSUint8Array a = do
452 vals <- fromJSArray a
453 doubles <- mapM fromJSNumber vals
454 return $ BS.pack $ map round doubles
455 fromJSNumber (JSRef_JavaScriptCore val) = do
456 jsContext <- askJSContext
457 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
459 jsContext <- askJSContext
460 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
461 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
462 x <- peekElemOff argv n
463 jsvalueprotect jsContext x
464 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
465 unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext
466 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
467 liftIO $ jsvalueprotect jsContext cbRef
468 return $ JSFun $ JSRef_JavaScriptCore cbRef
469 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
470 jsContext <- askJSContext
471 liftIO $ jsvalueunprotect jsContext f
472 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
473 withJSStringRaw propName $ \propNameRaw -> do
474 jsContext <- askJSContext
475 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
476 getJSProp propName (JSRef_JavaScriptCore objRef) = do
477 withJSStringRaw propName $ \propNameRaw -> do
478 jsContext <- askJSContext
479 liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
480 withJSNode = error "withJSNode is only supported in ghcjs"
484class FromJS x a where
485 fromJS :: MonadJS x m => JSRef x -> m a
487instance FromJS x () where
488 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
490instance FromJS x Bool where
493instance ToJS x Bool where
496instance FromJS x String where
497 fromJS = fromJSString
499instance FromJS x Text where
500 fromJS s = T.pack <$> fromJSString s
502instance FromJS x a => FromJS x (Maybe a) where
505 if n then return Nothing else Just <$> fromJS x
508 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
510instance ToJS x (JSRef x) where
513instance FromJS x (JSRef x) where
516instance ToJS x String where
517 withJS = withJSString
519instance ToJS x Text where
520 withJS = withJSString . T.unpack
522newtype JSArray a = JSArray { unJSArray :: [a] }
524instance ToJS x a => ToJS x (JSArray a) where
525 withJS = withJSArrayFromList . unJSArray
527instance FromJS x a => FromJS x (JSArray a) where
528 fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
530withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
531withJSArrayFromList as f = go as []
532 where go [] jsRefs = withJSArray (reverse jsRefs) f
533 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
535newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
537instance ToJS x (JSUint8Array x) where
538 withJS (JSUint8Array r) = ($ r)
540instance FromJS x (JSUint8Array x) where
541 fromJS = return . JSUint8Array
543instance ToJS x Word8 where
544 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
546instance ToJS x Int where
547 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
549instance FromJS x Int where
550 fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
552instance ToJS x Double where
553 withJS = withJSNumber
555instance FromJS x Double where
556 fromJS = fromJSNumber
558instance ToJS x Node where
562importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
563importJS safety body name qt = do
565 let (argTypes, _) = parseType t
566 argNames <- forM argTypes $ \_ -> do
568 argRef <- newName "argRef"
570 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
571 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
573 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
574 e <- lamE (map (varP. fst) argNames) $ go argNames
576 return $ jsffiDecs ++
578 , ValD (VarP n) (NormalB e) []
581mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
583mkJSFFI safety body = do
584 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
586 n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
587 t <- [t| JSFFI_Internal |]
588 let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
589 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
590 e <- [| JSFFI $(varE n) |]
594 e <- [| JSFFI body |]
598parseType :: Type -> ([Type], Type)
599parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
600 | monadJs == ''MonadJS = go funType
601 where go t = case t of
602 AppT (AppT ArrowT arg) t' ->
603 let (args, result) = go t'
604 in (arg : args, result)
605 AppT (VarT m') result
606 | m' == m -> ([], result)
607 _ -> error $ "parseType: can't parse type " <> show t
608parseType t = error $ "parseType: can't parse type " <> show t
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list