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.Deletable.Class
25import Reflex.DynamicWriter
26import Reflex.PerformEvent.Base
27import Reflex.PerformEvent.Class
28import Reflex.PostBuild.Class
29import Reflex.Host.Class
31import Language.Haskell.TH
34import qualified GHCJS.Buffer as JS
36import GHCJS.DOM.Types hiding (Text, fromJSString)
37import qualified GHCJS.DOM.Types as JS
38import qualified GHCJS.Foreign as JS
39import qualified GHCJS.Foreign.Callback as JS
40import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
41import qualified GHCJS.Marshal as JS
42import qualified GHCJS.Marshal.Pure as JS
43import qualified GHCJS.Types as JS
44import qualified JavaScript.Array as JS
45import qualified JavaScript.Array.Internal (SomeJSArray (..))
46import qualified JavaScript.Object as JS
47import qualified JavaScript.Object.Internal (Object (..))
48import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
57import Graphics.UI.Gtk.WebKit.DOM.Node
58import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
59import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
60import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
61import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
62import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
63import Graphics.UI.Gtk.WebKit.WebView
67import Control.Concurrent
69import Control.Monad.Exception
70import Control.Monad.Fix
71import Control.Monad.IO.Class
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
112newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
114instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
115 {-# INLINABLE newEventWithTrigger #-}
116 newEventWithTrigger = lift . newEventWithTrigger
117 {-# INLINABLE newFanEventWithTrigger #-}
118 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
120instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
121 {-# INLINABLE subscribeEvent #-}
122 subscribeEvent = lift . subscribeEvent
124instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
125 type ReadPhase (WithWebView x m) = ReadPhase m
126 {-# INLINABLE fireEventsAndRead #-}
127 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
128 {-# INLINABLE runHostFrame #-}
129 runHostFrame = lift . runHostFrame
131instance MonadSample t m => MonadSample t (WithWebView x m) where
132 {-# INLINABLE sample #-}
133 sample = lift . sample
135instance MonadHold t m => MonadHold t (WithWebView x m) where
136 {-# INLINABLE hold #-}
137 hold v0 = lift . hold v0
138 {-# INLINABLE holdDyn #-}
139 holdDyn v0 = lift . holdDyn v0
140 {-# INLINABLE holdIncremental #-}
141 holdIncremental v0 = lift . holdIncremental v0
143instance MonadTransControl (WithWebView x) where
144 type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
145 {-# INLINABLE liftWith #-}
146 liftWith = defaultLiftWith WithWebView unWithWebView
147 {-# INLINABLE restoreT #-}
148 restoreT = defaultRestoreT WithWebView
150instance PerformEvent t m => PerformEvent t (WithWebView x m) where
151 type Performable (WithWebView x m) = WithWebView x (Performable m)
152 {-# INLINABLE performEvent_ #-}
153 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
154 {-# INLINABLE performEvent #-}
155 performEvent e = liftWith $ \run -> performEvent $ fmap run e
157instance Deletable t m => Deletable t (WithWebView x m) where
158 {-# INLINABLE deletable #-}
159 deletable = liftThrough . deletable
161runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
162runWithWebView = runReaderT . unWithWebView
164instance (Monad m) => HasWebView (WithWebView x m) where
165 type WebViewPhantom (WithWebView x m) = x
166 askWebView = WithWebView ask
168instance MonadRef m => MonadRef (WithWebView x m) where
169 type Ref (WithWebView x m) = Ref m
170 newRef = lift . newRef
171 readRef = lift . readRef
172 writeRef r = lift . writeRef r
174instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
175 atomicModifyRef r = lift . atomicModifyRef r
177withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
178withWebViewSingleton wv f = f $ WebViewSingleton wv
180-- | 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
181newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
184type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
185newtype JSFFI = JSFFI JSFFI_Internal
187newtype JSFFI = JSFFI String
190newtype JSFun x = JSFun { unJSFun :: JSRef x }
192instance ToJS x (JSFun x) where
193 withJS (JSFun r) f = f r
195instance FromJS x (JSFun x) where
196 fromJS = return . JSFun
198class IsJSContext x where
201class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
203 liftJS :: JSM m a -> m a
205instance HasJS x m => HasJS x (ReaderT r m) where
206 type JSM (ReaderT r m) = JSM m
207 liftJS = lift . liftJS
209instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
210 type JSM (PostBuildT t m) = JSM m
211 liftJS = lift . liftJS
213instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
214 type JSM (PerformEventT t m) = JSM (HostFrame t)
215 liftJS = PerformEventT . lift . liftJS
217instance HasJS x m => HasJS x (DynamicWriterT t w m) where
218 type JSM (DynamicWriterT t w m) = JSM m
219 liftJS = lift . liftJS
221-- | A Monad that is capable of executing JavaScript
222class Monad m => MonadJS x m | m -> x where
223 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
224 forkJS :: m () -> m ThreadId
225 mkJSUndefined :: m (JSRef x)
226 isJSNull :: JSRef x -> m Bool
227 isJSUndefined :: JSRef x -> m Bool
228 fromJSBool :: JSRef x -> m Bool
229 fromJSString :: JSRef x -> m String
230 fromJSArray :: JSRef x -> m [JSRef x]
231 fromJSUint8Array :: JSRef x -> m ByteString
232 fromJSNumber :: JSRef x -> m Double
233 withJSBool :: Bool -> (JSRef x -> m r) -> m r
234 withJSString :: String -> (JSRef x -> m r) -> m r
235 withJSNumber :: Double -> (JSRef x -> m r) -> m r
236 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
237 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
238 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
239 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
240 freeJSFun :: JSFun x -> m ()
241 setJSProp :: String -> JSRef x -> JSRef x -> m ()
242 getJSProp :: String -> JSRef x -> m (JSRef x)
243 withJSNode :: Node -> (JSRef x -> m r) -> m r
249instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
250 type JSM (WithWebView x m) = IO
253instance IsJSContext JSCtx_IO where
254 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
256instance MonadJS JSCtx_IO IO where
257 runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)
259 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
260 isJSNull (JSRef_IO r) = return $ JS.isNull r
261 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
262 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
263 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
264 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
265 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
266 fromJSNumber (JSRef_IO r) = do
267 Just n <- JS.fromJSVal r
269 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
270 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
271 withJSNumber n f = do
275 r <- JS.fromListIO $ coerce l
276 f $ JSRef_IO $ coerce r
277 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
278 ba <- extractByteArray cStr $ BS.length payload
279 f $ JSUint8Array $ JSRef_IO ba
281 cb <- JS.syncCallback1' $ \args -> do
282 l <- JS.toListIO $ coerce args
283 JSRef_IO result <- f $ coerce l
285 fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
286 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
287 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
288 getJSProp s (JSRef_IO o) = do
289 r <- JS.getProp (JS.toJSString s) $ coerce o
291 withJSNode n f = f $ JSRef_IO $ unNode n
293foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
295foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
299-- | Make a JS string available that is not wrapped up as a JSValueRef
300withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
301withJSStringRaw str a = do
302 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
305fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double
306fromJSNumberRaw val = do
307 jsContext <- askJSContext
308 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
311data JSCtx_JavaScriptCore x
313instance IsJSContext (JSCtx_JavaScriptCore x) where
314 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
316instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
317 type JSM (WithWebView x m) = WithWebView x IO
320 liftIO $ runWithWebView a wv
322newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
324runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
325runWithJSContext = runReaderT . unWithJSContext
327class Monad m => HasJSContext m where
328 askJSContext :: m JSContextRef
330instance MonadIO m => HasJSContext (WithWebView x m) where
333 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
335instance Monad m => HasJSContext (WithJSContext x m) where
336 askJSContext = WithJSContext ask
338lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
339lowerWithJSContext a = do
341 liftIO $ runWithJSContext a c
343liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
344 => ((t1 -> t m1 a) -> WithJSContext x IO b)
345 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
347liftWithWebViewThroughWithJSContext f a = do
349 lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv
351instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
354 liftIO $ forkIO $ runWithWebView a wv
357 lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv
358 runJS expr args = lowerWithJSContext $ runJS expr args
359 mkJSUndefined = lowerWithJSContext mkJSUndefined
360 isJSNull = lowerWithJSContext . isJSNull
361 isJSUndefined = lowerWithJSContext . isJSUndefined
362 fromJSBool = lowerWithJSContext . fromJSBool
363 fromJSString = lowerWithJSContext . fromJSString
364 fromJSArray = lowerWithJSContext . fromJSArray
365 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
366 fromJSNumber = lowerWithJSContext . fromJSNumber
367 freeJSFun = lowerWithJSContext . freeJSFun
368 withJSBool = liftWithWebViewThroughWithJSContext . withJSBool
369 withJSString = liftWithWebViewThroughWithJSContext . withJSString
370 withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber
371 withJSArray = liftWithWebViewThroughWithJSContext . withJSArray
372 withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array
373 withJSNode = liftWithWebViewThroughWithJSContext . withJSNode
374 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
375 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
377instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
378 runJS (JSFFI body) args = do
379 jsContext <- askJSContext
380 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
381 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
382 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
385 liftIO $ forkIO $ runWithJSContext a c
387 jsContext <- askJSContext
388 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
389 isJSNull (JSRef_JavaScriptCore r) = do
390 jsContext <- askJSContext
391 liftIO $ jsvalueisnull jsContext r
392 isJSUndefined (JSRef_JavaScriptCore r) = do
393 jsContext <- askJSContext
394 liftIO $ jsvalueisundefined jsContext r
395 fromJSBool (JSRef_JavaScriptCore r) = do
396 jsContext <- askJSContext
397 liftIO $ jsvaluetoboolean jsContext r
398 fromJSString (JSRef_JavaScriptCore r) = do
399 jsContext <- askJSContext
401 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
402 l <- jsstringgetmaximumutf8cstringsize s
403 allocaBytes (fromIntegral l) $ \ps -> do
404 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
407 jsContext <- askJSContext
408 valRef <- liftIO $ jsvaluemakeboolean jsContext b
409 a $ JSRef_JavaScriptCore valRef
410 withJSString str a = do
411 jsContext <- askJSContext
412 withJSStringRaw str $ \strRef -> do
413 valRef <- liftIO $ jsvaluemakestring jsContext strRef
414 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
415 withJSNumber n a = do
416 jsContext <- askJSContext
417 valRef <- liftIO $ jsvaluemakenumber jsContext n
418 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
419 withJSArray elems a = do
420 jsContext <- askJSContext
421 let numElems = length elems
422 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
423 liftIO $ pokeArray elemsArr $ coerce elems
424 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
425 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
426 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
427 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
428 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
429 f $ JSUint8Array payloadRef
430 fromJSArray (JSRef_JavaScriptCore a) = do
431 jsContext <- askJSContext
432 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
433 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
434 lenDouble <- fromJSNumberRaw lenRef
435 let len = round lenDouble
436 liftIO $ forM [0..len-1] $ \i -> do
437 JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
438 fromJSUint8Array a = do
439 vals <- fromJSArray a
440 doubles <- mapM fromJSNumber vals
441 return $ BS.pack $ map round doubles
442 fromJSNumber (JSRef_JavaScriptCore val) = do
443 jsContext <- askJSContext
444 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
446 jsContext <- askJSContext
447 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
448 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
449 x <- peekElemOff argv n
450 jsvalueprotect jsContext x
451 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
452 unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext
453 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
454 liftIO $ jsvalueprotect jsContext cbRef
455 return $ JSFun $ JSRef_JavaScriptCore cbRef
456 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
457 jsContext <- askJSContext
458 liftIO $ jsvalueunprotect jsContext f
459 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
460 withJSStringRaw propName $ \propNameRaw -> do
461 jsContext <- askJSContext
462 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
463 getJSProp propName (JSRef_JavaScriptCore objRef) = do
464 withJSStringRaw propName $ \propNameRaw -> do
465 jsContext <- askJSContext
466 liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
467 withJSNode = error "withJSNode is only supported in ghcjs"
471class FromJS x a where
472 fromJS :: MonadJS x m => JSRef x -> m a
474instance FromJS x () where
475 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
477instance FromJS x Bool where
480instance ToJS x Bool where
483instance FromJS x String where
484 fromJS = fromJSString
486instance FromJS x Text where
487 fromJS s = T.pack <$> fromJSString s
489instance FromJS x a => FromJS x (Maybe a) where
492 if n then return Nothing else Just <$> fromJS x
495 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
497instance ToJS x (JSRef x) where
500instance FromJS x (JSRef x) where
503instance ToJS x String where
504 withJS = withJSString
506instance ToJS x Text where
507 withJS = withJSString . T.unpack
509newtype JSArray a = JSArray { unJSArray :: [a] }
511instance ToJS x a => ToJS x (JSArray a) where
512 withJS = withJSArrayFromList . unJSArray
514instance FromJS x a => FromJS x (JSArray a) where
515 fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
517withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
518withJSArrayFromList as f = go as []
519 where go [] jsRefs = withJSArray (reverse jsRefs) f
520 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
522newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
524instance ToJS x (JSUint8Array x) where
525 withJS (JSUint8Array r) = ($ r)
527instance FromJS x (JSUint8Array x) where
528 fromJS = return . JSUint8Array
530instance ToJS x Word8 where
531 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
533instance ToJS x Int where
534 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
536instance FromJS x Int where
537 fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
539instance ToJS x Double where
540 withJS = withJSNumber
542instance FromJS x Double where
543 fromJS = fromJSNumber
545instance ToJS x Node where
549importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
550importJS safety body name qt = do
552 let (argTypes, _) = parseType t
553 argNames <- forM argTypes $ \_ -> do
555 argRef <- newName "argRef"
557 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
558 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
560 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
561 e <- lamE (map (varP. fst) argNames) $ go argNames
563 return $ jsffiDecs ++
565 , ValD (VarP n) (NormalB e) []
568mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
570mkJSFFI safety body = do
571 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
573 n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
574 t <- [t| JSFFI_Internal |]
575 let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
576 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
577 e <- [| JSFFI $(varE n) |]
581 e <- [| JSFFI body |]
585parseType :: Type -> ([Type], Type)
586parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
587 | monadJs == ''MonadJS = go funType
588 where go t = case t of
589 AppT (AppT ArrowT arg) t' ->
590 let (args, result) = go t'
591 in (arg : args, result)
592 AppT (VarT m') result
593 | m' == m -> ([], result)
594 _ -> error $ "parseType: can't parse type " <> show t
595parseType 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