git.iko.soy/reflex-dom
on 9b63cd5 help sign in
reflex-dom/src/Foreign/JavaScript/TH.hs
548 lines 21 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE ForeignFunctionInterface #-}
7{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE StandaloneDeriving #-}
12#ifdef USE_TEMPLATE_HASKELL
13{-# LANGUAGE TemplateHaskell #-}
14#endif
15{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeSynonymInstances #-}
17{-# LANGUAGE UndecidableInstances #-}
18#ifdef __GHCJS__
19{-# LANGUAGE JavaScriptFFI #-}
20#endif
21module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
22#ifdef USE_TEMPLATE_HASKELL
23 , Safety (..)
24#endif
25 ) where
27import Prelude hiding((!!))
28import Reflex.Class
29import Reflex.DynamicWriter
30import Reflex.Host.Class
31import Reflex.PerformEvent.Base
32import Reflex.PerformEvent.Class
33import Reflex.PostBuild.Base
34import Reflex.Requester.Base
36#ifdef USE_TEMPLATE_HASKELL
37import Language.Haskell.TH
38#endif
40import GHCJS.DOM.Types
41 (toJSString, liftJSM, askJSM, runJSM, JSContextRef,
42 Node(..), MonadJSM(..), toJSVal, JSVal)
43#ifdef __GHCJS__
44import qualified GHCJS.Buffer as JS
45import qualified GHCJS.DOM.Types as JS
46import qualified GHCJS.Foreign as JS
47import qualified GHCJS.Foreign.Callback as JS
48import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
49import qualified GHCJS.Marshal as JS
50import qualified GHCJS.Marshal.Pure as JS
51import qualified GHCJS.Types as JS
52import qualified JavaScript.Array as JS
53import qualified JavaScript.Array.Internal (SomeJSArray (..))
54import qualified JavaScript.Object as JS
55import qualified JavaScript.Object.Internal (Object (..))
56import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
58import Data.Hashable
59import Data.Word
60import Foreign.C.Types
61import Foreign.Ptr
62import Text.Encoding.Z
63#else
64import Data.Word (Word8)
65import Control.Lens.Operators ((^.))
66import Language.Javascript.JSaddle
67 (eval, valMakeString, valToNumber, function,
68 valMakeNumber, valBool, valToText, valToBool, valIsUndefined,
69 valUndefined, valIsNull, Function(..), (!!),
70 js, js1, jss, array, freeFunction)
71#endif
73import Control.Concurrent
74import Control.Monad
75import Control.Monad.Exception
76import Control.Monad.Fix
77import Control.Monad.IO.Class
78import Control.Monad.Primitive
79import Control.Monad.Reader
80import Control.Monad.Ref
81import Control.Monad.State
82import qualified Control.Monad.State.Strict as Strict
83import Control.Monad.Trans.Control
84import Data.ByteString (ByteString)
85import qualified Data.ByteString as BS
86import Data.Coerce (coerce)
87import Data.Monoid
88import Data.Text (Text)
89import qualified Data.Text as T
91class Monad m => HasJSContext m where
92 type JSContextPhantom m :: *
93 askJSContext :: m (JSContextSingleton (JSContextPhantom m))
95instance HasJSContext m => HasJSContext (ReaderT r m) where
96 type JSContextPhantom (ReaderT r m) = JSContextPhantom m
97 askJSContext = lift askJSContext
99instance HasJSContext m => HasJSContext (StateT r m) where
100 type JSContextPhantom (StateT r m) = JSContextPhantom m
101 askJSContext = lift askJSContext
103instance HasJSContext m => HasJSContext (Strict.StateT r m) where
104 type JSContextPhantom (Strict.StateT r m) = JSContextPhantom m
105 askJSContext = lift askJSContext
107instance HasJSContext m => HasJSContext (PostBuildT t m) where
108 type JSContextPhantom (PostBuildT t m) = JSContextPhantom m
109 askJSContext = lift askJSContext
111instance (ReflexHost t, HasJSContext (HostFrame t)) => HasJSContext (PerformEventT t m) where
112 type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)
113 askJSContext = PerformEventT $ lift askJSContext
115instance HasJSContext m => HasJSContext (DynamicWriterT t w m) where
116 type JSContextPhantom (DynamicWriterT t w m) = JSContextPhantom m
117 askJSContext = lift askJSContext
119newtype WithJSContextSingleton x m a = WithJSContextSingleton { unWithJSContextSingleton :: ReaderT (JSContextSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
121instance PrimMonad m => PrimMonad (WithJSContextSingleton x m) where
122 type PrimState (WithJSContextSingleton x m) = PrimState m
123 primitive = lift . primitive
125instance MonadAdjust t m => MonadAdjust t (WithJSContextSingleton x m) where
126 runWithReplace a0 a' = WithJSContextSingleton $ runWithReplace (coerce a0) (coerceEvent a')
127 sequenceDMapWithAdjust dm0 dm' = WithJSContextSingleton $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
129instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithJSContextSingleton x m) where
130 {-# INLINABLE newEventWithTrigger #-}
131 newEventWithTrigger = lift . newEventWithTrigger
132 {-# INLINABLE newFanEventWithTrigger #-}
133 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
135instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithJSContextSingleton x m) where
136 {-# INLINABLE subscribeEvent #-}
137 subscribeEvent = lift . subscribeEvent
139instance MonadReflexHost t m => MonadReflexHost t (WithJSContextSingleton x m) where
140 type ReadPhase (WithJSContextSingleton x m) = ReadPhase m
141 {-# INLINABLE fireEventsAndRead #-}
142 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
143 {-# INLINABLE runHostFrame #-}
144 runHostFrame = lift . runHostFrame
146instance MonadSample t m => MonadSample t (WithJSContextSingleton x m) where
147 {-# INLINABLE sample #-}
148 sample = lift . sample
150instance MonadHold t m => MonadHold t (WithJSContextSingleton x m) where
151 {-# INLINABLE hold #-}
152 hold v0 = lift . hold v0
153 {-# INLINABLE holdDyn #-}
154 holdDyn v0 = lift . holdDyn v0
155 {-# INLINABLE holdIncremental #-}
156 holdIncremental v0 = lift . holdIncremental v0
158instance MonadTransControl (WithJSContextSingleton x) where
159 type StT (WithJSContextSingleton x) a = StT (ReaderT (JSContextSingleton x)) a
160 {-# INLINABLE liftWith #-}
161 liftWith = defaultLiftWith WithJSContextSingleton unWithJSContextSingleton
162 {-# INLINABLE restoreT #-}
163 restoreT = defaultRestoreT WithJSContextSingleton
165instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where
166 type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m)
167 {-# INLINABLE performEvent_ #-}
168 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
169 {-# INLINABLE performEvent #-}
170 performEvent e = liftWith $ \run -> performEvent $ fmap run e
172runWithJSContextSingleton :: WithJSContextSingleton x m a -> JSContextSingleton x -> m a
173runWithJSContextSingleton = runReaderT . unWithJSContextSingleton
175instance (Monad m) => HasJSContext (WithJSContextSingleton x m) where
176 type JSContextPhantom (WithJSContextSingleton x m) = x
177 askJSContext = WithJSContextSingleton ask
179instance MonadRef m => MonadRef (WithJSContextSingleton x m) where
180 type Ref (WithJSContextSingleton x m) = Ref m
181 newRef = lift . newRef
182 readRef = lift . readRef
183 writeRef r = lift . writeRef r
185instance MonadAtomicRef m => MonadAtomicRef (WithJSContextSingleton x m) where
186 atomicModifyRef r = lift . atomicModifyRef r
188withJSContextSingleton :: MonadJSM m => (forall x. JSContextSingleton x -> m r) -> m r
189withJSContextSingleton f = askJSM >>= f . JSContextSingleton
191-- | A singleton type for a given JS Context; we use this to statically guarantee that different JSContexts (and thus different javscript contexts) don't get mixed up
192newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }
194#ifdef __GHCJS__
195type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
196newtype JSFFI = JSFFI JSFFI_Internal
197#else
198newtype JSFFI = JSFFI String
199#endif
201data JSFun x = JSFun { unJSFun :: JSRef x
202#ifndef __GHCJS__
203 , unJSFunction :: Function
204#endif
205 }
207instance ToJS x (JSFun x) where
208 withJS r f = f (unJSFun r)
210class IsJSContext x where
211 data JSRef x
213class (Monad m, MonadIO (JSX m), MonadFix (JSX m), MonadJS x (JSX m)) => HasJS x m | m -> x where
214 type JSX m :: * -> *
215 liftJS :: JSX m a -> m a
217instance HasJS x m => HasJS x (ReaderT r m) where
218 type JSX (ReaderT r m) = JSX m
219 liftJS = lift . liftJS
221instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
222 type JSX (PostBuildT t m) = JSX m
223 liftJS = lift . liftJS
225instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
226 type JSX (PerformEventT t m) = JSX (HostFrame t)
227 liftJS = PerformEventT . lift . liftJS
229instance HasJS x m => HasJS x (DynamicWriterT t w m) where
230 type JSX (DynamicWriterT t w m) = JSX m
231 liftJS = lift . liftJS
233instance HasJS x m => HasJS x (RequesterT t request response m) where
234 type JSX (RequesterT t request response m) = JSX m
235 liftJS = lift . liftJS
237-- | A Monad that is capable of executing JavaScript
238class Monad m => MonadJS x m | m -> x where
239 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
240 forkJS :: m () -> m ThreadId
241 mkJSUndefined :: m (JSRef x)
242 isJSNull :: JSRef x -> m Bool
243 isJSUndefined :: JSRef x -> m Bool
244 fromJSBool :: JSRef x -> m Bool
245 fromJSString :: JSRef x -> m String
246 fromJSArray :: JSRef x -> m [JSRef x]
247 fromJSUint8Array :: JSRef x -> m ByteString
248 fromJSNumber :: JSRef x -> m Double
249 withJSBool :: Bool -> (JSRef x -> m r) -> m r
250 withJSString :: String -> (JSRef x -> m r) -> m r
251 withJSNumber :: Double -> (JSRef x -> m r) -> m r
252 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
253 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
254 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
255 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
256 freeJSFun :: JSFun x -> m ()
257 setJSProp :: String -> JSRef x -> JSRef x -> m ()
258 getJSProp :: String -> JSRef x -> m (JSRef x)
259 withJSNode :: Node -> (JSRef x -> m r) -> m r
261#ifdef __GHCJS__
263data JSCtx_IO
265instance MonadIO m => HasJS JSCtx_IO (WithJSContextSingleton x m) where
266 type JSX (WithJSContextSingleton x m) = IO
267 liftJS = liftIO
269instance IsJSContext JSCtx_IO where
270 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
272instance MonadJS JSCtx_IO IO where
273 runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)
274 forkJS = forkIO
275 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
276 isJSNull (JSRef_IO r) = return $ JS.isNull r
277 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
278 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
279 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
280 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
281 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
282 fromJSNumber (JSRef_IO r) = JS.fromJSValUnchecked r
283 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
284 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
285 withJSNumber n f = do
286 r <- JS.toJSVal n
287 f $ JSRef_IO r
288 withJSArray l f = do
289 r <- JS.fromListIO $ coerce l
290 f $ JSRef_IO $ coerce r
291 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
292 ba <- extractByteArray cStr $ BS.length payload
293 f $ JSUint8Array $ JSRef_IO ba
294 mkJSFun f = do
295 cb <- JS.syncCallback1' $ \args -> do
296 l <- JS.toListIO $ coerce args
297 JSRef_IO result <- f $ coerce l
298 return result
299 fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
300 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
301 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
302 getJSProp s (JSRef_IO o) = do
303 r <- JS.getProp (JS.toJSString s) $ coerce o
304 return $ JSRef_IO r
305 withJSNode n f = f $ JSRef_IO $ unNode n
307foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
309foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
311#else
313data JSCtx_JavaScriptCore x
315instance IsJSContext (JSCtx_JavaScriptCore x) where
316 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSVal }
318instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x m) where
319 type JSX (WithJSContextSingleton x m) = WithJSContextSingleton x IO
320 liftJS a = do
321 wv <- askJSContext
322 liftIO $ runWithJSContextSingleton a wv
324newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
326runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
327runWithJSContext = runReaderT . unWithJSContext
329instance MonadIO m => MonadJSM (WithJSContextSingleton x m) where
330 liftJSM' f = do
331 wv <- askJSContext
332 runJSM f $ unJSContextSingleton wv
334instance MonadIO m => MonadJSM (WithJSContext x m) where
335 liftJSM' f =
336 runJSM f =<< WithJSContext ask
338lowerWithJSContext :: MonadJSM m => WithJSContext x IO a -> m a
339lowerWithJSContext a = do
340 c <- askJSM
341 liftIO $ runWithJSContext a c
343liftWithJSContextSingletonThroughWithJSContext :: (HasJSContext m, MonadJSM m, MonadTrans t, Monad m1)
344 => ((t1 -> t m1 a) -> WithJSContext x IO b)
345 -> (t1 -> WithJSContextSingleton (JSContextPhantom m) m1 a)
346 -> m b
347liftWithJSContextSingletonThroughWithJSContext f a = do
348 wv <- askJSContext
349 lowerWithJSContext $ f $ \b' -> lift $ runWithJSContextSingleton (a b') wv
351instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x IO) where
352 forkJS a = do
353 wv <- askJSContext
354 liftIO $ forkIO $ runWithJSContextSingleton a wv
355 mkJSFun a = do
356 wv <- askJSContext
357 lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithJSContextSingleton (a args) wv
358 runJS expr args = lowerWithJSContext $ runJS expr args
359 mkJSUndefined = lowerWithJSContext mkJSUndefined
360 isJSNull = lowerWithJSContext . isJSNull
361 isJSUndefined = lowerWithJSContext . isJSUndefined
362 fromJSBool = lowerWithJSContext . fromJSBool
363 fromJSString = lowerWithJSContext . fromJSString
364 fromJSArray = lowerWithJSContext . fromJSArray
365 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
366 fromJSNumber = lowerWithJSContext . fromJSNumber
367 freeJSFun = lowerWithJSContext . freeJSFun
368 withJSBool = liftWithJSContextSingletonThroughWithJSContext . withJSBool
369 withJSString = liftWithJSContextSingletonThroughWithJSContext . withJSString
370 withJSNumber = liftWithJSContextSingletonThroughWithJSContext . withJSNumber
371 withJSArray = liftWithJSContextSingletonThroughWithJSContext . withJSArray
372 withJSUint8Array = liftWithJSContextSingletonThroughWithJSContext . withJSUint8Array
373 withJSNode = liftWithJSContextSingletonThroughWithJSContext . withJSNode
374 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
375 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
377instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
378 runJS (JSFFI body) args =
379 withJSArray args $ \(JSRef_JavaScriptCore this) -> do
380 result <- liftJSM $ eval ("(function(){ return (" <> body <> "); })") ^. js1 "apply" this
381 return $ JSRef_JavaScriptCore result
382 forkJS a = do
383 c <- askJSM
384 liftIO . forkIO $ runWithJSContext a c
385 mkJSUndefined = return $ JSRef_JavaScriptCore valUndefined
386 isJSNull (JSRef_JavaScriptCore r) = liftJSM $ valIsNull r
387 isJSUndefined (JSRef_JavaScriptCore r) = liftJSM $ valIsUndefined r
388 fromJSBool (JSRef_JavaScriptCore r) = liftJSM $ valToBool r
389 fromJSString (JSRef_JavaScriptCore r) = liftJSM (T.unpack <$> valToText r)
390 withJSBool b a = a $ JSRef_JavaScriptCore (valBool b)
391 withJSString str a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeString $ toJSString str)
392 withJSNumber n a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeNumber n)
393 withJSArray elems a = a . JSRef_JavaScriptCore =<< liftJSM
394 (toJSVal =<< array (map (\(JSRef_JavaScriptCore r) -> r) elems))
395 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
396 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
397 f $ JSUint8Array payloadRef
398 fromJSArray (JSRef_JavaScriptCore a) = liftJSM $ do
399 len <- round <$> (valToNumber =<< (a ^. js "length"))
400 forM [0..len-1] $ \i -> JSRef_JavaScriptCore <$> a !! i
401 fromJSUint8Array a = do
402 vals <- fromJSArray a
403 doubles <- mapM fromJSNumber vals
404 return $ BS.pack $ map round doubles
405 fromJSNumber (JSRef_JavaScriptCore val) = liftJSM $ valToNumber val
406 mkJSFun a = liftJSM $ do
407 ctx <- askJSM
408 f <- function $ \_ _ args -> liftIO $ void $ runWithJSContext (a $ map JSRef_JavaScriptCore args) ctx
409 fRef <- toJSVal f
410 return $ JSFun (JSRef_JavaScriptCore fRef) f
411 freeJSFun (JSFun _ f) = liftJSM $ freeFunction f
412 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) =
413 liftJSM $ objRef ^. jss propName valRef
414 getJSProp propName (JSRef_JavaScriptCore objRef) =
415 JSRef_JavaScriptCore <$> liftJSM (objRef ^. js propName)
416 withJSNode n f = f . JSRef_JavaScriptCore =<< liftJSM (toJSVal n)
418#endif
420class FromJS x a where
421 fromJS :: MonadJS x m => JSRef x -> m a
423instance FromJS x () where
424 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
426instance FromJS x Bool where
427 fromJS = fromJSBool
429instance ToJS x Bool where
430 withJS = withJSBool
432instance FromJS x String where
433 fromJS = fromJSString
435instance FromJS x Text where
436 fromJS s = T.pack <$> fromJSString s
438instance FromJS x a => FromJS x (Maybe a) where
439 fromJS x = do
440 n <- isJSNull x
441 if n then return Nothing else Just <$> fromJS x
443class ToJS x a where
444 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
446instance ToJS x (JSRef x) where
447 withJS r = ($ r)
449instance FromJS x (JSRef x) where
450 fromJS = return
452instance ToJS x String where
453 withJS = withJSString
455instance ToJS x Text where
456 withJS = withJSString . T.unpack
458newtype JSArray a = JSArray { unJSArray :: [a] }
460instance ToJS x a => ToJS x (JSArray a) where
461 withJS = withJSArrayFromList . unJSArray
463instance FromJS x a => FromJS x (JSArray a) where
464 fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
466withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
467withJSArrayFromList as f = go as []
468 where go [] jsRefs = withJSArray (reverse jsRefs) f
469 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
471newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
473instance ToJS x (JSUint8Array x) where
474 withJS (JSUint8Array r) = ($ r)
476instance FromJS x (JSUint8Array x) where
477 fromJS = return . JSUint8Array
479instance ToJS x Word8 where
480 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
482instance ToJS x Int where
483 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
485instance FromJS x Int where
486 fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
488instance ToJS x Double where
489 withJS = withJSNumber
491instance FromJS x Double where
492 fromJS = fromJSNumber
494instance ToJS x Node where
495 withJS = withJSNode
498#ifdef USE_TEMPLATE_HASKELL
500importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
501importJS safety body name qt = do
502 t <- qt
503 let (argTypes, _) = parseType t
504 argNames <- forM argTypes $ \_ -> do
505 arg <- newName "arg"
506 argRef <- newName "argRef"
507 return (arg, argRef)
508 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
509 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
510 |]
511 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
512 e <- lamE (map (varP. fst) argNames) $ go argNames
513 let n = mkName name
514 return $ jsffiDecs ++
515 [ SigD n t
516 , ValD (VarP n) (NormalB e) []
517 ]
519mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
520#ifdef __GHCJS__
521mkJSFFI safety body = do
522 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
523 l <- location
524 n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
525 t <- [t| JSFFI_Internal |]
526 let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
527 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
528 e <- [| JSFFI $(varE n) |]
529 return (decs, e)
530#else
531mkJSFFI _ body = do
532 e <- [| JSFFI body |]
533 return ([], e)
534#endif
536parseType :: Type -> ([Type], Type)
537parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
538 | monadJs == ''MonadJS = go funType
539 where go t = case t of
540 AppT (AppT ArrowT arg) t' ->
541 let (args, result) = go t'
542 in (arg : args, result)
543 AppT (VarT m') result
544 | m' == m -> ([], result)
545 _ -> error $ "parseType: can't parse type " <> show t
546parseType t = error $ "parseType: can't parse type " <> show t
548#endif