on develop help sign in
Faster HydrationDomBuilderT

IORef instead of StateT INLINE everything

commit32f4b45a3527e40ba5dce61760cc027c01c8e1e7 authorTom Smalley <tfsmalley@gmail.com> dateThu 10 Jan 2019, 14:47 (8 years ago) parent11809c2
7 files changed+313−167
reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+166−126 reflex-dom-core/src/Reflex/Dom/Core.hs+1−1 reflex-dom-core/src/Reflex/Dom/Main.hs+25−35 reflex-dom-core/src/Reflex/Dom/Prerender.hs+2−1 reflex-dom-core/src/Reflex/Dom/Specializations.hs+115−1 reflex-dom-core/test/hydration.hs+2−2 reflex-dom/benchmarks/krausest.hs+2−1
reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+166−126
@@ -55,18 +55,25 @@ module Reflex.Dom.Builder.Hydration
5555 , hydrateNode
5656 , getPreviousNode, setPreviousNode
5757 , runHydrationDomBuilderT
58− , askParent
5958 , askEvents
60− , append
61− , textNodeInternal
6259 , SupportsHydrationDomBuilder
63− , wrap
60+ -- Exported for specialization
61+ , HydrationDomSpace
6462 , makeElement
6563 , drawChildUpdate
66− -- * Internal
67− , traverseDMapWithKeyWithAdjust'
68− , hoistTraverseWithKeyWithAdjust
64+ , drawChildUpdateInt
65+ , ChildReadyState
66+ , DomRenderHookT
67+ , TraverseChild
68+ , append
69+ , wrap
70+ , triggerBody
71+ , WrapArg
72+ , EventTrigger
6973 , traverseIntMapWithKeyWithAdjust'
74+ , hoistTraverseIntMapWithKeyWithAdjust
75+ , makeNodeInternal
76+ , runDomRenderHookT
7077 ) where
7178
7279import Control.Concurrent
@@ -143,19 +150,22 @@ import Data.Functor.Contravariant (phantom)
143150import GHCJS.DOM.Types (MonadJSM (..))
144151
145152instance MonadJSM m => MonadJSM (HydrationRunnerT t m) where
146− liftJSM' = lift . liftJSM'
153+ {-# INLINE liftJSM' #-}
154+ liftJSM' = lift . liftJSM'
147155
148156instance MonadJSM m => MonadJSM (HydrationDomBuilderT t m) where
149− liftJSM' = lift . liftJSM'
157+ {-# INLINE liftJSM' #-}
158+ liftJSM' = lift . liftJSM'
150159
151160instance MonadJSM m => MonadJSM (DomRenderHookT t m) where
152− liftJSM' = lift . liftJSM'
161+ {-# INLINE liftJSM' #-}
162+ liftJSM' = lift . liftJSM'
153163#endif
154164
155−data HydrationDomBuilderEnv t = HydrationDomBuilderEnv
165+data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv
156166 { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
157167 -- ^ Reference to the document
158− , _hydrationDomBuilderEnv_parent :: {-# UNPACK #-} !(IORef Node)
168+ , _hydrationDomBuilderEnv_parent :: !(Either Node (IORef Node))
159169 -- ^ This is in an IORef because in the time up to hydration we can't actually know what the
160170 -- parent is - we populate this reference during the DOM traversal at hydration time
161171 , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word)
@@ -165,6 +175,7 @@ data HydrationDomBuilderEnv t = HydrationDomBuilderEnv
165175 , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode)
166176 -- ^ In hydration mode? Should be switched to `HydrationMode_Immediate` after hydration is finished
167177 , _hydrationDomBuilderEnv_switchover :: !(Event t ())
178+ , _hydrationDomBuilderEnv_delayed :: {-# UNPACK #-} !(IORef (HydrationRunnerT t m ()))
168179 }
169180
170181-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.
@@ -176,48 +187,55 @@ newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT
176187#endif
177188 )
178189
190+{-# INLINE localRunner #-}
179191localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a
180192localRunner (HydrationRunnerT m) s parent = HydrationRunnerT . lift $ local (\_ -> parent) (evalStateT m s)
181193
194+{-# INLINE runHydrationRunnerT #-}
182195runHydrationRunnerT
183196 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
184197 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
185198runHydrationRunnerT (HydrationRunnerT m) s parent = runDomRenderHookT (runReaderT (evalStateT m s) parent)
186199
187200instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
188− {-# INLINABLE newEventWithTrigger #-}
201+ {-# INLINE newEventWithTrigger #-}
189202 newEventWithTrigger = lift . newEventWithTrigger
190− {-# INLINABLE newFanEventWithTrigger #-}
203+ {-# INLINE newFanEventWithTrigger #-}
191204 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
192205
193206instance MonadTrans (HydrationRunnerT t) where
207+ {-# INLINE lift #-}
194208 lift = HydrationRunnerT . lift . lift . lift
195209
196210instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where
211+ {-# INLINE sample #-}
197212 sample = lift . sample
198213
199214-- | Add a hydration step which depends on some computation that should only be
200215-- done *before* the switchover to immediate mode - this is most likely some
201216-- form of 'hold' which we want to remove after hydration is done
217+{-# INLINE addHydrationStepWithSetup #-}
202218addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT t m ()
203219addHydrationStepWithSetup setup f = getHydrationMode >>= \case
204220 HydrationMode_Immediate -> pure ()
205221 HydrationMode_Hydrating -> do
206222 switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
207− --s <- lift setup
208223 (s, _) <- lift $ runWithReplace setup $ return () <$ switchover -- 4% more memory than above
209− HydrationDomBuilderT $ modify' (>> f s)
224+ addHydrationStep (f s)
210225
211226-- | Add a hydration step
212−addHydrationStep :: Monad m => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()
213−addHydrationStep m = HydrationDomBuilderT $ modify' (>> m)
227+{-# INLINE addHydrationStep #-}
228+addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()
229+addHydrationStep m = do
230+ delayedRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_delayed
231+ liftIO $ modifyIORef' delayedRef (>> m)
214232
215233-- | A monad for DomBuilder which just gets the results of children and pushes
216234-- work into an action that is delayed until after postBuild (to match the
217235-- static builder). The action runs in 'HydrationRunnerT', which performs the
218236-- DOM takeover and sets up the events, after which point this monad will
219237-- continue in the vein of 'ImmediateDomBuilderT'.
220−newtype HydrationDomBuilderT t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t) (StateT (HydrationRunnerT t m ()) (DomRenderHookT t m)) a }
238+newtype HydrationDomBuilderT t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (DomRenderHookT t m) a }
221239 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
222240#if MIN_VERSION_base(4,9,1)
223241 , MonadAsyncException
@@ -229,7 +247,8 @@ instance PrimMonad m => PrimMonad (HydrationDomBuilderT x m) where
229247 primitive = lift . primitive
230248
231249instance MonadTrans (HydrationDomBuilderT t) where
232− lift = HydrationDomBuilderT . lift . lift . lift
250+ {-# INLINE lift #-}
251+ lift = HydrationDomBuilderT . lift . lift
233252
234253-- | Shared behavior for HydrationDomBuilderT and HydrationRunnerT
235254newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t JSM Identity (TriggerEventT t m) a }
@@ -239,7 +258,7 @@ newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t
239258#endif
240259 )
241260
242−{-# INLINABLE runDomRenderHookT #-}
261+{-# INLINE runDomRenderHookT #-}
243262runDomRenderHookT
244263 :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)
245264 => DomRenderHookT t m a
@@ -257,6 +276,7 @@ runDomRenderHookT (DomRenderHookT a) events = do
257276 void . liftIO $ f v
258277
259278instance MonadTrans (DomRenderHookT t) where
279+ {-# INLINE lift #-}
260280 lift = DomRenderHookT . lift . lift
261281
262282instance (Reflex t, MonadFix m) => DomRenderHook t (DomRenderHookT t m) where
@@ -268,16 +288,16 @@ instance (Reflex t, MonadFix m) => DomRenderHook t (DomRenderHookT t m) where
268288 requestDomAction_ = DomRenderHookT . requesting_
269289
270290instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT t m) where
271− withRenderHook hook = HydrationDomBuilderT . mapReaderT (mapStateT (withRenderHook hook)) . unHydrationDomBuilderT
272− requestDomAction = HydrationDomBuilderT . lift . lift . requestDomAction
273− requestDomAction_ = HydrationDomBuilderT . lift . lift . requestDomAction_
291+ withRenderHook hook = HydrationDomBuilderT . mapReaderT (withRenderHook hook) . unHydrationDomBuilderT
292+ requestDomAction = HydrationDomBuilderT . lift . requestDomAction
293+ requestDomAction_ = HydrationDomBuilderT . lift . requestDomAction_
274294
275295instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where
276296 withRenderHook hook = HydrationRunnerT . mapStateT (mapReaderT (withRenderHook hook)) . unHydrationRunnerT
277297 requestDomAction = HydrationRunnerT . lift . lift . requestDomAction
278298 requestDomAction_ = HydrationRunnerT . lift . lift . requestDomAction_
279299
280−{-# INLINABLE runHydrationDomBuilderT #-}
300+{-# INLINE runHydrationDomBuilderT #-}
281301runHydrationDomBuilderT
282302 :: ( MonadFix m
283303 , PerformEvent t m
@@ -288,20 +308,20 @@ runHydrationDomBuilderT
288308 , Ref m ~ IORef
289309 )
290310 => HydrationDomBuilderT t m a
291− -> HydrationDomBuilderEnv t
311+ -> HydrationDomBuilderEnv t m
292312 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
293− -> m (a, HydrationRunnerT t m ())
294−runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runStateT (runReaderT a env) (pure ()))
313+ -> m a
314+runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)
295315
296316instance Monad m => HasDocument (HydrationDomBuilderT t m) where
297− {-# INLINABLE askDocument #-}
317+ {-# INLINE askDocument #-}
298318 askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
299319
300−{-# INLINABLE localEnv #-}
301−localEnv :: Monad m => (HydrationDomBuilderEnv t -> HydrationDomBuilderEnv t) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a
302−localEnv f = HydrationDomBuilderT . local f . unHydrationDomBuilderT
320+{-# INLINE localEnv #-}
321+localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a
322+localEnv f = HydrationDomBuilderT . local (f $!) . unHydrationDomBuilderT
303323
304−{-# INLINABLE append #-}
324+{-# INLINE append #-}
305325append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT t m ()
306326append n = do
307327 p <- getParent
@@ -313,39 +333,39 @@ data HydrationMode
313333 | HydrationMode_Immediate
314334 deriving (Eq, Ord, Show)
315335
316−{-# INLINABLE askParent #-}
336+{-# INLINE askParent #-}
317337askParent :: Monad m => HydrationRunnerT t m DOM.Node
318338askParent = HydrationRunnerT ask
319339
320−{-# INLINABLE getPreviousNode #-}
340+{-# INLINE getPreviousNode #-}
321341getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)
322342getPreviousNode = HydrationRunnerT get
323343
324−{-# INLINABLE setPreviousNode #-}
344+{-# INLINE setPreviousNode #-}
325345setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
326346setPreviousNode = HydrationRunnerT . put
327347
328−{-# INLINABLE getParent #-}
348+{-# INLINE getParent #-}
329349getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node
330−getParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
350+getParent = either pure (liftIO . readIORef) =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
331351
332−{-# INLINABLE askUnreadyChildren #-}
352+{-# INLINE askUnreadyChildren #-}
333353askUnreadyChildren :: Monad m => HydrationDomBuilderT t m (IORef Word)
334354askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
335355
336−{-# INLINABLE askCommitAction #-}
356+{-# INLINE askCommitAction #-}
337357askCommitAction :: Monad m => HydrationDomBuilderT t m (JSM ())
338358askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction
339359
340−{-# INLINABLE getHydrationMode #-}
360+{-# INLINE getHydrationMode #-}
341361getHydrationMode :: MonadIO m => HydrationDomBuilderT t m HydrationMode
342362getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
343363
344−{-# INLINABLE askEvents #-}
364+{-# INLINE askEvents #-}
345365askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
346−askEvents = HydrationDomBuilderT . lift . lift . DomRenderHookT . lift $ TriggerEventT.askEvents
366+askEvents = HydrationDomBuilderT . lift . DomRenderHookT . lift $ TriggerEventT.askEvents
347367
348−{-# INLINABLE makeNodeInternal #-}
368+{-# INLINE makeNodeInternal #-}
349369makeNodeInternal
350370 :: forall node t m. (MonadJSM m, IsNode node, Typeable node)
351371 => HydrationDomBuilderT t m node -> HydrationDomBuilderT t m node
@@ -354,7 +374,7 @@ makeNodeInternal mkNode = do
354374 append $ toNode n
355375 return n
356376
357−{-# INLINABLE hydrateNode #-}
377+{-# INLINE hydrateNode #-}
358378-- | This function expects the existing DOM at the current hydration node to be
359379-- correct. It skips any nodes that are the wrong type, or that fail the
360380-- @check@. The previous node reference is also updated.
@@ -378,7 +398,7 @@ hydrateNode check constructor = do
378398type SupportsHydrationDomBuilder t m = (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, Adjustable t m, PrimMonad m, PerformEvent t m, MonadJSM (Performable m))
379399
380400-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself
381−{-# INLINABLE wrap #-}
401+{-# INLINE wrap #-}
382402wrap
383403 :: forall m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m)
384404 => Chan [DSum (EventTriggerRef t) TriggerInvocation]
@@ -404,7 +424,7 @@ wrap events e cfg = do
404424 return $ en :=> EventFilterTriggerRef triggerRef
405425 return eventTriggerRefs
406426
407−{-# INLINABLE triggerBody #-}
427+{-# INLINE triggerBody #-}
408428triggerBody
409429 :: forall er t x. DOM.JSContextRef
410430 -> ElementConfig er t HydrationDomSpace
@@ -434,19 +454,19 @@ triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup
434454 handler :: GhcjsEventHandler er
435455 !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg
436456
437−{-# INLINABLE makeElement #-}
457+{-# INLINE makeElement #-}
438458makeElement
439459 :: 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)
440460 => Text
441461 -> ElementConfig er t HydrationDomSpace
442462 -> HydrationDomBuilderT t m a
443− -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)
463+ -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), Either DOM.Element (IORef DOM.Element))
444464makeElement elementTag cfg child = do
445465 doc <- askDocument
446466 ctx <- askJSM
447467 events <- askEvents
448468
449− let buildElement :: MonadJSM n => n DOM.Element
469+ let buildElement :: JSM DOM.Element
450470 buildElement = do
451471 e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
452472 Nothing -> createElement doc elementTag
@@ -462,21 +482,23 @@ makeElement elementTag cfg child = do
462482 Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr
463483 getHydrationMode >>= \case
464484 HydrationMode_Immediate -> do
465− e <- makeNodeInternal buildElement
466− p <- liftIO $ newIORef $ toNode e
485+ e <- makeNodeInternal $ liftJSM buildElement
467486 -- Run the child builder with updated parent and previous sibling references
468− result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = p }) child
487+ result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child
469488 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg
470489 es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e
471− e' <- liftIO $ newIORef e
472− return ((Element es (), result), e')
490+ return ((Element es (), result), Left e)
473491 HydrationMode_Hydrating -> do
474492 -- Schedule everything for after postBuild, except for getting the result itself
475493 parent <- liftIO $ newIORef $ error "Parent not yet initialized"
476494 e' <- liftIO $ newIORef $ error "makeElement: Element not yet initialized"
477495 env <- HydrationDomBuilderT ask
478− let env' = env { _hydrationDomBuilderEnv_parent = parent }
479− (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') (pure ())
496+ childDelayedRef <- liftIO $ newIORef $ pure ()
497+ let env' = env
498+ { _hydrationDomBuilderEnv_parent = Right parent
499+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
500+ }
501+ result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
480502 wrapResult <- liftIO newEmptyMVar
481503 let activateElement = do
482504 e <- hydrateNode hasSSRAttribute DOM.Element
@@ -487,6 +509,7 @@ makeElement elementTag cfg child = do
487509 refs <- wrap events e $ extractRawElementConfig cfg
488510 liftIO $ putMVar wrapResult (e, refs)
489511 pure $ toNode e
512+ childDom <- liftIO $ readIORef childDelayedRef
490513 addHydrationStep $ activateElement >>= localRunner childDom Nothing
491514
492515 -- We need the EventSelector to switch to the real event handler after activation
@@ -510,9 +533,9 @@ makeElement elementTag cfg child = do
510533 Just c -> c
511534
512535 let dummyElement = error "makeElement: DOM.Element"
513− return ((Element es dummyElement, result), e')
536+ return ((Element es dummyElement, result), Right e')
514537
515−{-# INLINABLE textNodeInternal #-}
538+{-# INLINE textNodeInternal #-}
516539textNodeInternal :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t) => Text -> Maybe (Event t Text) -> HydrationDomBuilderT t m DOM.Text
517540textNodeInternal !t mSetContents = getHydrationMode >>= \case
518541 HydrationMode_Immediate -> do
@@ -529,7 +552,7 @@ textNodeInternal !t mSetContents = getHydrationMode >>= \case
529552-- text content of each node we come to, comparing it to the content we
530553-- expect. We also have a special case for empty text nodes - we always create
531554-- the and add them after the previous node reference.
532−{-# INLINABLE hydrateTextNode #-}
555+{-# INLINE hydrateTextNode #-}
533556hydrateTextNode :: MonadJSM m => Text -> HydrationRunnerT t m DOM.Text
534557hydrateTextNode t@"" = do
535558 doc <- Node.getOwnerDocumentUnchecked =<< askParent
@@ -557,7 +580,7 @@ hydrateTextNode t = do
557580 Nothing -> go parent $ Just $ toNode originalNode
558581
559582
560−{-# INLINABLE commentNodeInternal #-}
583+{-# INLINE commentNodeInternal #-}
561584commentNodeInternal :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, ToDOMString contents, Reflex t, Adjustable t m) => contents -> Maybe (Event t contents) -> HydrationDomBuilderT t m DOM.Comment
562585commentNodeInternal !t mSetContents = getHydrationMode >>= \case
563586 HydrationMode_Immediate -> do
@@ -572,6 +595,7 @@ commentNodeInternal !t mSetContents = getHydrationMode >>= \case
572595
573596-- | We leave markers in the static builder as comments, and rip these comments
574597-- out at hydration time, replacing them with empty text nodes.
598+{-# INLINE skipToAndReplaceComment #-}
575599skipToAndReplaceComment
576600 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m)
577601 => Text
@@ -615,9 +639,11 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
615639 writeIORef keyRef key
616640 pure (switchComment, textNodeRef, keyRef)
617641
642+{-# INLINE skipToReplaceStart #-}
618643skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m) => HydrationDomBuilderT t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
619644skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
620645
646+{-# INLINE skipToReplaceEnd #-}
621647skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m) => IORef Text -> HydrationDomBuilderT t m (HydrationRunnerT t m (), IORef DOM.Text)
622648skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
623649
@@ -664,18 +690,18 @@ instance DomSpace HydrationDomSpace where
664690
665691instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT t m) where
666692 type DomBuilderSpace (HydrationDomBuilderT t m) = HydrationDomSpace
667− {-# INLINABLE textNode #-}
693+ {-# INLINE textNode #-}
668694 textNode (TextNodeConfig initialContents mSetContents) = do
669695 _ <- textNodeInternal initialContents mSetContents
670696 return $ TextNode ()
671− {-# INLINABLE commentNode #-}
697+ {-# INLINE commentNode #-}
672698 commentNode (CommentNodeConfig initialContents mSetContents) = do
673699 _ <- commentNodeInternal initialContents mSetContents
674700 return $ CommentNode ()
675− {-# INLINABLE element #-}
701+ {-# INLINE element #-}
676702 element elementTag cfg child = do
677703 fst <$> makeElement elementTag cfg child
678− {-# INLINABLE inputElement #-}
704+ {-# INLINE inputElement #-}
679705 inputElement cfg = do
680706 ((e, _), domElementRef) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
681707
@@ -694,7 +720,7 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT
694720 let v0 = _inputElementConfig_initialValue cfg
695721 impl :: (DomRenderHook t n, MonadJSM n) => n ()
696722 impl = do
697− domElement <- liftIO $ readIORef domElementRef
723+ domElement <- either pure (liftIO . readIORef) domElementRef
698724 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
699725 getValue = Input.getValue domInputElement
700726
@@ -767,7 +793,7 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT
767793 , _inputElement_files = files
768794 }
769795
770− {-# INLINABLE textAreaElement #-}
796+ {-# INLINE textAreaElement #-}
771797 textAreaElement cfg = do
772798 ((e, _), domElementRef) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
773799
@@ -782,7 +808,7 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT
782808 let v0 = _textAreaElementConfig_initialValue cfg
783809 impl :: (DomRenderHook t n, MonadJSM n) => n ()
784810 impl = do
785− domElement <- liftIO $ readIORef domElementRef
811+ domElement <- either pure (liftIO . readIORef) domElementRef
786812 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
787813 getValue = TextArea.getValue domTextAreaElement
788814
@@ -827,7 +853,7 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT
827853 , _textAreaElement_raw = ()
828854 }
829855
830− {-# INLINABLE selectElement #-}
856+ {-# INLINE selectElement #-}
831857 selectElement cfg child = do
832858 ((e, result), domElementRef) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
833859
@@ -842,7 +868,7 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT
842868 let v0 = _selectElementConfig_initialValue cfg
843869 impl :: (DomRenderHook t n, MonadJSM n) => n ()
844870 impl = do
845− domElement <- liftIO $ readIORef domElementRef
871+ domElement <- either pure (liftIO . readIORef) domElementRef
846872 let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
847873 getValue = Select.getValue domSelectElement
848874
@@ -912,8 +938,7 @@ instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomB
912938 type DomFragment (HydrationDomBuilderT t m) = HydrationDomFragment
913939 buildDomFragment w = do
914940 df <- createDocumentFragment =<< askDocument
915− p <- liftIO $ newIORef $ toNode df
916− result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = p }) w
941+ result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode df }) w
917942 s <- liftIO $ newIORef FragmentState_Unmounted
918943 return (HydrationDomFragment df s, result)
919944 mountDomFragment fragment setFragment = do
@@ -937,7 +962,7 @@ instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjus
937962 traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
938963
939964instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (HydrationDomBuilderT t m) where
940− {-# INLINABLE runWithReplace #-}
965+ {-# INLINE runWithReplace #-}
941966 runWithReplace a0 a' = do
942967 initialEnv <- HydrationDomBuilderT ask
943968 let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
@@ -963,7 +988,6 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) =>
963988 p' <- case h of
964989 HydrationMode_Hydrating -> pure parent
965990 HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
966− p <- liftIO $ newIORef p'
967991 unreadyChildren <- liftIO $ newIORef 0
968992 let a0' = case h of
969993 HydrationMode_Hydrating -> a0
@@ -971,22 +995,28 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) =>
971995 a <- a0
972996 insertBefore p' =<< liftIO (readIORef after)
973997 pure a
974− (result, dom) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT a0') initialEnv
998+ delayed <- case h of
999+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1000+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1001+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv
9751002 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
9761003 , _hydrationDomBuilderEnv_commitAction = myCommitAction
977− , _hydrationDomBuilderEnv_parent = p
1004+ , _hydrationDomBuilderEnv_parent = Left p'
1005+ , _hydrationDomBuilderEnv_delayed = delayed
9781006 }
1007+ dom <- case h of
1008+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1009+ HydrationMode_Immediate -> pure $ pure ()
9791010 liftIO $ readIORef unreadyChildren >>= \case
9801011 0 -> writeIORef haveEverBeenReady True
9811012 _ -> modifyIORef' parentUnreadyChildren succ
9821013 return (dom, result)
9831014 a'' <- numberOccurrences a'
984− ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
1015+ ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
9851016 h <- liftIO $ readIORef hydrating
9861017 p' <- case h of
9871018 HydrationMode_Hydrating -> pure parent
9881019 HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
989− p <- liftIO $ newIORef p'
9901020 unreadyChildren <- liftIO $ newIORef 0
9911021 let commitAction = do
9921022 c <- liftIO $ readIORef currentCohort
@@ -997,13 +1027,20 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) =>
9971027 insertBefore p' after'
9981028 liftIO $ writeIORef currentCohort cohortId
9991029 myCommitAction
1000− (result, dom) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) $ initialEnv
1030+ delayed <- case h of
1031+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1032+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1033+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv
10011034 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
10021035 , _hydrationDomBuilderEnv_commitAction = case h of
10031036 HydrationMode_Hydrating -> myCommitAction
10041037 HydrationMode_Immediate -> commitAction
1005− , _hydrationDomBuilderEnv_parent = p
1038+ , _hydrationDomBuilderEnv_parent = Left p'
1039+ , _hydrationDomBuilderEnv_delayed = delayed
10061040 }
1041+ dom <- case h of
1042+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1043+ HydrationMode_Immediate -> pure $ pure ()
10071044 uc <- liftIO $ readIORef unreadyChildren
10081045 let commitActionToRunNow = if uc == 0
10091046 then Just $ commitAction
@@ -1020,11 +1057,11 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) =>
10201057 requestDomAction_ $ fmapMaybe id commitAction
10211058 return (result0, snd <$> child')
10221059
1023− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
1060+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}
10241061 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
1025− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
1062+ {-# INLINE traverseDMapWithKeyWithAdjust #-}
10261063 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
1027− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
1064+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}
10281065 traverseDMapWithKeyWithAdjustWithMove = do
10291066 let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do
10301067 let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState (Some k)))) a)
@@ -1084,7 +1121,7 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) =>
10841121 mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time
10851122 liftIO $ writeIORef placeholders $! phsAfter
10861123
1087−{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
1124+{-# INLINE traverseDMapWithKeyWithAdjust' #-}
10881125traverseDMapWithKeyWithAdjust'
10891126 :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k)
10901127 => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
@@ -1130,7 +1167,7 @@ traverseDMapWithKeyWithAdjust' = do
11301167 Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate
11311168 liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
11321169
1133−{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
1170+{-# INLINE traverseIntMapWithKeyWithAdjust' #-}
11341171traverseIntMapWithKeyWithAdjust'
11351172 :: forall t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m)
11361173 => (IntMap.Key -> v -> HydrationDomBuilderT t m v')
@@ -1187,7 +1224,7 @@ insertAfterPreviousNode node = do
11871224 Node.insertBefore_ parent node nextNode
11881225 setPreviousNode $ Just $ toNode node
11891226
1190−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1227+{-# INLINE hoistTraverseWithKeyWithAdjust #-}
11911228hoistTraverseWithKeyWithAdjust
11921229 ::
11931230 ( Adjustable t m
@@ -1257,7 +1294,7 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
12571294 when (DMap.null newUnready) $ do
12581295 applyDomUpdate p
12591296 (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))
1260− <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1297+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
12611298 let processChild k (Compose (TraverseChild e _)) = case e of
12621299 Left _ -> pure $ ComposeMaybe Nothing
12631300 Right immediate -> ComposeMaybe <$> do
@@ -1296,7 +1333,7 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
12961333 result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose
12971334 return (result0, result')
12981335
1299−{-# INLINABLE hoistTraverseIntMapWithKeyWithAdjust #-}
1336+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
13001337hoistTraverseIntMapWithKeyWithAdjust ::
13011338 ( Adjustable t m
13021339 , MonadHold t m
@@ -1365,7 +1402,7 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
13651402 when (IntMap.null newUnready) $ do
13661403 applyDomUpdate p
13671404 (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))
1368− <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1405+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
13691406 let processChild k (TraverseChild e _) = case e of
13701407 Left _ -> pure Nothing
13711408 Right immediate -> do
@@ -1405,11 +1442,11 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
14051442 return (result0, result')
14061443
14071444data TraverseChildImmediate k = TraverseChildImmediate
1408− { _traverseChildImmediate_fragment :: DOM.DocumentFragment
1445+ { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment
14091446 -- ^ Child is appended to this fragment
1410− , _traverseChildImmediate_placeholder :: DOM.Text
1447+ , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text
14111448 -- ^ Placeholder reference
1412− , _traverseChildImmediate_childReadyState :: IORef (ChildReadyState k)
1449+ , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))
14131450 }
14141451
14151452newtype TraverseChildHydration t m = TraverseChildHydration
@@ -1418,13 +1455,13 @@ newtype TraverseChildHydration t m = TraverseChildHydration
14181455 }
14191456
14201457data TraverseChild t m k a = TraverseChild
1421− { _traverseChild_mode :: Either (TraverseChildHydration t m) (TraverseChildImmediate k)
1422− , _traverseChild_result :: a
1458+ { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))
1459+ , _traverseChild_result :: !a
14231460 } deriving Functor
14241461
1425−{-# INLINABLE drawChildUpdate #-}
1426−drawChildUpdate :: (MonadIO m, MonadJSM m, Reflex t)
1427− => HydrationDomBuilderEnv t
1462+{-# INLINE drawChildUpdate #-}
1463+drawChildUpdate :: (MonadJSM m, Reflex t)
1464+ => HydrationDomBuilderEnv t m
14281465 -> (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
14291466 -> HydrationDomBuilderT t m (f a)
14301467 -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)
@@ -1433,9 +1470,12 @@ drawChildUpdate initialEnv markReady child = do
14331470 unreadyChildren <- liftIO $ newIORef 0
14341471 liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case
14351472 HydrationMode_Hydrating -> do
1436− (result, childDelayed) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1473+ childDelayedRef <- liftIO $ newIORef $ pure ()
1474+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
14371475 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1476+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
14381477 }
1478+ childDelayed <- liftIO $ readIORef childDelayedRef
14391479 return $ Compose $ TraverseChild
14401480 { _traverseChild_result = result
14411481 , _traverseChild_mode = Left TraverseChildHydration
@@ -1451,9 +1491,8 @@ drawChildUpdate initialEnv markReady child = do
14511491 df <- createDocumentFragment doc
14521492 placeholder <- createTextNode doc ("" :: Text)
14531493 Node.appendChild_ df placeholder
1454− parentRef <- liftIO . newIORef $ toNode df
1455− (result, _s) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1456− { _hydrationDomBuilderEnv_parent = parentRef
1494+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
1495+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
14571496 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
14581497 , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
14591498 }
@@ -1468,8 +1507,9 @@ drawChildUpdate initialEnv markReady child = do
14681507 }
14691508 }
14701509
1510+{-# INLINE drawChildUpdateInt #-}
14711511drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
1472− => HydrationDomBuilderEnv t
1512+ => HydrationDomBuilderEnv t m
14731513 -> (IORef (ChildReadyState k) -> JSM ())
14741514 -> HydrationDomBuilderT t m v
14751515 -> DomRenderHookT t m (TraverseChild t m k v)
@@ -1477,35 +1517,35 @@ drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdat
14771517
14781518instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where
14791519 type Performable (HydrationDomBuilderT t m) = Performable m
1480− {-# INLINABLE performEvent_ #-}
1520+ {-# INLINE performEvent_ #-}
14811521 performEvent_ e = lift $ performEvent_ e
1482− {-# INLINABLE performEvent #-}
1522+ {-# INLINE performEvent #-}
14831523 performEvent e = lift $ performEvent e
14841524
14851525instance PostBuild t m => PostBuild t (HydrationDomBuilderT t m) where
1486− {-# INLINABLE getPostBuild #-}
1526+ {-# INLINE getPostBuild #-}
14871527 getPostBuild = lift getPostBuild
14881528
14891529instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT t m) where
1490− {-# INLINABLE newEventWithTrigger #-}
1530+ {-# INLINE newEventWithTrigger #-}
14911531 newEventWithTrigger = lift . newEventWithTrigger
1492− {-# INLINABLE newFanEventWithTrigger #-}
1532+ {-# INLINE newFanEventWithTrigger #-}
14931533 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
14941534
14951535instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT t m) where
1496− {-# INLINABLE newTriggerEvent #-}
1497− newTriggerEvent = HydrationDomBuilderT . lift . lift $ newTriggerEvent
1498− {-# INLINABLE newTriggerEventWithOnComplete #-}
1499− newTriggerEventWithOnComplete = HydrationDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
1500− {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1501− newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
1536+ {-# INLINE newTriggerEvent #-}
1537+ newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent
1538+ {-# INLINE newTriggerEventWithOnComplete #-}
1539+ newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete
1540+ {-# INLINE newEventWithLazyTriggerWithOnComplete #-}
1541+ newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f
15021542
15031543instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where
1504− {-# INLINABLE newTriggerEvent #-}
1544+ {-# INLINE newTriggerEvent #-}
15051545 newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent
1506− {-# INLINABLE newTriggerEventWithOnComplete #-}
1546+ {-# INLINE newTriggerEventWithOnComplete #-}
15071547 newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete
1508− {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1548+ {-# INLINE newEventWithLazyTriggerWithOnComplete #-}
15091549 newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f
15101550
15111551instance HasJSContext m => HasJSContext (HydrationDomBuilderT t m) where
@@ -1514,15 +1554,15 @@ instance HasJSContext m => HasJSContext (HydrationDomBuilderT t m) where
15141554
15151555instance MonadRef m => MonadRef (HydrationDomBuilderT t m) where
15161556 type Ref (HydrationDomBuilderT t m) = Ref m
1517− {-# INLINABLE newRef #-}
1557+ {-# INLINE newRef #-}
15181558 newRef = lift . newRef
1519− {-# INLINABLE readRef #-}
1559+ {-# INLINE readRef #-}
15201560 readRef = lift . readRef
1521− {-# INLINABLE writeRef #-}
1561+ {-# INLINE writeRef #-}
15221562 writeRef r = lift . writeRef r
15231563
15241564instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT t m) where
1525− {-# INLINABLE atomicModifyRef #-}
1565+ {-# INLINE atomicModifyRef #-}
15261566 atomicModifyRef r = lift . atomicModifyRef r
15271567
15281568instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT t m) where
@@ -1530,18 +1570,18 @@ instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT t m) where
15301570 liftJS = lift . liftJS
15311571
15321572instance MonadSample t m => MonadSample t (HydrationDomBuilderT t m) where
1533− {-# INLINABLE sample #-}
1573+ {-# INLINE sample #-}
15341574 sample = lift . sample
15351575
15361576instance MonadHold t m => MonadHold t (HydrationDomBuilderT t m) where
1537− {-# INLINABLE hold #-}
1577+ {-# INLINE hold #-}
15381578 hold v0 v' = lift $ hold v0 v'
1539− {-# INLINABLE holdDyn #-}
1579+ {-# INLINE holdDyn #-}
15401580 holdDyn v0 v' = lift $ holdDyn v0 v'
1541− {-# INLINABLE holdIncremental #-}
1581+ {-# INLINE holdIncremental #-}
15421582 holdIncremental v0 v' = lift $ holdIncremental v0 v'
1543− {-# INLINABLE buildDynamic #-}
1583+ {-# INLINE buildDynamic #-}
15441584 buildDynamic a0 = lift . buildDynamic a0
1545− {-# INLINABLE headE #-}
1585+ {-# INLINE headE #-}
15461586 headE = lift . headE
15471587
reflex-dom-core/src/Reflex/Dom/Core.hs+1−1
@@ -2,7 +2,7 @@ module Reflex.Dom.Core (module X) where
22
33import Reflex as X hiding (askEvents)
44import Reflex.Dom.Builder.Class as X
5−import Reflex.Dom.Builder.Hydration as X hiding (askParent, askEvents, append, textNodeInternal, wrap, makeElement, drawChildUpdate, traverseDMapWithKeyWithAdjust', hoistTraverseWithKeyWithAdjust, traverseIntMapWithKeyWithAdjust')
5+import Reflex.Dom.Builder.Hydration as X hiding (askEvents, makeElement, ChildReadyState, drawChildUpdate, append, wrap, traverseIntMapWithKeyWithAdjust', hoistTraverseIntMapWithKeyWithAdjust)
66import Reflex.Dom.Builder.Immediate as X
77import Reflex.Dom.Builder.InputDisabled as X
88import Reflex.Dom.Builder.Static as X
reflex-dom-core/src/Reflex/Dom/Main.hs+25−35
@@ -85,13 +85,13 @@ attachHydrationWidget
8585 -> IORef HydrationMode
8686 -> IORef [(Node, HydrationRunnerT DomTimeline (PostBuildT DomTimeline (WithJSContextSingleton () (PerformEventT DomTimeline DomHost))) ())]
8787 -> JSContextSingleton ()
88− -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (IORef (Maybe (EventTrigger DomTimeline ()))))
89− -> IO ()
88+ -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ()))))
89+ -> IO (a, FireCommand DomTimeline DomHost)
9090attachHydrationWidget switchoverAction hydrationMode rootNodesRef jsSing w = do
9191 events <- newChan
9292 runDomHost $ flip runTriggerEventT events $ mdo
9393 (syncEvent, fireSync) <- newTriggerEvent
94− (postBuildTriggerRef, fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do
94+ ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do
9595 a <- w events syncEvent
9696 _ <- runWithReplace (return ()) $ delayedAction <$ syncEvent
9797 pure a
@@ -99,13 +99,12 @@ attachHydrationWidget switchoverAction hydrationMode rootNodesRef jsSing w = do
9999 lift $ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
100100 liftIO $ fireSync ()
101101 rootNodes <- liftIO $ readIORef rootNodesRef
102− -- TODO: DomHost is SpiderHost Global only if we're not in profiling mode
103102 let delayedAction = do
104103 for_ (reverse rootNodes) $ \(rootNode, runner) -> do
105104 void $ runWithJSContextSingleton (runPostBuildT (runHydrationRunnerT runner Nothing rootNode events) never) jsSing
106105 liftIO $ writeIORef hydrationMode HydrationMode_Immediate
107106 liftIO $ switchoverAction
108− liftIO $ processAsyncEvents events fc
107+ pure (result, fc)
109108
110109type HydrationWidget x a = HydrationDomBuilderT DomTimeline (DomCoreWidget x) a
111110
@@ -114,6 +113,7 @@ type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)
114113
115114type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))
116115
116+{-# INLINABLE runHydrationWidgetWithHeadAndBody #-}
117117runHydrationWidgetWithHeadAndBody
118118 :: IO ()
119119 -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"
@@ -128,81 +128,71 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM
128128 unreadyChildren <- liftIO $ newIORef 0
129129 hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating
130130 hydrationResult <- liftIO $ newIORef []
131− liftIO $ attachHydrationWidget switchoverAction hydrationMode hydrationResult jsSing $ \events switchover -> flip runWithJSContextSingleton jsSing $ do
131+ (events, fc) <- liftIO . attachHydrationWidget switchoverAction hydrationMode hydrationResult jsSing $ \events switchover -> do
132132 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
133133 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
134134 hydrateDom n w = do
135135 events' <- TriggerEvent.askEvents
136− parent <- liftIO $ newIORef $ toNode n
136+ delayed <- liftIO $ newIORef $ pure ()
137137 lift $ do
138138 let builderEnv = HydrationDomBuilderEnv
139139 { _hydrationDomBuilderEnv_document = globalDoc
140− , _hydrationDomBuilderEnv_parent = parent
140+ , _hydrationDomBuilderEnv_parent = Left $ toNode n
141141 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
142142 , _hydrationDomBuilderEnv_commitAction = pure ()
143143 , _hydrationDomBuilderEnv_hydrationMode = hydrationMode
144144 , _hydrationDomBuilderEnv_switchover = switchover
145+ , _hydrationDomBuilderEnv_delayed = delayed
145146 }
146− (a, res) <- runHydrationDomBuilderT w builderEnv events'
147+ a <- runHydrationDomBuilderT w builderEnv events'
148+ res <- liftIO $ readIORef delayed
147149 liftIO $ modifyIORef' hydrationResult ((n, res) :)
148150 pure a
149− flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)
150− return postBuildTriggerRef
151+ runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events) postBuild) jsSing
152+ return (events, postBuildTriggerRef)
153+ liftIO $ processAsyncEvents events fc
151154
152155{-# INLINABLE mainHydrationWidgetWithHeadImmediate #-}
153156-- | Warning: `mainHydrationWidgetWithHeadImmediate` is provided only as performance tweak. It is expected to disappear in future releases.
154157mainHydrationWidgetWithHeadImmediate :: HydrationWidget () () -> HydrationWidget () () -> JSM ()
155158mainHydrationWidgetWithHeadImmediate head' body = do
156− runHydrationWidgetWithHeadAndBodyImmediate (pure ()) $ \appendHead appendBody -> do
159+ runHydrationWidgetWithHeadAndBodyImmediate $ \appendHead appendBody -> do
157160 appendHead head'
158161 appendBody body
159162
160−{-# INLINABLE attachHydrationWidgetImmediate #-}
161−attachHydrationWidgetImmediate
162− :: JSContextSingleton ()
163− -> (EventChannel -> PerformEventT DomTimeline DomHost (IORef (Maybe (EventTrigger DomTimeline ()))))
164− -> IO ()
165−attachHydrationWidgetImmediate jsSing w = do
166− events <- newChan
167− runDomHost $ flip runTriggerEventT events $ mdo
168− (postBuildTriggerRef, fc@(FireCommand fire)) <- lift $ hostPerformEventT $ w events
169− mPostBuildTrigger <- readRef postBuildTriggerRef
170− lift $ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
171− liftIO $ processAsyncEvents events fc
172−
173163{-# INLINABLE runHydrationWidgetWithHeadAndBodyImmediate #-}
174164runHydrationWidgetWithHeadAndBodyImmediate
175− :: IO ()
176− -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"
165+ :: ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"
177166 -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body"
178167 -> FloatingWidget () ()
179168 )
180169 -> JSM ()
181−runHydrationWidgetWithHeadAndBodyImmediate switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
170+runHydrationWidgetWithHeadAndBodyImmediate app = withJSContextSingletonMono $ \jsSing -> do
182171 globalDoc <- currentDocumentUnchecked
183172 headElement <- getHeadUnchecked globalDoc
184173 bodyElement <- getBodyUnchecked globalDoc
185174 unreadyChildren <- liftIO $ newIORef 0
186175 hydrationMode <- liftIO $ newIORef HydrationMode_Immediate
187− liftIO $ attachHydrationWidgetImmediate jsSing $ \events -> flip runWithJSContextSingleton jsSing $ do
176+ (events, fc) <- liftIO . attachWidget'' $ \events -> do
188177 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
189178 let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
190179 hydrateDom n w = do
191180 events' <- TriggerEvent.askEvents
192− parent <- liftIO $ newIORef $ toNode n
181+ delayed <- liftIO $ newIORef $ pure ()
193182 lift $ do
194183 let builderEnv = HydrationDomBuilderEnv
195184 { _hydrationDomBuilderEnv_document = globalDoc
196− , _hydrationDomBuilderEnv_parent = parent
185+ , _hydrationDomBuilderEnv_parent = Left $ toNode n
197186 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
198187 , _hydrationDomBuilderEnv_commitAction = pure ()
199188 , _hydrationDomBuilderEnv_hydrationMode = hydrationMode
200189 , _hydrationDomBuilderEnv_switchover = never
190+ , _hydrationDomBuilderEnv_delayed = delayed
201191 }
202− (a, _res) <- runHydrationDomBuilderT w builderEnv events'
203− pure a
204− flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)
205− return postBuildTriggerRef
192+ runHydrationDomBuilderT w builderEnv events'
193+ runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events) postBuild) jsSing
194+ return (events, postBuildTriggerRef)
195+ liftIO $ processAsyncEvents events fc
206196
207197{-# INLINE mainWidget #-}
208198mainWidget :: (forall x. Widget x ()) -> JSM ()
reflex-dom-core/src/Reflex/Dom/Prerender.hs+2−1
@@ -115,7 +115,8 @@ instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerend
115115 , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
116116 , _immediateDomBuilderEnv_commitAction = pure ()
117117 }
118− ((a, b0), _) <- lift $ runHydrationDomBuilderT server env events
118+ delayed <- liftIO $ newIORef $ pure ()
119+ (a, b0) <- lift $ runHydrationDomBuilderT server (env { _hydrationDomBuilderEnv_delayed = delayed }) events
119120 (b', trigger) <- newTriggerEvent
120121 getHydrationMode >>= \case
121122 HydrationMode_Immediate -> do
reflex-dom-core/src/Reflex/Dom/Specializations.hs+115−1
@@ -1,9 +1,14 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE PolyKinds #-}
34{-# LANGUAGE Rank2Types #-}
45{-# LANGUAGE ScopedTypeVariables #-}
5−module Reflex.Dom.Specializations where
6+module Reflex.Dom.Specializations () where
67
8+import Control.Concurrent.Chan (Chan)
9+import Data.Dependent.Sum (DSum)
10+import Data.Dependent.Map (DMap)
11+import Data.Some (Some)
712import Data.Text (Text)
813import Reflex.Spider
914import Reflex.Class
@@ -14,6 +19,7 @@ import Reflex.Requester.Base
1419import Reflex.TriggerEvent.Base
1520import Reflex.Dom.Builder.Class
1621import Reflex.Dom.Builder.Immediate
22+import qualified Reflex.Dom.Builder.Hydration as H
1723import Data.Functor.Identity
1824import Data.Functor.Compose
1925import Data.IORef
@@ -59,3 +65,111 @@ import qualified GHCJS.DOM.Types as DOM
5965 -> Event (SpiderTimeline Global) (PatchIntMap v)
6066 -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
6167 #-}
68+
69+-- Hydration stuff
70+
71+type HydrationM = WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))
72+
73+{-# SPECIALIZE H.makeElement
74+ :: Text
75+ -> ElementConfig er Spider H.HydrationDomSpace
76+ -> H.HydrationDomBuilderT Spider HydrationM a
77+ -> H.HydrationDomBuilderT Spider HydrationM
78+ ((Element er H.HydrationDomSpace Spider, a), Either DOM.Element (IORef DOM.Element))
79+ #-}
80+
81+{-# SPECIALIZE H.makeNodeInternal
82+ :: H.HydrationDomBuilderT Spider HydrationM DOM.Element
83+ -> H.HydrationDomBuilderT Spider HydrationM DOM.Element
84+ #-}
85+{-# SPECIALIZE H.makeNodeInternal
86+ :: H.HydrationDomBuilderT Spider HydrationM DOM.Text
87+ -> H.HydrationDomBuilderT Spider HydrationM DOM.Text
88+ #-}
89+
90+{-# SPECIALIZE H.makeNodeInternal
91+ :: H.HydrationDomBuilderT Spider HydrationM DOM.Comment
92+ -> H.HydrationDomBuilderT Spider HydrationM DOM.Comment
93+ #-}
94+
95+{-# SPECIALIZE H.drawChildUpdate
96+ :: H.HydrationDomBuilderEnv Spider HydrationM
97+ -> (IORef (H.ChildReadyState Int) -> JSM ())
98+ -> H.HydrationDomBuilderT Spider HydrationM (Identity a)
99+ -> H.DomRenderHookT Spider HydrationM (Compose (H.TraverseChild Spider HydrationM Int) Identity a)
100+ #-}
101+
102+{-# SPECIALIZE H.drawChildUpdate
103+ :: H.HydrationDomBuilderEnv Spider HydrationM
104+ -> (IORef (H.ChildReadyState (Some k)) -> JSM ())
105+ -> H.HydrationDomBuilderT Spider HydrationM (f a)
106+ -> H.DomRenderHookT Spider HydrationM (Compose (H.TraverseChild Spider HydrationM (Some k)) f a)
107+ #-}
108+
109+{-# SPECIALIZE H.drawChildUpdateInt
110+ :: H.HydrationDomBuilderEnv Spider HydrationM
111+ -> (IORef (H.ChildReadyState k) -> JSM ())
112+ -> H.HydrationDomBuilderT Spider HydrationM v
113+ -> H.DomRenderHookT Spider HydrationM (H.TraverseChild Spider HydrationM k v)
114+ #-}
115+
116+{-# SPECIALIZE H.append
117+ :: DOM.Node
118+ -> H.HydrationDomBuilderT Spider HydrationM ()
119+ #-}
120+
121+{-# SPECIALIZE H.wrap
122+ :: Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
123+ -> DOM.Element
124+ -> RawElementConfig er Spider H.HydrationDomSpace
125+ -> H.HydrationDomBuilderT Spider HydrationM (DMap EventName (EventFilterTriggerRef Spider er))
126+ #-}
127+
128+{-# SPECIALIZE H.triggerBody
129+ :: DOM.JSContextRef
130+ -> ElementConfig er Spider H.HydrationDomSpace
131+ -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
132+ -> DMap EventName (EventFilterTriggerRef Spider er)
133+ -> DOM.Element
134+ -> H.WrapArg er EventName x
135+ -> H.EventTrigger Spider x
136+ -> IO (IO ())
137+ #-}
138+
139+{-# SPECIALIZE H.traverseIntMapWithKeyWithAdjust'
140+ :: (IntMap.Key -> v -> H.HydrationDomBuilderT Spider HydrationM v')
141+ -> IntMap v
142+ -> Event Spider (PatchIntMap v)
143+ -> H.HydrationDomBuilderT Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))
144+ #-}
145+
146+{-# SPECIALIZE H.hoistTraverseIntMapWithKeyWithAdjust
147+ :: ((IntMap.Key -> v -> H.DomRenderHookT Spider HydrationM (H.TraverseChild Spider HydrationM Int v'))
148+ -> IntMap v
149+ -> Event Spider (PatchIntMap v)
150+ -> H.DomRenderHookT Spider HydrationM (IntMap (H.TraverseChild Spider HydrationM Int v'), Event Spider (PatchIntMap (H.TraverseChild Spider HydrationM Int v'))))
151+ -> (PatchIntMap (H.TraverseChild Spider HydrationM Int v')
152+ -> IntMap (IORef (H.ChildReadyState Int))
153+ -> IO (IntMap (IORef (H.ChildReadyState Int))))
154+ -> (IORef (IntMap DOM.Text)
155+ -> DOM.Text
156+ -> PatchIntMap (H.TraverseChild Spider HydrationM Int v')
157+ -> JSM ())
158+ -> (IntMap.Key -> v -> H.HydrationDomBuilderT Spider HydrationM v')
159+ -> IntMap v
160+ -> Event Spider (PatchIntMap v)
161+ -> H.HydrationDomBuilderT Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))
162+ #-}
163+
164+{-# SPECIALIZE H.runHydrationDomBuilderT
165+ :: H.HydrationDomBuilderT Spider HydrationM a
166+ -> H.HydrationDomBuilderEnv Spider HydrationM
167+ -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
168+ -> HydrationM a
169+ #-}
170+
171+{-# SPECIALIZE H.runDomRenderHookT
172+ :: H.DomRenderHookT Spider HydrationM a
173+ -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
174+ -> HydrationM a
175+ #-}
reflex-dom-core/test/hydration.hs+2−2
@@ -1352,7 +1352,7 @@ testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out")
13521352 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
13531353 let entryPoint = do
13541354 liftIO $ takeMVar waitBeforeJS
1355− mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) $ bodyWidget
1355+ mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) bodyWidget
13561356 syncPoint
13571357 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse ->
13581358 sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
@@ -1397,7 +1397,7 @@ testWidgetDebug bodyWidget = liftIO $ do
13971397 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
13981398 ((), html) <- renderStatic staticApp
13991399 let entryPoint = do
1400− mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) $ bodyWidget
1400+ mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) bodyWidget
14011401 syncPoint
14021402 application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
14031403 Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
reflex-dom/benchmarks/krausest.hs+2−1
@@ -26,7 +26,8 @@ type TableDiff = PatchIntMap Row
2626main :: IO ()
2727main = do
2828 seed <- randomIO
29− mainWidgetWithHead {-mainHydrationWidgetWithHeadImmediate-} headW (bodyW seed)
29+-- mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed) -- Immediate builder
30+ mainHydrationWidgetWithHeadImmediate headW (bodyW seed) -- Hydration builder
3031
3132titleW :: DomBuilder t m => m ()
3233titleW = text "Reflex-dom keyed"