1{-# LANGUAGE ForeignFunctionInterface, CPP, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, GeneralizedNewtypeDeriving, ExistentialQuantification, FunctionalDependencies, EmptyDataDecls, FlexibleContexts, RankNTypes, UndecidableInstances #-}
3{-# LANGUAGE JavaScriptFFI #-}
5module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
10import Reflex.Host.Class
11import Reflex.Dom.PerformEvent.Class
12import Reflex.Dom.Deletable.Class
14import Language.Haskell.TH
17import qualified GHCJS.Marshal as JS
18import qualified GHCJS.Marshal.Pure as JS
19import qualified GHCJS.Foreign as JS
20import qualified GHCJS.Foreign.Callback as JS
21import qualified GHCJS.Types as JS
22import qualified GHCJS.Buffer as JS
24import GHCJS.DOM.Types hiding (fromJSString, Text)
25import qualified GHCJS.DOM.Types as JS
26import qualified JavaScript.Array as JS
27import qualified JavaScript.Object as JS
28import qualified JavaScript.Object.Internal (Object (..))
29import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
30import qualified JavaScript.Array.Internal (SomeJSArray (..))
31import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
40import Graphics.UI.Gtk.WebKit.WebView
41import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
42import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
43import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
44import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
45import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
46import Graphics.UI.Gtk.WebKit.DOM.Node
51import Control.Monad.Ref
52import Control.Monad.Fix
53import Control.Monad.IO.Class
54import Control.Monad.Exception
55import Control.Monad.Reader
56import Control.Monad.State
57import Control.Monad.Trans.Control
58import qualified Control.Monad.State.Strict as Strict
59import Data.ByteString (ByteString)
60import qualified Data.ByteString as BS
61import Control.Concurrent
64import Data.Text (Text)
65import qualified Data.Text as T
67class Monad m => HasWebView m where
68 type WebViewPhantom m :: *
69 askWebView :: m (WebViewSingleton (WebViewPhantom m))
71instance HasWebView m => HasWebView (ReaderT r m) where
72 type WebViewPhantom (ReaderT r m) = WebViewPhantom m
73 askWebView = lift askWebView
75instance HasWebView m => HasWebView (StateT r m) where
76 type WebViewPhantom (StateT r m) = WebViewPhantom m
77 askWebView = lift askWebView
79instance HasWebView m => HasWebView (Strict.StateT r m) where
80 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m
81 askWebView = lift askWebView
83newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
85instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
86 {-# INLINABLE newEventWithTrigger #-}
87 newEventWithTrigger = lift . newEventWithTrigger
88 {-# INLINABLE newFanEventWithTrigger #-}
89 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
91instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
92 {-# INLINABLE subscribeEvent #-}
93 subscribeEvent = lift . subscribeEvent
95instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
96 type ReadPhase (WithWebView x m) = ReadPhase m
97 {-# INLINABLE fireEventsAndRead #-}
98 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
99 {-# INLINABLE runHostFrame #-}
100 runHostFrame = lift . runHostFrame
102instance MonadSample t m => MonadSample t (WithWebView x m) where
103 {-# INLINABLE sample #-}
104 sample = lift . sample
106instance MonadHold t m => MonadHold t (WithWebView x m) where
107 {-# INLINABLE hold #-}
108 hold v0 = lift . hold v0
109 {-# INLINABLE holdDyn #-}
110 holdDyn v0 = lift . holdDyn v0
111 {-# INLINABLE holdIncremental #-}
112 holdIncremental v0 = lift . holdIncremental v0
114instance MonadTransControl (WithWebView x) where
115 type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
116 {-# INLINABLE liftWith #-}
117 liftWith = defaultLiftWith WithWebView unWithWebView
118 {-# INLINABLE restoreT #-}
119 restoreT = defaultRestoreT WithWebView
121instance PerformEvent t m => PerformEvent t (WithWebView x m) where
122 type Performable (WithWebView x m) = WithWebView x (Performable m)
123 {-# INLINABLE performEvent_ #-}
124 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
125 {-# INLINABLE performEvent #-}
126 performEvent e = liftWith $ \run -> performEvent $ fmap run e
128instance Deletable t m => Deletable t (WithWebView x m) where
129 {-# INLINABLE deletable #-}
130 deletable = liftThrough . deletable
132runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
133runWithWebView = runReaderT . unWithWebView
135instance (Monad m) => HasWebView (WithWebView x m) where
136 type WebViewPhantom (WithWebView x m) = x
137 askWebView = WithWebView ask
139instance MonadRef m => MonadRef (WithWebView x m) where
140 type Ref (WithWebView x m) = Ref m
141 newRef = lift . newRef
142 readRef = lift . readRef
143 writeRef r = lift . writeRef r
145instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
146 atomicModifyRef r = lift . atomicModifyRef r
148withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
149withWebViewSingleton wv f = f $ WebViewSingleton wv
151-- | 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
152newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
155type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
156newtype JSFFI = JSFFI JSFFI_Internal
158newtype JSFFI = JSFFI String
161newtype JSFun x = JSFun { unJSFun :: JSRef x }
163instance ToJS x (JSFun x) where
164 withJS (JSFun r) f = f r
166instance FromJS x (JSFun x) where
167 fromJS = return . JSFun
169class IsJSContext x where
172class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
174 liftJS :: JSM m a -> m a
176instance HasJS x m => HasJS x (ReaderT r m) where
177 type JSM (ReaderT r m) = JSM m
178 liftJS = lift . liftJS
180-- | A Monad that is capable of executing JavaScript
181class Monad m => MonadJS x m | m -> x where
182 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
183 forkJS :: m () -> m ThreadId
184 mkJSUndefined :: m (JSRef x)
185 isJSNull :: JSRef x -> m Bool
186 isJSUndefined :: JSRef x -> m Bool
187 fromJSBool :: JSRef x -> m Bool
188 fromJSString :: JSRef x -> m String
189 fromJSArray :: JSRef x -> m [JSRef x]
190 fromJSUint8Array :: JSRef x -> m ByteString
191 fromJSNumber :: JSRef x -> m Double
192 withJSBool :: Bool -> (JSRef x -> m r) -> m r
193 withJSString :: String -> (JSRef x -> m r) -> m r
194 withJSNumber :: Double -> (JSRef x -> m r) -> m r
195 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
196 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
197 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
198 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
199 freeJSFun :: JSFun x -> m ()
200 setJSProp :: String -> JSRef x -> JSRef x -> m ()
201 getJSProp :: String -> JSRef x -> m (JSRef x)
202 withJSNode :: Node -> (JSRef x -> m r) -> m r
208instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
209 type JSM (WithWebView x m) = IO
212instance IsJSContext JSCtx_IO where
213 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
215instance MonadJS JSCtx_IO IO where
216 runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.fromListIO (coerce l)
218 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
219 isJSNull (JSRef_IO r) = return $ JS.isNull r
220 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
221 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
222 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
223 fromJSArray (JSRef_IO r) = liftM coerce $ JS.toListIO $ coerce r
224 fromJSUint8Array (JSRef_IO r) = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
225 fromJSNumber (JSRef_IO r) = do
226 Just n <- JS.fromJSVal r
228 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
229 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
230 withJSNumber n f = do
234 r <- JS.fromListIO $ coerce l
235 f $ JSRef_IO $ coerce r
236 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
237 ba <- extractByteArray cStr $ BS.length payload
238 f $ JSUint8Array $ JSRef_IO ba
240 cb <- JS.syncCallback1' $ \args -> do
241 l <- JS.toListIO $ coerce args
242 JSRef_IO result <- f $ coerce l
244 liftM (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
245 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
246 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
247 getJSProp s (JSRef_IO o) = do
248 r <- JS.getProp (JS.toJSString s) $ coerce o
250 withJSNode n f = f $ JSRef_IO $ unNode n
252foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
254foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
258askJSContext :: MonadIO m => WithWebView x m JSContextRef
261 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
263-- | Make a JS string available that is not wrapped up as a JSValueRef
264withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
265withJSStringRaw str a = do
266 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
269fromJSNumberRaw :: MonadIO m => JSValueRef -> WithWebView x m Double
270fromJSNumberRaw val = do
271 jsContext <- askJSContext
272 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
275data JSCtx_JavaScriptCore x
277instance IsJSContext (JSCtx_JavaScriptCore x) where
278 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
280instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
281 type JSM (WithWebView x m) = WithWebView x IO
284 liftIO $ runWithWebView a wv
286instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
287 runJS (JSFFI body) args = do
288 jsContext <- askJSContext
289 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
290 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
291 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
294 liftIO $ forkIO $ runWithWebView a wv
296 jsContext <- askJSContext
297 liftM JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
298 isJSNull (JSRef_JavaScriptCore r) = do
299 jsContext <- askJSContext
300 liftIO $ jsvalueisnull jsContext r
301 isJSUndefined (JSRef_JavaScriptCore r) = do
302 jsContext <- askJSContext
303 liftIO $ jsvalueisundefined jsContext r
304 fromJSBool (JSRef_JavaScriptCore r) = do
305 jsContext <- askJSContext
306 liftIO $ jsvaluetoboolean jsContext r
307 fromJSString (JSRef_JavaScriptCore r) = do
308 jsContext <- askJSContext
310 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
311 l <- jsstringgetmaximumutf8cstringsize s
312 allocaBytes (fromIntegral l) $ \ps -> do
313 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
316 jsContext <- askJSContext
317 valRef <- liftIO $ jsvaluemakeboolean jsContext b
318 a $ JSRef_JavaScriptCore valRef
319 withJSString str a = do
320 jsContext <- askJSContext
321 withJSStringRaw str $ \strRef -> do
322 valRef <- liftIO $ jsvaluemakestring jsContext strRef
323 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
324 withJSNumber n a = do
325 jsContext <- askJSContext
326 valRef <- liftIO $ jsvaluemakenumber jsContext n
327 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
328 withJSArray elems a = do
329 jsContext <- askJSContext
330 let numElems = length elems
331 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
332 liftIO $ pokeArray elemsArr $ coerce elems
333 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
334 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
335 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
336 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
337 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
338 f $ JSUint8Array payloadRef
339 fromJSArray (JSRef_JavaScriptCore a) = do
340 jsContext <- askJSContext
341 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
342 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
343 lenDouble <- fromJSNumberRaw lenRef
344 let len = round lenDouble
345 liftIO $ forM [0..len-1] $ \i -> do
346 liftM JSRef_JavaScriptCore $ jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
347 fromJSUint8Array a = do
348 vals <- fromJSArray a
349 doubles <- mapM fromJSNumber vals
350 return $ BS.pack $ map round doubles
351 fromJSNumber (JSRef_JavaScriptCore val) = do
352 jsContext <- askJSContext
353 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
356 jsContext <- askJSContext
357 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
358 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
359 x <- peekElemOff argv n
360 jsvalueprotect jsContext x
361 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
362 liftM unJSRef_JavaScriptCore $ runWithWebView (a args) wv
363 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
364 liftIO $ jsvalueprotect jsContext cbRef
365 return $ JSFun $ JSRef_JavaScriptCore cbRef
366 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
367 jsContext <- askJSContext
368 liftIO $ jsvalueunprotect jsContext f
369 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
370 withJSStringRaw propName $ \propNameRaw -> do
371 jsContext <- askJSContext
372 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
373 getJSProp propName (JSRef_JavaScriptCore objRef) = do
374 withJSStringRaw propName $ \propNameRaw -> do
375 jsContext <- askJSContext
376 liftIO $ liftM JSRef_JavaScriptCore $ jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
377 withJSNode = error "withJSNode is only supported in ghcjs"
381class FromJS x a where
382 fromJS :: MonadJS x m => JSRef x -> m a
384instance FromJS x () where
385 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
387instance FromJS x Bool where
390instance ToJS x Bool where
393instance FromJS x String where
394 fromJS = fromJSString
396instance FromJS x Text where
397 fromJS s = T.pack <$> fromJSString s
399instance FromJS x a => FromJS x (Maybe a) where
402 if n then return Nothing else liftM Just $ fromJS x
405 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
407instance ToJS x (JSRef x) where
410instance FromJS x (JSRef x) where
413instance ToJS x String where
414 withJS = withJSString
416instance ToJS x Text where
417 withJS = withJSString . T.unpack
419newtype JSArray a = JSArray { unJSArray :: [a] }
421instance ToJS x a => ToJS x (JSArray a) where
422 withJS = withJSArrayFromList . unJSArray
424instance FromJS x a => FromJS x (JSArray a) where
425 fromJS = liftM JSArray . mapM fromJS <=< fromJSArray
427withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
428withJSArrayFromList as f = go as []
429 where go [] jsRefs = withJSArray (reverse jsRefs) f
430 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
432newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
434instance ToJS x (JSUint8Array x) where
435 withJS (JSUint8Array r) = ($ r)
437instance FromJS x (JSUint8Array x) where
438 fromJS = return . JSUint8Array
440instance ToJS x Word8 where
441 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
443instance ToJS x Int where
444 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
446instance FromJS x Int where
447 fromJS = liftM round . fromJSNumber --TODO: Check things; throw exceptions
449instance ToJS x Double where
450 withJS = withJSNumber
452instance FromJS x Double where
453 fromJS = fromJSNumber
455instance ToJS x Node where
459importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
460importJS safety body name qt = do
462 let (argTypes, _) = parseType t
463 argNames <- forM argTypes $ \_ -> do
465 argRef <- newName "argRef"
467 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
468 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
470 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
471 e <- lamE (map (varP. fst) argNames) $ go argNames
473 return $ jsffiDecs ++
475 , ValD (VarP n) (NormalB e) []
478mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
480mkJSFFI safety body = do
481 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
483 n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
484 t <- [t| JSFFI_Internal |]
485 let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
486 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
487 e <- [| JSFFI $(varE n) |]
491 e <- [| JSFFI body |]
495parseType :: Type -> ([Type], Type)
496parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
497 | monadJs == ''MonadJS = go funType
498 where go t = case t of
499 AppT (AppT ArrowT arg) t' ->
500 let (args, result) = go t'
501 in (arg : args, result)
502 AppT (VarT m') result
503 | m' == m -> ([], result)
504 _ -> error $ "parseType: can't parse type " <> show t
505parseType 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