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
84class Monad m => HasWebView m where
85 type WebViewPhantom m :: *
86 askWebView :: m (WebViewSingleton (WebViewPhantom m))
88instance HasWebView m => HasWebView (ReaderT r m) where
89 type WebViewPhantom (ReaderT r m) = WebViewPhantom m
90 askWebView = lift askWebView
92instance HasWebView m => HasWebView (StateT r m) where
93 type WebViewPhantom (StateT r m) = WebViewPhantom m
94 askWebView = lift askWebView
96instance HasWebView m => HasWebView (Strict.StateT r m) where
97 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m
98 askWebView = lift askWebView
100instance HasWebView m => HasWebView (PostBuildT t m) where
101 type WebViewPhantom (PostBuildT t m) = WebViewPhantom m
102 askWebView = lift askWebView
104instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where
105 type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)
106 askWebView = PerformEventT $ lift askWebView
108instance HasWebView m => HasWebView (DynamicWriterT t w m) where
109 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
110 askWebView = lift askWebView
112instance HasWebView m => HasWebView (RequestT t request response m) where
113 type WebViewPhantom (RequestT t request response m) = WebViewPhantom m
114 askWebView = lift askWebView
116newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
118instance PrimMonad m => PrimMonad (WithWebView x m) where
119 type PrimState (WithWebView x m) = PrimState m
120 primitive = lift . primitive
122instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where
123 runWithReplace a0 a' = WithWebView $ runWithReplace (coerce a0) (coerceEvent a')
124 sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
126instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
127 {-# INLINABLE newEventWithTrigger #-}
128 newEventWithTrigger = lift . newEventWithTrigger
129 {-# INLINABLE newFanEventWithTrigger #-}
130 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
132instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
133 {-# INLINABLE subscribeEvent #-}
134 subscribeEvent = lift . subscribeEvent
136instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
137 type ReadPhase (WithWebView x m) = ReadPhase m
138 {-# INLINABLE fireEventsAndRead #-}
139 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
140 {-# INLINABLE runHostFrame #-}
141 runHostFrame = lift . runHostFrame
143instance MonadSample t m => MonadSample t (WithWebView x m) where
144 {-# INLINABLE sample #-}
145 sample = lift . sample
147instance MonadHold t m => MonadHold t (WithWebView x m) where
148 {-# INLINABLE hold #-}
149 hold v0 = lift . hold v0
150 {-# INLINABLE holdDyn #-}
151 holdDyn v0 = lift . holdDyn v0
152 {-# INLINABLE holdIncremental #-}
153 holdIncremental v0 = lift . holdIncremental v0
155instance MonadTransControl (WithWebView x) where
156 type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
157 {-# INLINABLE liftWith #-}
158 liftWith = defaultLiftWith WithWebView unWithWebView
159 {-# INLINABLE restoreT #-}
160 restoreT = defaultRestoreT WithWebView
162instance PerformEvent t m => PerformEvent t (WithWebView x m) where
163 type Performable (WithWebView x m) = WithWebView x (Performable m)
164 {-# INLINABLE performEvent_ #-}
165 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
166 {-# INLINABLE performEvent #-}
167 performEvent e = liftWith $ \run -> performEvent $ fmap run e
169runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
170runWithWebView = runReaderT . unWithWebView
172instance (Monad m) => HasWebView (WithWebView x m) where
173 type WebViewPhantom (WithWebView x m) = x
174 askWebView = WithWebView ask
176instance MonadRef m => MonadRef (WithWebView x m) where
177 type Ref (WithWebView x m) = Ref m
178 newRef = lift . newRef
179 readRef = lift . readRef
180 writeRef r = lift . writeRef r
182instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
183 atomicModifyRef r = lift . atomicModifyRef r
185withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
186withWebViewSingleton wv f = f $ WebViewSingleton wv
188-- | 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
189newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
192type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
193newtype JSFFI = JSFFI JSFFI_Internal
195newtype JSFFI = JSFFI String
198newtype JSFun x = JSFun { unJSFun :: JSRef x }
200instance ToJS x (JSFun x) where
201 withJS (JSFun r) f = f r
203instance FromJS x (JSFun x) where
204 fromJS = return . JSFun
206class IsJSContext x where
209class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
211 liftJS :: JSM m a -> m a
213instance HasJS x m => HasJS x (ReaderT r m) where
214 type JSM (ReaderT r m) = JSM m
215 liftJS = lift . liftJS
217instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
218 type JSM (PostBuildT t m) = JSM m
219 liftJS = lift . liftJS
221instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
222 type JSM (PerformEventT t m) = JSM (HostFrame t)
223 liftJS = PerformEventT . lift . liftJS
225instance HasJS x m => HasJS x (DynamicWriterT t w m) where
226 type JSM (DynamicWriterT t w m) = JSM m
227 liftJS = lift . liftJS
229instance HasJS x m => HasJS x (RequestT t request response m) where
230 type JSM (RequestT t request response m) = JSM m
231 liftJS = lift . liftJS
233-- | A Monad that is capable of executing JavaScript
234class Monad m => MonadJS x m | m -> x where
235 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
236 forkJS :: m () -> m ThreadId
237 mkJSUndefined :: m (JSRef x)
238 isJSNull :: JSRef x -> m Bool
239 isJSUndefined :: JSRef x -> m Bool
240 fromJSBool :: JSRef x -> m Bool
241 fromJSString :: JSRef x -> m String
242 fromJSArray :: JSRef x -> m [JSRef x]
243 fromJSUint8Array :: JSRef x -> m ByteString
244 fromJSNumber :: JSRef x -> m Double
245 withJSBool :: Bool -> (JSRef x -> m r) -> m r
246 withJSString :: String -> (JSRef x -> m r) -> m r
247 withJSNumber :: Double -> (JSRef x -> m r) -> m r
248 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
249 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
250 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
251 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
252 freeJSFun :: JSFun x -> m ()
253 setJSProp :: String -> JSRef x -> JSRef x -> m ()
254 getJSProp :: String -> JSRef x -> m (JSRef x)
255 withJSNode :: Node -> (JSRef x -> m r) -> m r
261instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
262 type JSM (WithWebView x m) = IO
265instance IsJSContext JSCtx_IO where
266 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
268instance MonadJS JSCtx_IO IO where
269 runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)
271 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
272 isJSNull (JSRef_IO r) = return $ JS.isNull r
273 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
274 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
275 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
276 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
277 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
278 fromJSNumber (JSRef_IO r) = do
279 Just n <- JS.fromJSVal r
281 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
282 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
283 withJSNumber n f = do
287 r <- JS.fromListIO $ coerce l
288 f $ JSRef_IO $ coerce r
289 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
290 ba <- extractByteArray cStr $ BS.length payload
291 f $ JSUint8Array $ JSRef_IO ba
293 cb <- JS.syncCallback1' $ \args -> do
294 l <- JS.toListIO $ coerce args
295 JSRef_IO result <- f $ coerce l
297 fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
298 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
299 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
300 getJSProp s (JSRef_IO o) = do
301 r <- JS.getProp (JS.toJSString s) $ coerce o
303 withJSNode n f = f $ JSRef_IO $ unNode n
305foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
307foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
311-- | Make a JS string available that is not wrapped up as a JSValueRef
312withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
313withJSStringRaw str a = do
314 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
317fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double
318fromJSNumberRaw val = do
319 jsContext <- askJSContext
320 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
323data JSCtx_JavaScriptCore x
325instance IsJSContext (JSCtx_JavaScriptCore x) where
326 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
328instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
329 type JSM (WithWebView x m) = WithWebView x IO
332 liftIO $ runWithWebView a wv
334newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
336runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
337runWithJSContext = runReaderT . unWithJSContext
339class Monad m => HasJSContext m where
340 askJSContext :: m JSContextRef
342instance MonadIO m => HasJSContext (WithWebView x m) where
345 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
347instance Monad m => HasJSContext (WithJSContext x m) where
348 askJSContext = WithJSContext ask
350lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
351lowerWithJSContext a = do
353 liftIO $ runWithJSContext a c
355liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
356 => ((t1 -> t m1 a) -> WithJSContext x IO b)
357 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
359liftWithWebViewThroughWithJSContext f a = do
361 lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv
363instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
366 liftIO $ forkIO $ runWithWebView a wv
369 lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv
370 runJS expr args = lowerWithJSContext $ runJS expr args
371 mkJSUndefined = lowerWithJSContext mkJSUndefined
372 isJSNull = lowerWithJSContext . isJSNull
373 isJSUndefined = lowerWithJSContext . isJSUndefined
374 fromJSBool = lowerWithJSContext . fromJSBool
375 fromJSString = lowerWithJSContext . fromJSString
376 fromJSArray = lowerWithJSContext . fromJSArray
377 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
378 fromJSNumber = lowerWithJSContext . fromJSNumber
379 freeJSFun = lowerWithJSContext . freeJSFun
380 withJSBool = liftWithWebViewThroughWithJSContext . withJSBool
381 withJSString = liftWithWebViewThroughWithJSContext . withJSString
382 withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber
383 withJSArray = liftWithWebViewThroughWithJSContext . withJSArray
384 withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array
385 withJSNode = liftWithWebViewThroughWithJSContext . withJSNode
386 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
387 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
389instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
390 runJS (JSFFI body) args = do
391 jsContext <- askJSContext
392 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
393 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
394 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
397 liftIO $ forkIO $ runWithJSContext a c
399 jsContext <- askJSContext
400 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
401 isJSNull (JSRef_JavaScriptCore r) = do
402 jsContext <- askJSContext
403 liftIO $ jsvalueisnull jsContext r
404 isJSUndefined (JSRef_JavaScriptCore r) = do
405 jsContext <- askJSContext
406 liftIO $ jsvalueisundefined jsContext r
407 fromJSBool (JSRef_JavaScriptCore r) = do
408 jsContext <- askJSContext
409 liftIO $ jsvaluetoboolean jsContext r
410 fromJSString (JSRef_JavaScriptCore r) = do
411 jsContext <- askJSContext
413 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
414 l <- jsstringgetmaximumutf8cstringsize s
415 allocaBytes (fromIntegral l) $ \ps -> do
416 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
419 jsContext <- askJSContext
420 valRef <- liftIO $ jsvaluemakeboolean jsContext b
421 a $ JSRef_JavaScriptCore valRef
422 withJSString str a = do
423 jsContext <- askJSContext
424 withJSStringRaw str $ \strRef -> do
425 valRef <- liftIO $ jsvaluemakestring jsContext strRef
426 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
427 withJSNumber n a = do
428 jsContext <- askJSContext
429 valRef <- liftIO $ jsvaluemakenumber jsContext n
430 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
431 withJSArray elems a = do
432 jsContext <- askJSContext
433 let numElems = length elems
434 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
435 liftIO $ pokeArray elemsArr $ coerce elems
436 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
437 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
438 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
439 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
440 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
441 f $ JSUint8Array payloadRef
442 fromJSArray (JSRef_JavaScriptCore a) = do
443 jsContext <- askJSContext
444 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
445 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
446 lenDouble <- fromJSNumberRaw lenRef
447 let len = round lenDouble
448 liftIO $ forM [0..len-1] $ \i -> do
449 JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
450 fromJSUint8Array a = do
451 vals <- fromJSArray a
452 doubles <- mapM fromJSNumber vals
453 return $ BS.pack $ map round doubles
454 fromJSNumber (JSRef_JavaScriptCore val) = do
455 jsContext <- askJSContext
456 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
458 jsContext <- askJSContext
459 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
460 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
461 x <- peekElemOff argv n
462 jsvalueprotect jsContext x
463 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
464 unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext
465 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
466 liftIO $ jsvalueprotect jsContext cbRef
467 return $ JSFun $ JSRef_JavaScriptCore cbRef
468 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
469 jsContext <- askJSContext
470 liftIO $ jsvalueunprotect jsContext f
471 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
472 withJSStringRaw propName $ \propNameRaw -> do
473 jsContext <- askJSContext
474 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
475 getJSProp propName (JSRef_JavaScriptCore objRef) = do
476 withJSStringRaw propName $ \propNameRaw -> do
477 jsContext <- askJSContext
478 liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
479 withJSNode = error "withJSNode is only supported in ghcjs"
483class FromJS x a where
484 fromJS :: MonadJS x m => JSRef x -> m a
486instance FromJS x () where
487 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
489instance FromJS x Bool where
492instance ToJS x Bool where
495instance FromJS x String where
496 fromJS = fromJSString
498instance FromJS x Text where
499 fromJS s = T.pack <$> fromJSString s
501instance FromJS x a => FromJS x (Maybe a) where
504 if n then return Nothing else Just <$> fromJS x
507 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
509instance ToJS x (JSRef x) where
512instance FromJS x (JSRef x) where
515instance ToJS x String where
516 withJS = withJSString
518instance ToJS x Text where
519 withJS = withJSString . T.unpack
521newtype JSArray a = JSArray { unJSArray :: [a] }
523instance ToJS x a => ToJS x (JSArray a) where
524 withJS = withJSArrayFromList . unJSArray
526instance FromJS x a => FromJS x (JSArray a) where
527 fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
529withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
530withJSArrayFromList as f = go as []
531 where go [] jsRefs = withJSArray (reverse jsRefs) f
532 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
534newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
536instance ToJS x (JSUint8Array x) where
537 withJS (JSUint8Array r) = ($ r)
539instance FromJS x (JSUint8Array x) where
540 fromJS = return . JSUint8Array
542instance ToJS x Word8 where
543 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
545instance ToJS x Int where
546 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
548instance FromJS x Int where
549 fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
551instance ToJS x Double where
552 withJS = withJSNumber
554instance FromJS x Double where
555 fromJS = fromJSNumber
557instance ToJS x Node where
561importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
562importJS safety body name qt = do
564 let (argTypes, _) = parseType t
565 argNames <- forM argTypes $ \_ -> do
567 argRef <- newName "argRef"
569 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
570 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
572 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
573 e <- lamE (map (varP. fst) argNames) $ go argNames
575 return $ jsffiDecs ++
577 , ValD (VarP n) (NormalB e) []
580mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
582mkJSFFI safety body = do
583 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
585 n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
586 t <- [t| JSFFI_Internal |]
587 let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
588 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
589 e <- [| JSFFI $(varE n) |]
593 e <- [| JSFFI body |]
597parseType :: Type -> ([Type], Type)
598parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
599 | monadJs == ''MonadJS = go funType
600 where go t = case t of
601 AppT (AppT ArrowT arg) t' ->
602 let (args, result) = go t'
603 in (arg : args, result)
604 AppT (VarT m') result
605 | m' == m -> ([], result)
606 _ -> error $ "parseType: can't parse type " <> show t
607parseType 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