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.EventWriter
26import Reflex.Host.Class
27import Reflex.PerformEvent.Base
28import Reflex.PerformEvent.Class
29import Reflex.PostBuild.Base
30import Reflex.Requester.Base
32import Language.Haskell.TH
35import qualified GHCJS.Buffer as JS
37import GHCJS.DOM.Types hiding (Text, fromJSString)
38import qualified GHCJS.DOM.Types as JS
39import qualified GHCJS.Foreign as JS
40import qualified GHCJS.Foreign.Callback as JS
41import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
42import qualified GHCJS.Marshal as JS
43import qualified GHCJS.Marshal.Pure as JS
44import qualified GHCJS.Types as JS
45import qualified JavaScript.Array as JS
46import qualified JavaScript.Array.Internal (SomeJSArray (..))
47import qualified JavaScript.Object as JS
48import qualified JavaScript.Object.Internal (Object (..))
49import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
58import Graphics.UI.Gtk.WebKit.DOM.Node
59import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
60import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
61import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
62import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
63import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
64import Graphics.UI.Gtk.WebKit.WebView
68import Control.Concurrent
70import Control.Monad.Exception
71import Control.Monad.Fix
72import Control.Monad.IO.Class
73import Control.Monad.Primitive
74import Control.Monad.Reader
75import Control.Monad.Ref
76import Control.Monad.State
77import qualified Control.Monad.State.Strict as Strict
78import Control.Monad.Trans.Control
79import Data.ByteString (ByteString)
80import qualified Data.ByteString as BS
83import Data.Text (Text)
84import 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 (EventWriterT t w m) where
115 type WebViewPhantom (EventWriterT t w m) = WebViewPhantom m
116 askWebView = lift askWebView
118instance HasWebView m => HasWebView (RequesterT t request response m) where
119 type WebViewPhantom (RequesterT t request response m) = WebViewPhantom m
120 askWebView = lift askWebView
122newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
124instance PrimMonad m => PrimMonad (WithWebView x m) where
125 type PrimState (WithWebView x m) = PrimState m
126 primitive = lift . primitive
128instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where
129 runWithReplace a0 a' = WithWebView $ runWithReplace (coerce a0) (coerceEvent a')
130 sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
132instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
133 {-# INLINABLE newEventWithTrigger #-}
134 newEventWithTrigger = lift . newEventWithTrigger
135 {-# INLINABLE newFanEventWithTrigger #-}
136 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
138instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
139 {-# INLINABLE subscribeEvent #-}
140 subscribeEvent = lift . subscribeEvent
142instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
143 type ReadPhase (WithWebView x m) = ReadPhase m
144 {-# INLINABLE fireEventsAndRead #-}
145 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
146 {-# INLINABLE runHostFrame #-}
147 runHostFrame = lift . runHostFrame
149instance MonadSample t m => MonadSample t (WithWebView x m) where
150 {-# INLINABLE sample #-}
151 sample = lift . sample
153instance MonadHold t m => MonadHold t (WithWebView x m) where
154 {-# INLINABLE hold #-}
155 hold v0 = lift . hold v0
156 {-# INLINABLE holdDyn #-}
157 holdDyn v0 = lift . holdDyn v0
158 {-# INLINABLE holdIncremental #-}
159 holdIncremental v0 = lift . holdIncremental v0
161instance MonadTransControl (WithWebView x) where
162 type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
163 {-# INLINABLE liftWith #-}
164 liftWith = defaultLiftWith WithWebView unWithWebView
165 {-# INLINABLE restoreT #-}
166 restoreT = defaultRestoreT WithWebView
168instance PerformEvent t m => PerformEvent t (WithWebView x m) where
169 type Performable (WithWebView x m) = WithWebView x (Performable m)
170 {-# INLINABLE performEvent_ #-}
171 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
172 {-# INLINABLE performEvent #-}
173 performEvent e = liftWith $ \run -> performEvent $ fmap run e
175runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
176runWithWebView = runReaderT . unWithWebView
178instance (Monad m) => HasWebView (WithWebView x m) where
179 type WebViewPhantom (WithWebView x m) = x
180 askWebView = WithWebView ask
182instance MonadRef m => MonadRef (WithWebView x m) where
183 type Ref (WithWebView x m) = Ref m
184 newRef = lift . newRef
185 readRef = lift . readRef
186 writeRef r = lift . writeRef r
188instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
189 atomicModifyRef r = lift . atomicModifyRef r
191withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
192withWebViewSingleton wv f = f $ WebViewSingleton wv
194-- | Warning: `withWebViewSingletonMono` does not provide the same guarantees that `withWebViewSingleton` does.
195withWebViewSingletonMono :: WebView -> (WebViewSingleton () -> r) -> r
196withWebViewSingletonMono wv f = f $ WebViewSingleton wv
198-- | 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
199newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
202type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
203newtype JSFFI = JSFFI JSFFI_Internal
205newtype JSFFI = JSFFI String
208newtype JSFun x = JSFun { unJSFun :: JSRef x }
210instance ToJS x (JSFun x) where
211 withJS (JSFun r) f = f r
213instance FromJS x (JSFun x) where
214 fromJS = return . JSFun
216class IsJSContext x where
219class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
221 liftJS :: JSM m a -> m a
223instance HasJS x m => HasJS x (ReaderT r m) where
224 type JSM (ReaderT r m) = JSM m
225 liftJS = lift . liftJS
227instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
228 type JSM (PostBuildT t m) = JSM m
229 liftJS = lift . liftJS
231instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
232 type JSM (PerformEventT t m) = JSM (HostFrame t)
233 liftJS = PerformEventT . lift . liftJS
235instance HasJS x m => HasJS x (DynamicWriterT t w m) where
236 type JSM (DynamicWriterT t w m) = JSM m
237 liftJS = lift . liftJS
239instance HasJS x m => HasJS x (RequesterT t request response m) where
240 type JSM (RequesterT t request response m) = JSM m
241 liftJS = lift . liftJS
243-- | A Monad that is capable of executing JavaScript
244class Monad m => MonadJS x m | m -> x where
245 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
246 forkJS :: m () -> m ThreadId
247 mkJSUndefined :: m (JSRef x)
248 isJSNull :: JSRef x -> m Bool
249 isJSUndefined :: JSRef x -> m Bool
250 fromJSBool :: JSRef x -> m Bool
251 fromJSString :: JSRef x -> m String
252 fromJSArray :: JSRef x -> m [JSRef x]
253 fromJSUint8Array :: JSRef x -> m ByteString
254 fromJSNumber :: JSRef x -> m Double
255 withJSBool :: Bool -> (JSRef x -> m r) -> m r
256 withJSString :: String -> (JSRef x -> m r) -> m r
257 withJSNumber :: Double -> (JSRef x -> m r) -> m r
258 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
259 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
260 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
261 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
262 freeJSFun :: JSFun x -> m ()
263 setJSProp :: String -> JSRef x -> JSRef x -> m ()
264 getJSProp :: String -> JSRef x -> m (JSRef x)
265 withJSNode :: Node -> (JSRef x -> m r) -> m r
271instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
272 type JSM (WithWebView x m) = IO
275instance IsJSContext JSCtx_IO where
276 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
278instance MonadJS JSCtx_IO IO where
279 runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)
281 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
282 isJSNull (JSRef_IO r) = return $ JS.isNull r
283 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
284 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
285 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
286 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
287 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
288 fromJSNumber (JSRef_IO r) = do
289 Just n <- JS.fromJSVal r
291 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
292 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
293 withJSNumber n f = do
297 r <- JS.fromListIO $ coerce l
298 f $ JSRef_IO $ coerce r
299 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
300 ba <- extractByteArray cStr $ BS.length payload
301 f $ JSUint8Array $ JSRef_IO ba
303 cb <- JS.syncCallback1' $ \args -> do
304 l <- JS.toListIO $ coerce args
305 JSRef_IO result <- f $ coerce l
307 fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
308 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
309 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
310 getJSProp s (JSRef_IO o) = do
311 r <- JS.getProp (JS.toJSString s) $ coerce o
313 withJSNode n f = f $ JSRef_IO $ unNode n
315foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
317foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
321-- | Make a JS string available that is not wrapped up as a JSValueRef
322withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
323withJSStringRaw str a = do
324 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
327fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double
328fromJSNumberRaw val = do
329 jsContext <- askJSContext
330 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
333data JSCtx_JavaScriptCore x
335instance IsJSContext (JSCtx_JavaScriptCore x) where
336 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
338instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
339 type JSM (WithWebView x m) = WithWebView x IO
342 liftIO $ runWithWebView a wv
344newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
346runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
347runWithJSContext = runReaderT . unWithJSContext
349class Monad m => HasJSContext m where
350 askJSContext :: m JSContextRef
352instance MonadIO m => HasJSContext (WithWebView x m) where
355 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
357instance Monad m => HasJSContext (WithJSContext x m) where
358 askJSContext = WithJSContext ask
360lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
361lowerWithJSContext a = do
363 liftIO $ runWithJSContext a c
365liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
366 => ((t1 -> t m1 a) -> WithJSContext x IO b)
367 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
369liftWithWebViewThroughWithJSContext f a = do
371 lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv
373instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
376 liftIO $ forkIO $ runWithWebView a wv
379 lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv
380 runJS expr args = lowerWithJSContext $ runJS expr args
381 mkJSUndefined = lowerWithJSContext mkJSUndefined
382 isJSNull = lowerWithJSContext . isJSNull
383 isJSUndefined = lowerWithJSContext . isJSUndefined
384 fromJSBool = lowerWithJSContext . fromJSBool
385 fromJSString = lowerWithJSContext . fromJSString
386 fromJSArray = lowerWithJSContext . fromJSArray
387 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
388 fromJSNumber = lowerWithJSContext . fromJSNumber
389 freeJSFun = lowerWithJSContext . freeJSFun
390 withJSBool = liftWithWebViewThroughWithJSContext . withJSBool
391 withJSString = liftWithWebViewThroughWithJSContext . withJSString
392 withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber
393 withJSArray = liftWithWebViewThroughWithJSContext . withJSArray
394 withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array
395 withJSNode = liftWithWebViewThroughWithJSContext . withJSNode
396 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
397 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
399instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
400 runJS (JSFFI body) args = do
401 jsContext <- askJSContext
402 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
403 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
404 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
407 liftIO $ forkIO $ runWithJSContext a c
409 jsContext <- askJSContext
410 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
411 isJSNull (JSRef_JavaScriptCore r) = do
412 jsContext <- askJSContext
413 liftIO $ jsvalueisnull jsContext r
414 isJSUndefined (JSRef_JavaScriptCore r) = do
415 jsContext <- askJSContext
416 liftIO $ jsvalueisundefined jsContext r
417 fromJSBool (JSRef_JavaScriptCore r) = do
418 jsContext <- askJSContext
419 liftIO $ jsvaluetoboolean jsContext r
420 fromJSString (JSRef_JavaScriptCore r) = do
421 jsContext <- askJSContext
423 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
424 l <- jsstringgetmaximumutf8cstringsize s
425 allocaBytes (fromIntegral l) $ \ps -> do
426 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
429 jsContext <- askJSContext
430 valRef <- liftIO $ jsvaluemakeboolean jsContext b
431 a $ JSRef_JavaScriptCore valRef
432 withJSString str a = do
433 jsContext <- askJSContext
434 withJSStringRaw str $ \strRef -> do
435 valRef <- liftIO $ jsvaluemakestring jsContext strRef
436 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
437 withJSNumber n a = do
438 jsContext <- askJSContext
439 valRef <- liftIO $ jsvaluemakenumber jsContext n
440 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
441 withJSArray elems a = do
442 jsContext <- askJSContext
443 let numElems = length elems
444 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
445 liftIO $ pokeArray elemsArr $ coerce elems
446 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
447 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
448 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
449 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
450 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
451 f $ JSUint8Array payloadRef
452 fromJSArray (JSRef_JavaScriptCore a) = do
453 jsContext <- askJSContext
454 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
455 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
456 lenDouble <- fromJSNumberRaw lenRef
457 let len = round lenDouble
458 liftIO $ forM [0..len-1] $ \i -> do
459 JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
460 fromJSUint8Array a = do
461 vals <- fromJSArray a
462 doubles <- mapM fromJSNumber vals
463 return $ BS.pack $ map round doubles
464 fromJSNumber (JSRef_JavaScriptCore val) = do
465 jsContext <- askJSContext
466 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
468 jsContext <- askJSContext
469 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
470 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
471 x <- peekElemOff argv n
472 jsvalueprotect jsContext x
473 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
474 unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext
475 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
476 liftIO $ jsvalueprotect jsContext cbRef
477 return $ JSFun $ JSRef_JavaScriptCore cbRef
478 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
479 jsContext <- askJSContext
480 liftIO $ jsvalueunprotect jsContext f
481 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
482 withJSStringRaw propName $ \propNameRaw -> do
483 jsContext <- askJSContext
484 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
485 getJSProp propName (JSRef_JavaScriptCore objRef) = do
486 withJSStringRaw propName $ \propNameRaw -> do
487 jsContext <- askJSContext
488 liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
489 withJSNode = error "withJSNode is only supported in ghcjs"
493class FromJS x a where
494 fromJS :: MonadJS x m => JSRef x -> m a
496instance FromJS x () where
497 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
499instance FromJS x Bool where
502instance ToJS x Bool where
505instance FromJS x String where
506 fromJS = fromJSString
508instance FromJS x Text where
509 fromJS s = T.pack <$> fromJSString s
511instance FromJS x a => FromJS x (Maybe a) where
514 if n then return Nothing else Just <$> fromJS x
517 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
519instance ToJS x (JSRef x) where
522instance FromJS x (JSRef x) where
525instance ToJS x String where
526 withJS = withJSString
528instance ToJS x Text where
529 withJS = withJSString . T.unpack
531newtype JSArray a = JSArray { unJSArray :: [a] }
533instance ToJS x a => ToJS x (JSArray a) where
534 withJS = withJSArrayFromList . unJSArray
536instance FromJS x a => FromJS x (JSArray a) where
537 fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
539withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
540withJSArrayFromList as f = go as []
541 where go [] jsRefs = withJSArray (reverse jsRefs) f
542 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
544newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
546instance ToJS x (JSUint8Array x) where
547 withJS (JSUint8Array r) = ($ r)
549instance FromJS x (JSUint8Array x) where
550 fromJS = return . JSUint8Array
552instance ToJS x Word8 where
553 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
555instance ToJS x Int where
556 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
558instance FromJS x Int where
559 fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
561instance ToJS x Double where
562 withJS = withJSNumber
564instance FromJS x Double where
565 fromJS = fromJSNumber
567instance ToJS x Node where
571importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
572importJS safety body name qt = do
574 let (argTypes, _) = parseType t
575 argNames <- forM argTypes $ \_ -> do
577 argRef <- newName "argRef"
579 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
580 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
582 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
583 e <- lamE (map (varP. fst) argNames) $ go argNames
585 return $ jsffiDecs ++
587 , ValD (VarP n) (NormalB e) []
590mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
592mkJSFFI safety body = do
593 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
595 n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
596 t <- [t| JSFFI_Internal |]
597 let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
598 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
599 e <- [| JSFFI $(varE n) |]
603 e <- [| JSFFI body |]
607parseType :: Type -> ([Type], Type)
608parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
609 | monadJs == ''MonadJS = go funType
610 where go t = case t of
611 AppT (AppT ArrowT arg) t' ->
612 let (args, result) = go t'
613 in (arg : args, result)
614 AppT (VarT m') result
615 | m' == m -> ([], result)
616 _ -> error $ "parseType: can't parse type " <> show t
617parseType 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