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