@@ -2,7 +2,8 @@
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE ConstraintKinds #-}
44{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE DefaultSignatures #-}
5+{-# LANGUAGE DeriveFunctor #-}
6+{-# LANGUAGE DeriveTraversable #-}
67{-# LANGUAGE EmptyDataDecls #-}
78{-# LANGUAGE FlexibleContexts #-}
89{-# LANGUAGE FlexibleInstances #-}
@@ -11,14 +12,15 @@
1112{-# LANGUAGE LambdaCase #-}
1213{-# LANGUAGE MultiParamTypeClasses #-}
1314{-# LANGUAGE OverloadedStrings #-}
15+{-# LANGUAGE PatternGuards #-}
1416{-# LANGUAGE PolyKinds #-}
1517{-# LANGUAGE RankNTypes #-}
1618{-# LANGUAGE RecursiveDo #-}
1719{-# LANGUAGE ScopedTypeVariables #-}
18−{-# LANGUAGE StandaloneDeriving #-}
1920#ifdef USE_TEMPLATE_HASKELL
2021{-# LANGUAGE TemplateHaskell #-}
2122#endif
23+{-# LANGUAGE TupleSections #-}
2224{-# LANGUAGE TypeFamilies #-}
2325{-# LANGUAGE TypeOperators #-}
2426{-# LANGUAGE UndecidableInstances #-}
@@ -26,184 +28,344 @@
2628{-# LANGUAGE ForeignFunctionInterface #-}
2729{-# LANGUAGE JavaScriptFFI #-}
2830#endif
31+-- | This is a builder to be used on the client side. It can be run in two modes:
32+--
33+-- 1. in "hydration mode", reusing DOM nodes already in the page (as produced
34+-- by 'Reflex.Dom.Builder.Static.renderStatic')
35+-- 2. in "immediate mode", creating and appending DOM nodes as required
36+--
37+-- In "hydration mode", the preexisting DOM __must contain__ what the builder
38+-- will expect at switchover time (the time at which parity with the static
39+-- renderer is reached, and the time after which the page is "live").
40+--
41+-- For example, displaying the current time as text should be done inside
42+-- 'Reflex.Dom.Prerender.prerender' to ensure that we don't attempt to hydrate the incorrect text.
43+-- The server will prerender a text node with time A, and the client will expect
44+-- a text node with time B. Barring a miracle, time A and time B will not match,
45+-- and hydration will fail.
2946module Reflex.Dom.Builder.Immediate
30− ( EventTriggerRef (..)
31− , ImmediateDomBuilderEnv (..)
32− , ImmediateDomBuilderT (..)
33− , runImmediateDomBuilderT
34− , askParent
35− , askEvents
36− , append
37− , textNodeInternal
38− , deleteBetweenExclusive
39− , extractBetweenExclusive
40− , deleteUpTo
41− , extractUpTo
42− , SupportsImmediateDomBuilder
43− , collectUpTo
44− , collectUpToGivenParent
45− , EventFilterTriggerRef (..)
46− , wrap
47− , makeElement
48− , GhcjsDomHandler (..)
49− , GhcjsDomHandler1 (..)
50− , GhcjsDomEvent (..)
51− , GhcjsDomSpace
52− , GhcjsEventFilter (..)
53− , Pair1 (..)
54− , Maybe1 (..)
55− , GhcjsEventSpec (..)
56− , HasDocument (..)
57− , ghcjsEventSpec_filters
58− , ghcjsEventSpec_handler
59− , GhcjsEventHandler (..)
47+ ( HydrationDomBuilderT (..)
48+ , HydrationDomBuilderEnv (..)
49+ , HydrationMode (..)
50+ , HydrationRunnerT (..)
51+ , runHydrationRunnerT
52+ , ImmediateDomBuilderT
53+ , runHydrationDomBuilderT
54+ , getHydrationMode
55+ , addHydrationStep
56+ , addHydrationStepWithSetup
57+ , setPreviousNode
58+ , insertAfterPreviousNode
59+ , hydrateComment
60+ , askParent
61+ , askEvents
62+ , append
63+ , textNodeInternal
64+ , removeSubsequentNodes
65+ , deleteBetweenExclusive
66+ , extractBetweenExclusive
67+ , deleteUpTo
68+ , extractUpTo
69+ , SupportsHydrationDomBuilder
70+ , collectUpTo
71+ , collectUpToGivenParent
72+ , EventTriggerRef (..)
73+ , EventFilterTriggerRef (..)
74+ , wrap
75+ , elementInternal
76+ , HydrationDomSpace
77+ , GhcjsDomSpace
78+ , GhcjsDomHandler (..)
79+ , GhcjsDomHandler1 (..)
80+ , GhcjsDomEvent (..)
81+ , GhcjsEventFilter (..)
82+ , Pair1 (..)
83+ , Maybe1 (..)
84+ , GhcjsEventSpec (..)
85+ , HasDocument (..)
86+ , ghcjsEventSpec_filters
87+ , ghcjsEventSpec_handler
88+ , GhcjsEventHandler (..)
6089#ifndef USE_TEMPLATE_HASKELL
61− , phantom2
90+ , phantom2
6291#endif
63− , drawChildUpdate
64− , ChildReadyState (..)
65− , ChildReadyStateInt (..)
66− , mkHasFocus
67− , insertBefore
68− , EventType
69− , defaultDomEventHandler
70− , defaultDomWindowEventHandler
71− , withIsEvent
72− , showEventName
73− , elementOnEventName
74− , windowOnEventName
75− , wrapDomEvent
76− , subscribeDomEvent
77− , wrapDomEventMaybe
78− , wrapDomEventsMaybe
79− , getKeyEvent
80− , getMouseEventCoords
81− , getTouchEvent
82− , WindowConfig (..)
83− , Window (..)
84− , wrapWindow
85− -- * Internal
86− , traverseDMapWithKeyWithAdjust'
87− , hoistTraverseWithKeyWithAdjust
88− , traverseIntMapWithKeyWithAdjust'
89− , hoistTraverseIntMapWithKeyWithAdjust
90− ) where
91−
92−import Foreign.JavaScript.TH
93−import Reflex.Adjustable.Class
94−import Reflex.Class as Reflex
95−import Reflex.Dom.Builder.Class
96−import Reflex.Dynamic
97−import Reflex.Host.Class
98−import qualified Reflex.Patch.DMap as PatchDMap
99−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
100−import Reflex.PerformEvent.Class
101−import Reflex.PostBuild.Class
102−import Reflex.TriggerEvent.Base hiding (askEvents)
103−import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
104−import Reflex.TriggerEvent.Class
92+ , drawChildUpdate
93+ , ChildReadyState (..)
94+ , mkHasFocus
95+ , insertBefore
96+ , EventType
97+ , defaultDomEventHandler
98+ , defaultDomWindowEventHandler
99+ , withIsEvent
100+ , showEventName
101+ , elementOnEventName
102+ , windowOnEventName
103+ , wrapDomEvent
104+ , subscribeDomEvent
105+ , wrapDomEventMaybe
106+ , wrapDomEventsMaybe
107+ , getKeyEvent
108+ , getMouseEventCoords
109+ , getTouchEvent
110+ , WindowConfig (..)
111+ , Window (..)
112+ , wrapWindow
113+ -- * Internal
114+ , traverseDMapWithKeyWithAdjust'
115+ , hoistTraverseWithKeyWithAdjust
116+ , traverseIntMapWithKeyWithAdjust'
117+ , hoistTraverseIntMapWithKeyWithAdjust
118+ ) where
105119
106120import Control.Concurrent
107−import Control.Lens hiding (element, ix)
121+import Control.Exception (bracketOnError)
122+import Control.Lens (Identity(..), imapM_, iforM_, (^.), makeLenses)
108123import Control.Monad.Exception
109124import Control.Monad.Primitive
110125import Control.Monad.Reader
111126import Control.Monad.Ref
112−#ifndef USE_TEMPLATE_HASKELL
113−import Data.Functor.Contravariant (phantom)
114−#endif
127+import Control.Monad.State.Strict (StateT, mapStateT, get, modify', gets, runStateT)
115128import Data.Bitraversable
116129import Data.Default
117130import Data.Dependent.Map (DMap)
118−import qualified Data.Dependent.Map as DMap
119131import Data.Dependent.Sum
132+import Data.FastMutableIntMap (PatchIntMap (..))
133+import Data.Foldable (for_, traverse_)
120134import Data.Functor.Compose
121135import Data.Functor.Constant
122136import Data.Functor.Misc
123137import Data.Functor.Product
124138import Data.IORef
125−import qualified Data.Map as Map
139+import Data.IntMap.Strict (IntMap)
126140import Data.Maybe
127−import Data.Monoid hiding (Product)
128−import Data.Some (Some)
129−import qualified Data.Some as Some
141+import Data.Some (Some(..))
130142import Data.Text (Text)
143+import Foreign.JavaScript.Internal.Utils
144+import Foreign.JavaScript.TH
145+import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
146+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
147+import GHCJS.DOM.EventM (EventM, event, on)
148+import GHCJS.DOM.KeyboardEvent as KeyboardEvent
149+import GHCJS.DOM.MouseEvent
150+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
151+import GHCJS.DOM.Types (liftJSM, askJSM, runJSM, JSM, MonadJSM, FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)
152+import GHCJS.DOM.UIEvent
153+import Language.Javascript.JSaddle (call, eval)
154+import Reflex.Adjustable.Class
155+import Reflex.Class as Reflex
156+import Reflex.Dom.Builder.Class
157+import Reflex.Dynamic
158+import Reflex.Host.Class
159+import Reflex.Patch.DMapWithMove (PatchDMapWithMove(..))
160+import Reflex.Patch.MapWithMove (PatchMapWithMove(..))
161+import Reflex.PerformEvent.Base (PerformEventT)
162+import Reflex.PerformEvent.Class
163+import Reflex.PostBuild.Base (PostBuildT)
164+import Reflex.PostBuild.Class
165+import Reflex.Requester.Base
166+import Reflex.Requester.Class
167+import Reflex.Spider (Spider, SpiderHost, Global)
168+import Reflex.TriggerEvent.Base hiding (askEvents)
169+import Reflex.TriggerEvent.Class
170+
171+import qualified Data.Dependent.Map as DMap
172+import qualified Data.FastMutableIntMap as FastMutableIntMap
173+import qualified Data.IntMap.Strict as IntMap
174+import qualified Data.Map as Map
175+import qualified Data.Text as T
131176import qualified GHCJS.DOM as DOM
132−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
133−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
177+import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
178+import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
134179import qualified GHCJS.DOM.Element as Element
135180import qualified GHCJS.DOM.Event as Event
136−import qualified GHCJS.DOM.GlobalEventHandlers as Events
137−import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
138−import GHCJS.DOM.EventM (EventM, event, on)
139181import qualified GHCJS.DOM.EventM as DOM
140182import qualified GHCJS.DOM.FileList as FileList
183+import qualified GHCJS.DOM.GlobalEventHandlers as Events
141184import qualified GHCJS.DOM.HTMLInputElement as Input
142185import qualified GHCJS.DOM.HTMLSelectElement as Select
143186import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
144−import GHCJS.DOM.MouseEvent
187+import qualified GHCJS.DOM.Node as Node
188+import qualified GHCJS.DOM.Text as DOM
145189import qualified GHCJS.DOM.Touch as Touch
146190import qualified GHCJS.DOM.TouchEvent as TouchEvent
147191import qualified GHCJS.DOM.TouchList as TouchList
148−import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
149−import qualified GHCJS.DOM.Node as DOM (insertBefore_)
150−import GHCJS.DOM.Types
151− (liftJSM, askJSM, runJSM, JSM, MonadJSM,
152− FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
153− ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)
154192import qualified GHCJS.DOM.Types as DOM
155−import GHCJS.DOM.UIEvent
156−import GHCJS.DOM.KeyboardEvent as KeyboardEvent
157193import qualified GHCJS.DOM.Window as Window
158−import Language.Javascript.JSaddle (call, eval)
159−import Data.IntMap.Strict (IntMap)
160−import qualified Data.IntMap.Strict as IntMap
161−import Data.FastMutableIntMap (PatchIntMap (..))
162−import qualified Data.FastMutableIntMap as FastMutableIntMap
194+import qualified Reflex.Patch.DMap as PatchDMap
195+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
196+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
197+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
163198
164−import Reflex.Requester.Base
165−import Reflex.Requester.Class
166−import Foreign.JavaScript.Internal.Utils
199+#ifndef USE_TEMPLATE_HASKELL
200+import Data.Functor.Contravariant (phantom)
201+#endif
167202
168203#ifndef ghcjs_HOST_OS
169204import GHCJS.DOM.Types (MonadJSM (..))
170205
171−instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
172− liftJSM' = ImmediateDomBuilderT . liftJSM'
206+instance MonadJSM m => MonadJSM (HydrationRunnerT t m) where
207+ {-# INLINABLE liftJSM' #-}
208+ liftJSM' = lift . liftJSM'
209+
210+instance MonadJSM m => MonadJSM (HydrationDomBuilderT s t m) where
211+ {-# INLINABLE liftJSM' #-}
212+ liftJSM' = lift . liftJSM'
213+
214+instance MonadJSM m => MonadJSM (DomRenderHookT t m) where
215+ {-# INLINABLE liftJSM' #-}
216+ liftJSM' = lift . liftJSM'
173217#endif
174218
175−data ImmediateDomBuilderEnv t
176− = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document
177− , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node
178− , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
179− , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
180− }
219+data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv
220+ { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
221+ -- ^ Reference to the document
222+ , _hydrationDomBuilderEnv_parent :: !(Either Node (IORef Node))
223+ -- ^ This is in an IORef because in the time up to hydration we can't actually know what the
224+ -- parent is - we populate this reference during the DOM traversal at hydration time
225+ , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word)
226+ -- ^ Number of children who still aren't fully rendered
227+ , _hydrationDomBuilderEnv_commitAction :: !(JSM ())
228+ -- ^ Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
229+ , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode)
230+ -- ^ In hydration mode? Should be switched to `HydrationMode_Immediate` after hydration is finished
231+ , _hydrationDomBuilderEnv_switchover :: !(Event t ())
232+ , _hydrationDomBuilderEnv_delayed :: {-# UNPACK #-} !(IORef (HydrationRunnerT t m ()))
233+ }
181234
182−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }
235+-- | A monad for DomBuilder which just gets the results of children and pushes
236+-- work into an action that is delayed until after postBuild (to match the
237+-- static builder). The action runs in 'HydrationRunnerT', which performs the
238+-- DOM takeover and sets up the events, after which point this monad will
239+-- continue in the vein of 'ImmediateDomBuilderT'.
240+newtype HydrationDomBuilderT s t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (DomRenderHookT t m) a }
183241 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
184242#if MIN_VERSION_base(4,9,1)
185243 , MonadAsyncException
186244#endif
187245 )
188246
189−instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
190− type PrimState (ImmediateDomBuilderT x m) = PrimState m
247+instance PrimMonad m => PrimMonad (HydrationDomBuilderT s t m) where
248+ type PrimState (HydrationDomBuilderT s t m) = PrimState m
191249 primitive = lift . primitive
192250
193−instance MonadTrans (ImmediateDomBuilderT t) where
194− lift = ImmediateDomBuilderT . lift . lift . lift
251+instance MonadTrans (HydrationDomBuilderT s t) where
252+ lift = HydrationDomBuilderT . lift . lift
253+
254+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT s t m) where
255+ withRenderHook hook = HydrationDomBuilderT . mapReaderT (withRenderHook hook) . unHydrationDomBuilderT
256+ requestDomAction = HydrationDomBuilderT . lift . requestDomAction
257+ requestDomAction_ = HydrationDomBuilderT . lift . requestDomAction_
195258
196−instance (Reflex t, MonadFix m) => DomRenderHook t (ImmediateDomBuilderT t m) where
197− withRenderHook hook (ImmediateDomBuilderT a) = do
198− e <- ImmediateDomBuilderT ask
199− ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do
200− (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp
259+-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.
260+-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.
261+newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT HydrationState (ReaderT Node (DomRenderHookT t m)) a }
262+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
263+#if MIN_VERSION_base(4,9,1)
264+ , MonadAsyncException
265+#endif
266+ )
267+
268+data HydrationState = HydrationState
269+ { _hydrationState_previousNode :: !(Maybe Node)
270+ , _hydrationState_failed :: !Bool
271+ }
272+
273+{-# INLINABLE localRunner #-}
274+localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a
275+localRunner (HydrationRunnerT m) s parent = do
276+ s0 <- HydrationRunnerT get
277+ (a, s') <- HydrationRunnerT $ lift $ local (\_ -> parent) $ runStateT m (s0 { _hydrationState_previousNode = s })
278+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
279+ HydrationRunnerT $ modify' $ \hs -> hs { _hydrationState_failed = _hydrationState_failed s' }
280+ pure a
281+
282+{-# INLINABLE runHydrationRunnerT #-}
283+runHydrationRunnerT
284+ :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
285+ => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
286+runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
287+ (a, s') <- runStateT m (HydrationState s False)
288+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
289+ when (_hydrationState_failed s') $ liftIO $ putStrLn "reflex-dom warning: hydration failed: the DOM was not as expected at switchover time. This may be due to invalid HTML which the browser has altered upon parsing, some external JS altering the DOM, or the page being served from an outdated cache."
290+ pure a
291+
292+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
293+ {-# INLINABLE newEventWithTrigger #-}
294+ newEventWithTrigger = lift . newEventWithTrigger
295+ {-# INLINABLE newFanEventWithTrigger #-}
296+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
297+
298+instance MonadTrans (HydrationRunnerT t) where
299+ {-# INLINABLE lift #-}
300+ lift = HydrationRunnerT . lift . lift . lift
301+
302+instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where
303+ {-# INLINABLE sample #-}
304+ sample = lift . sample
305+
306+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where
307+ withRenderHook hook = HydrationRunnerT . mapStateT (mapReaderT (withRenderHook hook)) . unHydrationRunnerT
308+ requestDomAction = HydrationRunnerT . lift . lift . requestDomAction
309+ requestDomAction_ = HydrationRunnerT . lift . lift . requestDomAction_
310+
311+-- | Add a hydration step which depends on some computation that should only be
312+-- done *before* the switchover to immediate mode - this is most likely some
313+-- form of 'hold' which we want to remove after hydration is done
314+{-# INLINABLE addHydrationStepWithSetup #-}
315+addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()
316+addHydrationStepWithSetup setup f = getHydrationMode >>= \case
317+ HydrationMode_Immediate -> pure ()
318+ HydrationMode_Hydrating -> do
319+ switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
320+ (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
321+ addHydrationStep (f s)
322+
323+-- | Add a hydration step
324+{-# INLINABLE addHydrationStep #-}
325+addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT s t m ()
326+addHydrationStep m = do
327+ delayedRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_delayed
328+ liftIO $ modifyIORef' delayedRef (>> m)
329+
330+-- | Shared behavior for HydrationDomBuilderT and HydrationRunnerT
331+newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t JSM Identity (TriggerEventT t m) a }
332+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
333+#if MIN_VERSION_base(4,9,1)
334+ , MonadAsyncException
335+#endif
336+ )
337+
338+{-# INLINABLE runDomRenderHookT #-}
339+runDomRenderHookT
340+ :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)
341+ => DomRenderHookT t m a
342+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
343+ -> m a
344+runDomRenderHookT (DomRenderHookT a) events = do
345+ flip runTriggerEventT events $ do
346+ rec (result, req) <- runRequesterT a rsp
347+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
348+ traverseRequesterData (\r -> Identity <$> r) rm
349+ return result
350+ where
351+ runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
352+ v <- synchronously x
353+ void . liftIO $ f v
354+
355+instance MonadTrans (DomRenderHookT t) where
356+ {-# INLINABLE lift #-}
357+ lift = DomRenderHookT . lift . lift
358+
359+instance (Reflex t, MonadFix m) => DomRenderHook t (DomRenderHookT t m) where
360+ withRenderHook hook (DomRenderHookT a) = do
361+ DomRenderHookT $ withRequesting $ \rsp -> do
362+ (x, req) <- lift $ runRequesterT a $ runIdentity <$> rsp
201363 return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)
202− requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity
203− requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
364+ requestDomAction = DomRenderHookT . requestingIdentity
365+ requestDomAction_ = DomRenderHookT . requesting_
204366
205−{-# INLINABLE runImmediateDomBuilderT #-}
206−runImmediateDomBuilderT
367+{-# INLINABLE runHydrationDomBuilderT #-}
368+runHydrationDomBuilderT
207369 :: ( MonadFix m
208370 , PerformEvent t m
209371 , MonadReflexCreateTrigger t m
@@ -212,50 +374,76 @@ runImmediateDomBuilderT
212374 , MonadRef m
213375 , Ref m ~ IORef
214376 )
215− => ImmediateDomBuilderT t m a
216− -> ImmediateDomBuilderEnv t
377+ => HydrationDomBuilderT s t m a
378+ -> HydrationDomBuilderEnv t m
217379 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
218380 -> m a
219−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan =
220− flip runTriggerEventT eventChan $ do
221− rec (x, req) <- runRequesterT (runReaderT a env) rsp
222− rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
223− traverseRequesterData (\r -> Identity <$> r) rm
224− return x
225− where
226− runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
227− v <- synchronously x
228− void . liftIO $ f v
381+runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)
229382
230−instance Monad m => HasDocument (ImmediateDomBuilderT t m) where
383+instance (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, Monad m) => HasDocument (HydrationDomBuilderT s t m) where
231384 {-# INLINABLE askDocument #-}
232− askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document
385+ askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
233386
234387{-# INLINABLE askParent #-}
235−askParent :: Monad m => ImmediateDomBuilderT t m Node
236−askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent
388+askParent :: Monad m => HydrationRunnerT t m DOM.Node
389+askParent = HydrationRunnerT ask
390+
391+{-# INLINABLE getParent #-}
392+getParent :: MonadIO m => HydrationDomBuilderT s t m DOM.Node
393+getParent = either pure (liftIO . readIORef) =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
237394
238395{-# INLINABLE askEvents #-}
239−askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
240−askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents
396+askEvents :: Monad m => HydrationDomBuilderT s t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
397+askEvents = HydrationDomBuilderT . lift . DomRenderHookT . lift $ TriggerEventT.askEvents
241398
242−localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
243−localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT
399+{-# INLINABLE localEnv #-}
400+localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT s t m a -> HydrationDomBuilderT s t m a
401+localEnv f = HydrationDomBuilderT . local (f $!) . unHydrationDomBuilderT
244402
245403{-# INLINABLE append #-}
246−append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()
404+append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT s t m ()
247405append n = do
248− p <- askParent
406+ p <- getParent
249407 liftJSM $ appendChild_ p n
250408 return ()
251409
252−{-# INLINABLE textNodeInternal #-}
253−textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
254−textNodeInternal !t = do
255− doc <- askDocument
256− n <- liftJSM $ createTextNode doc t
257− append $ toNode n
258− return n
410+{-# SPECIALIZE append
411+ :: DOM.Node
412+ -> HydrationDomBuilderT s Spider HydrationM ()
413+ #-}
414+
415+data HydrationMode
416+ = HydrationMode_Hydrating
417+ -- ^ The time from initial load to parity with static builder
418+ | HydrationMode_Immediate
419+ -- ^ After hydration
420+ deriving (Eq, Ord, Show)
421+
422+{-# INLINABLE getPreviousNode #-}
423+getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)
424+getPreviousNode = HydrationRunnerT $ gets _hydrationState_previousNode
425+
426+{-# INLINABLE setPreviousNode #-}
427+setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
428+setPreviousNode n = HydrationRunnerT $ modify' (\hs -> hs { _hydrationState_previousNode = n })
429+
430+{-# INLINABLE askUnreadyChildren #-}
431+askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)
432+askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
433+
434+{-# INLINABLE askCommitAction #-}
435+askCommitAction :: Monad m => HydrationDomBuilderT s t m (JSM ())
436+askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction
437+
438+{-# INLINABLE getHydrationMode #-}
439+getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode
440+getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
441+
442+-- | Remove all nodes after given node
443+removeSubsequentNodes :: (MonadJSM m, IsNode n) => n -> m ()
444+removeSubsequentNodes n = liftJSM $ do
445+ f <- eval ("(function(n) { while (n.nextSibling) { (n.parentNode).removeChild(n.nextSibling); }; })" :: Text)
446+ void $ call f f [n]
259447
260448-- | s and e must both be children of the same node and s must precede e;
261449-- all nodes between s and e will be removed, but s and e will not be removed
@@ -293,7 +481,7 @@ extractUpTo df s e = liftJSM $ do
293481 void $ call f f (df, s, e)
294482#endif
295483
296−type SupportsImmediateDomBuilder 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)
484+type 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))
297485
298486{-# INLINABLE collectUpTo #-}
299487collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
@@ -311,10 +499,15 @@ collectUpToGivenParent currentParent s e = do
311499
312500newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
313501
314−{-# INLINABLE wrap #-}
315−wrap :: forall m er t. (Reflex t, MonadFix m, MonadJSM m, MonadReflexCreateTrigger t m) => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
316−wrap e cfg = do
317− events <- askEvents
502+-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself
503+{-# INLINE wrap #-}
504+wrap
505+ :: forall s m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m, EventSpec s ~ GhcjsEventSpec)
506+ => Chan [DSum (EventTriggerRef t) TriggerInvocation]
507+ -> DOM.Element
508+ -> RawElementConfig er t s
509+ -> m (DMap EventName (EventFilterTriggerRef t er))
510+wrap events e cfg = do
318511 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
319512 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
320513 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
@@ -331,46 +524,74 @@ wrap e cfg = do
331524 mv <- liftJSM k --TODO: Only do this when the event is subscribed
332525 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
333526 return $ en :=> EventFilterTriggerRef triggerRef
334− es <- do
335− let h :: GhcjsEventHandler er
336− !h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
337− ctx <- askJSM
338− newFanEventWithTrigger $ \(WrapArg en) t ->
339− case DMap.lookup en eventTriggerRefs of
340− Just (EventFilterTriggerRef r) -> do
341− writeIORef r $ Just t
342− return $ do
343− writeIORef r Nothing
344− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
345− evt <- DOM.event
346− mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)
347− case mv of
348− Nothing -> return ()
349− Just v -> liftIO $ do
350− --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
351− ref <- newIORef $ Just t
352− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
353− return $ Element
354− { _element_events = es
355− , _element_raw = e
356− }
357−
358−{-# INLINABLE makeElement #-}
359−makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
360−makeElement elementTag cfg child = do
361− doc <- askDocument
362− e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
363− Nothing -> createElement doc elementTag
364− Just ens -> createElementNS doc (Just ens) elementTag
365− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
366− Nothing -> lift $ setAttribute e n v
367− Just ans -> lift $ setAttributeNS e (Just ans) n v
368− result <- flip localEnv child $ \env -> env
369− { _immediateDomBuilderEnv_parent = toNode e
370− }
371− append $ toNode e
372− wrapped <- wrap e $ extractRawElementConfig cfg
373− return ((wrapped, result), e)
527+ return eventTriggerRefs
528+
529+{-# SPECIALIZE wrap
530+ :: Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
531+ -> DOM.Element
532+ -> RawElementConfig er Spider HydrationDomSpace
533+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (DMap EventName (EventFilterTriggerRef Spider er))
534+ #-}
535+
536+{-# SPECIALIZE wrap
537+ :: Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
538+ -> DOM.Element
539+ -> RawElementConfig er Spider GhcjsDomSpace
540+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (DMap EventName (EventFilterTriggerRef Spider er))
541+ #-}
542+
543+{-# INLINE triggerBody #-}
544+triggerBody
545+ :: forall s er t x. EventSpec s ~ GhcjsEventSpec
546+ => DOM.JSContextRef
547+ -> RawElementConfig er t s
548+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
549+ -> DMap EventName (EventFilterTriggerRef t er)
550+ -> DOM.Element
551+ -> WrapArg er EventName x
552+ -> EventTrigger t x
553+ -> IO (IO ())
554+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
555+ Just (EventFilterTriggerRef r) -> do
556+ writeIORef r $ Just t
557+ return $ do
558+ writeIORef r Nothing
559+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
560+ evt <- DOM.event
561+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
562+ case mv of
563+ Nothing -> return ()
564+ Just v -> liftIO $ do
565+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
566+ ref <- newIORef $ Just t
567+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
568+ where
569+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
570+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
571+ handler :: GhcjsEventHandler er
572+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
573+
574+{-# SPECIALIZE triggerBody
575+ :: DOM.JSContextRef
576+ -> RawElementConfig er Spider HydrationDomSpace
577+ -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
578+ -> DMap EventName (EventFilterTriggerRef Spider er)
579+ -> DOM.Element
580+ -> WrapArg er EventName x
581+ -> EventTrigger Spider x
582+ -> IO (IO ())
583+ #-}
584+
585+{-# SPECIALIZE triggerBody
586+ :: DOM.JSContextRef
587+ -> RawElementConfig er Spider GhcjsDomSpace
588+ -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]
589+ -> DMap EventName (EventFilterTriggerRef Spider er)
590+ -> DOM.Element
591+ -> WrapArg er EventName x
592+ -> EventTrigger Spider x
593+ -> IO (IO ())
594+ #-}
374595
375596newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
376597
@@ -384,8 +605,8 @@ instance DomSpace GhcjsDomSpace where
384605 type EventSpec GhcjsDomSpace = GhcjsEventSpec
385606 type RawDocument GhcjsDomSpace = DOM.Document
386607 type RawTextNode GhcjsDomSpace = DOM.Text
608+ type RawCommentNode GhcjsDomSpace = DOM.Comment
387609 type RawElement GhcjsDomSpace = DOM.Element
388− type RawFile GhcjsDomSpace = DOM.File
389610 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement
390611 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement
391612 type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement
@@ -438,137 +659,746 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
438659 runReaderT (defaultDomEventHandler e en) evt
439660 }
440661
441−instance SupportsImmediateDomBuilder t m => NotReady t (ImmediateDomBuilderT t m) where
662+{-# INLINE makeElement #-}
663+makeElement :: MonadJSM m => Document -> Text -> ElementConfig er t s -> m DOM.Element
664+makeElement doc elementTag cfg = do
665+ e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
666+ Nothing -> createElement doc elementTag
667+ Just ens -> createElementNS doc (Just ens) elementTag
668+ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
669+ Nothing -> setAttribute e n v
670+ Just ans -> setAttributeNS e (Just ans) n v
671+ pure e
672+
673+{-# INLINE elementImmediate #-}
674+elementImmediate
675+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
676+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m )
677+ => Text
678+ -> ElementConfig er t s
679+ -> HydrationDomBuilderT s t m a
680+ -> HydrationDomBuilderT s t m (Element er GhcjsDomSpace t, a)
681+elementImmediate elementTag cfg child = do
682+ doc <- askDocument
683+ ctx <- askJSM
684+ events <- askEvents
685+ parent <- getParent
686+ e <- makeElement doc elementTag cfg
687+ appendChild_ parent e
688+ -- Run the child builder with updated parent and previous sibling references
689+ result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child
690+ let rawCfg = extractRawElementConfig cfg
691+ eventTriggerRefs <- wrap events e rawCfg
692+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
693+ return (Element es e, result)
694+
695+{-# SPECIALIZE elementImmediate
696+ :: Text
697+ -> ElementConfig er Spider HydrationDomSpace
698+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM a
699+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (Element er GhcjsDomSpace Spider, a)
700+ #-}
701+
702+{-# SPECIALIZE elementImmediate
703+ :: Text
704+ -> ElementConfig er Spider GhcjsDomSpace
705+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM a
706+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (Element er GhcjsDomSpace Spider, a)
707+ #-}
708+
709+-- For specialisation
710+
711+-- | The Reflex timeline for interacting with the DOM
712+type DomTimeline =
713+#ifdef PROFILE_REFLEX
714+ ProfiledTimeline
715+#endif
716+ Spider
717+
718+-- | The ReflexHost the DOM lives in
719+type DomHost =
720+#ifdef PROFILE_REFLEX
721+ ProfiledM
722+#endif
723+ (SpiderHost Global)
724+
725+type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))
726+type HydrationM = DomCoreWidget ()
727+
728+{-# INLINE elementInternal #-}
729+elementInternal
730+ :: (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
731+ => Text
732+ -> ElementConfig er t HydrationDomSpace
733+ -> HydrationDomBuilderT HydrationDomSpace t m a
734+ -> HydrationDomBuilderT HydrationDomSpace t m (Element er HydrationDomSpace t, a)
735+elementInternal elementTag cfg child = getHydrationMode >>= \case
736+ HydrationMode_Immediate -> do
737+ (Element es _, result) <- elementImmediate elementTag cfg child
738+ return (Element es (), result)
739+ HydrationMode_Hydrating -> fst <$> hydrateElement elementTag cfg child
740+
741+{-# SPECIALIZE elementInternal
742+ :: Text
743+ -> ElementConfig er Spider HydrationDomSpace
744+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM a
745+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (Element er HydrationDomSpace Spider, a)
746+ #-}
747+
748+{-# INLINE hydrateElement #-}
749+hydrateElement
750+ :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
751+ => Text
752+ -> ElementConfig er t HydrationDomSpace
753+ -> HydrationDomBuilderT HydrationDomSpace t m a
754+ -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)
755+hydrateElement elementTag cfg child = do
756+ ctx <- askJSM
757+ events <- askEvents
758+ -- Schedule everything for after postBuild, except for getting the result itself
759+ parentRef <- liftIO $ newIORef $ error "Parent not yet initialized"
760+ e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"
761+ env <- HydrationDomBuilderT ask
762+ childDelayedRef <- liftIO $ newIORef $ pure ()
763+ let env' = env
764+ { _hydrationDomBuilderEnv_parent = Right parentRef
765+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
766+ }
767+ result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
768+ wrapResult <- liftIO newEmptyMVar
769+ let ssrAttr = "data-ssr" :: DOM.JSString
770+ hasSSRAttribute :: DOM.Element -> HydrationRunnerT t m Bool
771+ hasSSRAttribute e = case cfg ^. namespace of
772+ Nothing -> hasAttribute e ssrAttr <* removeAttribute e ssrAttr
773+ Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr
774+ childDom <- liftIO $ readIORef childDelayedRef
775+ let rawCfg = extractRawElementConfig cfg
776+ doc <- askDocument
777+ addHydrationStep $ do
778+ parent <- askParent
779+ lastHydrationNode <- getPreviousNode
780+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
781+ Nothing -> do -- ran out of nodes, create the element
782+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
783+ e <- makeElement doc elementTag cfg
784+ insertAfterPreviousNode e
785+ pure e
786+ Just node -> DOM.castTo DOM.Element node >>= \case
787+ Nothing -> go (Just node) -- this node is not an element, skip
788+ Just e -> hasSSRAttribute e >>= \case
789+ False -> go (Just node) -- this element was not added by the static renderer, skip
790+ True -> do
791+ t <- Element.getTagName e
792+ -- TODO: check attributes?
793+ if T.toCaseFold elementTag == T.toCaseFold t
794+ then pure e
795+ -- we came to some other statically rendered element, so something has gone wrong
796+ else do
797+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
798+ n <- makeElement doc elementTag cfg
799+ insertAfterPreviousNode n
800+ pure n
801+ e <- go lastHydrationNode
802+ setPreviousNode $ Just $ toNode e
803+ -- Update the parent node used by the children
804+ liftIO $ writeIORef parentRef $ toNode e
805+ liftIO $ writeIORef e' e
806+ -- Setup events, store the result so we can wait on it later
807+ refs <- wrap events e rawCfg
808+ liftIO $ putMVar wrapResult (e, refs)
809+ localRunner childDom Nothing $ toNode e
810+ -- We need the EventSelector to switch to the real event handler after activation
811+ es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
812+ cleanup <- newEmptyMVar
813+ threadId <- forkIO $ do
814+ -- Wait on the data we need from the delayed action
815+ (e, eventTriggerRefs) <- readMVar wrapResult
816+ bracketOnError
817+ -- Run the setup, acquiring the cleanup action
818+ (triggerBody ctx rawCfg events eventTriggerRefs e (WrapArg en) t)
819+ -- Run the cleanup, if we have it - but only when an exception is
820+ -- raised (we might get killed between acquiring the cleanup action
821+ -- from 'triggerBody' and putting it in the MVar)
822+ id
823+ -- Try to put this action into the cleanup MVar
824+ (putMVar cleanup)
825+ pure $ do
826+ tryReadMVar cleanup >>= \case
827+ Nothing -> killThread threadId
828+ Just c -> c
829+ return ((Element es (), result), e')
830+
831+{-# SPECIALIZE hydrateElement
832+ :: Text
833+ -> ElementConfig er Spider HydrationDomSpace
834+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM a
835+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM ((Element er HydrationDomSpace Spider, a), IORef DOM.Element)
836+ #-}
837+
838+{-# INLINE inputElementImmediate #-}
839+inputElementImmediate
840+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
841+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
842+ , MonadRef m, Ref m ~ IORef )
843+ => InputElementConfig er t s -> HydrationDomBuilderT s t m (InputElement er GhcjsDomSpace t)
844+inputElementImmediate cfg = do
845+ (e@(Element eventSelector domElement), ()) <- elementImmediate "input" (_inputElementConfig_elementConfig cfg) $ return ()
846+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
847+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
848+ v0 <- Input.getValue domInputElement
849+ let getMyValue = Input.getValue domInputElement
850+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
851+ valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
852+ Nothing -> return never
853+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
854+ Input.setValue domInputElement v'
855+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
856+ v <- holdDyn v0 $ leftmost
857+ [ valueChangedBySetValue
858+ , valueChangedByUI
859+ ]
860+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
861+ checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
862+ Input.getChecked domInputElement
863+ checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
864+ Nothing -> return never
865+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
866+ oldChecked <- Input.getChecked domInputElement
867+ Input.setChecked domInputElement newChecked
868+ return $ if newChecked /= oldChecked
869+ then Just newChecked
870+ else Nothing
871+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
872+ [ fmapMaybe id checkedChangedBySetChecked
873+ , checkedChangedByUI
874+ ]
875+ hasFocus <- mkHasFocus e
876+ files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
877+ mfiles <- Input.getFiles domInputElement
878+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
879+ maybe (return []) getMyFiles mfiles
880+ checked <- holdUniqDyn c
881+ return $ InputElement
882+ { _inputElement_value = v
883+ , _inputElement_checked = checked
884+ , _inputElement_checkedChange = checkedChangedByUI
885+ , _inputElement_input = valueChangedByUI
886+ , _inputElement_hasFocus = hasFocus
887+ , _inputElement_element = e
888+ , _inputElement_raw = domInputElement
889+ , _inputElement_files = files
890+ }
891+
892+{-# INLINE inputElementInternal #-}
893+inputElementInternal
894+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
895+ , MonadRef m, Ref m ~ IORef )
896+ => InputElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (InputElement er HydrationDomSpace t)
897+inputElementInternal cfg = getHydrationMode >>= \case
898+ HydrationMode_Immediate -> ffor (inputElementImmediate cfg) $ \result -> result
899+ { _inputElement_element = Element (_element_events $ _inputElement_element result) ()
900+ , _inputElement_raw = ()
901+ }
902+ HydrationMode_Hydrating -> do
903+ ((e, _), domElementRef) <- hydrateElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
904+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
905+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
906+ (focusChange, triggerFocusChange) <- newTriggerEvent
907+ (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent
908+ (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent
909+ (fileChange, triggerFileChange) <- newTriggerEvent
910+ doc <- askDocument
911+ -- Expected initial value from config
912+ let v0 = _inputElementConfig_initialValue cfg
913+ addHydrationStep $ do
914+ domElement <- liftIO $ readIORef domElementRef
915+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
916+ getValue = Input.getValue domInputElement
917+ -- The browser might have messed with the value, or the user could have
918+ -- altered it before activation, so we set it if it isn't what we expect
919+ liftJSM getValue >>= \v0' -> do
920+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
921+ -- Watch for user interaction and trigger event accordingly
922+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
923+ for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
924+ requestDomAction_ $ ffor eSetValue $ \v' -> do
925+ Input.setValue domInputElement v'
926+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
927+ liftIO $ triggerChangeBySetValue v
928+ let focusChange' = leftmost
929+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
930+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
931+ ]
932+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
933+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
934+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
935+ _ <- liftJSM $ domInputElement `on` Events.click $ do
936+ liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
937+ for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
938+ requestDomAction $ ffor eNewchecked $ \newChecked -> do
939+ oldChecked <- Input.getChecked domInputElement
940+ Input.setChecked domInputElement newChecked
941+ when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked
942+ _ <- liftJSM $ domInputElement `on` Events.change $ do
943+ mfiles <- Input.getFiles domInputElement
944+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
945+ liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
946+ return ()
947+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
948+ [ checkedChangedBySetChecked
949+ , checkedChangedByUI
950+ ]
951+ checked <- holdUniqDyn checked'
952+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
953+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
954+ v <- holdDyn v0 $ leftmost
955+ [ valueChangedBySetValue
956+ , valueChangedByUI
957+ ]
958+ files <- holdDyn mempty fileChange
959+ return $ InputElement
960+ { _inputElement_value = v
961+ , _inputElement_checked = checked
962+ , _inputElement_checkedChange = checkedChangedByUI
963+ , _inputElement_input = valueChangedByUI
964+ , _inputElement_hasFocus = hasFocus
965+ , _inputElement_element = e
966+ , _inputElement_raw = ()
967+ , _inputElement_files = files
968+ }
969+
970+{-# INLINE textAreaElementImmediate #-}
971+textAreaElementImmediate
972+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
973+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
974+ , MonadRef m, Ref m ~ IORef )
975+ => TextAreaElementConfig er t s -> HydrationDomBuilderT s t m (TextAreaElement er GhcjsDomSpace t)
976+textAreaElementImmediate cfg = do
977+ (e@(Element eventSelector domElement), _) <- elementImmediate "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
978+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
979+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
980+ v0 <- TextArea.getValue domTextAreaElement
981+ let getMyValue = TextArea.getValue domTextAreaElement
982+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
983+ valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
984+ Nothing -> return never
985+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
986+ TextArea.setValue domTextAreaElement v'
987+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
988+ v <- holdDyn v0 $ leftmost
989+ [ valueChangedBySetValue
990+ , valueChangedByUI
991+ ]
992+ hasFocus <- mkHasFocus e
993+ return $ TextAreaElement
994+ { _textAreaElement_value = v
995+ , _textAreaElement_input = valueChangedByUI
996+ , _textAreaElement_hasFocus = hasFocus
997+ , _textAreaElement_element = e
998+ , _textAreaElement_raw = domTextAreaElement
999+ }
1000+
1001+{-# INLINE textAreaElementInternal #-}
1002+textAreaElementInternal
1003+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1004+ , MonadRef m, Ref m ~ IORef )
1005+ => TextAreaElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (TextAreaElement er HydrationDomSpace t)
1006+textAreaElementInternal cfg = getHydrationMode >>= \case
1007+ HydrationMode_Immediate -> ffor (textAreaElementImmediate cfg) $ \result -> result
1008+ { _textAreaElement_element = Element (_element_events $ _textAreaElement_element result) ()
1009+ , _textAreaElement_raw = ()
1010+ }
1011+ HydrationMode_Hydrating -> do
1012+ ((e, _), domElementRef) <- hydrateElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
1013+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1014+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1015+ (focusChange, triggerFocusChange) <- newTriggerEvent
1016+ doc <- askDocument
1017+ -- Expected initial value from config
1018+ let v0 = _textAreaElementConfig_initialValue cfg
1019+ addHydrationStep $ do
1020+ domElement <- liftIO $ readIORef domElementRef
1021+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
1022+ getValue = TextArea.getValue domTextAreaElement
1023+ -- The browser might have messed with the value, or the user could have
1024+ -- altered it before activation, so we set it if it isn't what we expect
1025+ liftJSM getValue >>= \v0' -> do
1026+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1027+ -- Watch for user interaction and trigger event accordingly
1028+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
1029+ for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
1030+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1031+ TextArea.setValue domTextAreaElement v'
1032+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1033+ liftIO $ triggerChangeBySetValue v
1034+ let focusChange' = leftmost
1035+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1036+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1037+ ]
1038+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1039+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1040+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1041+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1042+ v <- holdDyn v0 $ leftmost
1043+ [ valueChangedBySetValue
1044+ , valueChangedByUI
1045+ ]
1046+ return $ TextAreaElement
1047+ { _textAreaElement_value = v
1048+ , _textAreaElement_input = valueChangedByUI
1049+ , _textAreaElement_hasFocus = hasFocus
1050+ , _textAreaElement_element = e
1051+ , _textAreaElement_raw = ()
1052+ }
1053+
1054+{-# INLINE selectElementImmediate #-}
1055+selectElementImmediate
1056+ :: ( EventSpec s ~ GhcjsEventSpec, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
1057+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m )
1058+ => SelectElementConfig er t s
1059+ -> HydrationDomBuilderT s t m a
1060+ -> HydrationDomBuilderT s t m (SelectElement er GhcjsDomSpace t, a)
1061+selectElementImmediate cfg child = do
1062+ (e@(Element eventSelector domElement), result) <- elementImmediate "select" (cfg ^. selectElementConfig_elementConfig) child
1063+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1064+ Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
1065+ v0 <- Select.getValue domSelectElement
1066+ let getMyValue = Select.getValue domSelectElement
1067+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Change)
1068+ valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
1069+ Nothing -> return never
1070+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
1071+ Select.setValue domSelectElement v'
1072+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
1073+ v <- holdDyn v0 $ leftmost
1074+ [ valueChangedBySetValue
1075+ , valueChangedByUI
1076+ ]
1077+ hasFocus <- mkHasFocus e
1078+ let wrapped = SelectElement
1079+ { _selectElement_value = v
1080+ , _selectElement_change = valueChangedByUI
1081+ , _selectElement_hasFocus = hasFocus
1082+ , _selectElement_element = e
1083+ , _selectElement_raw = domSelectElement
1084+ }
1085+ return (wrapped, result)
1086+
1087+{-# INLINE selectElementInternal #-}
1088+selectElementInternal
1089+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1090+ , MonadRef m, Ref m ~ IORef )
1091+ => SelectElementConfig er t HydrationDomSpace
1092+ -> HydrationDomBuilderT HydrationDomSpace t m a
1093+ -> HydrationDomBuilderT HydrationDomSpace t m (SelectElement er HydrationDomSpace t, a)
1094+selectElementInternal cfg child = getHydrationMode >>= \case
1095+ HydrationMode_Immediate -> ffor (selectElementImmediate cfg child) $ \(e, result) -> (e
1096+ { _selectElement_element = Element (_element_events $ _selectElement_element e) ()
1097+ , _selectElement_raw = ()
1098+ }, result)
1099+ HydrationMode_Hydrating -> do
1100+ ((e, result), domElementRef) <- hydrateElement "select" (cfg ^. selectElementConfig_elementConfig) child
1101+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1102+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1103+ (focusChange, triggerFocusChange) <- newTriggerEvent
1104+ doc <- askDocument
1105+ -- Expected initial value from config
1106+ let v0 = _selectElementConfig_initialValue cfg
1107+ addHydrationStep $ do
1108+ domElement <- liftIO $ readIORef domElementRef
1109+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1110+ getValue = Select.getValue domSelectElement
1111+ -- The browser might have messed with the value, or the user could have
1112+ -- altered it before activation, so we set it if it isn't what we expect
1113+ liftJSM getValue >>= \v0' -> do
1114+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1115+ -- Watch for user interaction and trigger event accordingly
1116+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)
1117+ for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->
1118+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1119+ Select.setValue domSelectElement v'
1120+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1121+ liftIO $ triggerChangeBySetValue v
1122+ let focusChange' = leftmost
1123+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1124+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1125+ ]
1126+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1127+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1128+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1129+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1130+ v <- holdDyn v0 $ leftmost
1131+ [ valueChangedBySetValue
1132+ , valueChangedByUI
1133+ ]
1134+ return $ (,result) $ SelectElement
1135+ { _selectElement_value = v
1136+ , _selectElement_change = valueChangedByUI
1137+ , _selectElement_hasFocus = hasFocus
1138+ , _selectElement_element = e
1139+ , _selectElement_raw = ()
1140+ }
1141+
1142+{-# INLINE textNodeImmediate #-}
1143+textNodeImmediate
1144+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1145+ => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text
1146+textNodeImmediate (TextNodeConfig !t mSetContents) = do
1147+ p <- getParent
1148+ doc <- askDocument
1149+ n <- createTextNode doc t
1150+ appendChild_ p n
1151+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1152+ pure n
1153+
1154+{-# SPECIALIZE textNodeImmediate
1155+ :: TextNodeConfig DomTimeline
1156+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM DOM.Text
1157+ #-}
1158+
1159+{-# SPECIALIZE textNodeImmediate
1160+ :: TextNodeConfig DomTimeline
1161+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM DOM.Text
1162+ #-}
1163+
1164+{-# INLINE textNodeInternal #-}
1165+textNodeInternal
1166+ :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)
1167+ => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)
1168+textNodeInternal tc@(TextNodeConfig !t mSetContents) = do
1169+ doc <- askDocument
1170+ getHydrationMode >>= \case
1171+ HydrationMode_Immediate -> void $ textNodeImmediate tc
1172+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do
1173+ n <- hydrateTextNode doc =<< sample currentText
1174+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1175+ pure $ TextNode ()
1176+
1177+{-# SPECIALIZE textNodeInternal
1178+ :: TextNodeConfig DomTimeline
1179+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (TextNode HydrationDomSpace DomTimeline)
1180+ #-}
1181+
1182+-- | The static builder mashes adjacent text nodes into one node: we check the
1183+-- text content of each node we come to, comparing it to the content we
1184+-- expect. We also have a special case for empty text nodes - we always create
1185+-- the and add them after the previous node reference.
1186+{-# INLINE hydrateTextNode #-}
1187+hydrateTextNode :: MonadJSM m => Document -> Text -> HydrationRunnerT t m DOM.Text
1188+hydrateTextNode doc t@"" = do
1189+ tn <- createTextNode doc t
1190+ insertAfterPreviousNode tn
1191+ pure tn
1192+hydrateTextNode doc t = do
1193+ n <- join $ go <$> askParent <*> getPreviousNode
1194+ setPreviousNode $ Just $ toNode n
1195+ return n
1196+ where
1197+ go parent mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1198+ Nothing -> do
1199+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1200+ n <- createTextNode doc t
1201+ insertAfterPreviousNode n
1202+ pure n
1203+ Just node -> DOM.castTo DOM.Text node >>= \case
1204+ Nothing -> go parent $ Just node
1205+ Just originalNode -> do
1206+ originalText <- Node.getTextContentUnchecked originalNode
1207+ case T.stripPrefix t originalText of
1208+ Just "" -> return originalNode
1209+ Just _ -> do
1210+ -- If we have the right prefix, we split the text node into a node containing the
1211+ -- required text and a subsequent sibling node containing the rest of the text.
1212+ DOM.splitText_ originalNode $ fromIntegral $ T.length t
1213+ return originalNode
1214+ Nothing -> do
1215+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1216+ n <- createTextNode doc t
1217+ insertAfterPreviousNode n
1218+ pure n
1219+
1220+{-# INLINE commentNodeImmediate #-}
1221+commentNodeImmediate
1222+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1223+ => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment
1224+commentNodeImmediate (CommentNodeConfig !t mSetContents) = do
1225+ p <- getParent
1226+ doc <- askDocument
1227+ n <- createComment doc t
1228+ appendChild_ p n
1229+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1230+ pure n
1231+
1232+{-# INLINE commentNodeInternal #-}
1233+commentNodeInternal
1234+ :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Reflex t, Adjustable t m, MonadHold t m, MonadSample t m)
1235+ => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)
1236+commentNodeInternal tc@(CommentNodeConfig t0 mSetContents) = do
1237+ doc <- askDocument
1238+ getHydrationMode >>= \case
1239+ HydrationMode_Immediate -> void $ commentNodeInternal tc
1240+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do
1241+ t <- sample bt
1242+ void $ hydrateComment doc t mSetContents
1243+ pure $ CommentNode ()
1244+
1245+{-# INLINE hydrateComment #-}
1246+hydrateComment :: (MonadJSM m, Reflex t, MonadFix m) => Document -> Text -> Maybe (Event t Text) -> HydrationRunnerT t m DOM.Comment
1247+hydrateComment doc t mSetContents = do
1248+ parent <- askParent
1249+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1250+ Nothing -> do
1251+ c <- createComment doc t
1252+ insertAfterPreviousNode c
1253+ pure c
1254+ Just node -> DOM.castTo DOM.Comment node >>= \case
1255+ Nothing -> go (Just node)
1256+ Just c -> do
1257+ t' <- Node.getTextContentUnchecked c
1258+ if t == t'
1259+ then pure c
1260+ else do
1261+ c' <- createComment doc t
1262+ insertAfterPreviousNode c'
1263+ pure c'
1264+ n <- go =<< getPreviousNode
1265+ setPreviousNode $ Just $ toNode n
1266+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1267+ pure n
1268+
1269+-- | We leave markers in the static builder as comments, and rip these comments
1270+-- out at hydration time, replacing them with empty text nodes.
1271+{-# INLINABLE skipToAndReplaceComment #-}
1272+skipToAndReplaceComment
1273+ :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1274+ => Text
1275+ -> IORef Text
1276+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1277+skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
1278+ HydrationMode_Immediate -> do
1279+ -- If we're in immediate mode, we don't try to replace an existing comment,
1280+ -- and just return a dummy key
1281+ t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
1282+ append $ toNode t
1283+ textNodeRef <- liftIO $ newIORef t
1284+ keyRef <- liftIO $ newIORef ""
1285+ pure (pure (), textNodeRef, keyRef)
1286+ HydrationMode_Hydrating -> do
1287+ doc <- askDocument
1288+ textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
1289+ keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1290+ let go key0 mLastNode = do
1291+ parent <- askParent
1292+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1293+ DOM.castTo DOM.Comment node >>= \case
1294+ Just comment -> do
1295+ commentText <- Node.getTextContentUnchecked comment
1296+ case T.stripPrefix (prefix <> key0) commentText of
1297+ Just key -> do
1298+ -- Replace the comment with an (invisible) text node
1299+ tn <- createTextNode doc ("" :: Text)
1300+ Node.replaceChild_ parent tn comment
1301+ pure (tn, key)
1302+ Nothing -> do
1303+ go key0 (Just node)
1304+ Nothing -> do
1305+ go key0 (Just node)
1306+ switchComment = do
1307+ key0 <- liftIO $ readIORef key0Ref
1308+ (tn, key) <- go key0 =<< getPreviousNode
1309+ setPreviousNode $ Just $ toNode tn
1310+ liftIO $ do
1311+ writeIORef textNodeRef tn
1312+ writeIORef keyRef key
1313+ pure (switchComment, textNodeRef, keyRef)
1314+
1315+{-# INLINABLE skipToReplaceStart #-}
1316+skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1317+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
1318+
1319+{-# INLINABLE skipToReplaceEnd #-}
1320+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)
1321+skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
1322+
1323+instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
4421324 notReadyUntil e = do
4431325 eOnce <- headE e
444− env <- ImmediateDomBuilderT ask
445− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1326+ unreadyChildren <- askUnreadyChildren
1327+ commitAction <- askCommitAction
4461328 liftIO $ modifyIORef' unreadyChildren succ
4471329 let ready = do
4481330 old <- liftIO $ readIORef unreadyChildren
4491331 let new = pred old
4501332 liftIO $ writeIORef unreadyChildren $! new
451− when (new == 0) $ _immediateDomBuilderEnv_commitAction env
1333+ when (new == 0) commitAction
4521334 requestDomAction_ $ ready <$ eOnce
4531335 notReady = do
454− env <- ImmediateDomBuilderT ask
455− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1336+ unreadyChildren <- askUnreadyChildren
4561337 liftIO $ modifyIORef' unreadyChildren succ
4571338
458−instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
459− type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace
1339+data HydrationDomSpace
1340+
1341+instance DomSpace HydrationDomSpace where
1342+ type EventSpec HydrationDomSpace = GhcjsEventSpec
1343+ type RawDocument HydrationDomSpace = DOM.Document
1344+ type RawTextNode HydrationDomSpace = ()
1345+ type RawCommentNode HydrationDomSpace = ()
1346+ type RawElement HydrationDomSpace = ()
1347+ type RawInputElement HydrationDomSpace = ()
1348+ type RawTextAreaElement HydrationDomSpace = ()
1349+ type RawSelectElement HydrationDomSpace = ()
1350+ addEventSpecFlags _ en f es = es
1351+ { _ghcjsEventSpec_filters =
1352+ let f' = Just . GhcjsEventFilter . \case
1353+ Nothing -> \evt -> do
1354+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)
1355+ return (f mEventResult, return mEventResult)
1356+ Just (GhcjsEventFilter oldFilter) -> \evt -> do
1357+ (oldFlags, oldContinuation) <- oldFilter evt
1358+ mEventResult <- oldContinuation
1359+ let newFlags = oldFlags <> f mEventResult
1360+ return (newFlags, return mEventResult)
1361+ in DMap.alter f' en $ _ghcjsEventSpec_filters es
1362+ }
1363+
1364+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT HydrationDomSpace t m) where
1365+ type DomBuilderSpace (HydrationDomBuilderT HydrationDomSpace t m) = HydrationDomSpace
1366+ {-# INLINABLE element #-}
1367+ element = elementInternal
4601368 {-# INLINABLE textNode #-}
461− textNode (TextNodeConfig initialContents mSetContents) = do
462− n <- textNodeInternal initialContents
463− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
464− return $ TextNode n
1369+ textNode = textNodeInternal
1370+ {-# INLINABLE commentNode #-}
1371+ commentNode = commentNodeInternal
1372+ {-# INLINABLE inputElement #-}
1373+ inputElement = inputElementInternal
1374+ {-# INLINABLE textAreaElement #-}
1375+ textAreaElement = textAreaElementInternal
1376+ {-# INLINABLE selectElement #-}
1377+ selectElement = selectElementInternal
1378+ placeRawElement () = pure ()
1379+ wrapRawElement () _cfg = pure $ Element (EventSelector $ const never) ()
1380+
1381+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1382+ type DomBuilderSpace (HydrationDomBuilderT GhcjsDomSpace t m) = GhcjsDomSpace
4651383 {-# INLINABLE element #-}
466− element elementTag cfg child = fst <$> makeElement elementTag cfg child
1384+ element = elementImmediate
1385+ {-# INLINABLE textNode #-}
1386+ textNode = fmap TextNode . textNodeImmediate
1387+ {-# INLINABLE commentNode #-}
1388+ commentNode = fmap CommentNode . commentNodeImmediate
4671389 {-# INLINABLE inputElement #-}
468− inputElement cfg = do
469− ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
470− let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
471− Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
472− v0 <- Input.getValue domInputElement
473− let getMyValue = Input.getValue domInputElement
474− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
475− valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
476− Nothing -> return never
477− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
478− Input.setValue domInputElement v'
479− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
480− v <- holdDyn v0 $ leftmost
481− [ valueChangedBySetValue
482− , valueChangedByUI
483− ]
484− Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
485− checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
486− Input.getChecked domInputElement
487− checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
488− Nothing -> return never
489− Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
490− oldChecked <- Input.getChecked domInputElement
491− Input.setChecked domInputElement newChecked
492− return $ if newChecked /= oldChecked
493− then Just newChecked
494− else Nothing
495− c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
496− [ fmapMaybe id checkedChangedBySetChecked
497− , checkedChangedByUI
498− ]
499− let initialFocus = False --TODO: Is this correct?
500− hasFocus <- holdDyn initialFocus $ leftmost
501− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
502− , True <$ Reflex.select (_element_events e) (WrapArg Focus)
503− ]
504− files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
505− mfiles <- Input.getFiles domInputElement
506− let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
507− maybe (return []) getMyFiles mfiles
508− checked <- holdUniqDyn c
509− return $ InputElement
510− { _inputElement_value = v
511− , _inputElement_checked = checked
512− , _inputElement_checkedChange = checkedChangedByUI
513− , _inputElement_input = valueChangedByUI
514− , _inputElement_hasFocus = hasFocus
515− , _inputElement_element = e
516− , _inputElement_raw = domInputElement
517− , _inputElement_files = files
518− }
1390+ inputElement = inputElementImmediate
5191391 {-# INLINABLE textAreaElement #-}
520− textAreaElement cfg = do --TODO
521− ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
522− let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
523− TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
524− v0 <- TextArea.getValue domTextAreaElement
525− let getMyValue = TextArea.getValue domTextAreaElement
526− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
527− valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
528− Nothing -> return never
529− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
530− TextArea.setValue domTextAreaElement v'
531− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
532− v <- holdDyn v0 $ leftmost
533− [ valueChangedBySetValue
534− , valueChangedByUI
535− ]
536− hasFocus <- mkHasFocus e
537− return $ TextAreaElement
538− { _textAreaElement_value = v
539− , _textAreaElement_input = valueChangedByUI
540− , _textAreaElement_hasFocus = hasFocus
541− , _textAreaElement_element = e
542− , _textAreaElement_raw = domTextAreaElement
543− }
1392+ textAreaElement = textAreaElementImmediate
5441393 {-# INLINABLE selectElement #-}
545− selectElement cfg child = do
546− ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
547− let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
548− Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
549− v0 <- Select.getValue domSelectElement
550− let getMyValue = Select.getValue domSelectElement
551− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
552− valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
553− Nothing -> return never
554− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
555− Select.setValue domSelectElement v'
556− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
557− v <- holdDyn v0 $ leftmost
558− [ valueChangedBySetValue
559− , valueChangedByUI
560− ]
561− hasFocus <- mkHasFocus e
562− let wrapped = SelectElement
563− { _selectElement_value = v
564− , _selectElement_change = valueChangedByUI
565− , _selectElement_hasFocus = hasFocus
566− , _selectElement_element = e
567− , _selectElement_raw = domSelectElement
568− }
569− return (wrapped, result)
1394+ selectElement = selectElementImmediate
5701395 placeRawElement = append . toNode
571− wrapRawElement = wrap
1396+ wrapRawElement e rawCfg = do
1397+ events <- askEvents
1398+ ctx <- askJSM
1399+ eventTriggerRefs <- wrap events e rawCfg
1400+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
1401+ pure $ Element es e
5721402
5731403data FragmentState
5741404 = FragmentState_Unmounted
@@ -588,21 +1418,21 @@ extractFragment fragment = do
5881418 extractBetweenExclusive (_immediateDomFragment_document fragment) before after
5891419 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
5901420
591−instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
592− type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
1421+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1422+ type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment
5931423 buildDomFragment w = do
5941424 df <- createDocumentFragment =<< askDocument
5951425 result <- flip localEnv w $ \env -> env
596− { _immediateDomBuilderEnv_parent = toNode df
1426+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
5971427 }
5981428 state <- liftIO $ newIORef FragmentState_Unmounted
5991429 return (ImmediateDomFragment df state, result)
6001430 mountDomFragment fragment setFragment = do
601− parent <- askParent
1431+ parent <- getParent
6021432 extractFragment fragment
603− before <- textNodeInternal ("" :: Text)
1433+ before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6041434 appendChild_ parent $ _immediateDomFragment_document fragment
605− after <- textNodeInternal ("" :: Text)
1435+ after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6061436 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
6071437 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
6081438 extractFragment previousFragment
@@ -611,12 +1441,19 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
6111441 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
6121442 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
6131443
614−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
1444+instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (DomRenderHookT t m) where
1445+ runWithReplace a0 a' = DomRenderHookT $ runWithReplace (unDomRenderHookT a0) (fmapCheap unDomRenderHookT a')
1446+ traverseIntMapWithKeyWithAdjust f m = DomRenderHookT . traverseIntMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1447+ traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1448+ traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
1449+
1450+instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Adjustable t (HydrationDomBuilderT s t m) where
6151451 {-# INLINABLE runWithReplace #-}
6161452 runWithReplace a0 a' = do
617− initialEnv <- ImmediateDomBuilderT ask
618− before <- textNodeInternal ("" :: Text)
619− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
1453+ initialEnv <- HydrationDomBuilderT ask
1454+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
1455+ (hydrateStart, before, beforeKey) <- skipToReplaceStart
1456+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
6201457 haveEverBeenReady <- liftIO $ newIORef False
6211458 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
6221459 let myCommitAction = do
@@ -627,79 +1464,117 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
6271464 old <- liftIO $ readIORef parentUnreadyChildren
6281465 let new = pred old
6291466 liftIO $ writeIORef parentUnreadyChildren $! new
630− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
1467+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
6311468 -- We draw 'after' in this roundabout way to avoid using MonadFix
6321469 doc <- askDocument
633− after <- createTextNode doc ("" :: Text)
1470+ parent <- getParent
1471+ (hydrateEnd, after) <- skipToReplaceEnd beforeKey
6341472 let drawInitialChild = do
1473+ h <- liftIO $ readIORef hydrating
1474+ p' <- case h of
1475+ HydrationMode_Hydrating -> pure parent
1476+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6351477 unreadyChildren <- liftIO $ newIORef 0
636− let f = do
637− result <- a0
638− append $ toNode after
639− return result
640− result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
641− { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
642− , _immediateDomBuilderEnv_commitAction = myCommitAction
1478+ let a0' = case h of
1479+ HydrationMode_Hydrating -> a0
1480+ HydrationMode_Immediate -> do
1481+ a <- a0
1482+ insertBefore p' =<< liftIO (readIORef after)
1483+ pure a
1484+ delayed <- case h of
1485+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1486+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1487+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv
1488+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1489+ , _hydrationDomBuilderEnv_commitAction = myCommitAction
1490+ , _hydrationDomBuilderEnv_parent = Left p'
1491+ , _hydrationDomBuilderEnv_delayed = delayed
6431492 }
1493+ dom <- case h of
1494+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1495+ HydrationMode_Immediate -> pure $ pure ()
6441496 liftIO $ readIORef unreadyChildren >>= \case
6451497 0 -> writeIORef haveEverBeenReady True
6461498 _ -> modifyIORef' parentUnreadyChildren succ
647− return result
1499+ return (dom, result)
6481500 a'' <- numberOccurrences a'
649− (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
650− df <- createDocumentFragment doc
1501+ ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
1502+ h <- liftIO $ readIORef hydrating
1503+ p' <- case h of
1504+ HydrationMode_Hydrating -> pure parent
1505+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6511506 unreadyChildren <- liftIO $ newIORef 0
6521507 let commitAction = do
6531508 c <- liftIO $ readIORef currentCohort
6541509 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
655− deleteBetweenExclusive before after
656− insertBefore df after
1510+ !before' <- liftIO $ readIORef before
1511+ !after' <- liftIO $ readIORef after
1512+ deleteBetweenExclusive before' after'
1513+ insertBefore p' after'
6571514 liftIO $ writeIORef currentCohort cohortId
6581515 myCommitAction
659− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
660− { _immediateDomBuilderEnv_parent = toNode df
661− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
662− , _immediateDomBuilderEnv_commitAction = commitAction
663− }
1516+ delayed <- case h of
1517+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1518+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1519+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv
1520+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1521+ , _hydrationDomBuilderEnv_commitAction = case h of
1522+ HydrationMode_Hydrating -> myCommitAction
1523+ HydrationMode_Immediate -> commitAction
1524+ , _hydrationDomBuilderEnv_parent = Left p'
1525+ , _hydrationDomBuilderEnv_delayed = delayed
1526+ }
1527+ dom <- case h of
1528+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1529+ HydrationMode_Immediate -> pure $ pure ()
6641530 uc <- liftIO $ readIORef unreadyChildren
6651531 let commitActionToRunNow = if uc == 0
666− then Just commitAction
1532+ then Just $ commitAction
6671533 else Nothing -- A child will run it when unreadyChildren is decremented to 0
668− return (commitActionToRunNow, result)
669− requestDomAction_ $ fmapMaybe fst child'
1534+ actions = case h of
1535+ HydrationMode_Hydrating -> Left dom
1536+ HydrationMode_Immediate -> Right commitActionToRunNow
1537+ return (actions, result)
1538+ let (hydrate', commitAction) = fanEither $ fmap fst child'
1539+ addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do
1540+ hydrateStart
1541+ join $ sample contents
1542+ hydrateEnd
1543+ requestDomAction_ $ fmapMaybe id commitAction
6701544 return (result0, snd <$> child')
1545+
6711546 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
6721547 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
6731548 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
6741549 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
6751550 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
6761551 traverseDMapWithKeyWithAdjustWithMove = do
677− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
678− let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
1552+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do
1553+ 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)
6791554 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
680− PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
681− readIORef sRef >>= \case
1555+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete
1556+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do
1557+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
6821558 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
6831559 ChildReadyState_Unready _ -> do
684− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
685− return $ PatchDMapWithMove.From_Insert $ Constant sRef
1560+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k
1561+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)
6861562 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
6871563 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
688− deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
1564+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState (Some k)))) (ComposeMaybe k) a -> IO (Constant () a)
6891565 deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do
690− writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
1566+ writeIORef sRef $ ChildReadyState_Unready $ This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
6911567 return $ Constant ()
6921568 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
6931569 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
6941570 return $ applyAlways p' old
695− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
1571+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) -> do
6961572 let p = unPatchDMapWithMove p_
6971573 phsBefore <- liftIO $ readIORef placeholders
698− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
699− let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
1574+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
7001575 collectIfMoved k e = do
701− let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
702− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
1576+ let mThisPlaceholder = Map.lookup (This k) phsBefore -- Will be Nothing if this element wasn't present before
1577+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsBefore
7031578 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
7041579 False -> do
7051580 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
@@ -707,13 +1582,22 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7071582 True -> do
7081583 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
7091584 collected <- DMap.traverseWithKey collectIfMoved p
710− let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
711− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
1585+ let !phsAfter = fromMaybe phsBefore $ apply filtered phsBefore
1586+ weakened :: PatchMapWithMove (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1587+ weakened = weakenPatchDMapWithMoveWith (_traverseChild_mode . getCompose) p_
1588+ filtered :: PatchMapWithMove (Some k) DOM.Text
1589+ filtered = PatchMapWithMove $ flip Map.mapMaybe (unPatchMapWithMove weakened) $ \(PatchMapWithMove.NodeInfo from to) -> flip PatchMapWithMove.NodeInfo to <$> case from of
1590+ PatchMapWithMove.From_Insert (Left _hydration) -> Nothing
1591+ PatchMapWithMove.From_Insert (Right immediate) -> Just $ PatchMapWithMove.From_Insert $ _traverseChildImmediate_placeholder immediate
1592+ PatchMapWithMove.From_Delete -> Just $ PatchMapWithMove.From_Delete
1593+ PatchMapWithMove.From_Move k -> Just $ PatchMapWithMove.From_Move k
1594+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a)
7121595 placeFragment k e = do
713− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
1596+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsAfter
7141597 case PatchDMapWithMove._nodeInfo_from e of
715− PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
716− df `insertBefore` nextPlaceholder
1598+ PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of
1599+ Left _ -> pure ()
1600+ Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
7171601 PatchDMapWithMove.From_Delete -> do
7181602 return ()
7191603 PatchDMapWithMove.From_Move fromKey -> do
@@ -724,105 +1608,166 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7241608 liftIO $ writeIORef placeholders $! phsAfter
7251609
7261610{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
727−traverseDMapWithKeyWithAdjust' :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k) => (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> ImmediateDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
1611+traverseDMapWithKeyWithAdjust'
1612+ :: forall s t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1613+ => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1614+ -> DMap k v
1615+ -> Event t (PatchDMap k v)
1616+ -> HydrationDomBuilderT s t m (DMap k v', Event t (PatchDMap k v'))
7281617traverseDMapWithKeyWithAdjust' = do
729− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
730− let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
1618+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some k)) v')) old = do
1619+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)
7311620 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
7321621 Nothing -> return Nothing
733− Just (Compose (_, _, sRef, _)) -> do
734− readIORef sRef >>= \case
1622+ Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing
1623+ Just (Compose (TraverseChild (Right immediate) _)) -> do
1624+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
7351625 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
7361626 ChildReadyState_Unready _ -> do
737− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
738− return $ Just $ Constant sRef
1627+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k
1628+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
7391629 delete _ (Constant sRef) = do
7401630 writeIORef sRef $ ChildReadyState_Unready Nothing
7411631 return $ Constant ()
7421632 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
7431633 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
7441634 return $ applyAlways p' old
745− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
1635+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do
7461636 phs <- liftIO $ readIORef placeholders
747− forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
748− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
749− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
750− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
751− forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
752− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
1637+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do
1638+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phs
1639+ -- Delete old node
1640+ forM_ (Map.lookup (This k) phs) $ \thisPlaceholder -> do
1641+ thisPlaceholder `deleteUpTo` nextPlaceholder
1642+ -- Insert new node
1643+ forM_ mv $ \(Compose (TraverseChild e _)) -> case e of
1644+ Left _hydration -> pure ()
1645+ Right immediate -> do
1646+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1647+ let weakened :: PatchMap (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1648+ weakened = weakenPatchDMapWith (_traverseChild_mode . getCompose) $ PatchDMap patch
1649+ filtered :: PatchMap (Some k) DOM.Text
1650+ filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case
1651+ Nothing -> Just Nothing -- deletion
1652+ Just (Left _) -> Nothing
1653+ Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1654+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
7531655
7541656{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
755−traverseIntMapWithKeyWithAdjust' :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m) => (IntMap.Key -> v -> ImmediateDomBuilderT t m v') -> IntMap v -> Event t (PatchIntMap v) -> ImmediateDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))
1657+traverseIntMapWithKeyWithAdjust'
1658+ :: forall s t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1659+ => (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1660+ -> IntMap v
1661+ -> Event t (PatchIntMap v)
1662+ -> HydrationDomBuilderT s t m (IntMap v', Event t (PatchIntMap v'))
7561663traverseIntMapWithKeyWithAdjust' = do
757− let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do
758− let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))
1664+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do
1665+ let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))
7591666 new k m = case m of
7601667 Nothing -> return Nothing
761− Just (_, _, sRef, _) -> do
1668+ Just (TraverseChild (Left _hydration) _) -> pure Nothing
1669+ Just (TraverseChild (Right immediate) _) -> do
1670+ let sRef = _traverseChildImmediate_childReadyState immediate
7621671 readIORef sRef >>= \case
763− ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready
764− ChildReadyStateInt_Unready _ -> do
765− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
1672+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
1673+ ChildReadyState_Unready _ -> do
1674+ writeIORef sRef $ ChildReadyState_Unready $ Just k
7661675 return $ Just sRef
7671676 delete _ sRef = do
768− writeIORef sRef $ ChildReadyStateInt_Unready Nothing
1677+ writeIORef sRef $ ChildReadyState_Unready Nothing
7691678 return ()
7701679 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
7711680 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
7721681 return $ applyAlways p' old
773− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do
1682+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do
7741683 phs <- liftIO $ readIORef placeholders
7751684 forM_ (IntMap.toList p) $ \(k, mv) -> do
776− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
7771685 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
1686+ -- Delete old node
7781687 forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
779− forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder
780− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs
1688+ -- Insert new node
1689+ forM_ mv $ \(TraverseChild e _) -> case e of
1690+ Left _hydration -> pure ()
1691+ Right immediate -> do
1692+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1693+ let filtered :: PatchIntMap DOM.Text
1694+ filtered = PatchIntMap $ flip IntMap.mapMaybe p $ \case
1695+ Nothing -> Just Nothing -- deletion
1696+ Just tc
1697+ | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1698+ | otherwise -> Nothing
1699+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
1700+
1701+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1702+ :: (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM v')
1703+ -> IntMap v
1704+ -> Event Spider (PatchIntMap v)
1705+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))
1706+ #-}
7811707
782−#if MIN_VERSION_base(4,9,0)
783−data ChildReadyState k
784−#else
785−data ChildReadyState (k :: * -> *)
786−#endif
1708+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1709+ :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM v')
1710+ -> IntMap v
1711+ -> Event Spider (PatchIntMap v)
1712+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))
1713+ #-}
1714+
1715+data ChildReadyState a
7871716 = ChildReadyState_Ready
788− | ChildReadyState_Unready !(Maybe (Some k))
1717+ | ChildReadyState_Unready !(Maybe a)
7891718 deriving (Show, Read, Eq, Ord)
7901719
791−data ChildReadyStateInt
792− = ChildReadyStateInt_Ready
793− | ChildReadyStateInt_Unready !(Maybe Int)
794− deriving (Show, Read, Eq, Ord)
1720+insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()
1721+insertAfterPreviousNode node = do
1722+ parent <- askParent
1723+ nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode
1724+ Node.insertBefore_ parent node nextNode
1725+ setPreviousNode $ Just $ toNode node
7951726
796−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
797−hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1727+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1728+hoistTraverseWithKeyWithAdjust
1729+ ::
7981730 ( Adjustable t m
1731+ , MonadHold t m
1732+ , DMap.GCompare k
7991733 , MonadIO m
8001734 , MonadJSM m
801− , MonadFix m
8021735 , PrimMonad m
803− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
804− , Functor p
1736+ , MonadFix m
1737+ , Patch (p k v)
1738+ , Patch (p k (Constant Int))
1739+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1740+ , Patch (p k (Compose (TraverseChild t m (Some k)) v'))
1741+ , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v')
1742+ , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))
1743+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
8051744 )
806− => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
807− -> IntMap v
808− -> Event t (p v)
809− -> RequesterT t JSM Identity (TriggerEventT t m) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event t (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
810− ) -- ^ The base monad's traversal
811− -> (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
812− -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM
813− -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')
814− -> IntMap v
815− -> Event t (p v)
816− -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))
817−hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
818− initialEnv <- ImmediateDomBuilderT ask
819− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
820− pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
1745+ => (forall vv vv'.
1746+ (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
1747+ -> DMap k vv
1748+ -> Event t (p k vv)
1749+ -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))
1750+ -- ^ The base monad's traversal
1751+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')
1752+ -- ^ A way of mapping over the patch type
1753+ -> (p k (Compose (TraverseChild t m (Some k)) v') -> DMap k (Constant (IORef (ChildReadyState (Some k)))) -> IO (DMap k (Constant (IORef (ChildReadyState (Some k))))))
1754+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1755+ -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())
1756+ -- ^ Apply a patch to the DOM
1757+ -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1758+ -> DMap k v
1759+ -> Event t (p k v)
1760+ -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))
1761+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1762+ doc <- askDocument
1763+ initialEnv <- HydrationDomBuilderT ask
1764+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1765+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty
8211766 haveEverBeenReady <- liftIO $ newIORef False
822− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
823− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1767+ placeholders <- liftIO $ newIORef Map.empty
1768+ lastPlaceholder <- createTextNode doc ("" :: Text)
8241769 let applyDomUpdate p = do
825− applyDomUpdate_ placeholders lastPlaceholderRef p
1770+ applyDomUpdate_ placeholders lastPlaceholder p
8261771 markSelfReady
8271772 liftIO $ writeIORef pendingChange $! mempty
8281773 markSelfReady = do
@@ -833,86 +1778,105 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
8331778 old <- liftIO $ readIORef parentUnreadyChildren
8341779 let new = pred old
8351780 liftIO $ writeIORef parentUnreadyChildren $! new
836− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
837− markChildReady :: IORef ChildReadyStateInt -> JSM ()
1781+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1782+ markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()
8381783 markChildReady childReadyState = do
8391784 liftIO (readIORef childReadyState) >>= \case
840− ChildReadyStateInt_Ready -> return ()
841− ChildReadyStateInt_Unready countedAt -> do
842− liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1785+ ChildReadyState_Ready -> return ()
1786+ ChildReadyState_Unready countedAt -> do
1787+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
8431788 case countedAt of
8441789 Nothing -> return ()
845− Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
1790+ Just (This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
8461791 (oldUnready, p) <- liftIO $ readIORef pendingChange
847− when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
848− let newUnready = IntMap.delete k oldUnready
1792+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
1793+ let newUnready = DMap.delete k oldUnready
8491794 liftIO $ writeIORef pendingChange (newUnready, p)
850− when (IntMap.null newUnready) $ do
1795+ when (DMap.null newUnready) $ do
8511796 applyDomUpdate p
852− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
853− let processChild k (_, _, sRef, _) = do
854− readIORef sRef >>= \case
855− ChildReadyStateInt_Ready -> return Nothing
856− ChildReadyStateInt_Unready _ -> do
857− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
858− return $ Just sRef
859− initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
860− liftIO $ if IntMap.null initialUnready
1797+ (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))
1798+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1799+ let processChild k (Compose (TraverseChild e _)) = case e of
1800+ Left _ -> pure $ ComposeMaybe Nothing
1801+ Right immediate -> ComposeMaybe <$> do
1802+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1803+ ChildReadyState_Ready -> return Nothing
1804+ ChildReadyState_Unready _ -> do
1805+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k
1806+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
1807+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1808+ liftIO $ if DMap.null initialUnready
8611809 then writeIORef haveEverBeenReady True
8621810 else do
8631811 modifyIORef' parentUnreadyChildren succ
8641812 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
865− let result0 = IntMap.map (\(_, _, _, v) -> v) children0
866− placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
867− result' = ffor children' $ fmap $ \(_, _, _, r) -> r
868− liftIO $ writeIORef placeholders $! placeholders0
869− _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
870− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
1813+ getHydrationMode >>= \case
1814+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1815+ dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1816+ phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
1817+ liftIO $ writeIORef placeholders $! phs
1818+ insertAfterPreviousNode lastPlaceholder
1819+ HydrationMode_Immediate -> do
1820+ let activate i = do
1821+ append $ toNode $ _traverseChildImmediate_fragment i
1822+ pure $ _traverseChildImmediate_placeholder i
1823+ phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1824+ liftIO $ writeIORef placeholders $! phs
1825+ append $ toNode lastPlaceholder
8711826 requestDomAction_ $ ffor children' $ \p -> do
8721827 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
8731828 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
8741829 let !newP = p <> oldP
8751830 liftIO $ writeIORef pendingChange (newUnready, newP)
876− when (IntMap.null newUnready) $ do
1831+ when (DMap.null newUnready) $ do
8771832 applyDomUpdate newP
1833+ let result0 = DMap.map (_traverseChild_result . getCompose) children0
1834+ result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose
8781835 return (result0, result')
8791836
880−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
881−hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1837+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
1838+hoistTraverseIntMapWithKeyWithAdjust ::
8821839 ( Adjustable t m
8831840 , MonadHold t m
884− , DMap.GCompare k
885− , MonadIO m
8861841 , MonadJSM m
887− , PrimMonad m
8881842 , MonadFix m
889− , Patch (p k v)
890− , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
891− , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
892− , Patch (p k (Constant Int))
1843+ , PrimMonad m
1844+ , Monoid (p (TraverseChild t m Int v'))
1845+ , Functor p
1846+ , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())
1847+ , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')
1848+ , Patch (p (HydrationRunnerT t m ()))
1849+ , Patch (p (TraverseChild t m Int v'))
1850+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
8931851 )
894− => (forall vv vv'.
895− (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))
896− -> DMap k vv
897− -> Event t (p k vv)
898− -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))
899− ) -- ^ The base monad's traversal
900− -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
901− -> (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k))))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
902− -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM
903− -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))
904− -> DMap k v
905− -> Event t (p k v)
906− -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))
907−hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
908− initialEnv <- ImmediateDomBuilderT ask
909− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
910− pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
1852+ => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))
1853+ -> IntMap v
1854+ -> Event t (p v)
1855+ -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))
1856+ -- ^ The base monad's traversal
1857+ -> (p (TraverseChild t m Int v')
1858+ -> IntMap (IORef (ChildReadyState Int))
1859+ -> IO (IntMap (IORef (ChildReadyState Int))))
1860+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1861+ -> (IORef (IntMap DOM.Text)
1862+ -> DOM.Text
1863+ -> p (TraverseChild t m Int v')
1864+ -> JSM ())
1865+ -- ^ Apply a patch to the DOM
1866+ -> (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1867+ -> IntMap v
1868+ -> Event t (p v)
1869+ -> HydrationDomBuilderT s t m (IntMap v', Event t (p v'))
1870+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1871+ doc <- askDocument
1872+ initialEnv <- HydrationDomBuilderT ask
1873+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1874+ pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty
9111875 haveEverBeenReady <- liftIO $ newIORef False
912− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
913− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1876+ placeholders <- liftIO $ newIORef IntMap.empty
1877+ lastPlaceholder <- createTextNode doc ("" :: Text)
9141878 let applyDomUpdate p = do
915− applyDomUpdate_ placeholders lastPlaceholderRef p
1879+ applyDomUpdate_ placeholders lastPlaceholder p
9161880 markSelfReady
9171881 liftIO $ writeIORef pendingChange $! mempty
9181882 markSelfReady = do
@@ -923,8 +1887,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9231887 old <- liftIO $ readIORef parentUnreadyChildren
9241888 let new = pred old
9251889 liftIO $ writeIORef parentUnreadyChildren $! new
926− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
927− markChildReady :: IORef (ChildReadyState k) -> JSM ()
1890+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1891+ markChildReady :: IORef (ChildReadyState Int) -> JSM ()
9281892 markChildReady childReadyState = do
9291893 liftIO (readIORef childReadyState) >>= \case
9301894 ChildReadyState_Ready -> return ()
@@ -932,82 +1896,191 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9321896 liftIO $ writeIORef childReadyState ChildReadyState_Ready
9331897 case countedAt of
9341898 Nothing -> return ()
935− Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
1899+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
9361900 (oldUnready, p) <- liftIO $ readIORef pendingChange
937− when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
938− let newUnready = DMap.delete k oldUnready
1901+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
1902+ let newUnready = IntMap.delete k oldUnready
9391903 liftIO $ writeIORef pendingChange (newUnready, p)
940− when (DMap.null newUnready) $ do
1904+ when (IntMap.null newUnready) $ do
9411905 applyDomUpdate p
942− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
943− let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
944− readIORef sRef >>= \case
945− ChildReadyState_Ready -> return Nothing
946− ChildReadyState_Unready _ -> do
947− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
948− return $ Just $ Constant sRef
949− initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
950− liftIO $ if DMap.null initialUnready
1906+ (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))
1907+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1908+ let processChild k (TraverseChild e _) = case e of
1909+ Left _ -> pure Nothing
1910+ Right immediate -> do
1911+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1912+ ChildReadyState_Ready -> return Nothing
1913+ ChildReadyState_Unready _ -> do
1914+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k
1915+ return $ Just (_traverseChildImmediate_childReadyState immediate)
1916+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
1917+ liftIO $ if IntMap.null initialUnready
9511918 then writeIORef haveEverBeenReady True
9521919 else do
9531920 modifyIORef' parentUnreadyChildren succ
9541921 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
955− let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
956− placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
957− result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
958− liftIO $ writeIORef placeholders $! placeholders0
959− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
960− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
1922+ getHydrationMode >>= \case
1923+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1924+ dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children
1925+ phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm
1926+ liftIO $ writeIORef placeholders $! phs
1927+ insertAfterPreviousNode lastPlaceholder
1928+ HydrationMode_Immediate -> do
1929+ let activate i = do
1930+ append $ toNode $ _traverseChildImmediate_fragment i
1931+ pure $ _traverseChildImmediate_placeholder i
1932+ phs <- traverse (either (error "impossible") activate . _traverseChild_mode) children0
1933+ liftIO $ writeIORef placeholders $! phs
1934+ append $ toNode lastPlaceholder
9611935 requestDomAction_ $ ffor children' $ \p -> do
9621936 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
9631937 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
9641938 let !newP = p <> oldP
9651939 liftIO $ writeIORef pendingChange (newUnready, newP)
966− when (DMap.null newUnready) $ do
1940+ when (IntMap.null newUnready) $ do
9671941 applyDomUpdate newP
1942+ let result0 = IntMap.map _traverseChild_result children0
1943+ result' = ffor children' $ fmap $ _traverseChild_result
9681944 return (result0, result')
9691945
1946+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1947+ :: ((IntMap.Key -> v -> DomRenderHookT Spider HydrationM (TraverseChild Spider HydrationM Int v'))
1948+ -> IntMap v
1949+ -> Event Spider (PatchIntMap v)
1950+ -> DomRenderHookT Spider HydrationM (IntMap (TraverseChild Spider HydrationM Int v'), Event Spider (PatchIntMap (TraverseChild Spider HydrationM Int v'))))
1951+ -> (PatchIntMap (TraverseChild Spider HydrationM Int v')
1952+ -> IntMap (IORef (ChildReadyState Int))
1953+ -> IO (IntMap (IORef (ChildReadyState Int))))
1954+ -> (IORef (IntMap DOM.Text)
1955+ -> DOM.Text
1956+ -> PatchIntMap (TraverseChild Spider HydrationM Int v')
1957+ -> JSM ())
1958+ -> (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM v')
1959+ -> IntMap v
1960+ -> Event Spider (PatchIntMap v)
1961+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))
1962+ #-}
1963+
1964+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1965+ :: ((IntMap.Key -> v -> DomRenderHookT Spider HydrationM (TraverseChild Spider HydrationM Int v'))
1966+ -> IntMap v
1967+ -> Event Spider (PatchIntMap v)
1968+ -> DomRenderHookT Spider HydrationM (IntMap (TraverseChild Spider HydrationM Int v'), Event Spider (PatchIntMap (TraverseChild Spider HydrationM Int v'))))
1969+ -> (PatchIntMap (TraverseChild Spider HydrationM Int v')
1970+ -> IntMap (IORef (ChildReadyState Int))
1971+ -> IO (IntMap (IORef (ChildReadyState Int))))
1972+ -> (IORef (IntMap DOM.Text)
1973+ -> DOM.Text
1974+ -> PatchIntMap (TraverseChild Spider HydrationM Int v')
1975+ -> JSM ())
1976+ -> (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM v')
1977+ -> IntMap v
1978+ -> Event Spider (PatchIntMap v)
1979+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))
1980+ #-}
1981+
1982+data TraverseChildImmediate k = TraverseChildImmediate
1983+ { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment
1984+ -- ^ Child is appended to this fragment
1985+ , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text
1986+ -- ^ Placeholder reference
1987+ , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))
1988+ }
1989+
1990+newtype TraverseChildHydration t m = TraverseChildHydration
1991+ { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text
1992+ -- ^ Action to run at switchover, returns the placeholder
1993+ }
1994+
1995+data TraverseChild t m k a = TraverseChild
1996+ { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))
1997+ , _traverseChild_result :: !a
1998+ } deriving Functor
1999+
9702000{-# INLINABLE drawChildUpdate #-}
971−drawChildUpdate :: (MonadIO m, MonadJSM m)
972− => ImmediateDomBuilderEnv t
2001+drawChildUpdate :: (MonadJSM m, Reflex t)
2002+ => HydrationDomBuilderEnv t m
9732003 -> (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
974− -> ImmediateDomBuilderT t m (v' a)
975− -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
2004+ -> HydrationDomBuilderT s t m (f a)
2005+ -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)
9762006drawChildUpdate initialEnv markReady child = do
977− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2007+ let doc = _hydrationDomBuilderEnv_document initialEnv
9782008 unreadyChildren <- liftIO $ newIORef 0
979− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
980− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
981− { _immediateDomBuilderEnv_parent = toNode df
982− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
983− , _immediateDomBuilderEnv_commitAction = markReady childReadyState
984− }
985− u <- liftIO $ readIORef unreadyChildren
986− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
987− return $ Compose (df, placeholder, childReadyState, result)
2009+ liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case
2010+ HydrationMode_Hydrating -> do
2011+ childDelayedRef <- liftIO $ newIORef $ pure ()
2012+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2013+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2014+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
2015+ }
2016+ childDelayed <- liftIO $ readIORef childDelayedRef
2017+ return $ Compose $ TraverseChild
2018+ { _traverseChild_result = result
2019+ , _traverseChild_mode = Left TraverseChildHydration
2020+ { _traverseChildHydration_delayed = do
2021+ placeholder <- createTextNode doc ("" :: Text)
2022+ insertAfterPreviousNode placeholder
2023+ childDelayed
2024+ pure placeholder
2025+ }
2026+ }
2027+ HydrationMode_Immediate -> do
2028+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2029+ df <- createDocumentFragment doc
2030+ placeholder <- createTextNode doc ("" :: Text)
2031+ Node.appendChild_ df placeholder
2032+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2033+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
2034+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2035+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
2036+ }
2037+ u <- liftIO $ readIORef unreadyChildren
2038+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
2039+ return $ Compose $ TraverseChild
2040+ { _traverseChild_result = result
2041+ , _traverseChild_mode = Right TraverseChildImmediate
2042+ { _traverseChildImmediate_fragment = df
2043+ , _traverseChildImmediate_placeholder = placeholder
2044+ , _traverseChildImmediate_childReadyState = childReadyState
2045+ }
2046+ }
9882047
989−{-# INLINABLE drawChildUpdateInt #-}
990−drawChildUpdateInt :: (MonadIO m, MonadJSM m)
991− => ImmediateDomBuilderEnv t
992− -> (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
993− -> ImmediateDomBuilderT t m v'
994− -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
995−drawChildUpdateInt initialEnv markReady child = do
996− childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing
997− unreadyChildren <- liftIO $ newIORef 0
998− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
999− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
1000− { _immediateDomBuilderEnv_parent = toNode df
1001− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
1002− , _immediateDomBuilderEnv_commitAction = markReady childReadyState
1003− }
1004− u <- liftIO $ readIORef unreadyChildren
1005− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1006− return (df, placeholder, childReadyState, result)
2048+{-# SPECIALIZE drawChildUpdate
2049+ :: HydrationDomBuilderEnv Spider HydrationM
2050+ -> (IORef (ChildReadyState Int) -> JSM ())
2051+ -> HydrationDomBuilderT s Spider HydrationM (Identity a)
2052+ -> DomRenderHookT Spider HydrationM (Compose (TraverseChild Spider HydrationM Int) Identity a)
2053+ #-}
2054+
2055+{-# SPECIALIZE drawChildUpdate
2056+ :: HydrationDomBuilderEnv Spider HydrationM
2057+ -> (IORef (ChildReadyState (Some k)) -> JSM ())
2058+ -> HydrationDomBuilderT s Spider HydrationM (f a)
2059+ -> DomRenderHookT Spider HydrationM (Compose (TraverseChild Spider HydrationM (Some k)) f a)
2060+ #-}
10072061
1008−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
2062+{-# INLINABLE drawChildUpdateInt #-}
2063+drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
2064+ => HydrationDomBuilderEnv t m
2065+ -> (IORef (ChildReadyState k) -> JSM ())
2066+ -> HydrationDomBuilderT s t m v
2067+ -> DomRenderHookT t m (TraverseChild t m k v)
2068+drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdate env mark (Identity <$> m)
2069+
2070+{-# SPECIALIZE drawChildUpdateInt
2071+ :: HydrationDomBuilderEnv Spider HydrationM
2072+ -> (IORef (ChildReadyState k) -> JSM ())
2073+ -> HydrationDomBuilderT s Spider HydrationM v
2074+ -> DomRenderHookT Spider HydrationM (TraverseChild Spider HydrationM k v)
2075+ #-}
2076+
2077+{-# INLINE mkHasFocus #-}
2078+mkHasFocus
2079+ :: (HasDocument m, MonadJSM m, IsNode (RawElement d), MonadHold t m, Reflex t, DOM.IsDocumentOrShadowRoot (RawDocument (DomBuilderSpace m)))
2080+ => Element er d t -> m (Dynamic t Bool)
10092081mkHasFocus e = do
1010− let initialFocus = False --TODO: Actually get the initial focus of the element
2082+ doc <- askDocument
2083+ initialFocus <- Node.isSameNode (toNode $ _element_raw e) . fmap toNode =<< Document.getActiveElement doc
10112084 holdDyn initialFocus $ leftmost
10122085 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
10132086 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
@@ -1016,39 +2089,49 @@ mkHasFocus e = do
10162089insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
10172090insertBefore new existing = do
10182091 p <- getParentNodeUnchecked existing
1019− 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
2092+ Node.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
10202093
1021−instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
1022− type Performable (ImmediateDomBuilderT t m) = Performable m
2094+type ImmediateDomBuilderT = HydrationDomBuilderT GhcjsDomSpace
2095+
2096+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where
2097+ type Performable (HydrationDomBuilderT s t m) = Performable m
10232098 {-# INLINABLE performEvent_ #-}
10242099 performEvent_ e = lift $ performEvent_ e
10252100 {-# INLINABLE performEvent #-}
10262101 performEvent e = lift $ performEvent e
10272102
1028−instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where
2103+instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where
10292104 {-# INLINABLE getPostBuild #-}
10302105 getPostBuild = lift getPostBuild
10312106
1032−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where
2107+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where
10332108 {-# INLINABLE newEventWithTrigger #-}
10342109 newEventWithTrigger = lift . newEventWithTrigger
10352110 {-# INLINABLE newFanEventWithTrigger #-}
10362111 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
10372112
1038−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where
2113+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT s t m) where
2114+ {-# INLINABLE newTriggerEvent #-}
2115+ newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent
2116+ {-# INLINABLE newTriggerEventWithOnComplete #-}
2117+ newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete
2118+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
2119+ newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f
2120+
2121+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where
10392122 {-# INLINABLE newTriggerEvent #-}
1040− newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
2123+ newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent
10412124 {-# INLINABLE newTriggerEventWithOnComplete #-}
1042− newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
2125+ newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete
10432126 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1044− newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
2127+ newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f
10452128
1046−instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
1047− type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
2129+instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where
2130+ type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m
10482131 askJSContext = lift askJSContext
10492132
1050−instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
1051− type Ref (ImmediateDomBuilderT t m) = Ref m
2133+instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where
2134+ type Ref (HydrationDomBuilderT s t m) = Ref m
10522135 {-# INLINABLE newRef #-}
10532136 newRef = lift . newRef
10542137 {-# INLINABLE readRef #-}
@@ -1056,12 +2139,12 @@ instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
10562139 {-# INLINABLE writeRef #-}
10572140 writeRef r = lift . writeRef r
10582141
1059−instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
2142+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where
10602143 {-# INLINABLE atomicModifyRef #-}
10612144 atomicModifyRef r = lift . atomicModifyRef r
10622145
1063−instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
1064− type JSX (ImmediateDomBuilderT t m) = JSX m
2146+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where
2147+ type JSX (HydrationDomBuilderT s t m) = JSX m
10652148 liftJS = lift . liftJS
10662149
10672150type family EventType en where
@@ -1519,11 +2602,11 @@ getTouchEvent = do
15192602 , _touchEventResult_touches = touches
15202603 }
15212604
1522−instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
2605+instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
15232606 {-# INLINABLE sample #-}
15242607 sample = lift . sample
15252608
1526−instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where
2609+instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where
15272610 {-# INLINABLE hold #-}
15282611 hold v0 v' = lift $ hold v0 v'
15292612 {-# INLINABLE holdDyn #-}
@@ -1545,7 +2628,7 @@ data Window t = Window
15452628 , _window_raw :: DOM.Window
15462629 }
15472630
1548−wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)
2631+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> HydrationDomBuilderT GhcjsDomSpace t m (Window t)
15492632wrapWindow wv _ = do
15502633 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
15512634 return $ Window