git.iko.soy/reflex-dom
on develop help sign in
Fix instant switchover when rendering dom elements
6b8d43fRyan Trinkle
src/Reflex/Dom/Internal.hs+38−24
compare with develop
unifiedsplit
@@ -15,7 +15,6 @@ module Reflex.Dom.Internal where
15
15
16import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
16import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
17
17
18−import qualified Reflex as R
19import Reflex.Dom.Builder.Immediate
18import Reflex.Dom.Builder.Immediate
20import Reflex.Dom.Class
19import Reflex.Dom.Class
21import Reflex.Dom.Internal.Foreign
20import Reflex.Dom.Internal.Foreign
@@ -78,37 +77,52 @@ attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
78
77
79-- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.
78-- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.
80mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> IO ()
79mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> IO ()
81−mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingletonMono webView $ \wv -> fmap fst $ attachWidget'' $ \events -> do
80+mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingletonMono webView $ \wv -> do
82− let (headWidget, bodyWidget) = widgets
83 Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
81 Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
84 Just headElement <- getHead doc
82 Just headElement <- getHead doc
83+ Just headFragment <- createDocumentFragment doc
85 Just bodyElement <- getBody doc
84 Just bodyElement <- getBody doc
85+ Just bodyFragment <- createDocumentFragment doc
86+ _ <- attachWidget'' $ \events -> do
87+ let (headWidget, bodyWidget) = widgets
86− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
88+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
87− rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement wv $ headWidget a
89+ let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c
88− a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement wv $ bodyWidget b
90+ go w df = do
89− return ((), postBuildTriggerRef)
91+ let builderEnv = ImmediateDomBuilderEnv
92+ { _immediateDomBuilderEnv_document = toDocument doc
93+ , _immediateDomBuilderEnv_parent = toNode df
94+ , _immediateDomBuilderEnv_events = events
95+ }
96+ runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
97+ rec b <- go (headWidget a) headFragment
98+ a <- go (bodyWidget b) bodyFragment
99+ return ((), postBuildTriggerRef)
100+ liftIO $ replaceElementContents headElement headFragment
101+ liftIO $ replaceElementContents bodyElement bodyFragment
102+
103+replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> IO ()
104+replaceElementContents e df = do
105+ setInnerHTML e $ Just ("" :: String)
106+ _ <- appendChild e $ Just df
107+ return ()
90
108
109+{-# INLINABLE attachWidget' #-}
91−unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> WebViewSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a
110+attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
92−unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do
111+attachWidget' rootElement wv w = do
93 Just doc <- getOwnerDocument rootElement
112 Just doc <- getOwnerDocument rootElement
94 Just df <- createDocumentFragment doc
113 Just df <- createDocumentFragment doc
114+ result <- attachWidget'' $ \events -> do
115+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
95− let builderEnv = ImmediateDomBuilderEnv
116+ let builderEnv = ImmediateDomBuilderEnv
96− { _immediateDomBuilderEnv_document = doc
117+ { _immediateDomBuilderEnv_document = toDocument doc
97− , _immediateDomBuilderEnv_parent = toNode df
118+ , _immediateDomBuilderEnv_parent = toNode df
98− , _immediateDomBuilderEnv_events = events
119+ , _immediateDomBuilderEnv_events = events
99− }
120+ }
100− result <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
121+ a <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
101− setInnerHTML rootElement $ Just ("" :: String)
122+ return (a, postBuildTriggerRef)
102− _ <- appendChild rootElement $ Just df
123+ replaceElementContents rootElement df
103 return result
124 return result
104
125
105−{-# INLINABLE attachWidget' #-}
106−attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
107−attachWidget' rootElement wv w = attachWidget'' $ \events -> do
108− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
109− result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w
110− return (result, postBuildTriggerRef)
111−
112type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
126type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
113
127
114{-# INLINABLE attachWidget'' #-}
128{-# INLINABLE attachWidget'' #-}