@@ -9,7 +9,6 @@
99{-# LANGUAGE MultiParamTypeClasses #-}
1010{-# LANGUAGE RankNTypes #-}
1111{-# LANGUAGE StandaloneDeriving #-}
12−{-# LANGUAGE TemplateHaskell #-}
1312{-# LANGUAGE TypeFamilies #-}
1413{-# LANGUAGE TypeSynonymInstances #-}
1514{-# LANGUAGE UndecidableInstances #-}
@@ -55,11 +54,8 @@ import Data.Coerce (coerce)
5554import Foreign.C.Types
5655import Foreign.Ptr
5756import Text.Encoding.Z
58−
59−import Reflex.Dom.Internal.Foreign (WebView)
6057#else
6158import Data.Word (Word8)
62−import GI.WebKit2 (WebView)
6359import Control.Lens.Operators ((^.))
6460import Language.Javascript.JSaddle
6561 (eval, valMakeString, valToNumber, function,
@@ -84,58 +80,58 @@ import Data.Monoid
8480import Data.Text (Text)
8581import qualified Data.Text as T
8682
87−class Monad m => HasWebView m where
88− type WebViewPhantom m :: *
89− askWebView :: m (WebViewSingleton (WebViewPhantom m))
83+class Monad m => HasJSContext m where
84+ type JSContextPhantom m :: *
85+ askJSContext :: m (JSContextSingleton (JSContextPhantom m))
9086
91−instance HasWebView m => HasWebView (ReaderT r m) where
92− type WebViewPhantom (ReaderT r m) = WebViewPhantom m
93− askWebView = lift askWebView
87+instance HasJSContext m => HasJSContext (ReaderT r m) where
88+ type JSContextPhantom (ReaderT r m) = JSContextPhantom m
89+ askJSContext = lift askJSContext
9490
95−instance HasWebView m => HasWebView (StateT r m) where
96− type WebViewPhantom (StateT r m) = WebViewPhantom m
97− askWebView = lift askWebView
91+instance HasJSContext m => HasJSContext (StateT r m) where
92+ type JSContextPhantom (StateT r m) = JSContextPhantom m
93+ askJSContext = lift askJSContext
9894
99−instance HasWebView m => HasWebView (Strict.StateT r m) where
100− type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m
101− askWebView = lift askWebView
95+instance HasJSContext m => HasJSContext (Strict.StateT r m) where
96+ type JSContextPhantom (Strict.StateT r m) = JSContextPhantom m
97+ askJSContext = lift askJSContext
10298
103−instance HasWebView m => HasWebView (PostBuildT t m) where
104− type WebViewPhantom (PostBuildT t m) = WebViewPhantom m
105− askWebView = lift askWebView
99+instance HasJSContext m => HasJSContext (PostBuildT t m) where
100+ type JSContextPhantom (PostBuildT t m) = JSContextPhantom m
101+ askJSContext = lift askJSContext
106102
107−instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where
108− type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)
109− askWebView = PerformEventT $ lift askWebView
103+instance (ReflexHost t, HasJSContext (HostFrame t)) => HasJSContext (PerformEventT t m) where
104+ type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)
105+ askJSContext = PerformEventT $ lift askJSContext
110106
111−instance HasWebView m => HasWebView (DynamicWriterT t w m) where
112− type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
113− askWebView = lift askWebView
107+instance HasJSContext m => HasJSContext (DynamicWriterT t w m) where
108+ type JSContextPhantom (DynamicWriterT t w m) = JSContextPhantom m
109+ askJSContext = lift askJSContext
114110
115−newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
111+newtype WithJSContextSingleton x m a = WithJSContextSingleton { unWithJSContextSingleton :: ReaderT (JSContextSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
116112
117−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
113+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithJSContextSingleton x m) where
118114 {-# INLINABLE newEventWithTrigger #-}
119115 newEventWithTrigger = lift . newEventWithTrigger
120116 {-# INLINABLE newFanEventWithTrigger #-}
121117 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
122118
123−instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
119+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithJSContextSingleton x m) where
124120 {-# INLINABLE subscribeEvent #-}
125121 subscribeEvent = lift . subscribeEvent
126122
127−instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
128− type ReadPhase (WithWebView x m) = ReadPhase m
123+instance MonadReflexHost t m => MonadReflexHost t (WithJSContextSingleton x m) where
124+ type ReadPhase (WithJSContextSingleton x m) = ReadPhase m
129125 {-# INLINABLE fireEventsAndRead #-}
130126 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
131127 {-# INLINABLE runHostFrame #-}
132128 runHostFrame = lift . runHostFrame
133129
134−instance MonadSample t m => MonadSample t (WithWebView x m) where
130+instance MonadSample t m => MonadSample t (WithJSContextSingleton x m) where
135131 {-# INLINABLE sample #-}
136132 sample = lift . sample
137133
138−instance MonadHold t m => MonadHold t (WithWebView x m) where
134+instance MonadHold t m => MonadHold t (WithJSContextSingleton x m) where
139135 {-# INLINABLE hold #-}
140136 hold v0 = lift . hold v0
141137 {-# INLINABLE holdDyn #-}
@@ -143,45 +139,45 @@ instance MonadHold t m => MonadHold t (WithWebView x m) where
143139 {-# INLINABLE holdIncremental #-}
144140 holdIncremental v0 = lift . holdIncremental v0
145141
146−instance MonadTransControl (WithWebView x) where
147− type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
142+instance MonadTransControl (WithJSContextSingleton x) where
143+ type StT (WithJSContextSingleton x) a = StT (ReaderT (JSContextSingleton x)) a
148144 {-# INLINABLE liftWith #-}
149− liftWith = defaultLiftWith WithWebView unWithWebView
145+ liftWith = defaultLiftWith WithJSContextSingleton unWithJSContextSingleton
150146 {-# INLINABLE restoreT #-}
151− restoreT = defaultRestoreT WithWebView
147+ restoreT = defaultRestoreT WithJSContextSingleton
152148
153−instance PerformEvent t m => PerformEvent t (WithWebView x m) where
154− type Performable (WithWebView x m) = WithWebView x (Performable m)
149+instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where
150+ type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m)
155151 {-# INLINABLE performEvent_ #-}
156152 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
157153 {-# INLINABLE performEvent #-}
158154 performEvent e = liftWith $ \run -> performEvent $ fmap run e
159155
160−instance Deletable t m => Deletable t (WithWebView x m) where
156+instance Deletable t m => Deletable t (WithJSContextSingleton x m) where
161157 {-# INLINABLE deletable #-}
162158 deletable = liftThrough . deletable
163159
164−runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
165−runWithWebView = runReaderT . unWithWebView
160+runWithJSContextSingleton :: WithJSContextSingleton x m a -> JSContextSingleton x -> m a
161+runWithJSContextSingleton = runReaderT . unWithJSContextSingleton
166162
167−instance (Monad m) => HasWebView (WithWebView x m) where
168− type WebViewPhantom (WithWebView x m) = x
169− askWebView = WithWebView ask
163+instance (Monad m) => HasJSContext (WithJSContextSingleton x m) where
164+ type JSContextPhantom (WithJSContextSingleton x m) = x
165+ askJSContext = WithJSContextSingleton ask
170166
171−instance MonadRef m => MonadRef (WithWebView x m) where
172− type Ref (WithWebView x m) = Ref m
167+instance MonadRef m => MonadRef (WithJSContextSingleton x m) where
168+ type Ref (WithJSContextSingleton x m) = Ref m
173169 newRef = lift . newRef
174170 readRef = lift . readRef
175171 writeRef r = lift . writeRef r
176172
177−instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
173+instance MonadAtomicRef m => MonadAtomicRef (WithJSContextSingleton x m) where
178174 atomicModifyRef r = lift . atomicModifyRef r
179175
180−withWebViewSingleton :: (WebView, JSContextRef) -> (forall x. WebViewSingleton x -> r) -> r
181−withWebViewSingleton wv f = f $ WebViewSingleton wv
176+withJSContextSingleton :: MonadJSM m => (forall x. JSContextSingleton x -> m r) -> m r
177+withJSContextSingleton f = askJSM >>= f . JSContextSingleton
182178
183−-- | 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
184−newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: (WebView, JSContextRef) }
179+-- | 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
180+newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }
185181
186182#ifdef __GHCJS__
187183type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
@@ -250,8 +246,8 @@ class Monad m => MonadJS x m | m -> x where
250246
251247data JSCtx_IO
252248
253−instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
254− type JSX (WithWebView x m) = IO
249+instance MonadIO m => HasJS JSCtx_IO (WithJSContextSingleton x m) where
250+ type JSX (WithJSContextSingleton x m) = IO
255251 liftJS = liftIO
256252
257253instance IsJSContext JSCtx_IO where
@@ -305,21 +301,21 @@ data JSCtx_JavaScriptCore x
305301instance IsJSContext (JSCtx_JavaScriptCore x) where
306302 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSVal }
307303
308−instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
309− type JSX (WithWebView x m) = WithWebView x IO
304+instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x m) where
305+ type JSX (WithJSContextSingleton x m) = WithJSContextSingleton x IO
310306 liftJS a = do
311− wv <- askWebView
312− liftIO $ runWithWebView a wv
307+ wv <- askJSContext
308+ liftIO $ runWithJSContextSingleton a wv
313309
314310newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
315311
316312runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
317313runWithJSContext = runReaderT . unWithJSContext
318314
319−instance MonadIO m => MonadJSM (WithWebView x m) where
315+instance MonadIO m => MonadJSM (WithJSContextSingleton x m) where
320316 liftJSM' f = do
321− wv <- askWebView
322− runJSM f . snd $ unWebViewSingleton wv
317+ wv <- askJSContext
318+ runJSM f $ unJSContextSingleton wv
323319
324320instance MonadIO m => MonadJSM (WithJSContext x m) where
325321 liftJSM' f =
@@ -330,21 +326,21 @@ lowerWithJSContext a = do
330326 c <- askJSM
331327 liftIO $ runWithJSContext a c
332328
333−liftWithWebViewThroughWithJSContext :: (HasWebView m, MonadJSM m, MonadTrans t, Monad m1)
329+liftWithJSContextSingletonThroughWithJSContext :: (HasJSContext m, MonadJSM m, MonadTrans t, Monad m1)
334330 => ((t1 -> t m1 a) -> WithJSContext x IO b)
335− -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
331+ -> (t1 -> WithJSContextSingleton (JSContextPhantom m) m1 a)
336332 -> m b
337−liftWithWebViewThroughWithJSContext f a = do
338− wv <- askWebView
339− lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv
333+liftWithJSContextSingletonThroughWithJSContext f a = do
334+ wv <- askJSContext
335+ lowerWithJSContext $ f $ \b' -> lift $ runWithJSContextSingleton (a b') wv
340336
341−instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
337+instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x IO) where
342338 forkJS a = do
343− wv <- askWebView
344− liftIO $ forkIO $ runWithWebView a wv
339+ wv <- askJSContext
340+ liftIO $ forkIO $ runWithJSContextSingleton a wv
345341 mkJSFun a = do
346− wv <- askWebView
347− lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv
342+ wv <- askJSContext
343+ lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithJSContextSingleton (a args) wv
348344 runJS expr args = lowerWithJSContext $ runJS expr args
349345 mkJSUndefined = lowerWithJSContext mkJSUndefined
350346 isJSNull = lowerWithJSContext . isJSNull
@@ -355,12 +351,12 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
355351 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
356352 fromJSNumber = lowerWithJSContext . fromJSNumber
357353 freeJSFun = lowerWithJSContext . freeJSFun
358− withJSBool = liftWithWebViewThroughWithJSContext . withJSBool
359− withJSString = liftWithWebViewThroughWithJSContext . withJSString
360− withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber
361− withJSArray = liftWithWebViewThroughWithJSContext . withJSArray
362− withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array
363− withJSNode = liftWithWebViewThroughWithJSContext . withJSNode
354+ withJSBool = liftWithJSContextSingletonThroughWithJSContext . withJSBool
355+ withJSString = liftWithJSContextSingletonThroughWithJSContext . withJSString
356+ withJSNumber = liftWithJSContextSingletonThroughWithJSContext . withJSNumber
357+ withJSArray = liftWithJSContextSingletonThroughWithJSContext . withJSArray
358+ withJSUint8Array = liftWithJSContextSingletonThroughWithJSContext . withJSUint8Array
359+ withJSNode = liftWithJSContextSingletonThroughWithJSContext . withJSNode
364360 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
365361 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
366362
@@ -485,6 +481,8 @@ instance ToJS x Node where
485481 withJS = withJSNode
486482
487483
484+#if 0
485+
488486importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
489487importJS safety body name qt = do
490488 t <- qt
@@ -532,3 +530,5 @@ parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
532530 | m' == m -> ([], result)
533531 _ -> error $ "parseType: can't parse type " <> show t
534532parseType t = error $ "parseType: can't parse type " <> show t
533+
534+#endif