git.iko.soy/reflex-dom
on 2ea6efe help sign in
reflex-dom/src/Foreign/JavaScript/TH.hs
397 lines 15 kB history raw
1{-# LANGUAGE ForeignFunctionInterface, CPP, TemplateHaskell, TypeFamilies, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, GeneralizedNewtypeDeriving, ExistentialQuantification, FunctionalDependencies, EmptyDataDecls, FlexibleContexts, RankNTypes #-}
2#ifdef __GHCJS__
3{-# LANGUAGE JavaScriptFFI #-}
4#endif
5module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
6 , Safety (..)
7 ) where
9import Language.Haskell.TH
11#ifdef __GHCJS__
12import qualified GHCJS.Marshal as JS
13import qualified GHCJS.Foreign as JS
14import qualified GHCJS.Types as JS
15import GHCJS.DOM.Types
16import Data.Word
17import Foreign.Ptr
18import Foreign.C.Types
19import Data.Hashable
20#else
21import System.Glib.FFI hiding (withForeignPtr)
22import Graphics.UI.Gtk.WebKit.WebView
23import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
24import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
25import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
26import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
27import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
28import Graphics.UI.Gtk.WebKit.DOM.Node
29import Graphics.UI.Gtk.WebKit.Types
30#endif
32import Control.Monad
33import Control.Monad.Fix
34import Control.Monad.IO.Class
35import Control.Monad.Exception
36import Foreign.Marshal
37import Data.ByteString (ByteString)
38import qualified Data.ByteString as BS
39import Control.Concurrent
40import Data.Coerce
42import Reflex.Dom (WithWebView, askWebView, runWithWebView, unWebViewSingleton)
44#ifdef __GHCJS__
45type JSFFI_Internal = JS.JSArray (JSRef JSCtx_IO) -> IO (JS.JSRef (JSRef JSCtx_IO))
46newtype JSFFI = JSFFI JSFFI_Internal
47#else
48newtype JSFFI = JSFFI String
49#endif
51newtype JSFun x = JSFun { unJSFun :: JSRef x }
53instance ToJS x (JSFun x) where
54 withJS (JSFun r) f = f r
56instance FromJS x (JSFun x) where
57 fromJS = return . JSFun
59class IsJSContext x where
60 data JSRef x
62class (MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
63 type JSM m :: * -> *
64 liftJS :: JSM m a -> m a
66-- | A Monad that is capable of executing JavaScript
67class Monad m => MonadJS x m | m -> x where
68 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
69 forkJS :: m () -> m ThreadId
70 mkJSUndefined :: m (JSRef x)
71 isJSNull :: JSRef x -> m Bool
72 isJSUndefined :: JSRef x -> m Bool
73 fromJSBool :: JSRef x -> m Bool
74 fromJSString :: JSRef x -> m String
75 fromJSArray :: JSRef x -> m [JSRef x]
76 fromJSNumber :: JSRef x -> m Double
77 withJSBool :: Bool -> (JSRef x -> m r) -> m r
78 withJSString :: String -> (JSRef x -> m r) -> m r
79 withJSNumber :: Double -> (JSRef x -> m r) -> m r
80 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
81 withJSUint8Array :: MonadJS x m => ByteString -> (JSUint8Array x -> m r) -> m r
82 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
83 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
84 freeJSFun :: JSFun x -> m ()
85 setJSProp :: String -> JSRef x -> JSRef x -> m ()
86 getJSProp :: String -> JSRef x -> m (JSRef x)
87 withJSNode :: Node -> (JSRef x -> m r) -> m r
89#ifdef __GHCJS__
91data JSCtx_IO
93instance IsJSContext JSCtx_IO where
94 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSRef (JSRef JSCtx_IO) }
96instance MonadJS JSCtx_IO IO where
97 runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.toArray (coerce l)
98 forkJS = forkIO
99 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
100 isJSNull (JSRef_IO r) = return $ JS.isNull r
101 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
102 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool $ JS.castRef r
103 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.castRef r
104 fromJSArray (JSRef_IO r) = liftM coerce $ JS.fromArray $ JS.castRef r
105 fromJSNumber (JSRef_IO r) = do
106 Just n <- JS.fromJSRef $ JS.castRef r
107 return n
108 withJSBool b f = f $ JSRef_IO $ JS.castRef $ JS.toJSBool b
109 withJSString s f = f $ JSRef_IO $ JS.castRef $ JS.toJSString s
110 withJSNumber n f = do
111 r <- JS.toJSRef n
112 f $ JSRef_IO $ JS.castRef r
113 withJSArray l f = do
114 r <- JS.toArray $ coerce l
115 f $ JSRef_IO $ JS.castRef r
116 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
117 ba <- extractByteArray cStr $ BS.length payload
118 f $ JSUint8Array $ JSRef_IO ba
119 mkJSFun f = do
120 cb <- JS.syncCallback1 JS.AlwaysRetain True $ \args -> do
121 l <- JS.fromArray args
122 JSRef_IO result <- f $ coerce l
123 return $ JS.castRef result
124 liftM (JSFun . JSRef_IO) $ funWithArguments cb
125 freeJSFun (JSFun (JSRef_IO r)) = JS.release $ JS.castRef r
126 setJSProp s (JSRef_IO o) (JSRef_IO v) = JS.setProp s o v
127 getJSProp s (JSRef_IO o) = do
128 r <- JS.getProp s o
129 return $ JSRef_IO r
130 withJSNode n f = f $ JSRef_IO $ JS.castRef $ unNode n
132foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO (JS.JSRef (JSRef JSCtx_IO))
134foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.JSFun (JS.JSArray (JS.JSRef b) -> IO a) -> IO (JS.JSRef (JSRef JSCtx_IO))
136#else
138askJSContext :: MonadIO m => WithWebView x m JSContextRef
139askJSContext = do
140 wv <- askWebView
141 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
143-- | Make a JS string available that is not wrapped up as a JSValueRef
144withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
145withJSStringRaw str a = do
146 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
147 a strRef
149fromJSNumberRaw :: MonadIO m => JSValueRef -> WithWebView x m Double
150fromJSNumberRaw val = do
151 jsContext <- askJSContext
152 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
154foreign import ccall "wrapper" mkJSObjectCallAsFunctionCallback :: JSObjectCallAsFunctionCallback' -> IO (FunPtr JSObjectCallAsFunctionCallback')
156data JSCtx_JavaScriptCore x
158instance IsJSContext (JSCtx_JavaScriptCore x) where
159 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
161instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
162 type JSM (WithWebView x m) = WithWebView x IO
163 liftJS a = do
164 wv <- askWebView
165 liftIO $ runWithWebView a wv
167instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
168 runJS (JSFFI body) args = do
169 jsContext <- askJSContext
170 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
171 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
172 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
173 forkJS a = do
174 wv <- askWebView
175 liftIO $ forkIO $ runWithWebView a wv
176 mkJSUndefined = do
177 jsContext <- askJSContext
178 liftM JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
179 isJSNull (JSRef_JavaScriptCore r) = do
180 jsContext <- askJSContext
181 liftIO $ jsvalueisnull jsContext r
182 isJSUndefined (JSRef_JavaScriptCore r) = do
183 jsContext <- askJSContext
184 liftIO $ jsvalueisundefined jsContext r
185 fromJSBool (JSRef_JavaScriptCore r) = do
186 jsContext <- askJSContext
187 liftIO $ jsvaluetoboolean jsContext r
188 fromJSString (JSRef_JavaScriptCore r) = do
189 jsContext <- askJSContext
190 liftIO $ do
191 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
192 l <- jsstringgetmaximumutf8cstringsize s
193 allocaBytes (fromIntegral l) $ \ps -> do
194 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
195 peekCString ps
196 withJSBool b a = do
197 jsContext <- askJSContext
198 valRef <- liftIO $ jsvaluemakeboolean jsContext bRef
199 a $ JSRef_JavaScriptCore valRef
200 withJSString str a = do
201 jsContext <- askJSContext
202 withJSStringRaw str $ \strRef -> do
203 valRef <- liftIO $ jsvaluemakestring jsContext strRef
204 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
205 withJSNumber n a = do
206 jsContext <- askJSContext
207 valRef <- liftIO $ jsvaluemakenumber jsContext n
208 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
209 withJSArray elems a = do
210 jsContext <- askJSContext
211 let numElems = length elems
212 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
213 liftIO $ pokeArray elemsArr $ coerce elems
214 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
215 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
216 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
217 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
218 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
219 f $ JSUint8Array payloadRef
220 fromJSArray (JSRef_JavaScriptCore a) = do
221 jsContext <- askJSContext
222 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
223 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
224 lenDouble <- fromJSNumberRaw lenRef
225 let len = round lenDouble
226 liftIO $ forM [0..len-1] $ \i -> do
227 liftM JSRef_JavaScriptCore $ jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
228 fromJSNumber (JSRef_JavaScriptCore val) = do
229 jsContext <- askJSContext
230 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
231 mkJSFun a = do
232 wv <- askWebView
233 jsContext <- askJSContext
234 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
235 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
236 x <- peekElemOff argv n
237 jsvalueprotect jsContext x
238 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
239 liftM unJSRef_JavaScriptCore $ runWithWebView (a args) wv
240 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
241 liftIO $ jsvalueprotect jsContext cbRef
242 return $ JSFun $ JSRef_JavaScriptCore cbRef
243 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
244 jsContext <- askJSContext
245 liftIO $ jsvalueunprotect jsContext f
246 setJSProp propName (JSRef_JavaScriptCore objRef) (JSRef_JavaScriptCore valRef) = do
247 withJSStringRaw propName $ \propNameRaw -> do
248 jsContext <- askJSContext
249 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
250 getJSProp propName (JSRef_JavaScriptCore objRef) = do
251 withJSStringRaw propName $ \propNameRaw -> do
252 jsContext <- askJSContext
253 liftIO $ jsobjectgetproperty jsContext objRef propNameRaw 0 nullPtr --TODO: property attribute, exceptions
254 withJSNode (Node n) f = do
255 jsContext <- askJSContext
256 withForeignPtr n $ \nPtr -> do
257 let acquire = liftIO $ do
258 jsNode <- webkit_dom_node_to_js jsContext nPtr
259 jsvalueprotect jsContext jsNode
260 return jsNode
261 release = liftIO . jsvalueunprotect jsContext
262 bracket acquire release $ f . JSRef_JavaScriptCore
264withForeignPtr :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b
265withForeignPtr fo io = do
266 r <- io $ unsafeForeignPtrToPtr fo
267 liftIO $ touchForeignPtr fo
268 return r
270foreign import ccall unsafe "webkit_dom_node_to_js" webkit_dom_node_to_js :: JSContextRef -> Ptr Node -> IO JSValueRef
272#endif
274class FromJS x a where
275 fromJS :: MonadJS x m => JSRef x -> m a
277instance FromJS x () where
278 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
280instance FromJS x Bool where
281 fromJS = fromJSBool
283instance ToJS x Bool where
284 withJS = withJSBool
286instance FromJS x String where
287 fromJS = fromJSString
289instance FromJS x a => FromJS x (Maybe a) where
290 fromJS x = do
291 n <- isJSNull x
292 if n then return Nothing else liftM Just $ fromJS x
294class ToJS x a where
295 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
297instance ToJS x (JSRef x) where
298 withJS r = ($ r)
300instance FromJS x (JSRef x) where
301 fromJS = return
303instance ToJS x String where
304 withJS = withJSString
306newtype JSArray a = JSArray { unJSArray :: [a] }
308instance ToJS x a => ToJS x (JSArray a) where
309 withJS = withJSArrayFromList . unJSArray
311instance FromJS x a => FromJS x (JSArray a) where
312 fromJS = liftM JSArray . mapM fromJS <=< fromJSArray
314withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
315withJSArrayFromList as f = go as []
316 where go [] jsRefs = withJSArray (reverse jsRefs) f
317 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
319newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
321instance ToJS x (JSUint8Array x) where
322 withJS (JSUint8Array r) = ($ r)
324instance FromJS x (JSUint8Array x) where
325 fromJS = return . JSUint8Array
327instance ToJS x Word8 where
328 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
330instance ToJS x Int where
331 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
333instance FromJS x Int where
334 fromJS = liftM round . fromJSNumber --TODO: Check things; throw exceptions
336instance ToJS x Double where
337 withJS = withJSNumber
339instance FromJS x Double where
340 fromJS = fromJSNumber
342instance ToJS x Node where
343 withJS = withJSNode
346fromJSUint8Array :: MonadJS x m => JSUint8Array x -> m ByteString
347fromJSUint8Array (JSUint8Array a) = do
348 vals <- fromJSArray a
349 doubles <- mapM fromJSNumber vals
350 return $ BS.pack $ map round doubles
352importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
353importJS safety body name qt = do
354 t <- qt
355 let (argTypes, _) = parseType t
356 argNames <- forM argTypes $ \_ -> do
357 arg <- newName "arg"
358 argRef <- newName "argRef"
359 return (arg, argRef)
360 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
361 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
362 |]
363 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
364 e <- lamE (map (varP. fst) argNames) $ go argNames
365 let n = mkName name
366 return $ jsffiDecs ++
367 [ SigD n t
368 , ValD (VarP n) (NormalB e) []
369 ]
371mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
372#ifdef __GHCJS__
373mkJSFFI safety body = do
374 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
375 let n = mkName $ "jsffi_" ++ show (abs (hash (show safety, body)))
376 t <- [t| JSFFI_Internal |]
377 let wrappedBody = "(function(){ return (" ++ body ++ "); }).apply($1)"
378 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
379 e <- [| JSFFI $(varE n) |]
380 return (decs, e)
381#else
382mkJSFFI _ body = do
383 e <- [| JSFFI body |]
384 return ([], e)
385#endif
387parseType :: Type -> ([Type], Type)
388parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
389 | monadJs == ''MonadJS = go funType
390 where go t = case t of
391 AppT (AppT ArrowT arg) t' ->
392 let (args, result) = go t'
393 in (arg : args, result)
394 AppT (VarT m') result
395 | m' == m -> ([], result)
396 _ -> error $ "parseType: can't parse type " ++ show t
397parseType t = error $ "parseType: can't parse type " ++ show t