git.iko.soy/reflex-dom
on d2bd15f 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 fromJSUint8Array :: JSRef x -> m ByteString
77 fromJSNumber :: JSRef x -> m Double
78 withJSBool :: Bool -> (JSRef x -> m r) -> m r
79 withJSString :: String -> (JSRef x -> m r) -> m r
80 withJSNumber :: Double -> (JSRef x -> m r) -> m r
81 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
82 withJSUint8Array :: MonadJS x m => ByteString -> (JSUint8Array x -> m r) -> m r
83 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
84 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
85 freeJSFun :: JSFun x -> m ()
86 setJSProp :: String -> JSRef x -> JSRef x -> m ()
87 getJSProp :: String -> JSRef x -> m (JSRef x)
88 withJSNode :: Node -> (JSRef x -> m r) -> m r
90#ifdef __GHCJS__
92data JSCtx_IO
94instance IsJSContext JSCtx_IO where
95 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSRef (JSRef JSCtx_IO) }
97instance MonadJS JSCtx_IO IO where
98 runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.toArray (coerce l)
99 forkJS = forkIO
100 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
101 isJSNull (JSRef_IO r) = return $ JS.isNull r
102 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
103 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool $ JS.castRef r
104 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.castRef r
105 fromJSArray (JSRef_IO r) = liftM coerce $ JS.fromArray $ JS.castRef r
106 fromJSUint8Array (JSRef_IO r) = JS.bufferByteString 0 0 $ JS.castRef r
107 fromJSNumber (JSRef_IO r) = do
108 Just n <- JS.fromJSRef $ JS.castRef r
109 return n
110 withJSBool b f = f $ JSRef_IO $ JS.castRef $ JS.toJSBool b
111 withJSString s f = f $ JSRef_IO $ JS.castRef $ JS.toJSString s
112 withJSNumber n f = do
113 r <- JS.toJSRef n
114 f $ JSRef_IO $ JS.castRef r
115 withJSArray l f = do
116 r <- JS.toArray $ coerce l
117 f $ JSRef_IO $ JS.castRef r
118 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
119 ba <- extractByteArray cStr $ BS.length payload
120 f $ JSUint8Array $ JSRef_IO ba
121 mkJSFun f = do
122 cb <- JS.syncCallback1 JS.AlwaysRetain True $ \args -> do
123 l <- JS.fromArray args
124 JSRef_IO result <- f $ coerce l
125 return $ JS.castRef result
126 liftM (JSFun . JSRef_IO) $ funWithArguments cb
127 freeJSFun (JSFun (JSRef_IO r)) = JS.release $ JS.castRef r
128 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp s v o
129 getJSProp s (JSRef_IO o) = do
130 r <- JS.getProp s o
131 return $ JSRef_IO r
132 withJSNode n f = f $ JSRef_IO $ JS.castRef $ unNode n
134foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO (JS.JSRef (JSRef JSCtx_IO))
136foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.JSFun (JS.JSArray (JS.JSRef b) -> IO a) -> IO (JS.JSRef (JSRef JSCtx_IO))
138#else
140askJSContext :: MonadIO m => WithWebView x m JSContextRef
141askJSContext = do
142 wv <- askWebView
143 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
145-- | Make a JS string available that is not wrapped up as a JSValueRef
146withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
147withJSStringRaw str a = do
148 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
149 a strRef
151fromJSNumberRaw :: MonadIO m => JSValueRef -> WithWebView x m Double
152fromJSNumberRaw val = do
153 jsContext <- askJSContext
154 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
156foreign import ccall "wrapper" mkJSObjectCallAsFunctionCallback :: JSObjectCallAsFunctionCallback' -> IO (FunPtr JSObjectCallAsFunctionCallback')
158data JSCtx_JavaScriptCore x
160instance IsJSContext (JSCtx_JavaScriptCore x) where
161 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
163instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
164 type JSM (WithWebView x m) = WithWebView x IO
165 liftJS a = do
166 wv <- askWebView
167 liftIO $ runWithWebView a wv
169instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
170 runJS (JSFFI body) args = do
171 jsContext <- askJSContext
172 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
173 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
174 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
175 forkJS a = do
176 wv <- askWebView
177 liftIO $ forkIO $ runWithWebView a wv
178 mkJSUndefined = do
179 jsContext <- askJSContext
180 liftM JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
181 isJSNull (JSRef_JavaScriptCore r) = do
182 jsContext <- askJSContext
183 liftIO $ jsvalueisnull jsContext r
184 isJSUndefined (JSRef_JavaScriptCore r) = do
185 jsContext <- askJSContext
186 liftIO $ jsvalueisundefined jsContext r
187 fromJSBool (JSRef_JavaScriptCore r) = do
188 jsContext <- askJSContext
189 liftIO $ jsvaluetoboolean jsContext r
190 fromJSString (JSRef_JavaScriptCore r) = do
191 jsContext <- askJSContext
192 liftIO $ do
193 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
194 l <- jsstringgetmaximumutf8cstringsize s
195 allocaBytes (fromIntegral l) $ \ps -> do
196 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
197 peekCString ps
198 withJSBool b a = do
199 jsContext <- askJSContext
200 valRef <- liftIO $ jsvaluemakeboolean jsContext bRef
201 a $ JSRef_JavaScriptCore valRef
202 withJSString str a = do
203 jsContext <- askJSContext
204 withJSStringRaw str $ \strRef -> do
205 valRef <- liftIO $ jsvaluemakestring jsContext strRef
206 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
207 withJSNumber n a = do
208 jsContext <- askJSContext
209 valRef <- liftIO $ jsvaluemakenumber jsContext n
210 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
211 withJSArray elems a = do
212 jsContext <- askJSContext
213 let numElems = length elems
214 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
215 liftIO $ pokeArray elemsArr $ coerce elems
216 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
217 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
218 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
219 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
220 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
221 f $ JSUint8Array payloadRef
222 fromJSArray (JSRef_JavaScriptCore a) = do
223 jsContext <- askJSContext
224 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
225 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
226 lenDouble <- fromJSNumberRaw lenRef
227 let len = round lenDouble
228 liftIO $ forM [0..len-1] $ \i -> do
229 liftM JSRef_JavaScriptCore $ jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
230 fromJSUint8Array a = do
231 vals <- fromJSArray a
232 doubles <- mapM fromJSNumber vals
233 return $ BS.pack $ map round doubles
234 fromJSNumber (JSRef_JavaScriptCore val) = do
235 jsContext <- askJSContext
236 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
237 mkJSFun a = do
238 wv <- askWebView
239 jsContext <- askJSContext
240 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
241 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
242 x <- peekElemOff argv n
243 jsvalueprotect jsContext x
244 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
245 liftM unJSRef_JavaScriptCore $ runWithWebView (a args) wv
246 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
247 liftIO $ jsvalueprotect jsContext cbRef
248 return $ JSFun $ JSRef_JavaScriptCore cbRef
249 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
250 jsContext <- askJSContext
251 liftIO $ jsvalueunprotect jsContext f
252 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
253 withJSStringRaw propName $ \propNameRaw -> do
254 jsContext <- askJSContext
255 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
256 getJSProp propName (JSRef_JavaScriptCore objRef) = do
257 withJSStringRaw propName $ \propNameRaw -> do
258 jsContext <- askJSContext
259 liftIO $ jsobjectgetproperty jsContext objRef propNameRaw 0 nullPtr --TODO: property attribute, exceptions
260 withJSNode (Node n) f = do
261 jsContext <- askJSContext
262 withForeignPtr n $ \nPtr -> do
263 let acquire = liftIO $ do
264 jsNode <- webkit_dom_node_to_js jsContext nPtr
265 jsvalueprotect jsContext jsNode
266 return jsNode
267 release = liftIO . jsvalueunprotect jsContext
268 bracket acquire release $ f . JSRef_JavaScriptCore
270withForeignPtr :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b
271withForeignPtr fo io = do
272 r <- io $ unsafeForeignPtrToPtr fo
273 liftIO $ touchForeignPtr fo
274 return r
276foreign import ccall unsafe "webkit_dom_node_to_js" webkit_dom_node_to_js :: JSContextRef -> Ptr Node -> IO JSValueRef
278#endif
280class FromJS x a where
281 fromJS :: MonadJS x m => JSRef x -> m a
283instance FromJS x () where
284 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
286instance FromJS x Bool where
287 fromJS = fromJSBool
289instance ToJS x Bool where
290 withJS = withJSBool
292instance FromJS x String where
293 fromJS = fromJSString
295instance FromJS x a => FromJS x (Maybe a) where
296 fromJS x = do
297 n <- isJSNull x
298 if n then return Nothing else liftM Just $ fromJS x
300class ToJS x a where
301 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
303instance ToJS x (JSRef x) where
304 withJS r = ($ r)
306instance FromJS x (JSRef x) where
307 fromJS = return
309instance ToJS x String where
310 withJS = withJSString
312newtype JSArray a = JSArray { unJSArray :: [a] }
314instance ToJS x a => ToJS x (JSArray a) where
315 withJS = withJSArrayFromList . unJSArray
317instance FromJS x a => FromJS x (JSArray a) where
318 fromJS = liftM JSArray . mapM fromJS <=< fromJSArray
320withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
321withJSArrayFromList as f = go as []
322 where go [] jsRefs = withJSArray (reverse jsRefs) f
323 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
325newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
327instance ToJS x (JSUint8Array x) where
328 withJS (JSUint8Array r) = ($ r)
330instance FromJS x (JSUint8Array x) where
331 fromJS = return . JSUint8Array
333instance ToJS x Word8 where
334 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
336instance ToJS x Int where
337 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
339instance FromJS x Int where
340 fromJS = liftM round . fromJSNumber --TODO: Check things; throw exceptions
342instance ToJS x Double where
343 withJS = withJSNumber
345instance FromJS x Double where
346 fromJS = fromJSNumber
348instance ToJS x Node where
349 withJS = withJSNode
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