@@ -3,7 +3,10 @@
33{-# LANGUAGE ConstraintKinds #-}
44{-# LANGUAGE DataKinds #-}
55{-# LANGUAGE DefaultSignatures #-}
6+{-# LANGUAGE DeriveFoldable #-}
7+{-# LANGUAGE DeriveFunctor #-}
68{-# LANGUAGE DeriveGeneric #-}
9+{-# LANGUAGE DeriveTraversable #-}
710{-# LANGUAGE EmptyDataDecls #-}
811{-# LANGUAGE FlexibleContexts #-}
912{-# LANGUAGE FlexibleInstances #-}
@@ -31,7 +34,13 @@ module Reflex.Dom.Builder.Hydration
3134 ( EventTriggerRef (..)
3235 , HydrationDomBuilderEnv (..)
3336 , HydrationDomBuilderT (..)
37+ , HydrationDomBuilderT' (..)
38+ , HydrationDomBuilderState (..)
3439 , HydrationMode (..)
40+ , HydrationRunnerT (..)
41+ , DOM(..), runDOMForest
42+ , HydrationRunnerEnv (..)
43+ , HydrationRunnerState (..)
3544 , runHydrationDomBuilderT
3645 , askParent
3746 , askEvents
@@ -113,6 +122,7 @@ import Data.Default
113122import Data.Dependent.Map (DMap)
114123import qualified Data.Dependent.Map as DMap
115124import Data.Dependent.Sum
125+import Data.Foldable (foldl')
116126import Data.Functor.Compose
117127import Data.Functor.Constant
118128import Data.Functor.Misc
@@ -125,7 +135,7 @@ import Data.Some (Some)
125135import qualified Data.Some as Some
126136import Data.Text (Text)
127137import qualified Data.Text as T
128−import Data.Typeable (Typeable, typeRep)
138+import Data.Typeable (Typeable, typeRep, Proxy(..))
129139import GHC.Generics (Generic)
130140import qualified GHCJS.DOM as DOM
131141import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
@@ -170,7 +180,7 @@ import Foreign.JavaScript.Internal.Utils
170180#ifndef ghcjs_HOST_OS
171181import GHCJS.DOM.Types (MonadJSM (..))
172182
173−instance MonadJSM m => MonadJSM (HydrationDomBuilderT t m) where
183+instance MonadJSM m => MonadJSM (HydrationDomBuilderT' env state t m) where
174184 liftJSM' = HydrationDomBuilderT . liftJSM'
175185#endif
176186
@@ -200,39 +210,84 @@ instance DomSpace HydrationDomSpace where
200210 in DMap.alter f' en $ _ghcjsEventSpec_filters es
201211 }
202212
203−data HydrationDomBuilderEnv t m
204− = HydrationDomBuilderEnv { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
205− , _hydrationDomBuilderEnv_parent :: {-# UNPACK #-} !Node
206− , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
207− , _hydrationDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
208− , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode) -- In hydration mode?
209− , _hydrationDomBuilderEnv_prerenderDepth :: {-# UNPACK #-} !(IORef Word)
210− , _hydrationDomBuilderEnv_eventChan :: {-# UNPACK #-} !(Chan [DSum (EventTriggerRef t) TriggerInvocation])
211− }
212−
213−data HydrationState t m = HydrationState
214− { _hydrationState_actions :: [Behavior t (m ())]
215− , _hydrationState_previousNode :: {-# UNPACK #-} !(Maybe Node)
213+data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv
214+ { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
215+ , _hydrationDomBuilderEnv_parent :: {-# UNPACK #-} !(IORef Node)
216+ , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
217+ , _hydrationDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
218+ , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode) -- In hydration mode?
219+ , _hydrationDomBuilderEnv_prerenderDepth :: {-# UNPACK #-} !(IORef Word)
216220 }
217221
218−addAction :: Monad m => Behavior t (m ()) -> HydrationDomBuilderT t m ()
219−addAction a = HydrationDomBuilderT $ modify $ \(HydrationState as n) -> HydrationState (a : as) n
222+data HydrationRunnerEnv = HydrationRunnerEnv
223+ { _hydrationRunnerEnv_document :: {-# UNPACK #-} !Document
224+ , _hydrationRunnerEnv_parent :: {-# UNPACK #-} !Node
225+ , _hydrationRunnerEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
226+ , _hydrationRunnerEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
227+ }
228+
229+--newtype Forest a = Forest { unForest :: [DOM a] } deriving (Functor, Foldable, Traversable)
230+data DOM t m
231+ = DOM_Element (HydrationRunnerT t m Node) [DOM t m]
232+ -- ^ Nodes with children, the action returns the node for the children to use as a parent
233+ | DOM_Node (HydrationRunnerT t m ())
234+ -- ^ Nodes without children
235+ | DOM_Replace (Behavior t [DOM t m])
236+ -- ^ runWithReplace content changes over time
237+
238+runDOMForest
239+ :: (Ref m ~ IORef, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, DOM.MonadJSM m, DOM.MonadJSM (Performable m), MonadRef m, MonadSample t m)
240+ => [DOM t m]
241+ -> HydrationRunnerT t m ()
242+runDOMForest = foldl' (\acc d -> runDOMTree d >> acc) (pure ())
243+
244+runDOMTree
245+ :: (Ref m ~ IORef, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, DOM.MonadJSM m, DOM.MonadJSM (Performable m), MonadRef m, MonadSample t m)
246+ => DOM t m -> HydrationRunnerT t m ()
247+runDOMTree = \case
248+ DOM_Node m -> m
249+ DOM_Element m children -> m >>= \p -> localEnv (\_ -> HydrationRunnerState Nothing) (\e -> e { _hydrationRunnerEnv_parent = p }) $ runDOMForest children
250+ DOM_Replace b -> runDOMForest =<< sample b
251+
252+data HydrationDomBuilderState t m = HydrationDomBuilderState
253+ { _hydrationDomBuilderState_delayed :: [DOM t m]
254+ }
255+
256+-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events
257+type HydrationRunnerT t m a = HydrationDomBuilderT' HydrationRunnerEnv HydrationRunnerState t m a
258+
259+data HydrationRunnerState = HydrationRunnerState
260+ { _hydrationRunnerState_previousNode :: {-# UNPACK #-} !(Maybe Node)
261+ }
262+
263+addAction :: Monad m => DOM t m -> HydrationDomBuilderT t m ()
264+addAction a = HydrationDomBuilderT $ modify $ \(HydrationDomBuilderState as) -> HydrationDomBuilderState (a : as)
265+
266+-- TODO probably can separate these two monads entirely, they have grown apart
267+-- over the course of refactoring
220268
221−newtype HydrationDomBuilderT t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (StateT (HydrationState t m) (RequesterT t JSM Identity (TriggerEventT t m))) a }
269+-- | A monad for DomBuilder which just gets the results of children and pushes
270+-- work into an action that is delayed until after postBuild (to match the
271+-- static builder). The action runs in 'HydrationRunnerT', which performs the
272+-- DOM takeover and sets up the events, after which point this monad will
273+-- continue in the vein of 'ImmediateDomBuilderT'.
274+type HydrationDomBuilderT t m a = HydrationDomBuilderT' (HydrationDomBuilderEnv t m) (HydrationDomBuilderState t m) t m a
275+
276+newtype HydrationDomBuilderT' env state t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT env (StateT state (RequesterT t JSM Identity (TriggerEventT t m))) a }
222277 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
223278#if MIN_VERSION_base(4,9,1)
224279 , MonadAsyncException
225280#endif
226281 )
227282
228−instance PrimMonad m => PrimMonad (HydrationDomBuilderT x m) where
229− type PrimState (HydrationDomBuilderT x m) = PrimState m
283+instance PrimMonad m => PrimMonad (HydrationDomBuilderT' env state x m) where
284+ type PrimState (HydrationDomBuilderT' env state x m) = PrimState m
230285 primitive = lift . primitive
231286
232−instance MonadTrans (HydrationDomBuilderT t) where
287+instance MonadTrans (HydrationDomBuilderT' env state t) where
233288 lift = HydrationDomBuilderT . lift . lift . lift . lift
234289
235−instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT t m) where
290+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT' env state t m) where
236291 withRenderHook hook (HydrationDomBuilderT a) = do
237292 e <- HydrationDomBuilderT ask
238293 s <- HydrationDomBuilderT get
@@ -241,8 +296,8 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT t m) wh
241296 return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)
242297 HydrationDomBuilderT $ put s'
243298 pure a
244− requestDomAction = HydrationDomBuilderT . lift . requestingIdentity
245− requestDomAction_ = HydrationDomBuilderT . lift . requesting_
299+ requestDomAction = HydrationDomBuilderT . lift . lift . requestingIdentity
300+ requestDomAction_ = HydrationDomBuilderT . lift . lift . requesting_
246301
247302{-# INLINABLE runHydrationDomBuilderT #-}
248303runHydrationDomBuilderT
@@ -254,51 +309,44 @@ runHydrationDomBuilderT
254309 , MonadRef m
255310 , Ref m ~ IORef
256311 )
257− => HydrationDomBuilderT t m a
258− -> HydrationDomBuilderEnv t m
259− -> Maybe Node
260− -> m (a, [Behavior t (m ())])
261−runHydrationDomBuilderT (HydrationDomBuilderT a) env prev = do
262− (a, hs) <- flip runTriggerEventT (_hydrationDomBuilderEnv_eventChan env) $ do
263− rec (result, req) <- runRequesterT (runStateT (runReaderT a env) (HydrationState [] prev)) rsp
312+ => HydrationDomBuilderT' env state t m a
313+ -> env
314+ -> state
315+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
316+ -> m (a, state)
317+runHydrationDomBuilderT (HydrationDomBuilderT a) env st events = do
318+ flip runTriggerEventT events $ do
319+ rec (result, req) <- runRequesterT (runStateT (runReaderT a env) st) rsp
264320 rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
265321 traverseRequesterData (\r -> Identity <$> r) rm
266322 return result
267− return (a, _hydrationState_actions hs)
268323 where
269324 runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
270325 v <- synchronously x
271326 void . liftIO $ f v
272327
273−instance Monad m => HasDocument (HydrationDomBuilderT t m) where
328+instance Monad m => HasDocument (HydrationDomBuilderT' (HydrationDomBuilderEnv t m) (HydrationDomBuilderState t m) t m) where
274329 {-# INLINABLE askDocument #-}
275− askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
330+ askDocument = askDocumentEnv
276331
277−{-# INLINABLE askParent #-}
278−askParent :: Monad m => HydrationDomBuilderT t m Node
279−askParent = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent
332+class HasDocEnv env where
333+ askDocumentEnv :: Monad m => HydrationDomBuilderT' env state t m DOM.Document
280334
281−{-# INLINABLE askEvents #-}
282−askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
283−askEvents = HydrationDomBuilderT . lift . lift . lift $ TriggerEventT.askEvents
335+instance HasDocEnv (HydrationDomBuilderEnv t m) where
336+ askDocumentEnv = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
337+
338+instance HasDocEnv HydrationRunnerEnv where
339+ askDocumentEnv = HydrationDomBuilderT $ asks _hydrationRunnerEnv_document
284340
285341{-# INLINABLE localEnv #-}
286−localEnv :: Monad m => (HydrationState t m -> HydrationState t m) -> (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a
342+localEnv :: Monad m => (s -> s) -> (e -> e) -> HydrationDomBuilderT' e s t m a -> HydrationDomBuilderT' e s t m a
287343localEnv f g (HydrationDomBuilderT m) = HydrationDomBuilderT $ do
288344 env <- ask
289345 hs <- get
290346 lift $ lift $ evalStateT (runReaderT m $ g env) (f hs)
291347
292−{-# INLINABLE getPreviousNode #-}
293−getPreviousNode :: Monad m => HydrationDomBuilderT t m (Maybe DOM.Node)
294−getPreviousNode = HydrationDomBuilderT $ gets _hydrationState_previousNode
295−
296−{-# INLINABLE setPreviousNode #-}
297−setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationDomBuilderT t m ()
298−setPreviousNode n = HydrationDomBuilderT $ modify $ \hs -> hs { _hydrationState_previousNode = n }
299−
300348{-# INLINABLE append #-}
301−append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT t m ()
349+append :: (MonadJSM m, HasParent env) => DOM.Node -> HydrationDomBuilderT' env state t m ()
302350append n = do
303351 p <- askParent
304352 appendChild_ p n
@@ -309,51 +357,96 @@ data HydrationMode
309357 | HydrationMode_Immediate
310358 deriving (Eq, Ord, Show)
311359
312−{-# INLINABLE getHydrationMode #-}
313−getHydrationMode :: MonadIO m => HydrationDomBuilderT t m HydrationMode
314−getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
360+class HasParent env where
361+ askParent :: (Monad m, MonadIO m) => HydrationDomBuilderT' env state t m DOM.Node
315362
316−{-# INLINABLE textNodeInternal #-}
317−textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Text
318−textNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> createTextNode doc t) DOM.Text
363+instance HasParent (HydrationDomBuilderEnv t m) where
364+ {-# INLINABLE askParent #-}
365+ askParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
366+
367+instance HasParent HydrationRunnerEnv where
368+ {-# INLINABLE askParent #-}
369+ askParent = HydrationDomBuilderT $ asks _hydrationRunnerEnv_parent
370+
371+class HasUnreadyChildren env where
372+ askUnreadyChildren :: Monad m => HydrationDomBuilderT' env state t m (IORef Word)
373+ askCommitAction :: Monad m => HydrationDomBuilderT' env state t m (JSM ())
374+
375+instance HasUnreadyChildren (HydrationDomBuilderEnv t m) where
376+ {-# INLINABLE askUnreadyChildren #-}
377+ askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
378+ {-# INLINABLE askCommitAction #-}
379+ askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction
380+
381+instance HasUnreadyChildren HydrationRunnerEnv where
382+ {-# INLINABLE askUnreadyChildren #-}
383+ askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationRunnerEnv_unreadyChildren
384+ {-# INLINABLE askCommitAction #-}
385+ askCommitAction = HydrationDomBuilderT $ asks _hydrationRunnerEnv_commitAction
386+
387+
388+class HasPreviousNode state where
389+ getPreviousNode :: Monad m => HydrationDomBuilderT' env state t m (Maybe DOM.Node)
390+ setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationDomBuilderT' env state t m ()
391+
392+instance HasPreviousNode HydrationRunnerState where
393+ {-# INLINABLE getPreviousNode #-}
394+ getPreviousNode = HydrationDomBuilderT $ gets _hydrationRunnerState_previousNode
395+ {-# INLINABLE setPreviousNode #-}
396+ setPreviousNode n = HydrationDomBuilderT $ modify $ \hs -> hs { _hydrationRunnerState_previousNode = n }
397+
398+class HasHydrationMode env where
399+ getHydrationMode :: MonadIO m => HydrationDomBuilderT' env state t m HydrationMode
400+
401+instance HasHydrationMode (HydrationDomBuilderEnv t m) where
402+ {-# INLINABLE getHydrationMode #-}
403+ getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
404+
405+{-# INLINABLE askEvents #-}
406+askEvents :: Monad m => HydrationDomBuilderT' env state t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
407+askEvents = HydrationDomBuilderT . lift . lift . lift $ TriggerEventT.askEvents
319408
320−{-# INLINABLE commentNodeInternal #-}
321−commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Comment
322−commentNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> createComment doc t) DOM.Comment
323409
324410{-# 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.
328−makeNodeInternal :: (MonadJSM m, IsNode node, Typeable node) => (node -> HydrationDomBuilderT t m Bool) -> HydrationDomBuilderT t m node -> (DOM.JSVal -> node) -> HydrationDomBuilderT t m node
329−makeNodeInternal check mkNode constructor = do
330− doc <- askDocument
411+makeNodeInternal
412+ :: forall node env state t m. (MonadJSM m, IsNode node, Typeable node, HasParent env)
413+ => HydrationDomBuilderT' env state t m node -> HydrationDomBuilderT' env state t m node
414+makeNodeInternal mkNode = do
415+ liftIO $ putStr $ show (typeRep (Proxy :: Proxy node)) <> ": "
416+ liftIO $ putStrLn $ "Not in hydration mode, creating node"
417+ n <- mkNode
418+ append $ toNode n
419+ return n
420+
421+{-# INLINABLE hydrateNode #-}
422+-- | This function expects the existing DOM at the current hydration node to be
423+-- correct. It skips any nodes that are the wrong type, or that fail the
424+-- @check@. The previous node reference is also updated.
425+hydrateNode
426+ :: (MonadJSM m, IsNode node, Typeable node, HasPreviousNode state, HasParent env)
427+ => (node -> HydrationDomBuilderT' env state t m Bool) -> HydrationDomBuilderT' env state t m node -> (DOM.JSVal -> node) -> HydrationDomBuilderT' env state t m node
428+hydrateNode check mkNode constructor = do
331429 parent <- askParent
332430 liftIO $ putStr $ show (typeRep constructor) <> ": "
333− getHydrationMode >>= \case
334− HydrationMode_Immediate -> do
335− liftIO $ putStrLn $ "Not in hydration mode, creating node"
336− n <- mkNode
337− append $ toNode n
338− return n
339− HydrationMode_Hydrating -> do
340− lastHydrationNode <- getPreviousNode
341− let go mLastNode = do
342− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
343− DOM.castTo constructor node >>= \case
344− Nothing -> do
345− liftIO $ putStrLn $ "Wrong node type, skipping"
346− go (Just node)
347− Just tn -> check tn >>= \case
348− True -> do
349− liftIO $ putStrLn $ "Using existing node"
350− return tn
351− False -> do
352− liftIO $ putStrLn $ "Node failed check, skipping"
353− go (Just node)
354− n <- go lastHydrationNode
355− setPreviousNode $ Just $ toNode n
356− return n
431+ lastHydrationNode <- getPreviousNode
432+ let go mLastNode = do
433+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
434+ DOM.castTo constructor node >>= \case
435+ Nothing -> do
436+ liftIO $ putStr $ "Wrong node type, skipping... "
437+ go (Just node)
438+ Just tn -> check tn >>= \case
439+ True -> do
440+ liftIO $ putStr $ "Using existing node... "
441+ return tn
442+ False -> do
443+ liftIO $ putStr $ "Node failed check, skipping... "
444+ go (Just node)
445+ n <- go lastHydrationNode
446+ liftIO $ putStrLn ""
447+ setPreviousNode $ Just $ toNode n
448+ return n
449+
357450
358451-- | s and e must both be children of the same node and s must precede e;
359452-- all nodes between s and e will be removed, but s and e will not be removed
@@ -457,10 +550,16 @@ wrap events e cfg = do
457550 return es
458551
459552{-# INLINABLE makeElement #-}
460−makeElement :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m) => Text -> ElementConfig er t HydrationDomSpace -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), DOM.Element)
553+makeElement
554+ :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m)
555+ => Text
556+ -> ElementConfig er t HydrationDomSpace
557+ -> HydrationDomBuilderT t m a
558+ -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), DOM.Element)
461559makeElement elementTag cfg child = do
462560 doc <- askDocument
463− let buildElement = do
561+ let buildElement :: HydrationDomBuilderT' env state t m DOM.Element
562+ buildElement = do
464563 e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
465564 Nothing -> createElement doc elementTag
466565 Just ens -> createElementNS doc (Just ens) elementTag
@@ -469,52 +568,161 @@ makeElement elementTag cfg child = do
469568 Just ans -> setAttributeNS e (Just ans) n v
470569 pure e
471570 ssrAttr = "ssr" :: DOM.JSString
571+ hasSSRAttribute :: DOM.Element -> HydrationDomBuilderT' env state t m Bool
472572 hasSSRAttribute e = case cfg ^. namespace of
473573 Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr
474574 Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr
475− -- TODO: prerender needs completely replacing
476− e <- makeNodeInternal hasSSRAttribute buildElement DOM.Element
477− -- Run the child builder with updated parent and previous sibling references
478− result <- localEnv (\hs -> hs { _hydrationState_previousNode = Nothing }) (\env -> env { _hydrationDomBuilderEnv_parent = toNode e }) child
479− events <- askEvents
480− env <- HydrationDomBuilderT ask
481− (ese, fire) <- newTriggerEvent
482− addAction $ pure $ void $ runHydrationDomBuilderT (liftIO . fire <=< wrap events e $ extractRawElementConfig cfg) env Nothing
483− collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click)) -- TODO! this can't stay here, obviously.
484− let evts = fan collapsed
485− return ((Element evts (), result), e)
486−
487−instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT t m) where
575+ getHydrationMode >>= \case
576+ HydrationMode_Immediate -> do
577+ -- TODO: prerender needs completely replacing
578+ e <- makeNodeInternal buildElement
579+ p <- liftIO $ newIORef $ toNode e
580+ -- Run the child builder with updated parent and previous sibling references
581+ result <- localEnv (\hs -> hs) (\env -> env { _hydrationDomBuilderEnv_parent = p }) child
582+ events <- askEvents
583+ es <- wrap events e $ extractRawElementConfig cfg
584+ return ((Element es (), result), e)
585+ HydrationMode_Hydrating -> do
586+ -- Schedule everything for after postBuild, except for getting the result itself
587+ p <- liftIO $ newIORef $ error "Parent not yet initialized"
588+ env <- HydrationDomBuilderT ask
589+ let env' = env { _hydrationDomBuilderEnv_parent = p}
590+ hs = HydrationDomBuilderState { _hydrationDomBuilderState_delayed = [] }
591+ (result, hs') <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') hs
592+ (ese, fire) <- newTriggerEvent
593+ let activateElement = do
594+ e <- hydrateNode hasSSRAttribute buildElement DOM.Element
595+ liftIO $ writeIORef p $ toNode e
596+ events <- askEvents
597+ void $ liftIO . fire <=< wrap events e $ extractRawElementConfig cfg
598+ pure $ toNode e
599+ addAction $ DOM_Element activateElement $ _hydrationDomBuilderState_delayed hs'
600+ -- TODO! vvv this can't stay here, obviously.
601+ collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click))
602+ return ((Element (fan collapsed) (), result), error "makeElement: DOM.Element")
603+
604+{-# INLINABLE textNodeInternal #-}
605+textNodeInternal :: (MonadJSM m, MonadFix m, ToDOMString contents, Reflex t) => contents -> Maybe (Event t contents) -> HydrationDomBuilderT t m DOM.Text
606+textNodeInternal !t mSetContents = getHydrationMode >>= \case
607+ HydrationMode_Immediate -> do
608+ n <- makeNodeInternal (askDocumentEnv >>= \doc -> createTextNode doc t)
609+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
610+ pure n
611+ HydrationMode_Hydrating -> do
612+ let activateText = do
613+ liftIO $ putStrLn $ "Action: Text: " <> show (DOM.toJSString t)
614+ n <- hydrateNode (const $ pure True) (askDocumentEnv >>= \doc -> createTextNode doc t) DOM.Text
615+ --case mSetContents of
616+ -- Nothing -> liftIO $ putStrLn "No update events for text"
617+ -- Just e -> requestDomAction_ $ setNodeValue n . Just <$> e
618+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
619+ addAction $ DOM_Node activateText
620+ pure $ error "textNodeInternal: DOM.Text"
621+
622+{-# INLINABLE commentNodeInternal #-}
623+commentNodeInternal :: (MonadJSM m, MonadFix m, ToDOMString contents, Reflex t) => contents -> Maybe (Event t contents) -> HydrationDomBuilderT t m DOM.Comment
624+commentNodeInternal !t mSetContents = getHydrationMode >>= \case
625+ HydrationMode_Immediate -> do
626+ n <- makeNodeInternal (askDocumentEnv >>= \doc -> createComment doc t)
627+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
628+ pure n
629+ HydrationMode_Hydrating -> do
630+ let activateComment = do
631+ liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)
632+ n <- hydrateNode (const $ pure True) (askDocumentEnv >>= \doc -> createComment doc t) DOM.Comment
633+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
634+ addAction $ DOM_Node activateComment
635+ pure $ error "commentNodeInternal: DOM.Comment"
636+
637+-- | We leave markers in the static builder as comments, and rip these comments
638+-- out at hydration time, replacing them with empty text nodes.
639+skipToAndReplaceComment :: (MonadJSM m, Reflex t, MonadFix m) => Text -> IORef Text -> HydrationDomBuilderT t m (IORef DOM.Text, IORef Text)
640+skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
641+ HydrationMode_Immediate -> do
642+ -- If we're in immediate mode, we don't try to replace an existing comment,
643+ -- and just return a dummy key
644+ t <- textNodeInternal ("" :: Text) Nothing
645+ append $ toNode t
646+ textNodeRef <- liftIO $ newIORef t
647+ keyRef <- liftIO $ newIORef ""
648+ pure (textNodeRef, keyRef)
649+ HydrationMode_Hydrating -> do
650+ doc <- askDocument
651+ textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
652+ keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
653+ let go key0 mLastNode = do
654+ parent <- askParent
655+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
656+ DOM.castTo DOM.Comment node >>= \case
657+ Just comment -> do
658+ commentText <- Node.getTextContentUnchecked comment
659+ liftIO $ putStr $ T.unpack $ "[" <> prefix <> "]"
660+ liftIO $ putStr $ T.unpack $ "{" <> commentText <> "}"
661+ case T.stripPrefix (prefix <> key0) commentText of
662+ Just key -> do
663+ -- Replace the comment with an (invisible) text node
664+ textNode <- createTextNode doc ("" :: Text)
665+ liftIO $ putStr "Replacing existing comment..."
666+ Node.replaceChild_ parent textNode comment
667+ pure (textNode, key)
668+ Nothing -> do
669+ liftIO $ putStr "Bad key in comment, skipping... "
670+ go key0 (Just node)
671+ Nothing -> do
672+ liftIO $ putStr "Not a comment, skipping... "
673+ go key0 (Just node)
674+ switchComment = do
675+ key0 <- liftIO $ readIORef key0Ref
676+ liftIO $ putStrLn $ "///////////////////////////////// switchComment " <> T.unpack key0
677+ (textNode, key) <- go key0 =<< getPreviousNode
678+ liftIO $ putStrLn $ T.unpack key
679+ setPreviousNode $ Just $ toNode textNode
680+ liftIO $ do
681+ writeIORef textNodeRef textNode
682+ writeIORef keyRef key
683+ addAction $ DOM_Node switchComment
684+ pure (textNodeRef, keyRef)
685+
686+
687+skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m) => HydrationDomBuilderT t m (IORef DOM.Text, IORef Text)
688+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
689+
690+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m) => IORef Text -> HydrationDomBuilderT t m (IORef DOM.Text)
691+skipToReplaceEnd key = fmap fst $ skipToAndReplaceComment "replace-end" key
692+
693+instance (HasUnreadyChildren env, SupportsHydrationDomBuilder t m) => NotReady t (HydrationDomBuilderT' env state t m) where
488694 notReadyUntil e = do
489695 eOnce <- headE e
490− env <- HydrationDomBuilderT ask
491− let unreadyChildren = _hydrationDomBuilderEnv_unreadyChildren env
696+ unreadyChildren <- askUnreadyChildren
697+ commitAction <- askCommitAction
492698 liftIO $ modifyIORef' unreadyChildren succ
493699 let ready = do
494700 old <- liftIO $ readIORef unreadyChildren
495701 let new = pred old
496702 liftIO $ writeIORef unreadyChildren $! new
497− when (new == 0) $ _hydrationDomBuilderEnv_commitAction env
703+ when (new == 0) commitAction
498704 requestDomAction_ $ ready <$ eOnce
499705 notReady = do
500706 env <- HydrationDomBuilderT ask
501− let unreadyChildren = _hydrationDomBuilderEnv_unreadyChildren env
707+ unreadyChildren <- askUnreadyChildren
502708 liftIO $ modifyIORef' unreadyChildren succ
503709
504−instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT t m) where
505− type DomBuilderSpace (HydrationDomBuilderT t m) = HydrationDomSpace
710+instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT' (HydrationDomBuilderEnv t m) (HydrationDomBuilderState t m) t m) where
711+ type DomBuilderSpace (HydrationDomBuilderT' (HydrationDomBuilderEnv t m) (HydrationDomBuilderState t m) t m) = HydrationDomSpace
506712 {-# INLINABLE textNode #-}
507713 textNode (TextNodeConfig initialContents mSetContents) = do
508− n <- textNodeInternal initialContents
509− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
714+ liftIO $ putStrLn $ "Text: " <> T.unpack initialContents
715+ textNodeInternal initialContents mSetContents
510716 return $ TextNode ()
511717 {-# INLINABLE commentNode #-}
512718 commentNode (CommentNodeConfig initialContents mSetContents) = do
513− n <- commentNodeInternal initialContents
514− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
719+ liftIO $ putStrLn $ "Comment: " <> T.unpack initialContents
720+ commentNodeInternal initialContents mSetContents
515721 return $ CommentNode ()
516722 {-# INLINABLE element #-}
517− element elementTag cfg child = fst <$> makeElement elementTag cfg child
723+ element elementTag cfg child = do
724+ liftIO $ putStrLn $ "Element: " <> T.unpack elementTag
725+ fst <$> makeElement elementTag cfg child
518726 {-# INLINABLE inputElement #-}
519727 inputElement cfg = do
520728 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
@@ -639,19 +847,20 @@ extractFragment fragment = do
639847 extractBetweenExclusive (_hydrationDomFragment_document fragment) before after
640848 liftIO $ writeIORef (_hydrationDomFragment_state fragment) FragmentState_Unmounted
641849
642−instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT t m) where
643− type DomFragment (HydrationDomBuilderT t m) = HydrationDomFragment
850+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT' (HydrationDomBuilderEnv t m) (HydrationDomBuilderState t m) t m) where
851+ type DomFragment (HydrationDomBuilderT' (HydrationDomBuilderEnv t m) (HydrationDomBuilderState t m) t m) = HydrationDomFragment
644852 buildDomFragment w = do
645853 df <- createDocumentFragment =<< askDocument
646− result <- localEnv id (\env -> env { _hydrationDomBuilderEnv_parent = toNode df }) w
854+ p <- liftIO $ newIORef $ toNode df
855+ result <- localEnv id (\env -> env { _hydrationDomBuilderEnv_parent = p }) w
647856 state <- liftIO $ newIORef FragmentState_Unmounted
648857 return (HydrationDomFragment df state, result)
649858 mountDomFragment fragment setFragment = do
650859 parent <- askParent
651860 extractFragment fragment
652− before <- textNodeInternal ("" :: Text)
861+ before <- textNodeInternal ("" :: Text) Nothing
653862 appendChild_ parent $ _hydrationDomFragment_document fragment
654− after <- textNodeInternal ("" :: Text)
863+ after <- textNodeInternal ("" :: Text) Nothing
655864 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
656865 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
657866 extractFragment previousFragment
@@ -660,61 +869,14 @@ instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomB
660869 liftIO $ writeIORef (_hydrationDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
661870 liftIO $ writeIORef (_hydrationDomFragment_state fragment) $ FragmentState_Mounted (before, after)
662871
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)
698−
699−skipToReplaceStart :: MonadJSM m => HydrationDomBuilderT t m (DOM.Text, Text)
700−skipToReplaceStart = skipToAndReplaceComment "replace-start"
701−
702−skipToReplaceEnd :: MonadJSM m => Text -> HydrationDomBuilderT t m DOM.Text
703−skipToReplaceEnd key = fmap fst $ skipToAndReplaceComment $ "replace-end" <> key
704−
705−instance (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
872+instance (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' (HydrationDomBuilderEnv t m) (HydrationDomBuilderState t m) t m) where
706873 {-# INLINABLE runWithReplace #-}
707874 runWithReplace a0 a' = do
708875 liftIO $ putStrLn "In runWithReplace"
709876 initialEnv <- HydrationDomBuilderT ask
710877 let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
711878 initialHydrationMode <- liftIO $ readIORef hydrating
712− (before, beforeKey) <- case initialHydrationMode of
713− HydrationMode_Hydrating -> skipToReplaceStart
714− HydrationMode_Immediate -> do
715− t <- textNodeInternal ("" :: Text)
716− append $ toNode t
717− pure (t, "")
879+ (before, beforeKey) <- skipToReplaceStart
718880 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
719881 haveEverBeenReady <- liftIO $ newIORef False
720882 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
@@ -730,19 +892,16 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
730892 -- We draw 'after' in this roundabout way to avoid using MonadFix
731893 doc <- askDocument
732894 parent <- askParent
733− after <- case initialHydrationMode of
734− HydrationMode_Hydrating -> skipToReplaceEnd beforeKey
735− HydrationMode_Immediate -> do
736− t <- textNodeInternal ("" :: Text)
737− append $ toNode t
738− pure t
895+ after <- skipToReplaceEnd beforeKey
896+ -- TODO improve skipToReplace nonsense
897+ addAction $ DOM_Node $ setPreviousNode . Just . toNode =<< liftIO (readIORef before)
739898 let drawInitialChild = do
740899 liftIO $ putStrLn "drawInitialChild"
741900 p <- liftIO (readIORef hydrating) >>= \case
742− HydrationMode_Hydrating -> pure parent
743− HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
901+ HydrationMode_Hydrating -> liftIO $ newIORef parent
902+ HydrationMode_Immediate -> liftIO . newIORef . toNode =<< createDocumentFragment doc
744903 unreadyChildren <- liftIO $ newIORef 0
745− (result, HydrationState h' _) <- flip runStateT (HydrationState [] Nothing) $ runReaderT (unHydrationDomBuilderT a0) initialEnv
904+ (result, HydrationDomBuilderState h') <- flip runStateT (HydrationDomBuilderState []) $ runReaderT (unHydrationDomBuilderT a0) initialEnv
746905 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
747906 , _hydrationDomBuilderEnv_commitAction = myCommitAction
748907 , _hydrationDomBuilderEnv_parent = p
@@ -754,25 +913,30 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
754913 return (h', result)
755914 a'' <- numberOccurrences a'
756915 (result0, evt) <- HydrationDomBuilderT $ lift $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
757− p <- liftIO (readIORef hydrating) >>= \case
916+ h <- liftIO $ readIORef hydrating
917+ p' <- case h of
758918 HydrationMode_Hydrating -> pure parent
759919 HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
920+ p <- liftIO $ newIORef p'
760921 unreadyChildren <- liftIO $ newIORef 0
761922 let commitAction = do
762923 liftIO $ putStrLn "Committing runWithReplace update"
763924 c <- liftIO $ readIORef currentCohort
925+ !before' <- liftIO $ readIORef before
926+ !after' <- liftIO $ readIORef after
764927 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
765− deleteBetweenExclusive before after
766− insertBefore p after
928+ deleteBetweenExclusive before' after'
929+ insertBefore p' after'
767930 liftIO $ writeIORef currentCohort cohortId
768931 myCommitAction
769− (result, HydrationState h' _) <- flip runStateT (HydrationState [] $ Just $ toNode before) $ runReaderT (unHydrationDomBuilderT child) $ initialEnv
932+ (result, HydrationDomBuilderState h') <- flip runStateT (HydrationDomBuilderState []) $ runReaderT (unHydrationDomBuilderT child) $ initialEnv
770933 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
771− , _hydrationDomBuilderEnv_commitAction = commitAction
934+ , _hydrationDomBuilderEnv_commitAction = case h of
935+ HydrationMode_Hydrating -> myCommitAction
936+ HydrationMode_Immediate -> commitAction
772937 , _hydrationDomBuilderEnv_parent = p
773938 }
774939 uc <- liftIO $ readIORef unreadyChildren
775− h <- liftIO $ readIORef hydrating
776940 let commitActionToRunNow = if uc == 0
777941 then Just $ commitAction
778942 else Nothing -- A child will run it when unreadyChildren is decremented to 0
@@ -781,9 +945,8 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
781945 HydrationMode_Immediate -> Right commitActionToRunNow
782946 return (actions, result)
783947 let (hydrationAction, commitAction) = fanEither $ fmap fst evt
784− f :: [Behavior t (m ())] -> Behavior t (m ())
785− f = fmap (void . sequence) . sequence
786− addAction . join =<< hold (f $ fst result0) (fmap f hydrationAction)
948+ base :: Behavior t [DOM t m] <- hold (fst result0) hydrationAction
949+ addAction $ DOM_Replace base
787950 requestDomAction_ $ fmapMaybe id commitAction
788951 return (snd result0, fmap snd evt)
789952
@@ -925,6 +1088,7 @@ hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
9251088 -> Event t (p v)
9261089 -> HydrationDomBuilderT t m (IntMap v', Event t (p v'))
9271090hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1091+ (_, key) <- skipToReplaceStart
9281092 initialEnv <- HydrationDomBuilderT ask
9291093 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
9301094 pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
@@ -959,7 +1123,9 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
9591123 liftIO $ writeIORef pendingChange (newUnready, p)
9601124 when (IntMap.null newUnready) $ do
9611125 applyDomUpdate p
962− (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1126+ stateRef <- liftIO . newIORef =<< HydrationDomBuilderT get
1127+ (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdateInt stateRef initialEnv markChildReady $ f k v) dm0 dm'
1128+ HydrationDomBuilderT . put =<< liftIO (readIORef stateRef)
9631129 let processChild k (_, _, sRef, _) = do
9641130 readIORef sRef >>= \case
9651131 ChildReadyStateInt_Ready -> return Nothing
@@ -976,8 +1142,10 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
9761142 placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
9771143 result' = ffor children' $ fmap $ \(_, _, _, r) -> r
9781144 liftIO $ writeIORef placeholders $! placeholders0
979− _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
980− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
1145+ getHydrationMode >>= \case
1146+ HydrationMode_Immediate -> void $ IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
1147+ _ -> pure ()
1148+ lastPlaceholderRef <- skipToReplaceEnd key
9811149 requestDomAction_ $ ffor children' $ \p -> do
9821150 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
9831151 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1072,7 +1240,7 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
10721240 getHydrationMode >>= \case
10731241 HydrationMode_Immediate -> void $ DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
10741242 _ -> pure ()
1075− liftIO . writeIORef lastPlaceholderRef =<< skipToReplaceEnd key
1243+ lastPlaceholderRef <- skipToReplaceEnd key
10761244 requestDomAction_ $ ffor children' $ \p -> do
10771245 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
10781246 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1084,7 +1252,7 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
10841252
10851253{-# INLINABLE drawChildUpdate #-}
10861254drawChildUpdate :: (MonadIO m, MonadJSM m)
1087− => IORef (HydrationState t m)
1255+ => IORef (HydrationDomBuilderState t m)
10881256 -> HydrationDomBuilderEnv t m
10891257 -> (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
10901258 -> HydrationDomBuilderT t m (v' a)
@@ -1099,43 +1267,64 @@ drawChildUpdate stateRef initialEnv markReady child = do
10991267 p <- case hydrationMode of
11001268 HydrationMode_Hydrating -> do
11011269 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
1270+ p' <- liftIO $ readIORef p
1271+-- case _hydrationState_previousNode initialState of
1272+-- Nothing -> Node.appendChild_ p' placeholder
1273+-- Just pn -> Node.getNextSibling pn >>= Node.insertBefore_ p' placeholder
11051274 pure (Left p)
11061275 HydrationMode_Immediate -> do
11071276 df <- createDocumentFragment doc
11081277 Node.appendChild_ df placeholder
11091278 pure (Right df)
1279+ p' <- either pure (liftIO . newIORef . toNode) p
11101280 let env = initialEnv
1111− { _hydrationDomBuilderEnv_parent = either id toNode p
1281+ { _hydrationDomBuilderEnv_parent = p'
11121282 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
11131283 , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
11141284 }
1115− (result, finalState) <- runStateT (runReaderT (unHydrationDomBuilderT child) env) (initialState { _hydrationState_previousNode = Just $ toNode placeholder })
1285+ (result, finalState) <- runStateT (runReaderT (unHydrationDomBuilderT child) env) initialState-- { _hydrationState_previousNode = Just $ toNode placeholder })
11161286 liftIO $ writeIORef stateRef finalState
11171287 u <- liftIO $ readIORef unreadyChildren
11181288 when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1119− return (Compose (either (const $ error "Tried to use document fragment in hydration mode") id p, placeholder, childReadyState, result))
1289+ return (Compose (either (const $ error "drawChildUpdate: Tried to use document fragment in hydration mode") id p, placeholder, childReadyState, result))
11201290
11211291{-# INLINABLE drawChildUpdateInt #-}
11221292drawChildUpdateInt :: (MonadIO m, MonadJSM m)
1123− => HydrationDomBuilderEnv t m
1293+ => IORef (HydrationDomBuilderState t m)
1294+ -> HydrationDomBuilderEnv t m
11241295 -> (IORef ChildReadyStateInt -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
11251296 -> HydrationDomBuilderT t m v'
11261297 -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
1127−drawChildUpdateInt initialEnv markReady child = do
1298+drawChildUpdateInt stateRef initialEnv markReady child = do
11281299 childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing
1300+ let doc = _hydrationDomBuilderEnv_document initialEnv
11291301 unreadyChildren <- liftIO $ newIORef 0
1130− df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv
1131− (placeholder, result) <- flip evalStateT (HydrationState [] Nothing) $ runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
1132− { _hydrationDomBuilderEnv_parent = toNode df
1133− , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1134− , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1135− }
1302+ hydrationMode <- liftIO $ readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv
1303+ initialState <- liftIO $ readIORef stateRef
1304+ placeholder <- createTextNode doc ("" :: Text)
1305+ p <- case hydrationMode of
1306+ HydrationMode_Hydrating -> do
1307+ let p = _hydrationDomBuilderEnv_parent initialEnv
1308+ p' <- liftIO $ readIORef p
1309+-- case _hydrationState_previousNode initialState of
1310+-- Nothing -> Node.appendChild_ p' placeholder
1311+-- Just pn -> Node.getNextSibling pn >>= Node.insertBefore_ p' placeholder
1312+ pure (Left p)
1313+ HydrationMode_Immediate -> do
1314+ df <- createDocumentFragment doc
1315+ Node.appendChild_ df placeholder
1316+ pure (Right df)
1317+ p' <- either pure (liftIO . newIORef . toNode) p
1318+ let env = initialEnv
1319+ { _hydrationDomBuilderEnv_parent = p'
1320+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1321+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1322+ }
1323+ (result, finalState) <- runStateT (runReaderT (unHydrationDomBuilderT child) env) initialState --{ _hydrationState_previousNode = Just $ toNode placeholder })
1324+ liftIO $ writeIORef stateRef finalState
11361325 u <- liftIO $ readIORef unreadyChildren
11371326 when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1138− return (df, placeholder, childReadyState, result)
1327+ return (either (const $ error "drawChildUpdateInt: Tried to use document fragment in hydration mode") id p, placeholder, childReadyState, result)
11391328
11401329mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
11411330mkHasFocus e = do
@@ -1147,32 +1336,35 @@ mkHasFocus e = do
11471336
11481337insertAfter :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
11491338insertAfter new existing = do
1339+ liftIO $ putStrLn "insertAfter"
11501340 p <- getParentNodeUnchecked existing
11511341 Node.getNextSibling existing >>= DOM.insertBefore_ p new
11521342
11531343insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
11541344insertBefore new existing = do
1345+ liftIO $ putStrLn "insertBefore"
11551346 p <- getParentNodeUnchecked existing
1347+ liftIO $ putStrLn "insertBefore2"
11561348 DOM.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly
11571349
1158−instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where
1159− type Performable (HydrationDomBuilderT t m) = Performable m
1350+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT' env state t m) where
1351+ type Performable (HydrationDomBuilderT' env state t m) = Performable m
11601352 {-# INLINABLE performEvent_ #-}
11611353 performEvent_ e = lift $ performEvent_ e
11621354 {-# INLINABLE performEvent #-}
11631355 performEvent e = lift $ performEvent e
11641356
1165−instance PostBuild t m => PostBuild t (HydrationDomBuilderT t m) where
1357+instance PostBuild t m => PostBuild t (HydrationDomBuilderT' env state t m) where
11661358 {-# INLINABLE getPostBuild #-}
11671359 getPostBuild = lift getPostBuild
11681360
1169−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT t m) where
1361+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT' env state t m) where
11701362 {-# INLINABLE newEventWithTrigger #-}
11711363 newEventWithTrigger = lift . newEventWithTrigger
11721364 {-# INLINABLE newFanEventWithTrigger #-}
11731365 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
11741366
1175−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT t m) where
1367+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT' env state t m) where
11761368 {-# INLINABLE newTriggerEvent #-}
11771369 newTriggerEvent = HydrationDomBuilderT . lift . lift $ newTriggerEvent
11781370 {-# INLINABLE newTriggerEventWithOnComplete #-}
@@ -1180,12 +1372,12 @@ instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>
11801372 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
11811373 newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
11821374
1183−instance HasJSContext m => HasJSContext (HydrationDomBuilderT t m) where
1184− type JSContextPhantom (HydrationDomBuilderT t m) = JSContextPhantom m
1375+instance HasJSContext m => HasJSContext (HydrationDomBuilderT' env state t m) where
1376+ type JSContextPhantom (HydrationDomBuilderT' env state t m) = JSContextPhantom m
11851377 askJSContext = lift askJSContext
11861378
1187−instance MonadRef m => MonadRef (HydrationDomBuilderT t m) where
1188− type Ref (HydrationDomBuilderT t m) = Ref m
1379+instance MonadRef m => MonadRef (HydrationDomBuilderT' env state t m) where
1380+ type Ref (HydrationDomBuilderT' env state t m) = Ref m
11891381 {-# INLINABLE newRef #-}
11901382 newRef = lift . newRef
11911383 {-# INLINABLE readRef #-}
@@ -1193,12 +1385,12 @@ instance MonadRef m => MonadRef (HydrationDomBuilderT t m) where
11931385 {-# INLINABLE writeRef #-}
11941386 writeRef r = lift . writeRef r
11951387
1196−instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT t m) where
1388+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT' env state t m) where
11971389 {-# INLINABLE atomicModifyRef #-}
11981390 atomicModifyRef r = lift . atomicModifyRef r
11991391
1200−instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT t m) where
1201− type JSX (HydrationDomBuilderT t m) = JSX m
1392+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT' env state t m) where
1393+ type JSX (HydrationDomBuilderT' env state t m) = JSX m
12021394 liftJS = lift . liftJS
12031395
12041396{-# INLINABLE wrapDomEvent #-}
@@ -1218,11 +1410,11 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
12181410 etr <- newIORef $ Just et
12191411 writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]
12201412
1221−instance MonadSample t m => MonadSample t (HydrationDomBuilderT t m) where
1413+instance MonadSample t m => MonadSample t (HydrationDomBuilderT' env state t m) where
12221414 {-# INLINABLE sample #-}
12231415 sample = lift . sample
12241416
1225−instance MonadHold t m => MonadHold t (HydrationDomBuilderT t m) where
1417+instance MonadHold t m => MonadHold t (HydrationDomBuilderT' env state t m) where
12261418 {-# INLINABLE hold #-}
12271419 hold v0 v' = lift $ hold v0 v'
12281420 {-# INLINABLE holdDyn #-}