git.iko.soy/reflex-dom
on 581c8db help sign in
reflex-dom/src/Foreign/JavaScript/TH.hs
519 lines 20 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{-# LANGUAGE TemplateHaskell #-}
13{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
16#ifdef __GHCJS__
17{-# LANGUAGE JavaScriptFFI #-}
18#endif
19module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
20 , Safety (..)
21 ) where
23import Reflex.Class
24import Reflex.Dom.Deletable.Class
25import Reflex.Dom.PerformEvent.Class
26import Reflex.Host.Class
28import Language.Haskell.TH
30#ifdef __GHCJS__
31import qualified GHCJS.Buffer as JS
32import GHCJS.DOM
33import GHCJS.DOM.Types hiding (Text, fromJSString)
34import qualified GHCJS.DOM.Types as JS
35import qualified GHCJS.Foreign as JS
36import qualified GHCJS.Foreign.Callback as JS
37import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
38import qualified GHCJS.Marshal as JS
39import qualified GHCJS.Marshal.Pure as JS
40import qualified GHCJS.Types as JS
41import qualified JavaScript.Array as JS
42import qualified JavaScript.Array.Internal (SomeJSArray (..))
43import qualified JavaScript.Object as JS
44import qualified JavaScript.Object.Internal (Object (..))
45import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
47import Data.Hashable
48import Data.Word
49import Foreign.C.Types
50import Foreign.Ptr
51import Text.Encoding.Z
52#else
53import Foreign.Marshal
54import Graphics.UI.Gtk.WebKit.DOM.Node
55import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
56import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
57import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
58import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
59import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
60import Graphics.UI.Gtk.WebKit.WebView
61import System.Glib.FFI
62#endif
64import Control.Concurrent
65import Control.Monad
66import Control.Monad.Exception
67import Control.Monad.Fix
68import Control.Monad.IO.Class
69import Control.Monad.Reader
70import Control.Monad.Ref
71import Control.Monad.State
72import qualified Control.Monad.State.Strict as Strict
73import Control.Monad.Trans.Control
74import Data.ByteString (ByteString)
75import qualified Data.ByteString as BS
76import Data.Coerce
77import Data.Monoid
78import Data.Text (Text)
79import qualified Data.Text as T
81class Monad m => HasWebView m where
82 type WebViewPhantom m :: *
83 askWebView :: m (WebViewSingleton (WebViewPhantom m))
85instance HasWebView m => HasWebView (ReaderT r m) where
86 type WebViewPhantom (ReaderT r m) = WebViewPhantom m
87 askWebView = lift askWebView
89instance HasWebView m => HasWebView (StateT r m) where
90 type WebViewPhantom (StateT r m) = WebViewPhantom m
91 askWebView = lift askWebView
93instance HasWebView m => HasWebView (Strict.StateT r m) where
94 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m
95 askWebView = lift askWebView
97newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
99instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
100 {-# INLINABLE newEventWithTrigger #-}
101 newEventWithTrigger = lift . newEventWithTrigger
102 {-# INLINABLE newFanEventWithTrigger #-}
103 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
105instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
106 {-# INLINABLE subscribeEvent #-}
107 subscribeEvent = lift . subscribeEvent
109instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
110 type ReadPhase (WithWebView x m) = ReadPhase m
111 {-# INLINABLE fireEventsAndRead #-}
112 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
113 {-# INLINABLE runHostFrame #-}
114 runHostFrame = lift . runHostFrame
116instance MonadSample t m => MonadSample t (WithWebView x m) where
117 {-# INLINABLE sample #-}
118 sample = lift . sample
120instance MonadHold t m => MonadHold t (WithWebView x m) where
121 {-# INLINABLE hold #-}
122 hold v0 = lift . hold v0
123 {-# INLINABLE holdDyn #-}
124 holdDyn v0 = lift . holdDyn v0
125 {-# INLINABLE holdIncremental #-}
126 holdIncremental v0 = lift . holdIncremental v0
128instance MonadTransControl (WithWebView x) where
129 type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
130 {-# INLINABLE liftWith #-}
131 liftWith = defaultLiftWith WithWebView unWithWebView
132 {-# INLINABLE restoreT #-}
133 restoreT = defaultRestoreT WithWebView
135instance PerformEvent t m => PerformEvent t (WithWebView x m) where
136 type Performable (WithWebView x m) = WithWebView x (Performable m)
137 {-# INLINABLE performEvent_ #-}
138 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
139 {-# INLINABLE performEvent #-}
140 performEvent e = liftWith $ \run -> performEvent $ fmap run e
142instance Deletable t m => Deletable t (WithWebView x m) where
143 {-# INLINABLE deletable #-}
144 deletable = liftThrough . deletable
146runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
147runWithWebView = runReaderT . unWithWebView
149instance (Monad m) => HasWebView (WithWebView x m) where
150 type WebViewPhantom (WithWebView x m) = x
151 askWebView = WithWebView ask
153instance MonadRef m => MonadRef (WithWebView x m) where
154 type Ref (WithWebView x m) = Ref m
155 newRef = lift . newRef
156 readRef = lift . readRef
157 writeRef r = lift . writeRef r
159instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
160 atomicModifyRef r = lift . atomicModifyRef r
162withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
163withWebViewSingleton wv f = f $ WebViewSingleton wv
165-- | A singleton type for a given WebView; we use this to statically guarantee that different WebViews (and thus different javscript contexts) don't get mixed up
166newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
168#ifdef __GHCJS__
169type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
170newtype JSFFI = JSFFI JSFFI_Internal
171#else
172newtype JSFFI = JSFFI String
173#endif
175newtype JSFun x = JSFun { unJSFun :: JSRef x }
177instance ToJS x (JSFun x) where
178 withJS (JSFun r) f = f r
180instance FromJS x (JSFun x) where
181 fromJS = return . JSFun
183class IsJSContext x where
184 data JSRef x
186class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
187 type JSM m :: * -> *
188 liftJS :: JSM m a -> m a
190instance HasJS x m => HasJS x (ReaderT r m) where
191 type JSM (ReaderT r m) = JSM m
192 liftJS = lift . liftJS
194-- | A Monad that is capable of executing JavaScript
195class Monad m => MonadJS x m | m -> x where
196 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
197 forkJS :: m () -> m ThreadId
198 mkJSUndefined :: m (JSRef x)
199 isJSNull :: JSRef x -> m Bool
200 isJSUndefined :: JSRef x -> m Bool
201 fromJSBool :: JSRef x -> m Bool
202 fromJSString :: JSRef x -> m String
203 fromJSArray :: JSRef x -> m [JSRef x]
204 fromJSUint8Array :: JSRef x -> m ByteString
205 fromJSNumber :: JSRef x -> m Double
206 withJSBool :: Bool -> (JSRef x -> m r) -> m r
207 withJSString :: String -> (JSRef x -> m r) -> m r
208 withJSNumber :: Double -> (JSRef x -> m r) -> m r
209 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r
210 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r
211 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS
212 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions
213 freeJSFun :: JSFun x -> m ()
214 setJSProp :: String -> JSRef x -> JSRef x -> m ()
215 getJSProp :: String -> JSRef x -> m (JSRef x)
216 withJSNode :: Node -> (JSRef x -> m r) -> m r
218#ifdef __GHCJS__
220data JSCtx_IO
222instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
223 type JSM (WithWebView x m) = IO
224 liftJS = liftIO
226instance IsJSContext JSCtx_IO where
227 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
229instance MonadJS JSCtx_IO IO where
230 runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)
231 forkJS = forkIO
232 mkJSUndefined = return $ JSRef_IO JS.jsUndefined
233 isJSNull (JSRef_IO r) = return $ JS.isNull r
234 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
235 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
236 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
237 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
238 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
239 fromJSNumber (JSRef_IO r) = do
240 Just n <- JS.fromJSVal r
241 return n
242 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
243 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
244 withJSNumber n f = do
245 r <- JS.toJSVal n
246 f $ JSRef_IO r
247 withJSArray l f = do
248 r <- JS.fromListIO $ coerce l
249 f $ JSRef_IO $ coerce r
250 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
251 ba <- extractByteArray cStr $ BS.length payload
252 f $ JSUint8Array $ JSRef_IO ba
253 mkJSFun f = do
254 cb <- JS.syncCallback1' $ \args -> do
255 l <- JS.toListIO $ coerce args
256 JSRef_IO result <- f $ coerce l
257 return result
258 fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
259 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
260 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
261 getJSProp s (JSRef_IO o) = do
262 r <- JS.getProp (JS.toJSString s) $ coerce o
263 return $ JSRef_IO r
264 withJSNode n f = f $ JSRef_IO $ unNode n
266foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal
268foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
270#else
272askJSContext :: MonadIO m => WithWebView x m JSContextRef
273askJSContext = do
274 wv <- askWebView
275 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
277-- | Make a JS string available that is not wrapped up as a JSValueRef
278withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
279withJSStringRaw str a = do
280 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
281 a strRef
283fromJSNumberRaw :: MonadIO m => JSValueRef -> WithWebView x m Double
284fromJSNumberRaw val = do
285 jsContext <- askJSContext
286 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
289data JSCtx_JavaScriptCore x
291instance IsJSContext (JSCtx_JavaScriptCore x) where
292 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
294instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
295 type JSM (WithWebView x m) = WithWebView x IO
296 liftJS a = do
297 wv <- askWebView
298 liftIO $ runWithWebView a wv
300instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
301 runJS (JSFFI body) args = do
302 jsContext <- askJSContext
303 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
304 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
305 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
306 forkJS a = do
307 wv <- askWebView
308 liftIO $ forkIO $ runWithWebView a wv
309 mkJSUndefined = do
310 jsContext <- askJSContext
311 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
312 isJSNull (JSRef_JavaScriptCore r) = do
313 jsContext <- askJSContext
314 liftIO $ jsvalueisnull jsContext r
315 isJSUndefined (JSRef_JavaScriptCore r) = do
316 jsContext <- askJSContext
317 liftIO $ jsvalueisundefined jsContext r
318 fromJSBool (JSRef_JavaScriptCore r) = do
319 jsContext <- askJSContext
320 liftIO $ jsvaluetoboolean jsContext r
321 fromJSString (JSRef_JavaScriptCore r) = do
322 jsContext <- askJSContext
323 liftIO $ do
324 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
325 l <- jsstringgetmaximumutf8cstringsize s
326 allocaBytes (fromIntegral l) $ \ps -> do
327 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
328 peekCString ps
329 withJSBool b a = do
330 jsContext <- askJSContext
331 valRef <- liftIO $ jsvaluemakeboolean jsContext b
332 a $ JSRef_JavaScriptCore valRef
333 withJSString str a = do
334 jsContext <- askJSContext
335 withJSStringRaw str $ \strRef -> do
336 valRef <- liftIO $ jsvaluemakestring jsContext strRef
337 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
338 withJSNumber n a = do
339 jsContext <- askJSContext
340 valRef <- liftIO $ jsvaluemakenumber jsContext n
341 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
342 withJSArray elems a = do
343 jsContext <- askJSContext
344 let numElems = length elems
345 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
346 liftIO $ pokeArray elemsArr $ coerce elems
347 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
348 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
349 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
350 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
351 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
352 f $ JSUint8Array payloadRef
353 fromJSArray (JSRef_JavaScriptCore a) = do
354 jsContext <- askJSContext
355 lenRef <- withJSStringRaw "length" $ \lengthStr -> do
356 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
357 lenDouble <- fromJSNumberRaw lenRef
358 let len = round lenDouble
359 liftIO $ forM [0..len-1] $ \i -> do
360 JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
361 fromJSUint8Array a = do
362 vals <- fromJSArray a
363 doubles <- mapM fromJSNumber vals
364 return $ BS.pack $ map round doubles
365 fromJSNumber (JSRef_JavaScriptCore val) = do
366 jsContext <- askJSContext
367 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
368 mkJSFun a = do
369 wv <- askWebView
370 jsContext <- askJSContext
371 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
372 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
373 x <- peekElemOff argv n
374 jsvalueprotect jsContext x
375 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
376 unJSRef_JavaScriptCore <$> runWithWebView (a args) wv
377 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
378 liftIO $ jsvalueprotect jsContext cbRef
379 return $ JSFun $ JSRef_JavaScriptCore cbRef
380 freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
381 jsContext <- askJSContext
382 liftIO $ jsvalueunprotect jsContext f
383 setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
384 withJSStringRaw propName $ \propNameRaw -> do
385 jsContext <- askJSContext
386 liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
387 getJSProp propName (JSRef_JavaScriptCore objRef) = do
388 withJSStringRaw propName $ \propNameRaw -> do
389 jsContext <- askJSContext
390 liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
391 withJSNode = error "withJSNode is only supported in ghcjs"
393#endif
395class FromJS x a where
396 fromJS :: MonadJS x m => JSRef x -> m a
398instance FromJS x () where
399 fromJS _ = return () --TODO: Should this do some kind of checking for the js value?
401instance FromJS x Bool where
402 fromJS = fromJSBool
404instance ToJS x Bool where
405 withJS = withJSBool
407instance FromJS x String where
408 fromJS = fromJSString
410instance FromJS x Text where
411 fromJS s = T.pack <$> fromJSString s
413instance FromJS x a => FromJS x (Maybe a) where
414 fromJS x = do
415 n <- isJSNull x
416 if n then return Nothing else Just <$> fromJS x
418class ToJS x a where
419 withJS :: MonadJS x m => a -> (JSRef x -> m r) -> m r
421instance ToJS x (JSRef x) where
422 withJS r = ($ r)
424instance FromJS x (JSRef x) where
425 fromJS = return
427instance ToJS x String where
428 withJS = withJSString
430instance ToJS x Text where
431 withJS = withJSString . T.unpack
433newtype JSArray a = JSArray { unJSArray :: [a] }
435instance ToJS x a => ToJS x (JSArray a) where
436 withJS = withJSArrayFromList . unJSArray
438instance FromJS x a => FromJS x (JSArray a) where
439 fromJS = fmap JSArray . mapM fromJS <=< fromJSArray
441withJSArrayFromList :: (ToJS x a, MonadJS x m) => [a] -> (JSRef x -> m r) -> m r
442withJSArrayFromList as f = go as []
443 where go [] jsRefs = withJSArray (reverse jsRefs) f
444 go (h:t) jsRefs = withJS h $ \hRef -> go t (hRef : jsRefs)
446newtype JSUint8Array x = JSUint8Array { unJSUint8Array :: JSRef x }
448instance ToJS x (JSUint8Array x) where
449 withJS (JSUint8Array r) = ($ r)
451instance FromJS x (JSUint8Array x) where
452 fromJS = return . JSUint8Array
454instance ToJS x Word8 where
455 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
457instance ToJS x Int where
458 withJS n = withJSNumber $ fromIntegral n --TODO: Check things; throw exceptions
460instance FromJS x Int where
461 fromJS = fmap round . fromJSNumber --TODO: Check things; throw exceptions
463instance ToJS x Double where
464 withJS = withJSNumber
466instance FromJS x Double where
467 fromJS = fromJSNumber
469instance ToJS x Node where
470 withJS = withJSNode
473importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
474importJS safety body name qt = do
475 t <- qt
476 let (argTypes, _) = parseType t
477 argNames <- forM argTypes $ \_ -> do
478 arg <- newName "arg"
479 argRef <- newName "argRef"
480 return (arg, argRef)
481 (jsffiDecs, jsffiExp) <- mkJSFFI safety body
482 let go [] = [| runJS $(return jsffiExp) $(listE $ map (varE . snd) argNames) >>= fromJS
483 |]
484 go ((arg, argRef) : args) = [| withJS $(varE arg) $ $(lamE [varP argRef] $ go args) |]
485 e <- lamE (map (varP. fst) argNames) $ go argNames
486 let n = mkName name
487 return $ jsffiDecs ++
488 [ SigD n t
489 , ValD (VarP n) (NormalB e) []
490 ]
492mkJSFFI :: Safety -> String -> Q ([Dec], Exp)
493#ifdef __GHCJS__
494mkJSFFI safety body = do
495 -- n <- newName "jsffi" --TODO: Should use newName, but that doesn't seem to work with ghcjs
496 l <- location
497 n <- newName $ "jsffi_" <> zEncodeString (loc_package l <> ":" <> loc_module l) <> "_" <> show (abs (hash (show safety, body)))
498 t <- [t| JSFFI_Internal |]
499 let wrappedBody = "(function(){ return (" <> body <> "); }).apply($1)"
500 let decs = [ForeignD $ ImportF JavaScript safety wrappedBody n t]
501 e <- [| JSFFI $(varE n) |]
502 return (decs, e)
503#else
504mkJSFFI _ body = do
505 e <- [| JSFFI body |]
506 return ([], e)
507#endif
509parseType :: Type -> ([Type], Type)
510parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
511 | monadJs == ''MonadJS = go funType
512 where go t = case t of
513 AppT (AppT ArrowT arg) t' ->
514 let (args, result) = go t'
515 in (arg : args, result)
516 AppT (VarT m') result
517 | m' == m -> ([], result)
518 _ -> error $ "parseType: can't parse type " <> show t
519parseType t = error $ "parseType: can't parse type " <> show t