@@ -176,10 +176,6 @@ instance MonadJSM m => MonadJSM (HydrationDomBuilderT t m) where
176176
177177data HydrationDomSpace
178178
179−data HydrationEventSpec (er :: EventTag -> *) = HydrationEventSpec deriving (Generic)
180−
181−instance Default (HydrationEventSpec er)
182−
183179instance DomSpace HydrationDomSpace where
184180 type EventSpec HydrationDomSpace = GhcjsEventSpec
185181 type RawDocument HydrationDomSpace = DOM.Document
@@ -203,13 +199,6 @@ instance DomSpace HydrationDomSpace where
203199 return (newFlags, return mEventResult)
204200 in DMap.alter f' en $ _ghcjsEventSpec_filters es
205201 }
206−-- addEventSpecFlags _ _ _ _ = HydrationEventSpec
207−
208−{- Hydration:
209− - Fence off `prerender` and totally replace immediately
210− - Fence off `runWithReplace` and hydrate at postBuild
211− - Otherwise hydrate at build time, skipping elements without SSR attribute, stripping the attrs as we go
212−-}
213202
214203data HydrationDomBuilderEnv t m
215204 = HydrationDomBuilderEnv { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
@@ -293,6 +282,7 @@ askParent = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent
293282askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
294283askEvents = HydrationDomBuilderT . lift . lift . lift $ TriggerEventT.askEvents
295284
285+{-# INLINABLE localEnv #-}
296286localEnv :: Monad m => (HydrationState t m -> HydrationState t m) -> (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a
297287localEnv f g (HydrationDomBuilderT m) = HydrationDomBuilderT $ do
298288 env <- ask
@@ -311,7 +301,7 @@ setPreviousNode n = HydrationDomBuilderT $ modify $ \hs -> hs { _hydrationState_
311301append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT t m ()
312302append n = do
313303 p <- askParent
314− liftJSM $ appendChild_ p n
304+ appendChild_ p n
315305 return ()
316306
317307data HydrationMode
@@ -319,20 +309,22 @@ data HydrationMode
319309 | HydrationMode_Immediate
320310 deriving (Eq, Ord, Show)
321311
312+{-# INLINABLE getHydrationMode #-}
322313getHydrationMode :: MonadIO m => HydrationDomBuilderT t m HydrationMode
323−getHydrationMode = do
324− ref <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationMode
325− liftIO $ readIORef ref
314+getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
326315
327316{-# INLINABLE textNodeInternal #-}
328317textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Text
329−textNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> liftJSM $ createTextNode doc t) DOM.Text
318+textNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> createTextNode doc t) DOM.Text
330319
331320{-# INLINABLE commentNodeInternal #-}
332321commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Comment
333−commentNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> liftJSM $ createComment doc t) DOM.Comment
322+commentNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> createComment doc t) DOM.Comment
334323
335324{-# INLINABLE makeNodeInternal #-}
325+-- | This function, in hydration mode, expects the existing DOM at the current
326+-- hydration node to be correct. It skips any nodes that are the wrong type, or
327+-- that fail the @check@. The previous node reference is also updated.
336328makeNodeInternal :: (MonadJSM m, IsNode node, Typeable node) => (node -> HydrationDomBuilderT t m Bool) -> HydrationDomBuilderT t m node -> (DOM.JSVal -> node) -> HydrationDomBuilderT t m node
337329makeNodeInternal check mkNode constructor = do
338330 doc <- askDocument
@@ -363,14 +355,10 @@ makeNodeInternal check mkNode constructor = do
363355 setPreviousNode $ Just $ toNode n
364356 return n
365357
366−-- skipToCommentId "prerender-start" (liftJSM $ createComment doc "rerender-start") $ \new -> \case
367−-- Nothing -> void $ append $ toNode new
368−-- Just node -> void $ liftJSM $ Node.replaceChild parent new node
369−
370358-- | s and e must both be children of the same node and s must precede e;
371359-- all nodes between s and e will be removed, but s and e will not be removed
372360deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
373−deleteBetweenExclusive s e = liftJSM $ do
361+deleteBetweenExclusive s e = do
374362 df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
375363 extractBetweenExclusive df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
376364
@@ -672,35 +660,47 @@ instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomB
672660 liftIO $ writeIORef (_hydrationDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
673661 liftIO $ writeIORef (_hydrationDomFragment_state fragment) $ FragmentState_Mounted (before, after)
674662
675−skipToCommentId :: MonadJSM m => Text -> HydrationDomBuilderT t m (DOM.Node, Text)
676−skipToCommentId prefix = do
677− doc <- askDocument
678− parent <- askParent
679− lastHydrationNode <- getPreviousNode
680− let go mLastNode = do
681− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
682− DOM.castTo DOM.Comment node >>= \case
683− Just comment -> do
684− commentText <- Node.getTextContentUnchecked comment
685− case T.stripPrefix prefix commentText of
686− Just key -> pure (comment, key)
687− Nothing -> do
688− liftIO $ putStrLn $ "Bad key in comment, skipping"
689− go (Just node)
690− Nothing -> do
691− commentText <- Node.getTextContentUnchecked node
692− liftIO $ putStrLn $ "Not a comment, skipping"
693− liftIO $ putStrLn commentText
694− go (Just node)
695− (a, key) <- go lastHydrationNode
696− setPreviousNode $ Just $ toNode a
697− pure (toNode a, key)
663+-- | We leave markers in the static builder as comments, and rip these comments
664+-- out at hydration time, replacing them with empty text nodes.
665+skipToAndReplaceComment :: MonadJSM m => Text -> HydrationDomBuilderT t m (DOM.Text, Text)
666+skipToAndReplaceComment prefix = getHydrationMode >>= \case
667+ HydrationMode_Immediate -> do
668+ -- If we're in immediate mode, we don't try to replace an existing comment,
669+ -- and just return a dummy key
670+ t <- textNodeInternal ("" :: Text)
671+ pure (t, "")
672+ HydrationMode_Hydrating -> do
673+ doc <- askDocument
674+ parent <- askParent
675+ lastHydrationNode <- getPreviousNode
676+ let go mLastNode = do
677+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
678+ DOM.castTo DOM.Comment node >>= \case
679+ Just comment -> do
680+ commentText <- Node.getTextContentUnchecked comment
681+ case T.stripPrefix prefix commentText of
682+ Just key -> do
683+ -- Replace the comment with an (invisible) text node
684+ textNode <- createTextNode doc ("" :: Text)
685+ Node.replaceChild_ parent textNode comment
686+ pure (textNode, key)
687+ Nothing -> do
688+ liftIO $ putStrLn $ "Bad key in comment, skipping"
689+ go (Just node)
690+ Nothing -> do
691+ commentText <- Node.getTextContentUnchecked node
692+ liftIO $ putStrLn $ "Not a comment, skipping"
693+ liftIO $ putStrLn commentText
694+ go (Just node)
695+ (a, key) <- go lastHydrationNode
696+ setPreviousNode $ Just $ toNode a
697+ pure (a, key)
698698
699−skipToReplaceStart :: MonadJSM m => HydrationDomBuilderT t m (DOM.Node, Text)
700−skipToReplaceStart = skipToCommentId "replace-start"
699+skipToReplaceStart :: MonadJSM m => HydrationDomBuilderT t m (DOM.Text, Text)
700+skipToReplaceStart = skipToAndReplaceComment "replace-start"
701701
702−skipToReplaceEnd :: MonadJSM m => Text -> HydrationDomBuilderT t m DOM.Node
703−skipToReplaceEnd key = fmap fst $ skipToCommentId $ "replace-end" <> key
702+skipToReplaceEnd :: MonadJSM m => Text -> HydrationDomBuilderT t m DOM.Text
703+skipToReplaceEnd key = fmap fst $ skipToAndReplaceComment $ "replace-end" <> key
704704
705705instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ref m ~ IORef, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadRef m) => Adjustable t (HydrationDomBuilderT t m) where
706706 {-# INLINABLE runWithReplace #-}
@@ -714,7 +714,7 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
714714 HydrationMode_Immediate -> do
715715 t <- textNodeInternal ("" :: Text)
716716 append $ toNode t
717− pure (toNode t, "")
717+ pure (t, "")
718718 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
719719 haveEverBeenReady <- liftIO $ newIORef False
720720 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
@@ -735,7 +735,7 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
735735 HydrationMode_Immediate -> do
736736 t <- textNodeInternal ("" :: Text)
737737 append $ toNode t
738− pure (toNode t)
738+ pure t
739739 let drawInitialChild = do
740740 liftIO $ putStrLn "drawInitialChild"
741741 p <- liftIO (readIORef hydrating) >>= \case
@@ -843,7 +843,12 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
843843 liftIO $ writeIORef placeholders $! phsAfter
844844
845845{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
846−traverseDMapWithKeyWithAdjust' :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k) => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> HydrationDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
846+traverseDMapWithKeyWithAdjust'
847+ :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k)
848+ => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
849+ -> DMap k v
850+ -> Event t (PatchDMap k v)
851+ -> HydrationDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
847852traverseDMapWithKeyWithAdjust' = do
848853 let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
849854 let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
@@ -1010,6 +1015,7 @@ hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
10101015 -> Event t (p k v)
10111016 -> HydrationDomBuilderT t m (DMap k v', Event t (p k v'))
10121017hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
1018+ (_, key) <- skipToReplaceStart
10131019 initialEnv <- HydrationDomBuilderT ask
10141020 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
10151021 pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
@@ -1044,7 +1050,9 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
10441050 liftIO $ writeIORef pendingChange (newUnready, p)
10451051 when (DMap.null newUnready) $ do
10461052 applyDomUpdate p
1047− (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1053+ stateRef <- liftIO . newIORef =<< HydrationDomBuilderT get
1054+ (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate stateRef initialEnv markChildReady $ f k v) dm0 dm'
1055+ HydrationDomBuilderT . put =<< liftIO (readIORef stateRef)
10481056 let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
10491057 readIORef sRef >>= \case
10501058 ChildReadyState_Ready -> return Nothing
@@ -1061,8 +1069,10 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
10611069 placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
10621070 result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
10631071 liftIO $ writeIORef placeholders $! placeholders0
1064− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
1065− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
1072+ getHydrationMode >>= \case
1073+ HydrationMode_Immediate -> void $ DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
1074+ _ -> pure ()
1075+ liftIO . writeIORef lastPlaceholderRef =<< skipToReplaceEnd key
10661076 requestDomAction_ $ ffor children' $ \p -> do
10671077 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
10681078 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1074,22 +1084,39 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
10741084
10751085{-# INLINABLE drawChildUpdate #-}
10761086drawChildUpdate :: (MonadIO m, MonadJSM m)
1077− => HydrationDomBuilderEnv t m
1087+ => IORef (HydrationState t m)
1088+ -> HydrationDomBuilderEnv t m
10781089 -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
10791090 -> HydrationDomBuilderT t m (v' a)
10801091 -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
1081−drawChildUpdate initialEnv markReady child = do
1092+drawChildUpdate stateRef initialEnv markReady child = do
10821093 childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
1094+ let doc = _hydrationDomBuilderEnv_document initialEnv
10831095 unreadyChildren <- liftIO $ newIORef 0
1084− df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv
1085− (placeholder, result) <- flip evalStateT (HydrationState [] Nothing) $ runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
1086− { _hydrationDomBuilderEnv_parent = toNode df
1087− , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1088− , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1089− }
1096+ hydrationMode <- liftIO $ readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv
1097+ initialState <- liftIO $ readIORef stateRef
1098+ placeholder <- createTextNode doc ("" :: Text)
1099+ p <- case hydrationMode of
1100+ HydrationMode_Hydrating -> do
1101+ let p = _hydrationDomBuilderEnv_parent initialEnv
1102+ case _hydrationState_previousNode initialState of
1103+ Nothing -> Node.appendChild_ p placeholder
1104+ Just pn -> Node.getNextSibling pn >>= Node.insertBefore_ p placeholder
1105+ pure (Left p)
1106+ HydrationMode_Immediate -> do
1107+ df <- createDocumentFragment doc
1108+ Node.appendChild_ df placeholder
1109+ pure (Right df)
1110+ let env = initialEnv
1111+ { _hydrationDomBuilderEnv_parent = either id toNode p
1112+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1113+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1114+ }
1115+ (result, finalState) <- runStateT (runReaderT (unHydrationDomBuilderT child) env) (initialState { _hydrationState_previousNode = Just $ toNode placeholder })
1116+ liftIO $ writeIORef stateRef finalState
10901117 u <- liftIO $ readIORef unreadyChildren
10911118 when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1092− return $ Compose (df, placeholder, childReadyState, result)
1119+ return (Compose (either (const $ error "Tried to use document fragment in hydration mode") id p, placeholder, childReadyState, result))
10931120
10941121{-# INLINABLE drawChildUpdateInt #-}
10951122drawChildUpdateInt :: (MonadIO m, MonadJSM m)