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