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