@@ -17,7 +17,6 @@ module Reflex.Dom.Main where
1717
1818import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
1919
20−import qualified Reflex as R
2120import Reflex.Dom.Builder.Immediate
2221import Reflex.Dom.Class
2322import Reflex.Host.Class
@@ -90,41 +89,57 @@ instance MonadJSM m => MonadJSM (PostBuildT t m) where
9089
9190{-# INLINABLE attachWidget #-}
9291attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a
93−attachWidget rootElement wv w = liftIO $ fst <$> attachWidget' rootElement wv w
94−
95−mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> JSM ()
96−mainWidgetWithHead' widgets = withJSContextSingleton $ \jsSing -> do
97− doc <- currentDocumentUnchecked
98− headElement <- getHeadUnchecked doc
99− bodyElement <- getBodyUnchecked doc
100−-- runWebGUI $ \webView -> withWebViewSingleton webView $ \wv ->
101− liftIO $ fmap fst $ attachWidget'' $ \events -> do
102− let (headWidget, bodyWidget) = widgets
103− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
104− rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement jsSing $ headWidget a
105− a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement jsSing $ bodyWidget b
106− return ((), postBuildTriggerRef)
107−
108−unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> JSContextSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a
109−unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w = (`runWithJSContextSingleton` jsSing) $ do
110− doc <- getOwnerDocumentUnchecked rootElement
111− df <- createDocumentFragmentUnchecked doc
112− let builderEnv = ImmediateDomBuilderEnv
113− { _immediateDomBuilderEnv_document = doc
114− , _immediateDomBuilderEnv_parent = toNode df
115− , _immediateDomBuilderEnv_events = events
116− }
117− result <- runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv
118− setInnerHTML rootElement $ Just ("" :: String)
119− _ <- appendChildUnchecked rootElement $ Just df
120− return result
92+attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
93+
94+-- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.
95+mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> JSM ()
96+mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do
97+ doc <- currentDocumentUnchecked
98+ headElement <- getHeadUnchecked doc
99+ headFragment <- createDocumentFragmentUnchecked doc
100+ bodyElement <- getBodyUnchecked doc
101+ bodyFragment <- createDocumentFragmentUnchecked doc
102+ (events, fc) <- liftIO . attachWidget'' $ \events -> do
103+ let (headWidget, bodyWidget) = widgets
104+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
105+ let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c
106+ go w df = do
107+ let builderEnv = ImmediateDomBuilderEnv
108+ { _immediateDomBuilderEnv_document = toDocument doc
109+ , _immediateDomBuilderEnv_parent = toNode df
110+ , _immediateDomBuilderEnv_events = events
111+ }
112+ runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing
113+ rec b <- go (headWidget a) headFragment
114+ a <- go (bodyWidget b) bodyFragment
115+ return (events, postBuildTriggerRef)
116+ replaceElementContents headElement headFragment
117+ replaceElementContents bodyElement bodyFragment
118+ liftIO $ processAsyncEvents events fc
119+
120+replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> JSM ()
121+replaceElementContents e df = do
122+ setInnerHTML e $ Just ("" :: String)
123+ _ <- appendChildUnchecked e $ Just df
124+ return ()
121125
122126{-# INLINABLE attachWidget' #-}
123−attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
124−attachWidget' rootElement jsSing w = attachWidget'' $ \events -> do
125− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
126− result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w
127− return (result, postBuildTriggerRef)
127+attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM (a, FireCommand Spider (SpiderHost Global))
128+attachWidget' rootElement jsSing w = do
129+ doc <- getOwnerDocumentUnchecked rootElement
130+ df <- createDocumentFragmentUnchecked doc
131+ ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do
132+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
133+ let builderEnv = ImmediateDomBuilderEnv
134+ { _immediateDomBuilderEnv_document = toDocument doc
135+ , _immediateDomBuilderEnv_parent = toNode df
136+ , _immediateDomBuilderEnv_events = events
137+ }
138+ a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing
139+ return ((a, events), postBuildTriggerRef)
140+ replaceElementContents rootElement df
141+ liftIO $ processAsyncEvents events fc
142+ return (a, fc)
128143
129144type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
130145
@@ -132,21 +147,23 @@ type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
132147attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))
133148attachWidget'' w = do
134149 events <- newChan
135− (result, fc@(FireCommand fire)) <- runSpiderHost $ do
150+ runSpiderHost $ do
136151 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events
137152 mPostBuildTrigger <- readRef postBuildTriggerRef
138153 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
139154 return (result, fc)
140− void $ forkIO $ forever $ do
141− ers <- readChan events
142− _ <- runSpiderHost $ do
143− mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
144− me <- readIORef er
145− return $ fmap (\e -> e :=> Identity a) me
146− _ <- fire (catMaybes mes) $ return ()
147− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
148− return ()
149− return (result, fc)
155+
156+processAsyncEvents :: EventChannel -> FireCommand Spider (SpiderHost Global) -> IO ()
157+processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
158+ ers <- readChan events
159+ _ <- runSpiderHost $ do
160+ mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
161+ me <- readIORef er
162+ return $ fmap (\e -> e :=> Identity a) me
163+ _ <- fire (catMaybes mes) $ return ()
164+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
165+ return ()
166+
150167
151168-- | Run a reflex-dom application inside of an existing DOM element with the given ID
152169mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()