git.iko.soy/reflex-dom
on develop help sign in
wip
a945be7Tom Smalley
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+185−30
compare with develop
unifiedsplit
@@ -128,6 +128,7 @@ import Data.Monoid hiding (Product)
128import Data.Some (Some)
128import Data.Some (Some)
129import qualified Data.Some as Some
129import qualified Data.Some as Some
130import Data.Text (Text)
130import Data.Text (Text)
131+import qualified Data.Text as T
131import qualified GHCJS.DOM as DOM
132import qualified GHCJS.DOM as DOM
132import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
133import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
133import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
134import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
@@ -145,8 +146,10 @@ import GHCJS.DOM.MouseEvent
145import qualified GHCJS.DOM.Touch as Touch
146import qualified GHCJS.DOM.Touch as Touch
146import qualified GHCJS.DOM.TouchEvent as TouchEvent
147import qualified GHCJS.DOM.TouchEvent as TouchEvent
147import qualified GHCJS.DOM.TouchList as TouchList
148import qualified GHCJS.DOM.TouchList as TouchList
148−import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
149+import GHCJS.DOM.Node (appendChild_, getChildNodes, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
149import qualified GHCJS.DOM.Node as DOM (insertBefore_)
150import qualified GHCJS.DOM.Node as DOM (insertBefore_)
151+import qualified GHCJS.DOM.Node as Node
152+import qualified GHCJS.DOM.NodeList as NodeList
150import GHCJS.DOM.Types
153import GHCJS.DOM.Types
151 (liftJSM, askJSM, runJSM, JSM, MonadJSM,
154 (liftJSM, askJSM, runJSM, JSM, MonadJSM,
152 FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
155 FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
@@ -155,7 +158,7 @@ import qualified GHCJS.DOM.Types as DOM
155import GHCJS.DOM.UIEvent
158import GHCJS.DOM.UIEvent
156import GHCJS.DOM.KeyboardEvent as KeyboardEvent
159import GHCJS.DOM.KeyboardEvent as KeyboardEvent
157import qualified GHCJS.DOM.Window as Window
160import qualified GHCJS.DOM.Window as Window
158−import Language.Javascript.JSaddle (call, eval)
161+import Language.Javascript.JSaddle (call, eval, jsg, js1)
159import Data.IntMap.Strict (IntMap)
162import Data.IntMap.Strict (IntMap)
160import qualified Data.IntMap.Strict as IntMap
163import qualified Data.IntMap.Strict as IntMap
161import Data.FastMutableIntMap (PatchIntMap (..))
164import Data.FastMutableIntMap (PatchIntMap (..))
@@ -172,11 +175,19 @@ instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
172 liftJSM' = ImmediateDomBuilderT . liftJSM'
175 liftJSM' = ImmediateDomBuilderT . liftJSM'
173#endif
176#endif
174
177
178+{- Hydration:
179+ - Fence off `prerender` and totally replace immediately
180+ - Fence off `runWithReplace` and hydrate at postBuild
181+ - Otherwise hydrate at build time, skipping elements without SSR attribute, stripping the attrs as we go
182+-}
183+
175data ImmediateDomBuilderEnv t
184data ImmediateDomBuilderEnv t
176 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document
185 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document
177 , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node
186 , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node
178 , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
187 , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
179 , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
188 , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
189+ , _immediateDomBuilderEnv_hydrating :: {-# UNPACK #-} !(IORef Bool) -- In hydration mode?
190+ , _immediateDomBuilderEnv_hydrationNode :: {-# UNPACK #-} !(IORef (Maybe Node)) -- Hydration node index
180 }
191 }
181
192
182newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }
193newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }
@@ -249,21 +260,76 @@ append n = do
249 liftJSM $ appendChild_ p n
260 liftJSM $ appendChild_ p n
250 return ()
261 return ()
251
262
263+getHydrationMode :: MonadIO m => ImmediateDomBuilderT t m Bool
264+getHydrationMode = do
265+ ref <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrating
266+ liftIO $ readIORef ref
267+
252{-# INLINABLE textNodeInternal #-}
268{-# INLINABLE textNodeInternal #-}
253textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
269textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
254textNodeInternal !t = do
270textNodeInternal !t = do
255 doc <- askDocument
271 doc <- askDocument
256− n <- liftJSM $ createTextNode doc t
272+-- n <- liftJSM $ createTextNode doc t
257− append $ toNode n
273+-- append $ toNode n
258− return n
274+-- return n
275+ parent <- askParent
276+ getHydrationMode >>= \case
277+ False -> do
278+ liftIO $ print $ "Not in hydration mode, creating text node: " <> DOM.toJSString t
279+ n <- liftJSM $ createTextNode doc t -- not in hydration mode, create as usual
280+ append $ toNode n
281+ pure n
282+ True -> do
283+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
284+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
285+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
286+ Nothing -> do
287+ liftIO $ print $ "No node found, building text node: " <> DOM.toJSString t
288+ tn <- liftJSM $ createTextNode doc t
289+ append $ toNode tn -- we can append because there's no node at this index (we have exhausted all previous nodes)
290+ pure tn
291+ Just node -> DOM.castTo DOM.Text node >>= \case
292+ Nothing -> do
293+ liftIO $ putStrLn $ "Not a text node, skipping"
294+ go (Just node)
295+ Just tn -> do
296+ liftIO $ print $ "Using existing text node: instead of building " <> DOM.toJSString t
297+ pure tn
298+ n <- go lastHydrationNode
299+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode n)
300+ pure n
259
301
260{-# INLINABLE commentNodeInternal #-}
302{-# INLINABLE commentNodeInternal #-}
261commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Comment
303commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Comment
262commentNodeInternal !t = do
304commentNodeInternal !t = do
263 doc <- askDocument
305 doc <- askDocument
306+ parent <- askParent
307+
308+ getHydrationMode >>= \case
309+ False -> do
310+ liftIO $ print $ "Not in hydration mode, creating comment node: " <> DOM.toJSString t
264− n <- liftJSM $ createComment doc t
311+ n <- liftJSM $ createComment doc t -- not in hydration mode, create as usual
265− append $ toNode n
312+ append $ toNode n
266− return n
313+ pure n
314+ True -> do
315+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
316+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
317+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
318+ Nothing -> do
319+ liftIO $ print $ "No node found, building comment node: " <> DOM.toJSString t
320+ tn <- liftJSM $ createComment doc t
321+ append $ toNode tn -- we can append because there's no node at this index (we have exhausted all previous nodes)
322+ pure tn
323+ Just node -> DOM.castTo DOM.Comment node >>= \case
324+ Nothing -> do
325+ liftIO $ putStrLn $ "Not a comment node, skipping"
326+ go (Just node)
327+ Just tn -> do
328+ liftIO $ print $ "Using existing comment node: instead of building " <> DOM.toJSString t
329+ pure tn
330+ n <- go lastHydrationNode
331+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode n)
332+ pure n
267
333
268-- | s and e must both be children of the same node and s must precede e;
334-- | s and e must both be children of the same node and s must precede e;
269-- all nodes between s and e will be removed, but s and e will not be removed
335-- all nodes between s and e will be removed, but s and e will not be removed
@@ -367,16 +433,45 @@ wrap e cfg = do
367makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
433makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
368makeElement elementTag cfg child = do
434makeElement elementTag cfg child = do
369 doc <- askDocument
435 doc <- askDocument
436+ parent <- askParent
437+ let buildElement = do
370− e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
438+ e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
371− Nothing -> createElement doc elementTag
439+ Nothing -> createElement doc elementTag
372− Just ens -> createElementNS doc (Just ens) elementTag
440+ Just ens -> createElementNS doc (Just ens) elementTag
373− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
441+ ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
374− Nothing -> lift $ setAttribute e n v
442+ Nothing -> lift $ setAttribute e n v
375− Just ans -> lift $ setAttributeNS e (Just ans) n v
443+ Just ans -> lift $ setAttributeNS e (Just ans) n v
376− result <- flip localEnv child $ \env -> env
444+ pure e
445+ e <- getHydrationMode >>= \case
446+ False -> do
447+ liftIO $ print $ "Not in hydration mode, creating " <> elementTag
448+ e <- buildElement -- not in hydration mode, create as usual
449+ append $ toNode e
450+ pure e
451+ True -> do
452+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
453+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
454+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
455+ Nothing -> do
456+ liftIO $ print $ "No node found, building element: " <> elementTag
457+ e <- buildElement
458+ append $ toNode e -- we can append because there's no node at this index (we have exhausted all previous nodes)
459+ pure e
460+ Just node -> DOM.castTo DOM.Element node >>= \case
461+ Nothing -> do
462+ liftIO $ putStrLn $ "Not an element, skipping"
463+ go (Just node) -- TODO maybe check for SSR attribute?
464+ Just e -> do
465+ tn <- Element.getTagName e
466+ liftIO $ print $ "Using existing element: " <> tn <> " instead of building " <> elementTag
467+ pure e
468+ e <- go lastHydrationNode
469+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode e)
470+ pure e
471+
472+ -- TODO: prerender needs completely replacing
473+ childNode <- liftIO $ newIORef Nothing
377− { _immediateDomBuilderEnv_parent = toNode e
474+ result <- localEnv (\env -> env { _immediateDomBuilderEnv_parent = toNode e, _immediateDomBuilderEnv_hydrationNode = childNode }) child
378− }
379− append $ toNode e
380 wrapped <- wrap e $ extractRawElementConfig cfg
475 wrapped <- wrap e $ extractRawElementConfig cfg
381 return ((wrapped, result), e)
476 return ((wrapped, result), e)
382
477
@@ -625,11 +720,62 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
625 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
720 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
626 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
721 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
627
722
723+localNoHydration :: MonadIO m => ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
724+localNoHydration m = do
725+ h <- liftIO $ newIORef False
726+ localEnv (\env -> env { _immediateDomBuilderEnv_hydrating = h }) m
727+
728+skipToCommentId :: (MonadJSM m, IsNode a) => Text -> ImmediateDomBuilderT t m a -> (a -> Maybe DOM.Node -> ImmediateDomBuilderT t m ()) -> ImmediateDomBuilderT t m (a, Text)
729+skipToCommentId prefix buildElement replaceOrCreate = do
730+ doc <- askDocument
731+ parent <- askParent
732+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
733+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
734+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
735+ Nothing -> do
736+ liftIO $ print $ "No node found, building comment"
737+ a <- buildElement
738+ replaceOrCreate a Nothing
739+ pure (a, "")
740+ Just node -> DOM.castTo DOM.Comment node >>= \case
741+ Just comment -> do
742+ commentText <- Node.getTextContentUnchecked comment
743+ case T.stripPrefix prefix commentText of
744+ Just key -> do
745+ new <- buildElement
746+ replaceOrCreate new (Just node)
747+ pure (new, key)
748+ Nothing -> do
749+ liftIO $ putStrLn $ "Not a comment, skipping"
750+ go (Just node)
751+ Nothing -> do
752+ liftIO $ putStrLn $ "Not a comment, skipping"
753+ go (Just node)
754+ (a, key) <- go lastHydrationNode
755+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode a)
756+ pure (a, key)
757+
758+skipToReplaceStart :: MonadJSM m => ImmediateDomBuilderT t m (DOM.Text, Text)
759+skipToReplaceStart = do
760+ doc <- askDocument
761+ parent <- askParent
762+ skipToCommentId "replace-start" (liftJSM $ createTextNode doc ("" :: Text)) $ \new -> \case
763+ Nothing -> void $ append $ toNode new
764+ Just node -> void $ liftJSM $ Node.replaceChild parent new node
765+
766+skipToReplaceEnd :: MonadJSM m => Text -> ImmediateDomBuilderT t m DOM.Text
767+skipToReplaceEnd key = do
768+ doc <- askDocument
769+ parent <- askParent
770+ fmap fst $ skipToCommentId "replace-end" (liftJSM $ createTextNode doc ("" :: Text)) $ \new -> \case
771+ Nothing -> void $ append $ toNode new
772+ Just node -> void $ liftJSM $ Node.replaceChild parent new node
773+
628instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
774instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
629 {-# INLINABLE runWithReplace #-}
775 {-# INLINABLE runWithReplace #-}
630 runWithReplace a0 a' = do
776 runWithReplace a0 a' = do
631 initialEnv <- ImmediateDomBuilderT ask
777 initialEnv <- ImmediateDomBuilderT ask
632− before <- textNodeInternal ("" :: Text)
778+ (before, beforeKey) <- skipToReplaceStart
633 let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
779 let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
634 haveEverBeenReady <- liftIO $ newIORef False
780 haveEverBeenReady <- liftIO $ newIORef False
635 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
781 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
@@ -644,14 +790,17 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
644 when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
790 when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
645 -- We draw 'after' in this roundabout way to avoid using MonadFix
791 -- We draw 'after' in this roundabout way to avoid using MonadFix
646 doc <- askDocument
792 doc <- askDocument
647− after <- createTextNode doc ("" :: Text)
793+ after <- skipToReplaceEnd beforeKey
648 let drawInitialChild = do
794 let drawInitialChild = do
649 unreadyChildren <- liftIO $ newIORef 0
795 unreadyChildren <- liftIO $ newIORef 0
650− let f = do
796+-- let f = do
651− result <- a0
797+-- result <- a0
652− append $ toNode after
798+-- append $ toNode after
799+-- Node.getNextSibling (toNode result) >>= \case
800+-- Nothing -> append (toNode after)
801+-- Just next -> insertBefore (toNode after) next
653− return result
802+-- return result
654− result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
803+ result <- runReaderT (unImmediateDomBuilderT a0) initialEnv
655 { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
804 { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
656 , _immediateDomBuilderEnv_commitAction = myCommitAction
805 , _immediateDomBuilderEnv_commitAction = myCommitAction
657 }
806 }
@@ -670,11 +819,12 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
670 insertBefore df after
819 insertBefore df after
671 liftIO $ writeIORef currentCohort cohortId
820 liftIO $ writeIORef currentCohort cohortId
672 myCommitAction
821 myCommitAction
673− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
822+ let env = initialEnv
674− { _immediateDomBuilderEnv_parent = toNode df
823+ { _immediateDomBuilderEnv_parent = toNode df
675− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
824+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
676− , _immediateDomBuilderEnv_commitAction = commitAction
825+ , _immediateDomBuilderEnv_commitAction = commitAction
677− }
826+ }
827+ result <- runReaderT (unImmediateDomBuilderT child) env
678 uc <- liftIO $ readIORef unreadyChildren
828 uc <- liftIO $ readIORef unreadyChildren
679 let commitActionToRunNow = if uc == 0
829 let commitActionToRunNow = if uc == 0
680 then Just commitAction
830 then Just commitAction
@@ -1027,6 +1177,11 @@ mkHasFocus e = do
1027 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1177 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1028 ]
1178 ]
1029
1179
1180+insertAfter :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1181+insertAfter new existing = do
1182+ p <- getParentNodeUnchecked existing
1183+ Node.getNextSibling existing >>= DOM.insertBefore_ p new
1184+
1030insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1185insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1031insertBefore new existing = do
1186insertBefore new existing = do
1032 p <- getParentNodeUnchecked existing
1187 p <- getParentNodeUnchecked existing
reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+9−1
@@ -152,16 +152,24 @@ instance DomSpace StaticDomSpace where
152instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilderT t m) where
152instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilderT t m) where
153 askDocument = pure ()
153 askDocument = pure ()
154
154
155−instance (Reflex t, Adjustable t m, MonadHold t m) => Adjustable t (StaticDomBuilderT t m) where
155+instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where
156 runWithReplace a0 a' = do
156 runWithReplace a0 a' = do
157 e <- StaticDomBuilderT ask
157 e <- StaticDomBuilderT ask
158+ replaceStart
158 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
159 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
159 o <- hold (snd result0) $ fmapCheap snd result'
160 o <- hold (snd result0) $ fmapCheap snd result'
160 StaticDomBuilderT $ modify $ (:) $ join o
161 StaticDomBuilderT $ modify $ (:) $ join o
162+ replaceEnd
161 return (fst result0, fmapCheap fst result')
163 return (fst result0, fmapCheap fst result')
162 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
164 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
163 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
165 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
164
166
167+replaceStart :: DomBuilder t m => m ()
168+replaceStart = void $ commentNode $ def { _commentNodeConfig_initialContents = "replace-start" }
169+
170+replaceEnd :: DomBuilder t m => m ()
171+replaceEnd = void $ commentNode $ def { _commentNodeConfig_initialContents = "replace-end" }
172+
165hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
173hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
166 ( Adjustable t m
174 ( Adjustable t m
167 , MonadHold t m
175 , MonadHold t m
reflex-dom-core/src/Reflex/Dom/Main.hs+8
@@ -123,11 +123,15 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do
123 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c
123 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c
124 go w df = do
124 go w df = do
125 unreadyChildren <- liftIO $ newIORef 0
125 unreadyChildren <- liftIO $ newIORef 0
126+ hydrating <- liftIO $ newIORef True
127+ hydrationNode <- liftIO $ newIORef Nothing
126 let builderEnv = ImmediateDomBuilderEnv
128 let builderEnv = ImmediateDomBuilderEnv
127 { _immediateDomBuilderEnv_document = toDocument doc
129 { _immediateDomBuilderEnv_document = toDocument doc
128 , _immediateDomBuilderEnv_parent = toNode df
130 , _immediateDomBuilderEnv_parent = toNode df
129 , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
131 , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
130 , _immediateDomBuilderEnv_commitAction = return () --TODO
132 , _immediateDomBuilderEnv_commitAction = return () --TODO
133+ , _immediateDomBuilderEnv_hydrating = hydrating
134+ , _immediateDomBuilderEnv_hydrationNode = hydrationNode
131 }
135 }
132 runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing
136 runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing
133 rec b <- go (headWidget a) headFragment
137 rec b <- go (headWidget a) headFragment
@@ -151,11 +155,15 @@ attachWidget' rootElement jsSing w = do
151 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do
155 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do
152 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
156 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
153 unreadyChildren <- liftIO $ newIORef 0
157 unreadyChildren <- liftIO $ newIORef 0
158+ hydrating <- liftIO $ newIORef True
159+ hydrationNode <- liftIO $ newIORef Nothing
154 let builderEnv = ImmediateDomBuilderEnv
160 let builderEnv = ImmediateDomBuilderEnv
155 { _immediateDomBuilderEnv_document = toDocument doc
161 { _immediateDomBuilderEnv_document = toDocument doc
156 , _immediateDomBuilderEnv_parent = toNode df
162 , _immediateDomBuilderEnv_parent = toNode df
157 , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
163 , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
158 , _immediateDomBuilderEnv_commitAction = return () --TODO
164 , _immediateDomBuilderEnv_commitAction = return () --TODO
165+ , _immediateDomBuilderEnv_hydrating = hydrating
166+ , _immediateDomBuilderEnv_hydrationNode = hydrationNode
159 }
167 }
160 a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing
168 a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing
161 return ((a, events), postBuildTriggerRef)
169 return ((a, events), postBuildTriggerRef)
reflex-dom-core/src/Reflex/Dom/Prerender.hs+19−3
@@ -3,6 +3,7 @@
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE Rank2Types #-}
8{-# LANGUAGE Rank2Types #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
@@ -17,6 +18,7 @@ module Reflex.Dom.Prerender
17
18
18import Control.Monad.Reader
19import Control.Monad.Reader
19import Data.Constraint
20import Data.Constraint
21+import Data.Default
20import Foreign.JavaScript.TH
22import Foreign.JavaScript.TH
21import GHCJS.DOM.Types (MonadJSM)
23import GHCJS.DOM.Types (MonadJSM)
22import Reflex
24import Reflex
@@ -44,10 +46,24 @@ class Prerender js m | m -> js where
44-- | Draw one widget when prerendering (e.g. server-side) and another when the
46-- | Draw one widget when prerendering (e.g. server-side) and another when the
45-- widget is fully instantiated. In a given execution of this function, there
47-- widget is fully instantiated. In a given execution of this function, there
46-- will be exactly one invocation of exactly one of the arguments.
48-- will be exactly one invocation of exactly one of the arguments.
47−prerender :: forall js m a. Prerender js m => m a -> (PrerenderClientConstraint js m => m a) -> m a
49+prerender :: forall js t m a. (Prerender js m, DomBuilder t m) => m a -> (PrerenderClientConstraint js m => m a) -> m a
48prerender server client = case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
50prerender server client = case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
49− Nothing -> server
51+ Nothing -> prerenderStart *> server <* prerenderEnd
50− Just Dict -> client
52+ Just Dict -> rerenderStart *> client <* rerenderEnd
53+
54+-- TODO: add a unique ID
55+prerenderStart :: DomBuilder t m => m ()
56+prerenderStart = void $ commentNode $ def { _commentNodeConfig_initialContents = "prerender-start" }
57+
58+prerenderEnd :: DomBuilder t m => m ()
59+prerenderEnd = void $ commentNode $ def { _commentNodeConfig_initialContents = "prerender-end" }
60+
61+-- TODO: add a unique ID
62+rerenderStart :: DomBuilder t m => m ()
63+rerenderStart = void $ commentNode $ def { _commentNodeConfig_initialContents = "rerender-start" }
64+
65+rerenderEnd :: DomBuilder t m => m ()
66+rerenderEnd = void $ commentNode $ def { _commentNodeConfig_initialContents = "rerender-end" }
51
67
52instance ( HasJS js m
68instance ( HasJS js m
53 , HasJS js (Performable m)
69 , HasJS js (Performable m)