@@ -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,346 @@
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 (..)
60−#ifndef USE_TEMPLATE_HASKELL
61− , phantom2
62−#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
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 (..)
89+ , drawChildUpdate
90+ , ChildReadyState (..)
91+ , mkHasFocus
92+ , insertBefore
93+ , EventType
94+ , defaultDomEventHandler
95+ , defaultDomWindowEventHandler
96+ , withIsEvent
97+ , showEventName
98+ , elementOnEventName
99+ , windowOnEventName
100+ , wrapDomEvent
101+ , subscribeDomEvent
102+ , wrapDomEventMaybe
103+ , wrapDomEventsMaybe
104+ , getKeyEvent
105+ , getMouseEventCoords
106+ , getTouchEvent
107+ , WindowConfig (..)
108+ , Window (..)
109+ , wrapWindow
110+ -- * Internal
111+ , traverseDMapWithKeyWithAdjust'
112+ , hoistTraverseWithKeyWithAdjust
113+ , traverseIntMapWithKeyWithAdjust'
114+ , hoistTraverseIntMapWithKeyWithAdjust
115+ ) where
105116
106117import Control.Concurrent
107−import Control.Lens hiding (element, ix)
118+import Control.Exception (bracketOnError)
119+import Control.Lens (Identity(..), imapM_, iforM_, (^.), makeLenses)
108120import Control.Monad.Exception
109121import Control.Monad.Primitive
110122import Control.Monad.Reader
111123import Control.Monad.Ref
112−#ifndef USE_TEMPLATE_HASKELL
113−import Data.Functor.Contravariant (phantom)
114−#endif
124+import Control.Monad.State.Strict (StateT, mapStateT, get, modify', gets, runStateT)
115125import Data.Bitraversable
116126import Data.Default
117127import Data.Dependent.Map (DMap)
118−import qualified Data.Dependent.Map as DMap
119128import Data.Dependent.Sum
129+import Data.FastMutableIntMap (PatchIntMap (..))
130+import Data.Foldable (for_, traverse_)
120131import Data.Functor.Compose
121132import Data.Functor.Constant
122133import Data.Functor.Misc
123134import Data.Functor.Product
124135import Data.IORef
125−import qualified Data.Map as Map
136+import Data.IntMap.Strict (IntMap)
126137import Data.Maybe
127−import Data.Monoid hiding (Product)
128−import Data.Some (Some)
129−import qualified Data.Some as Some
138+import Data.Monoid ((<>))
139+import Data.Some (Some(..))
130140import Data.Text (Text)
141+import Foreign.JavaScript.Internal.Utils
142+import Foreign.JavaScript.TH
143+import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
144+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
145+import GHCJS.DOM.EventM (EventM, event, on)
146+import GHCJS.DOM.KeyboardEvent as KeyboardEvent
147+import GHCJS.DOM.MouseEvent
148+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
149+import GHCJS.DOM.Types (liftJSM, askJSM, runJSM, JSM, MonadJSM, FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)
150+import GHCJS.DOM.UIEvent
151+import Language.Javascript.JSaddle (call, eval)
152+import Reflex.Adjustable.Class
153+import Reflex.Class as Reflex
154+import Reflex.Dom.Builder.Class
155+import Reflex.Dynamic
156+import Reflex.Host.Class
157+import Reflex.Patch.DMapWithMove (PatchDMapWithMove(..))
158+import Reflex.Patch.MapWithMove (PatchMapWithMove(..))
159+import Reflex.PerformEvent.Base (PerformEventT)
160+import Reflex.PerformEvent.Class
161+import Reflex.PostBuild.Base (PostBuildT)
162+import Reflex.PostBuild.Class
163+#ifdef PROFILE_REFLEX
164+import Reflex.Profiled
165+#endif
166+import Reflex.Requester.Base
167+import Reflex.Requester.Class
168+import Reflex.Spider (Spider, SpiderHost, Global)
169+import Reflex.TriggerEvent.Base hiding (askEvents)
170+import Reflex.TriggerEvent.Class
171+
172+import qualified Data.Dependent.Map as DMap
173+import qualified Data.FastMutableIntMap as FastMutableIntMap
174+import qualified Data.IntMap.Strict as IntMap
175+import qualified Data.Map as Map
176+import qualified Data.Text as T
131177import 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)
178+import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
179+import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
134180import qualified GHCJS.DOM.Element as Element
135181import 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)
139182import qualified GHCJS.DOM.EventM as DOM
140183import qualified GHCJS.DOM.FileList as FileList
184+import qualified GHCJS.DOM.GlobalEventHandlers as Events
141185import qualified GHCJS.DOM.HTMLInputElement as Input
142186import qualified GHCJS.DOM.HTMLSelectElement as Select
143187import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
144−import GHCJS.DOM.MouseEvent
188+import qualified GHCJS.DOM.Node as Node
189+import qualified GHCJS.DOM.Text as DOM
145190import qualified GHCJS.DOM.Touch as Touch
146191import qualified GHCJS.DOM.TouchEvent as TouchEvent
147192import 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)
154193import qualified GHCJS.DOM.Types as DOM
155−import GHCJS.DOM.UIEvent
156−import GHCJS.DOM.KeyboardEvent as KeyboardEvent
157194import 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
195+import qualified Reflex.Patch.DMap as PatchDMap
196+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
198+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
163199
164−import Reflex.Requester.Base
165−import Reflex.Requester.Class
166−import Foreign.JavaScript.Internal.Utils
200+#ifndef USE_TEMPLATE_HASKELL
201+import Data.Functor.Contravariant (phantom)
202+import Control.Lens (Lens', Getter)
203+#endif
167204
168205#ifndef ghcjs_HOST_OS
169206import GHCJS.DOM.Types (MonadJSM (..))
170207
171−instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
172− liftJSM' = ImmediateDomBuilderT . liftJSM'
208+instance MonadJSM m => MonadJSM (HydrationRunnerT t m) where
209+ {-# INLINABLE liftJSM' #-}
210+ liftJSM' = lift . liftJSM'
211+
212+instance MonadJSM m => MonadJSM (HydrationDomBuilderT s t m) where
213+ {-# INLINABLE liftJSM' #-}
214+ liftJSM' = lift . liftJSM'
215+
216+instance MonadJSM m => MonadJSM (DomRenderHookT t m) where
217+ {-# INLINABLE liftJSM' #-}
218+ liftJSM' = lift . liftJSM'
173219#endif
174220
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− }
221+data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv
222+ { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
223+ -- ^ Reference to the document
224+ , _hydrationDomBuilderEnv_parent :: !(Either Node (IORef Node))
225+ -- ^ This is in an IORef because in the time up to hydration we can't actually know what the
226+ -- parent is - we populate this reference during the DOM traversal at hydration time
227+ , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word)
228+ -- ^ Number of children who still aren't fully rendered
229+ , _hydrationDomBuilderEnv_commitAction :: !(JSM ())
230+ -- ^ Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
231+ , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode)
232+ -- ^ In hydration mode? Should be switched to `HydrationMode_Immediate` after hydration is finished
233+ , _hydrationDomBuilderEnv_switchover :: !(Event t ())
234+ , _hydrationDomBuilderEnv_delayed :: {-# UNPACK #-} !(IORef (HydrationRunnerT t m ()))
235+ }
181236
182−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }
237+-- | A monad for DomBuilder which just gets the results of children and pushes
238+-- work into an action that is delayed until after postBuild (to match the
239+-- static builder). The action runs in 'HydrationRunnerT', which performs the
240+-- DOM takeover and sets up the events, after which point this monad will
241+-- continue in the vein of 'ImmediateDomBuilderT'.
242+newtype HydrationDomBuilderT s t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (DomRenderHookT t m) a }
183243 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
184244#if MIN_VERSION_base(4,9,1)
185245 , MonadAsyncException
186246#endif
187247 )
188248
189−instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
190− type PrimState (ImmediateDomBuilderT x m) = PrimState m
249+instance PrimMonad m => PrimMonad (HydrationDomBuilderT s t m) where
250+ type PrimState (HydrationDomBuilderT s t m) = PrimState m
191251 primitive = lift . primitive
192252
193−instance MonadTrans (ImmediateDomBuilderT t) where
194− lift = ImmediateDomBuilderT . lift . lift . lift
253+instance MonadTrans (HydrationDomBuilderT s t) where
254+ lift = HydrationDomBuilderT . lift . lift
255+
256+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT s t m) where
257+ withRenderHook hook = HydrationDomBuilderT . mapReaderT (withRenderHook hook) . unHydrationDomBuilderT
258+ requestDomAction = HydrationDomBuilderT . lift . requestDomAction
259+ requestDomAction_ = HydrationDomBuilderT . lift . requestDomAction_
260+
261+-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.
262+-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.
263+newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT HydrationState (ReaderT Node (DomRenderHookT t m)) a }
264+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
265+#if MIN_VERSION_base(4,9,1)
266+ , MonadAsyncException
267+#endif
268+ )
269+
270+data HydrationState = HydrationState
271+ { _hydrationState_previousNode :: !(Maybe Node)
272+ , _hydrationState_failed :: !Bool
273+ }
274+
275+{-# INLINABLE localRunner #-}
276+localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a
277+localRunner (HydrationRunnerT m) s parent = do
278+ s0 <- HydrationRunnerT get
279+ (a, s') <- HydrationRunnerT $ lift $ local (\_ -> parent) $ runStateT m (s0 { _hydrationState_previousNode = s })
280+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
281+ HydrationRunnerT $ modify' $ \hs -> hs { _hydrationState_failed = _hydrationState_failed s' }
282+ pure a
283+
284+{-# INLINABLE runHydrationRunnerT #-}
285+runHydrationRunnerT
286+ :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
287+ => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
288+runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
289+ (a, s') <- runStateT m (HydrationState s False)
290+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
291+ 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."
292+ pure a
293+
294+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
295+ {-# INLINABLE newEventWithTrigger #-}
296+ newEventWithTrigger = lift . newEventWithTrigger
297+ {-# INLINABLE newFanEventWithTrigger #-}
298+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
299+
300+instance MonadTrans (HydrationRunnerT t) where
301+ {-# INLINABLE lift #-}
302+ lift = HydrationRunnerT . lift . lift . lift
303+
304+instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where
305+ {-# INLINABLE sample #-}
306+ sample = lift . sample
307+
308+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where
309+ withRenderHook hook = HydrationRunnerT . mapStateT (mapReaderT (withRenderHook hook)) . unHydrationRunnerT
310+ requestDomAction = HydrationRunnerT . lift . lift . requestDomAction
311+ requestDomAction_ = HydrationRunnerT . lift . lift . requestDomAction_
312+
313+-- | Add a hydration step which depends on some computation that should only be
314+-- done *before* the switchover to immediate mode - this is most likely some
315+-- form of 'hold' which we want to remove after hydration is done
316+{-# INLINABLE addHydrationStepWithSetup #-}
317+addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()
318+addHydrationStepWithSetup setup f = getHydrationMode >>= \case
319+ HydrationMode_Immediate -> pure ()
320+ HydrationMode_Hydrating -> do
321+ switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
322+ (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
323+ addHydrationStep (f s)
324+
325+-- | Add a hydration step
326+{-# INLINABLE addHydrationStep #-}
327+addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT s t m ()
328+addHydrationStep m = do
329+ delayedRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_delayed
330+ liftIO $ modifyIORef' delayedRef (>> m)
331+
332+-- | Shared behavior for HydrationDomBuilderT and HydrationRunnerT
333+newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t JSM Identity (TriggerEventT t m) a }
334+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
335+#if MIN_VERSION_base(4,9,1)
336+ , MonadAsyncException
337+#endif
338+ )
339+
340+{-# INLINABLE runDomRenderHookT #-}
341+runDomRenderHookT
342+ :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)
343+ => DomRenderHookT t m a
344+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
345+ -> m a
346+runDomRenderHookT (DomRenderHookT a) events = do
347+ flip runTriggerEventT events $ do
348+ rec (result, req) <- runRequesterT a rsp
349+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
350+ traverseRequesterData (fmap Identity) rm
351+ return result
352+ where
353+ runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
354+ v <- synchronously x
355+ void . liftIO $ f v
356+
357+instance MonadTrans (DomRenderHookT t) where
358+ {-# INLINABLE lift #-}
359+ lift = DomRenderHookT . lift . lift
195360
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
201− return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)
202− requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity
203− requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
361+instance (Reflex t, MonadFix m) => DomRenderHook t (DomRenderHookT t m) where
362+ withRenderHook hook (DomRenderHookT a) = do
363+ DomRenderHookT $ withRequesting $ \rsp -> do
364+ (x, req) <- lift $ runRequesterT a $ runIdentity <$> rsp
365+ return (ffor req $ \rm -> hook $ traverseRequesterData (fmap Identity) rm, x)
366+ requestDomAction = DomRenderHookT . requestingIdentity
367+ requestDomAction_ = DomRenderHookT . requesting_
204368
205−{-# INLINABLE runImmediateDomBuilderT #-}
206−runImmediateDomBuilderT
369+{-# INLINABLE runHydrationDomBuilderT #-}
370+runHydrationDomBuilderT
207371 :: ( MonadFix m
208372 , PerformEvent t m
209373 , MonadReflexCreateTrigger t m
@@ -212,50 +376,76 @@ runImmediateDomBuilderT
212376 , MonadRef m
213377 , Ref m ~ IORef
214378 )
215− => ImmediateDomBuilderT t m a
216− -> ImmediateDomBuilderEnv t
379+ => HydrationDomBuilderT s t m a
380+ -> HydrationDomBuilderEnv t m
217381 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
218382 -> 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
383+runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)
229384
230−instance Monad m => HasDocument (ImmediateDomBuilderT t m) where
385+instance (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, Monad m) => HasDocument (HydrationDomBuilderT s t m) where
231386 {-# INLINABLE askDocument #-}
232− askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document
387+ askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
233388
234389{-# INLINABLE askParent #-}
235−askParent :: Monad m => ImmediateDomBuilderT t m Node
236−askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent
390+askParent :: Monad m => HydrationRunnerT t m DOM.Node
391+askParent = HydrationRunnerT ask
392+
393+{-# INLINABLE getParent #-}
394+getParent :: MonadIO m => HydrationDomBuilderT s t m DOM.Node
395+getParent = either pure (liftIO . readIORef) =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
237396
238397{-# INLINABLE askEvents #-}
239−askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
240−askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents
398+askEvents :: Monad m => HydrationDomBuilderT s t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
399+askEvents = HydrationDomBuilderT . lift . DomRenderHookT . lift $ TriggerEventT.askEvents
241400
242−localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
243−localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT
401+{-# INLINABLE localEnv #-}
402+localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT s t m a -> HydrationDomBuilderT s t m a
403+localEnv f = HydrationDomBuilderT . local (f $!) . unHydrationDomBuilderT
244404
245405{-# INLINABLE append #-}
246−append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()
406+append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT s t m ()
247407append n = do
248− p <- askParent
408+ p <- getParent
249409 liftJSM $ appendChild_ p n
250410 return ()
251411
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
412+{-# SPECIALIZE append
413+ :: DOM.Node
414+ -> HydrationDomBuilderT s Spider HydrationM ()
415+ #-}
416+
417+data HydrationMode
418+ = HydrationMode_Hydrating
419+ -- ^ The time from initial load to parity with static builder
420+ | HydrationMode_Immediate
421+ -- ^ After hydration
422+ deriving (Eq, Ord, Show)
423+
424+{-# INLINABLE getPreviousNode #-}
425+getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)
426+getPreviousNode = HydrationRunnerT $ gets _hydrationState_previousNode
427+
428+{-# INLINABLE setPreviousNode #-}
429+setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
430+setPreviousNode n = HydrationRunnerT $ modify' (\hs -> hs { _hydrationState_previousNode = n })
431+
432+{-# INLINABLE askUnreadyChildren #-}
433+askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)
434+askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
435+
436+{-# INLINABLE askCommitAction #-}
437+askCommitAction :: Monad m => HydrationDomBuilderT s t m (JSM ())
438+askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction
439+
440+{-# INLINABLE getHydrationMode #-}
441+getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode
442+getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
443+
444+-- | Remove all nodes after given node
445+removeSubsequentNodes :: (MonadJSM m, IsNode n) => n -> m ()
446+removeSubsequentNodes n = liftJSM $ do
447+ f <- eval ("(function(n) { while (n.nextSibling) { (n.parentNode).removeChild(n.nextSibling); }; })" :: Text)
448+ void $ call f f [n]
259449
260450-- | s and e must both be children of the same node and s must precede e;
261451-- all nodes between s and e will be removed, but s and e will not be removed
@@ -293,7 +483,7 @@ extractUpTo df s e = liftJSM $ do
293483 void $ call f f (df, s, e)
294484#endif
295485
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)
486+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))
297487
298488{-# INLINABLE collectUpTo #-}
299489collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
@@ -311,10 +501,15 @@ collectUpToGivenParent currentParent s e = do
311501
312502newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
313503
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
504+-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself
505+{-# INLINE wrap #-}
506+wrap
507+ :: forall s m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m, EventSpec s ~ GhcjsEventSpec)
508+ => Chan [DSum (EventTriggerRef t) TriggerInvocation]
509+ -> DOM.Element
510+ -> RawElementConfig er t s
511+ -> m (DMap EventName (EventFilterTriggerRef t er))
512+wrap events e cfg = do
318513 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
319514 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
320515 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
@@ -331,46 +526,74 @@ wrap e cfg = do
331526 mv <- liftJSM k --TODO: Only do this when the event is subscribed
332527 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
333528 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)
529+ return eventTriggerRefs
530+
531+{-# SPECIALIZE wrap
532+ :: Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
533+ -> DOM.Element
534+ -> RawElementConfig er DomTimeline HydrationDomSpace
535+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (DMap EventName (EventFilterTriggerRef DomTimeline er))
536+ #-}
537+
538+{-# SPECIALIZE wrap
539+ :: Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
540+ -> DOM.Element
541+ -> RawElementConfig er DomTimeline GhcjsDomSpace
542+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (DMap EventName (EventFilterTriggerRef DomTimeline er))
543+ #-}
544+
545+{-# INLINE triggerBody #-}
546+triggerBody
547+ :: forall s er t x. EventSpec s ~ GhcjsEventSpec
548+ => DOM.JSContextRef
549+ -> RawElementConfig er t s
550+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
551+ -> DMap EventName (EventFilterTriggerRef t er)
552+ -> DOM.Element
553+ -> WrapArg er EventName x
554+ -> EventTrigger t x
555+ -> IO (IO ())
556+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
557+ Just (EventFilterTriggerRef r) -> do
558+ writeIORef r $ Just t
559+ return $ do
560+ writeIORef r Nothing
561+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
562+ evt <- DOM.event
563+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
564+ case mv of
565+ Nothing -> return ()
566+ Just v -> liftIO $ do
567+ --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
568+ ref <- newIORef $ Just t
569+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
570+ where
571+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
572+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
573+ handler :: GhcjsEventHandler er
574+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
575+
576+{-# SPECIALIZE triggerBody
577+ :: DOM.JSContextRef
578+ -> RawElementConfig er DomTimeline HydrationDomSpace
579+ -> Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
580+ -> DMap EventName (EventFilterTriggerRef DomTimeline er)
581+ -> DOM.Element
582+ -> WrapArg er EventName x
583+ -> EventTrigger DomTimeline x
584+ -> IO (IO ())
585+ #-}
586+
587+{-# SPECIALIZE triggerBody
588+ :: DOM.JSContextRef
589+ -> RawElementConfig er DomTimeline GhcjsDomSpace
590+ -> Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
591+ -> DMap EventName (EventFilterTriggerRef DomTimeline er)
592+ -> DOM.Element
593+ -> WrapArg er EventName x
594+ -> EventTrigger DomTimeline x
595+ -> IO (IO ())
596+ #-}
374597
375598newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
376599
@@ -384,8 +607,8 @@ instance DomSpace GhcjsDomSpace where
384607 type EventSpec GhcjsDomSpace = GhcjsEventSpec
385608 type RawDocument GhcjsDomSpace = DOM.Document
386609 type RawTextNode GhcjsDomSpace = DOM.Text
610+ type RawCommentNode GhcjsDomSpace = DOM.Comment
387611 type RawElement GhcjsDomSpace = DOM.Element
388− type RawFile GhcjsDomSpace = DOM.File
389612 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement
390613 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement
391614 type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement
@@ -417,15 +640,11 @@ data GhcjsEventSpec er = GhcjsEventSpec
417640newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }
418641
419642#ifndef USE_TEMPLATE_HASKELL
420−phantom2 :: (Functor f, Contravariant f) => f a -> f b
421−phantom2 = phantom
422−{-# INLINE phantom2 #-}
423−
424643ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))
425644ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a
426645{-# INLINE ghcjsEventSpec_filters #-}
427646ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))
428−ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom2 (f b)
647+ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom (f b)
429648{-# INLINE ghcjsEventSpec_handler #-}
430649#endif
431650
@@ -438,137 +657,753 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
438657 runReaderT (defaultDomEventHandler e en) evt
439658 }
440659
441−instance SupportsImmediateDomBuilder t m => NotReady t (ImmediateDomBuilderT t m) where
660+{-# INLINE makeElement #-}
661+makeElement :: MonadJSM m => Document -> Text -> ElementConfig er t s -> m DOM.Element
662+makeElement doc elementTag cfg = do
663+ e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
664+ Nothing -> createElement doc elementTag
665+ Just ens -> createElementNS doc (Just ens) elementTag
666+ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
667+ Nothing -> setAttribute e n v
668+ Just ans -> setAttributeNS e (Just ans) n v
669+ pure e
670+
671+{-# INLINE elementImmediate #-}
672+elementImmediate
673+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
674+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m )
675+ => Text
676+ -> ElementConfig er t s
677+ -> HydrationDomBuilderT s t m a
678+ -> HydrationDomBuilderT s t m (Element er GhcjsDomSpace t, a)
679+elementImmediate elementTag cfg child = do
680+ doc <- askDocument
681+ ctx <- askJSM
682+ events <- askEvents
683+ parent <- getParent
684+ e <- makeElement doc elementTag cfg
685+ appendChild_ parent e
686+ -- Run the child builder with updated parent and previous sibling references
687+ result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child
688+ let rawCfg = extractRawElementConfig cfg
689+ eventTriggerRefs <- wrap events e rawCfg
690+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
691+ return (Element es e, result)
692+
693+{-# SPECIALIZE elementImmediate
694+ :: Text
695+ -> ElementConfig er DomTimeline HydrationDomSpace
696+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
697+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)
698+ #-}
699+
700+{-# SPECIALIZE elementImmediate
701+ :: Text
702+ -> ElementConfig er DomTimeline GhcjsDomSpace
703+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM a
704+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)
705+ #-}
706+
707+-- For specialisation
708+
709+-- | The Reflex timeline for interacting with the DOM
710+type DomTimeline =
711+#ifdef PROFILE_REFLEX
712+ ProfiledTimeline
713+#endif
714+ Spider
715+
716+-- | The ReflexHost the DOM lives in
717+type DomHost =
718+#ifdef PROFILE_REFLEX
719+ ProfiledM
720+#endif
721+ (SpiderHost Global)
722+
723+type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))
724+type HydrationM = DomCoreWidget ()
725+
726+{-# INLINE elementInternal #-}
727+elementInternal
728+ :: (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
729+ => Text
730+ -> ElementConfig er t HydrationDomSpace
731+ -> HydrationDomBuilderT HydrationDomSpace t m a
732+ -> HydrationDomBuilderT HydrationDomSpace t m (Element er HydrationDomSpace t, a)
733+elementInternal elementTag cfg child = getHydrationMode >>= \case
734+ HydrationMode_Immediate -> do
735+ (Element es _, result) <- elementImmediate elementTag cfg child
736+ return (Element es (), result)
737+ HydrationMode_Hydrating -> fst <$> hydrateElement elementTag cfg child
738+
739+{-# SPECIALIZE elementInternal
740+ :: Text
741+ -> ElementConfig er DomTimeline HydrationDomSpace
742+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
743+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
744+ #-}
745+
746+{-# INLINE hydrateElement #-}
747+hydrateElement
748+ :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
749+ => Text
750+ -> ElementConfig er t HydrationDomSpace
751+ -> HydrationDomBuilderT HydrationDomSpace t m a
752+ -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)
753+hydrateElement elementTag cfg child = do
754+ ctx <- askJSM
755+ events <- askEvents
756+ -- Schedule everything for after postBuild, except for getting the result itself
757+ parentRef <- liftIO $ newIORef $ error "Parent not yet initialized"
758+ e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"
759+ env <- HydrationDomBuilderT ask
760+ childDelayedRef <- liftIO $ newIORef $ pure ()
761+ let env' = env
762+ { _hydrationDomBuilderEnv_parent = Right parentRef
763+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
764+ }
765+ result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
766+ wrapResult <- liftIO newEmptyMVar
767+ let skipAttr = "data-hydration-skip" :: DOM.JSString
768+ ssrAttr = "data-ssr" :: DOM.JSString
769+ shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
770+ shouldSkip e = case cfg ^. namespace of
771+ Nothing -> do
772+ skip <- hasAttribute e skipAttr
773+ ssr <- hasAttribute e ssrAttr
774+ pure $ skip || not ssr
775+ Just ns -> do
776+ skip <- hasAttributeNS e (Just ns) skipAttr
777+ ssr <- hasAttributeNS e (Just ns) ssrAttr
778+ pure $ skip || not ssr
779+ childDom <- liftIO $ readIORef childDelayedRef
780+ let rawCfg = extractRawElementConfig cfg
781+ doc <- askDocument
782+ addHydrationStep $ do
783+ parent <- askParent
784+ lastHydrationNode <- getPreviousNode
785+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
786+ Nothing -> do -- ran out of nodes, create the element
787+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
788+ e <- makeElement doc elementTag cfg
789+ insertAfterPreviousNode e
790+ pure e
791+ Just node -> DOM.castTo DOM.Element node >>= \case
792+ Nothing -> go (Just node) -- this node is not an element, skip
793+ Just e -> shouldSkip e >>= \case
794+ True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
795+ False -> do
796+ t <- Element.getTagName e
797+ -- TODO: check attributes?
798+ if T.toCaseFold elementTag == T.toCaseFold t
799+ then pure e
800+ -- we came to some other statically rendered element, so something has gone wrong
801+ else do
802+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
803+ n <- makeElement doc elementTag cfg
804+ insertAfterPreviousNode n
805+ pure n
806+ e <- go lastHydrationNode
807+ setPreviousNode $ Just $ toNode e
808+ -- Update the parent node used by the children
809+ liftIO $ writeIORef parentRef $ toNode e
810+ liftIO $ writeIORef e' e
811+ -- Setup events, store the result so we can wait on it later
812+ refs <- wrap events e rawCfg
813+ liftIO $ putMVar wrapResult (e, refs)
814+ localRunner childDom Nothing $ toNode e
815+ -- We need the EventSelector to switch to the real event handler after activation
816+ es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
817+ cleanup <- newEmptyMVar
818+ threadId <- forkIO $ do
819+ -- Wait on the data we need from the delayed action
820+ (e, eventTriggerRefs) <- readMVar wrapResult
821+ bracketOnError
822+ -- Run the setup, acquiring the cleanup action
823+ (triggerBody ctx rawCfg events eventTriggerRefs e (WrapArg en) t)
824+ -- Run the cleanup, if we have it - but only when an exception is
825+ -- raised (we might get killed between acquiring the cleanup action
826+ -- from 'triggerBody' and putting it in the MVar)
827+ id
828+ -- Try to put this action into the cleanup MVar
829+ (putMVar cleanup)
830+ pure $ do
831+ tryReadMVar cleanup >>= \case
832+ Nothing -> killThread threadId
833+ Just c -> c
834+ return ((Element es (), result), e')
835+
836+{-# SPECIALIZE hydrateElement
837+ :: Text
838+ -> ElementConfig er DomTimeline HydrationDomSpace
839+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
840+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM ((Element er HydrationDomSpace DomTimeline, a), IORef DOM.Element)
841+ #-}
842+
843+{-# INLINE inputElementImmediate #-}
844+inputElementImmediate
845+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
846+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
847+ , MonadRef m, Ref m ~ IORef )
848+ => InputElementConfig er t s -> HydrationDomBuilderT s t m (InputElement er GhcjsDomSpace t)
849+inputElementImmediate cfg = do
850+ (e@(Element eventSelector domElement), ()) <- elementImmediate "input" (_inputElementConfig_elementConfig cfg) $ return ()
851+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
852+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
853+ v0 <- Input.getValue domInputElement
854+ let getMyValue = Input.getValue domInputElement
855+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
856+ valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
857+ Nothing -> return never
858+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
859+ Input.setValue domInputElement v'
860+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
861+ v <- holdDyn v0 $ leftmost
862+ [ valueChangedBySetValue
863+ , valueChangedByUI
864+ ]
865+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
866+ checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
867+ Input.getChecked domInputElement
868+ checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
869+ Nothing -> return never
870+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
871+ oldChecked <- Input.getChecked domInputElement
872+ Input.setChecked domInputElement newChecked
873+ return $ if newChecked /= oldChecked
874+ then Just newChecked
875+ else Nothing
876+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
877+ [ fmapMaybe id checkedChangedBySetChecked
878+ , checkedChangedByUI
879+ ]
880+ hasFocus <- mkHasFocus e
881+ files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
882+ mfiles <- Input.getFiles domInputElement
883+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
884+ maybe (return []) getMyFiles mfiles
885+ checked <- holdUniqDyn c
886+ return $ InputElement
887+ { _inputElement_value = v
888+ , _inputElement_checked = checked
889+ , _inputElement_checkedChange = checkedChangedByUI
890+ , _inputElement_input = valueChangedByUI
891+ , _inputElement_hasFocus = hasFocus
892+ , _inputElement_element = e
893+ , _inputElement_raw = domInputElement
894+ , _inputElement_files = files
895+ }
896+
897+{-# INLINE inputElementInternal #-}
898+inputElementInternal
899+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
900+ , MonadRef m, Ref m ~ IORef )
901+ => InputElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (InputElement er HydrationDomSpace t)
902+inputElementInternal cfg = getHydrationMode >>= \case
903+ HydrationMode_Immediate -> ffor (inputElementImmediate cfg) $ \result -> result
904+ { _inputElement_element = Element (_element_events $ _inputElement_element result) ()
905+ , _inputElement_raw = ()
906+ }
907+ HydrationMode_Hydrating -> do
908+ ((e, _), domElementRef) <- hydrateElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
909+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
910+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
911+ (focusChange, triggerFocusChange) <- newTriggerEvent
912+ (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent
913+ (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent
914+ (fileChange, triggerFileChange) <- newTriggerEvent
915+ doc <- askDocument
916+ -- Expected initial value from config
917+ let v0 = _inputElementConfig_initialValue cfg
918+ addHydrationStep $ do
919+ domElement <- liftIO $ readIORef domElementRef
920+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
921+ getValue = Input.getValue domInputElement
922+ -- The browser might have messed with the value, or the user could have
923+ -- altered it before activation, so we set it if it isn't what we expect
924+ liftJSM getValue >>= \v0' -> do
925+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
926+ -- Watch for user interaction and trigger event accordingly
927+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
928+ for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
929+ requestDomAction_ $ ffor eSetValue $ \v' -> do
930+ Input.setValue domInputElement v'
931+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
932+ liftIO $ triggerChangeBySetValue v
933+ let focusChange' = leftmost
934+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
935+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
936+ ]
937+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
938+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
939+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
940+ _ <- liftJSM $ domInputElement `on` Events.click $ do
941+ liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
942+ for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
943+ requestDomAction $ ffor eNewchecked $ \newChecked -> do
944+ oldChecked <- Input.getChecked domInputElement
945+ Input.setChecked domInputElement newChecked
946+ when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked
947+ _ <- liftJSM $ domInputElement `on` Events.change $ do
948+ mfiles <- Input.getFiles domInputElement
949+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
950+ liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
951+ return ()
952+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
953+ [ checkedChangedBySetChecked
954+ , checkedChangedByUI
955+ ]
956+ checked <- holdUniqDyn checked'
957+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
958+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
959+ v <- holdDyn v0 $ leftmost
960+ [ valueChangedBySetValue
961+ , valueChangedByUI
962+ ]
963+ files <- holdDyn mempty fileChange
964+ return $ InputElement
965+ { _inputElement_value = v
966+ , _inputElement_checked = checked
967+ , _inputElement_checkedChange = checkedChangedByUI
968+ , _inputElement_input = valueChangedByUI
969+ , _inputElement_hasFocus = hasFocus
970+ , _inputElement_element = e
971+ , _inputElement_raw = ()
972+ , _inputElement_files = files
973+ }
974+
975+{-# INLINE textAreaElementImmediate #-}
976+textAreaElementImmediate
977+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
978+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
979+ , MonadRef m, Ref m ~ IORef )
980+ => TextAreaElementConfig er t s -> HydrationDomBuilderT s t m (TextAreaElement er GhcjsDomSpace t)
981+textAreaElementImmediate cfg = do
982+ (e@(Element eventSelector domElement), _) <- elementImmediate "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
983+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
984+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
985+ v0 <- TextArea.getValue domTextAreaElement
986+ let getMyValue = TextArea.getValue domTextAreaElement
987+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
988+ valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
989+ Nothing -> return never
990+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
991+ TextArea.setValue domTextAreaElement v'
992+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
993+ v <- holdDyn v0 $ leftmost
994+ [ valueChangedBySetValue
995+ , valueChangedByUI
996+ ]
997+ hasFocus <- mkHasFocus e
998+ return $ TextAreaElement
999+ { _textAreaElement_value = v
1000+ , _textAreaElement_input = valueChangedByUI
1001+ , _textAreaElement_hasFocus = hasFocus
1002+ , _textAreaElement_element = e
1003+ , _textAreaElement_raw = domTextAreaElement
1004+ }
1005+
1006+{-# INLINE textAreaElementInternal #-}
1007+textAreaElementInternal
1008+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1009+ , MonadRef m, Ref m ~ IORef )
1010+ => TextAreaElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (TextAreaElement er HydrationDomSpace t)
1011+textAreaElementInternal cfg = getHydrationMode >>= \case
1012+ HydrationMode_Immediate -> ffor (textAreaElementImmediate cfg) $ \result -> result
1013+ { _textAreaElement_element = Element (_element_events $ _textAreaElement_element result) ()
1014+ , _textAreaElement_raw = ()
1015+ }
1016+ HydrationMode_Hydrating -> do
1017+ ((e, _), domElementRef) <- hydrateElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
1018+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1019+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1020+ (focusChange, triggerFocusChange) <- newTriggerEvent
1021+ doc <- askDocument
1022+ -- Expected initial value from config
1023+ let v0 = _textAreaElementConfig_initialValue cfg
1024+ addHydrationStep $ do
1025+ domElement <- liftIO $ readIORef domElementRef
1026+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
1027+ getValue = TextArea.getValue domTextAreaElement
1028+ -- The browser might have messed with the value, or the user could have
1029+ -- altered it before activation, so we set it if it isn't what we expect
1030+ liftJSM getValue >>= \v0' -> do
1031+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1032+ -- Watch for user interaction and trigger event accordingly
1033+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
1034+ for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
1035+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1036+ TextArea.setValue domTextAreaElement v'
1037+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1038+ liftIO $ triggerChangeBySetValue v
1039+ let focusChange' = leftmost
1040+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1041+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1042+ ]
1043+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1044+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1045+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1046+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1047+ v <- holdDyn v0 $ leftmost
1048+ [ valueChangedBySetValue
1049+ , valueChangedByUI
1050+ ]
1051+ return $ TextAreaElement
1052+ { _textAreaElement_value = v
1053+ , _textAreaElement_input = valueChangedByUI
1054+ , _textAreaElement_hasFocus = hasFocus
1055+ , _textAreaElement_element = e
1056+ , _textAreaElement_raw = ()
1057+ }
1058+
1059+{-# INLINE selectElementImmediate #-}
1060+selectElementImmediate
1061+ :: ( EventSpec s ~ GhcjsEventSpec, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
1062+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m )
1063+ => SelectElementConfig er t s
1064+ -> HydrationDomBuilderT s t m a
1065+ -> HydrationDomBuilderT s t m (SelectElement er GhcjsDomSpace t, a)
1066+selectElementImmediate cfg child = do
1067+ (e@(Element eventSelector domElement), result) <- elementImmediate "select" (cfg ^. selectElementConfig_elementConfig) child
1068+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1069+ Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
1070+ v0 <- Select.getValue domSelectElement
1071+ let getMyValue = Select.getValue domSelectElement
1072+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Change)
1073+ valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
1074+ Nothing -> return never
1075+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
1076+ Select.setValue domSelectElement v'
1077+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
1078+ v <- holdDyn v0 $ leftmost
1079+ [ valueChangedBySetValue
1080+ , valueChangedByUI
1081+ ]
1082+ hasFocus <- mkHasFocus e
1083+ let wrapped = SelectElement
1084+ { _selectElement_value = v
1085+ , _selectElement_change = valueChangedByUI
1086+ , _selectElement_hasFocus = hasFocus
1087+ , _selectElement_element = e
1088+ , _selectElement_raw = domSelectElement
1089+ }
1090+ return (wrapped, result)
1091+
1092+{-# INLINE selectElementInternal #-}
1093+selectElementInternal
1094+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1095+ , MonadRef m, Ref m ~ IORef )
1096+ => SelectElementConfig er t HydrationDomSpace
1097+ -> HydrationDomBuilderT HydrationDomSpace t m a
1098+ -> HydrationDomBuilderT HydrationDomSpace t m (SelectElement er HydrationDomSpace t, a)
1099+selectElementInternal cfg child = getHydrationMode >>= \case
1100+ HydrationMode_Immediate -> ffor (selectElementImmediate cfg child) $ \(e, result) -> (e
1101+ { _selectElement_element = Element (_element_events $ _selectElement_element e) ()
1102+ , _selectElement_raw = ()
1103+ }, result)
1104+ HydrationMode_Hydrating -> do
1105+ ((e, result), domElementRef) <- hydrateElement "select" (cfg ^. selectElementConfig_elementConfig) child
1106+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1107+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1108+ (focusChange, triggerFocusChange) <- newTriggerEvent
1109+ doc <- askDocument
1110+ -- Expected initial value from config
1111+ let v0 = _selectElementConfig_initialValue cfg
1112+ addHydrationStep $ do
1113+ domElement <- liftIO $ readIORef domElementRef
1114+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1115+ getValue = Select.getValue domSelectElement
1116+ -- The browser might have messed with the value, or the user could have
1117+ -- altered it before activation, so we set it if it isn't what we expect
1118+ liftJSM getValue >>= \v0' -> do
1119+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1120+ -- Watch for user interaction and trigger event accordingly
1121+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)
1122+ for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->
1123+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1124+ Select.setValue domSelectElement v'
1125+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1126+ liftIO $ triggerChangeBySetValue v
1127+ let focusChange' = leftmost
1128+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1129+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1130+ ]
1131+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1132+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1133+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1134+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1135+ v <- holdDyn v0 $ leftmost
1136+ [ valueChangedBySetValue
1137+ , valueChangedByUI
1138+ ]
1139+ return $ (,result) $ SelectElement
1140+ { _selectElement_value = v
1141+ , _selectElement_change = valueChangedByUI
1142+ , _selectElement_hasFocus = hasFocus
1143+ , _selectElement_element = e
1144+ , _selectElement_raw = ()
1145+ }
1146+
1147+{-# INLINE textNodeImmediate #-}
1148+textNodeImmediate
1149+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1150+ => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text
1151+textNodeImmediate (TextNodeConfig !t mSetContents) = do
1152+ p <- getParent
1153+ doc <- askDocument
1154+ n <- createTextNode doc t
1155+ appendChild_ p n
1156+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1157+ pure n
1158+
1159+{-# SPECIALIZE textNodeImmediate
1160+ :: TextNodeConfig DomTimeline
1161+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM DOM.Text
1162+ #-}
1163+
1164+{-# SPECIALIZE textNodeImmediate
1165+ :: TextNodeConfig DomTimeline
1166+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM DOM.Text
1167+ #-}
1168+
1169+{-# INLINE textNodeInternal #-}
1170+textNodeInternal
1171+ :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)
1172+ => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)
1173+textNodeInternal tc@(TextNodeConfig !t mSetContents) = do
1174+ doc <- askDocument
1175+ getHydrationMode >>= \case
1176+ HydrationMode_Immediate -> void $ textNodeImmediate tc
1177+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do
1178+ n <- hydrateTextNode doc =<< sample currentText
1179+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1180+ pure $ TextNode ()
1181+
1182+{-# SPECIALIZE textNodeInternal
1183+ :: TextNodeConfig DomTimeline
1184+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (TextNode HydrationDomSpace DomTimeline)
1185+ #-}
1186+
1187+-- | The static builder mashes adjacent text nodes into one node: we check the
1188+-- text content of each node we come to, comparing it to the content we
1189+-- expect. We also have a special case for empty text nodes - we always create
1190+-- the and add them after the previous node reference.
1191+{-# INLINE hydrateTextNode #-}
1192+hydrateTextNode :: MonadJSM m => Document -> Text -> HydrationRunnerT t m DOM.Text
1193+hydrateTextNode doc t@"" = do
1194+ tn <- createTextNode doc t
1195+ insertAfterPreviousNode tn
1196+ pure tn
1197+hydrateTextNode doc t = do
1198+ n <- join $ go <$> askParent <*> getPreviousNode
1199+ setPreviousNode $ Just $ toNode n
1200+ return n
1201+ where
1202+ go parent mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1203+ Nothing -> do
1204+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1205+ n <- createTextNode doc t
1206+ insertAfterPreviousNode n
1207+ pure n
1208+ Just node -> DOM.castTo DOM.Text node >>= \case
1209+ Nothing -> go parent $ Just node
1210+ Just originalNode -> do
1211+ originalText <- Node.getTextContentUnchecked originalNode
1212+ case T.stripPrefix t originalText of
1213+ Just "" -> return originalNode
1214+ Just _ -> do
1215+ -- If we have the right prefix, we split the text node into a node containing the
1216+ -- required text and a subsequent sibling node containing the rest of the text.
1217+ DOM.splitText_ originalNode $ fromIntegral $ T.length t
1218+ return originalNode
1219+ Nothing -> do
1220+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1221+ n <- createTextNode doc t
1222+ insertAfterPreviousNode n
1223+ pure n
1224+
1225+{-# INLINE commentNodeImmediate #-}
1226+commentNodeImmediate
1227+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1228+ => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment
1229+commentNodeImmediate (CommentNodeConfig !t mSetContents) = do
1230+ p <- getParent
1231+ doc <- askDocument
1232+ n <- createComment doc t
1233+ appendChild_ p n
1234+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1235+ pure n
1236+
1237+{-# INLINE commentNodeInternal #-}
1238+commentNodeInternal
1239+ :: (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)
1240+ => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)
1241+commentNodeInternal tc@(CommentNodeConfig t0 mSetContents) = do
1242+ doc <- askDocument
1243+ getHydrationMode >>= \case
1244+ HydrationMode_Immediate -> void $ commentNodeInternal tc
1245+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do
1246+ t <- sample bt
1247+ void $ hydrateComment doc t mSetContents
1248+ pure $ CommentNode ()
1249+
1250+{-# INLINE hydrateComment #-}
1251+hydrateComment :: (MonadJSM m, Reflex t, MonadFix m) => Document -> Text -> Maybe (Event t Text) -> HydrationRunnerT t m DOM.Comment
1252+hydrateComment doc t mSetContents = do
1253+ parent <- askParent
1254+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1255+ Nothing -> do
1256+ c <- createComment doc t
1257+ insertAfterPreviousNode c
1258+ pure c
1259+ Just node -> DOM.castTo DOM.Comment node >>= \case
1260+ Nothing -> go (Just node)
1261+ Just c -> do
1262+ t' <- Node.getTextContentUnchecked c
1263+ if t == t'
1264+ then pure c
1265+ else do
1266+ c' <- createComment doc t
1267+ insertAfterPreviousNode c'
1268+ pure c'
1269+ n <- go =<< getPreviousNode
1270+ setPreviousNode $ Just $ toNode n
1271+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1272+ pure n
1273+
1274+-- | We leave markers in the static builder as comments, and rip these comments
1275+-- out at hydration time, replacing them with empty text nodes.
1276+{-# INLINABLE skipToAndReplaceComment #-}
1277+skipToAndReplaceComment
1278+ :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1279+ => Text
1280+ -> IORef Text
1281+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1282+skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
1283+ HydrationMode_Immediate -> do
1284+ -- If we're in immediate mode, we don't try to replace an existing comment,
1285+ -- and just return a dummy key
1286+ t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
1287+ append $ toNode t
1288+ textNodeRef <- liftIO $ newIORef t
1289+ keyRef <- liftIO $ newIORef ""
1290+ pure (pure (), textNodeRef, keyRef)
1291+ HydrationMode_Hydrating -> do
1292+ doc <- askDocument
1293+ textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
1294+ keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1295+ let go key0 mLastNode = do
1296+ parent <- askParent
1297+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1298+ DOM.castTo DOM.Comment node >>= \case
1299+ Just comment -> do
1300+ commentText <- Node.getTextContentUnchecked comment
1301+ case T.stripPrefix (prefix <> key0) commentText of
1302+ Just key -> do
1303+ -- Replace the comment with an (invisible) text node
1304+ tn <- createTextNode doc ("" :: Text)
1305+ Node.replaceChild_ parent tn comment
1306+ pure (tn, key)
1307+ Nothing -> do
1308+ go key0 (Just node)
1309+ Nothing -> do
1310+ go key0 (Just node)
1311+ switchComment = do
1312+ key0 <- liftIO $ readIORef key0Ref
1313+ (tn, key) <- go key0 =<< getPreviousNode
1314+ setPreviousNode $ Just $ toNode tn
1315+ liftIO $ do
1316+ writeIORef textNodeRef tn
1317+ writeIORef keyRef key
1318+ pure (switchComment, textNodeRef, keyRef)
1319+
1320+{-# INLINABLE skipToReplaceStart #-}
1321+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)
1322+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
1323+
1324+{-# INLINABLE skipToReplaceEnd #-}
1325+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)
1326+skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
1327+
1328+instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
4421329 notReadyUntil e = do
4431330 eOnce <- headE e
444− env <- ImmediateDomBuilderT ask
445− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1331+ unreadyChildren <- askUnreadyChildren
1332+ commitAction <- askCommitAction
4461333 liftIO $ modifyIORef' unreadyChildren succ
4471334 let ready = do
4481335 old <- liftIO $ readIORef unreadyChildren
4491336 let new = pred old
4501337 liftIO $ writeIORef unreadyChildren $! new
451− when (new == 0) $ _immediateDomBuilderEnv_commitAction env
1338+ when (new == 0) commitAction
4521339 requestDomAction_ $ ready <$ eOnce
4531340 notReady = do
454− env <- ImmediateDomBuilderT ask
455− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1341+ unreadyChildren <- askUnreadyChildren
4561342 liftIO $ modifyIORef' unreadyChildren succ
4571343
458−instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
459− type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace
1344+data HydrationDomSpace
1345+
1346+instance DomSpace HydrationDomSpace where
1347+ type EventSpec HydrationDomSpace = GhcjsEventSpec
1348+ type RawDocument HydrationDomSpace = DOM.Document
1349+ type RawTextNode HydrationDomSpace = ()
1350+ type RawCommentNode HydrationDomSpace = ()
1351+ type RawElement HydrationDomSpace = ()
1352+ type RawInputElement HydrationDomSpace = ()
1353+ type RawTextAreaElement HydrationDomSpace = ()
1354+ type RawSelectElement HydrationDomSpace = ()
1355+ addEventSpecFlags _ en f es = es
1356+ { _ghcjsEventSpec_filters =
1357+ let f' = Just . GhcjsEventFilter . \case
1358+ Nothing -> \evt -> do
1359+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)
1360+ return (f mEventResult, return mEventResult)
1361+ Just (GhcjsEventFilter oldFilter) -> \evt -> do
1362+ (oldFlags, oldContinuation) <- oldFilter evt
1363+ mEventResult <- oldContinuation
1364+ let newFlags = oldFlags <> f mEventResult
1365+ return (newFlags, return mEventResult)
1366+ in DMap.alter f' en $ _ghcjsEventSpec_filters es
1367+ }
1368+
1369+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT HydrationDomSpace t m) where
1370+ type DomBuilderSpace (HydrationDomBuilderT HydrationDomSpace t m) = HydrationDomSpace
1371+ {-# INLINABLE element #-}
1372+ element = elementInternal
4601373 {-# INLINABLE textNode #-}
461− textNode (TextNodeConfig initialContents mSetContents) = do
462− n <- textNodeInternal initialContents
463− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
464− return $ TextNode n
1374+ textNode = textNodeInternal
1375+ {-# INLINABLE commentNode #-}
1376+ commentNode = commentNodeInternal
1377+ {-# INLINABLE inputElement #-}
1378+ inputElement = inputElementInternal
1379+ {-# INLINABLE textAreaElement #-}
1380+ textAreaElement = textAreaElementInternal
1381+ {-# INLINABLE selectElement #-}
1382+ selectElement = selectElementInternal
1383+ placeRawElement () = pure ()
1384+ wrapRawElement () _cfg = pure $ Element (EventSelector $ const never) ()
1385+
1386+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1387+ type DomBuilderSpace (HydrationDomBuilderT GhcjsDomSpace t m) = GhcjsDomSpace
4651388 {-# INLINABLE element #-}
466− element elementTag cfg child = fst <$> makeElement elementTag cfg child
1389+ element = elementImmediate
1390+ {-# INLINABLE textNode #-}
1391+ textNode = fmap TextNode . textNodeImmediate
1392+ {-# INLINABLE commentNode #-}
1393+ commentNode = fmap CommentNode . commentNodeImmediate
4671394 {-# 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− }
1395+ inputElement = inputElementImmediate
5191396 {-# 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− }
1397+ textAreaElement = textAreaElementImmediate
5441398 {-# 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)
1399+ selectElement = selectElementImmediate
5701400 placeRawElement = append . toNode
571− wrapRawElement = wrap
1401+ wrapRawElement e rawCfg = do
1402+ events <- askEvents
1403+ ctx <- askJSM
1404+ eventTriggerRefs <- wrap events e rawCfg
1405+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
1406+ pure $ Element es e
5721407
5731408data FragmentState
5741409 = FragmentState_Unmounted
@@ -588,21 +1423,21 @@ extractFragment fragment = do
5881423 extractBetweenExclusive (_immediateDomFragment_document fragment) before after
5891424 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
5901425
591−instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
592− type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
1426+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1427+ type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment
5931428 buildDomFragment w = do
5941429 df <- createDocumentFragment =<< askDocument
5951430 result <- flip localEnv w $ \env -> env
596− { _immediateDomBuilderEnv_parent = toNode df
1431+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
5971432 }
5981433 state <- liftIO $ newIORef FragmentState_Unmounted
5991434 return (ImmediateDomFragment df state, result)
6001435 mountDomFragment fragment setFragment = do
601− parent <- askParent
1436+ parent <- getParent
6021437 extractFragment fragment
603− before <- textNodeInternal ("" :: Text)
1438+ before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6041439 appendChild_ parent $ _immediateDomFragment_document fragment
605− after <- textNodeInternal ("" :: Text)
1440+ after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6061441 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
6071442 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
6081443 extractFragment previousFragment
@@ -611,12 +1446,19 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
6111446 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
6121447 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
6131448
614−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
1449+instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (DomRenderHookT t m) where
1450+ runWithReplace a0 a' = DomRenderHookT $ runWithReplace (unDomRenderHookT a0) (fmapCheap unDomRenderHookT a')
1451+ traverseIntMapWithKeyWithAdjust f m = DomRenderHookT . traverseIntMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1452+ traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1453+ traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
1454+
1455+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
6151456 {-# INLINABLE runWithReplace #-}
6161457 runWithReplace a0 a' = do
617− initialEnv <- ImmediateDomBuilderT ask
618− before <- textNodeInternal ("" :: Text)
619− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
1458+ initialEnv <- HydrationDomBuilderT ask
1459+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
1460+ (hydrateStart, before, beforeKey) <- skipToReplaceStart
1461+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
6201462 haveEverBeenReady <- liftIO $ newIORef False
6211463 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
6221464 let myCommitAction = do
@@ -627,79 +1469,117 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
6271469 old <- liftIO $ readIORef parentUnreadyChildren
6281470 let new = pred old
6291471 liftIO $ writeIORef parentUnreadyChildren $! new
630− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
1472+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
6311473 -- We draw 'after' in this roundabout way to avoid using MonadFix
6321474 doc <- askDocument
633− after <- createTextNode doc ("" :: Text)
1475+ parent <- getParent
1476+ (hydrateEnd, after) <- skipToReplaceEnd beforeKey
6341477 let drawInitialChild = do
1478+ h <- liftIO $ readIORef hydrating
1479+ p' <- case h of
1480+ HydrationMode_Hydrating -> pure parent
1481+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6351482 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
1483+ let a0' = case h of
1484+ HydrationMode_Hydrating -> a0
1485+ HydrationMode_Immediate -> do
1486+ a <- a0
1487+ insertBefore p' =<< liftIO (readIORef after)
1488+ pure a
1489+ delayed <- case h of
1490+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1491+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1492+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv
1493+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1494+ , _hydrationDomBuilderEnv_commitAction = myCommitAction
1495+ , _hydrationDomBuilderEnv_parent = Left p'
1496+ , _hydrationDomBuilderEnv_delayed = delayed
6431497 }
1498+ dom <- case h of
1499+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1500+ HydrationMode_Immediate -> pure $ pure ()
6441501 liftIO $ readIORef unreadyChildren >>= \case
6451502 0 -> writeIORef haveEverBeenReady True
6461503 _ -> modifyIORef' parentUnreadyChildren succ
647− return result
1504+ return (dom, result)
6481505 a'' <- numberOccurrences a'
649− (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
650− df <- createDocumentFragment doc
1506+ ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
1507+ h <- liftIO $ readIORef hydrating
1508+ p' <- case h of
1509+ HydrationMode_Hydrating -> pure parent
1510+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6511511 unreadyChildren <- liftIO $ newIORef 0
6521512 let commitAction = do
6531513 c <- liftIO $ readIORef currentCohort
6541514 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
655− deleteBetweenExclusive before after
656− insertBefore df after
1515+ !before' <- liftIO $ readIORef before
1516+ !after' <- liftIO $ readIORef after
1517+ deleteBetweenExclusive before' after'
1518+ insertBefore p' after'
6571519 liftIO $ writeIORef currentCohort cohortId
6581520 myCommitAction
659− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
660− { _immediateDomBuilderEnv_parent = toNode df
661− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
662− , _immediateDomBuilderEnv_commitAction = commitAction
663− }
1521+ delayed <- case h of
1522+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1523+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1524+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv
1525+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1526+ , _hydrationDomBuilderEnv_commitAction = case h of
1527+ HydrationMode_Hydrating -> myCommitAction
1528+ HydrationMode_Immediate -> commitAction
1529+ , _hydrationDomBuilderEnv_parent = Left p'
1530+ , _hydrationDomBuilderEnv_delayed = delayed
1531+ }
1532+ dom <- case h of
1533+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1534+ HydrationMode_Immediate -> pure $ pure ()
6641535 uc <- liftIO $ readIORef unreadyChildren
6651536 let commitActionToRunNow = if uc == 0
666− then Just commitAction
1537+ then Just $ commitAction
6671538 else Nothing -- A child will run it when unreadyChildren is decremented to 0
668− return (commitActionToRunNow, result)
669− requestDomAction_ $ fmapMaybe fst child'
1539+ actions = case h of
1540+ HydrationMode_Hydrating -> Left dom
1541+ HydrationMode_Immediate -> Right commitActionToRunNow
1542+ return (actions, result)
1543+ let (hydrate', commitAction) = fanEither $ fmap fst child'
1544+ addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do
1545+ hydrateStart
1546+ join $ sample contents
1547+ hydrateEnd
1548+ requestDomAction_ $ fmapMaybe id commitAction
6701549 return (result0, snd <$> child')
1550+
6711551 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
6721552 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
6731553 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
6741554 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
6751555 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
6761556 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)
1557+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do
1558+ 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)
6791559 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
680− PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
681− readIORef sRef >>= \case
1560+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete
1561+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do
1562+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
6821563 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
6831564 ChildReadyState_Unready _ -> do
684− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
685− return $ PatchDMapWithMove.From_Insert $ Constant sRef
1565+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
1566+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)
6861567 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
6871568 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)
1569+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState (Some k)))) (ComposeMaybe k) a -> IO (Constant () a)
6891570 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
1571+ writeIORef sRef $ ChildReadyState_Unready $ Some <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
6911572 return $ Constant ()
6921573 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
6931574 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
6941575 return $ applyAlways p' old
695− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
1576+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) -> do
6961577 let p = unPatchDMapWithMove p_
6971578 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)
1579+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
7001580 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
1581+ let mThisPlaceholder = Map.lookup (Some k) phsBefore -- Will be Nothing if this element wasn't present before
1582+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phsBefore
7031583 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
7041584 False -> do
7051585 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
@@ -707,13 +1587,22 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7071587 True -> do
7081588 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
7091589 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)
1590+ let !phsAfter = fromMaybe phsBefore $ apply filtered phsBefore
1591+ weakened :: PatchMapWithMove (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1592+ weakened = weakenPatchDMapWithMoveWith (_traverseChild_mode . getCompose) p_
1593+ filtered :: PatchMapWithMove (Some k) DOM.Text
1594+ filtered = PatchMapWithMove $ flip Map.mapMaybe (unPatchMapWithMove weakened) $ \(PatchMapWithMove.NodeInfo from to) -> flip PatchMapWithMove.NodeInfo to <$> case from of
1595+ PatchMapWithMove.From_Insert (Left _hydration) -> Nothing
1596+ PatchMapWithMove.From_Insert (Right immediate) -> Just $ PatchMapWithMove.From_Insert $ _traverseChildImmediate_placeholder immediate
1597+ PatchMapWithMove.From_Delete -> Just $ PatchMapWithMove.From_Delete
1598+ PatchMapWithMove.From_Move k -> Just $ PatchMapWithMove.From_Move k
1599+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a)
7121600 placeFragment k e = do
713− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
1601+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phsAfter
7141602 case PatchDMapWithMove._nodeInfo_from e of
715− PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
716− df `insertBefore` nextPlaceholder
1603+ PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of
1604+ Left _ -> pure ()
1605+ Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
7171606 PatchDMapWithMove.From_Delete -> do
7181607 return ()
7191608 PatchDMapWithMove.From_Move fromKey -> do
@@ -724,105 +1613,166 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7241613 liftIO $ writeIORef placeholders $! phsAfter
7251614
7261615{-# 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'))
1616+traverseDMapWithKeyWithAdjust'
1617+ :: 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)
1618+ => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1619+ -> DMap k v
1620+ -> Event t (PatchDMap k v)
1621+ -> HydrationDomBuilderT s t m (DMap k v', Event t (PatchDMap k v'))
7281622traverseDMapWithKeyWithAdjust' = 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)
1623+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some k)) v')) old = do
1624+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)
7311625 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
7321626 Nothing -> return Nothing
733− Just (Compose (_, _, sRef, _)) -> do
734− readIORef sRef >>= \case
1627+ Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing
1628+ Just (Compose (TraverseChild (Right immediate) _)) -> do
1629+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
7351630 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
7361631 ChildReadyState_Unready _ -> do
737− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
738− return $ Just $ Constant sRef
1632+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
1633+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
7391634 delete _ (Constant sRef) = do
7401635 writeIORef sRef $ ChildReadyState_Unready Nothing
7411636 return $ Constant ()
7421637 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
7431638 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
7441639 return $ applyAlways p' old
745− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
1640+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do
7461641 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
1642+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do
1643+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phs
1644+ -- Delete old node
1645+ forM_ (Map.lookup (Some k) phs) $ \thisPlaceholder -> do
1646+ thisPlaceholder `deleteUpTo` nextPlaceholder
1647+ -- Insert new node
1648+ forM_ mv $ \(Compose (TraverseChild e _)) -> case e of
1649+ Left _hydration -> pure ()
1650+ Right immediate -> do
1651+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1652+ let weakened :: PatchMap (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1653+ weakened = weakenPatchDMapWith (_traverseChild_mode . getCompose) $ PatchDMap patch
1654+ filtered :: PatchMap (Some k) DOM.Text
1655+ filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case
1656+ Nothing -> Just Nothing -- deletion
1657+ Just (Left _) -> Nothing
1658+ Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1659+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
7531660
7541661{-# 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'))
1662+traverseIntMapWithKeyWithAdjust'
1663+ :: 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)
1664+ => (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1665+ -> IntMap v
1666+ -> Event t (PatchIntMap v)
1667+ -> HydrationDomBuilderT s t m (IntMap v', Event t (PatchIntMap v'))
7561668traverseIntMapWithKeyWithAdjust' = 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))
1669+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do
1670+ let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))
7591671 new k m = case m of
7601672 Nothing -> return Nothing
761− Just (_, _, sRef, _) -> do
1673+ Just (TraverseChild (Left _hydration) _) -> pure Nothing
1674+ Just (TraverseChild (Right immediate) _) -> do
1675+ let sRef = _traverseChildImmediate_childReadyState immediate
7621676 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
1677+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
1678+ ChildReadyState_Unready _ -> do
1679+ writeIORef sRef $ ChildReadyState_Unready $ Just k
7661680 return $ Just sRef
7671681 delete _ sRef = do
768− writeIORef sRef $ ChildReadyStateInt_Unready Nothing
1682+ writeIORef sRef $ ChildReadyState_Unready Nothing
7691683 return ()
7701684 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
7711685 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
7721686 return $ applyAlways p' old
773− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do
1687+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do
7741688 phs <- liftIO $ readIORef placeholders
7751689 forM_ (IntMap.toList p) $ \(k, mv) -> do
776− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
7771690 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
1691+ -- Delete old node
7781692 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
1693+ -- Insert new node
1694+ forM_ mv $ \(TraverseChild e _) -> case e of
1695+ Left _hydration -> pure ()
1696+ Right immediate -> do
1697+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1698+ let filtered :: PatchIntMap DOM.Text
1699+ filtered = PatchIntMap $ flip IntMap.mapMaybe p $ \case
1700+ Nothing -> Just Nothing -- deletion
1701+ Just tc
1702+ | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1703+ | otherwise -> Nothing
1704+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
1705+
1706+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1707+ :: (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1708+ -> IntMap v
1709+ -> Event DomTimeline (PatchIntMap v)
1710+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1711+ #-}
7811712
782−#if MIN_VERSION_base(4,9,0)
783−data ChildReadyState k
784−#else
785−data ChildReadyState (k :: * -> *)
786−#endif
1713+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1714+ :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
1715+ -> IntMap v
1716+ -> Event DomTimeline (PatchIntMap v)
1717+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1718+ #-}
1719+
1720+data ChildReadyState a
7871721 = ChildReadyState_Ready
788− | ChildReadyState_Unready !(Maybe (Some k))
1722+ | ChildReadyState_Unready !(Maybe a)
7891723 deriving (Show, Read, Eq, Ord)
7901724
791−data ChildReadyStateInt
792− = ChildReadyStateInt_Ready
793− | ChildReadyStateInt_Unready !(Maybe Int)
794− deriving (Show, Read, Eq, Ord)
1725+insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()
1726+insertAfterPreviousNode node = do
1727+ parent <- askParent
1728+ nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode
1729+ Node.insertBefore_ parent node nextNode
1730+ setPreviousNode $ Just $ toNode node
7951731
796−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
797−hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1732+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1733+hoistTraverseWithKeyWithAdjust
1734+ ::
7981735 ( Adjustable t m
1736+ , MonadHold t m
1737+ , DMap.GCompare k
7991738 , MonadIO m
8001739 , MonadJSM m
801− , MonadFix m
8021740 , PrimMonad m
803− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
804− , Functor p
1741+ , MonadFix m
1742+ , Patch (p k v)
1743+ , Patch (p k (Constant Int))
1744+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1745+ , Patch (p k (Compose (TraverseChild t m (Some k)) v'))
1746+ , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v')
1747+ , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))
1748+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
8051749 )
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
1750+ => (forall vv vv'.
1751+ (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
1752+ -> DMap k vv
1753+ -> Event t (p k vv)
1754+ -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))
1755+ -- ^ The base monad's traversal
1756+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')
1757+ -- ^ A way of mapping over the patch type
1758+ -> (p k (Compose (TraverseChild t m (Some k)) v') -> DMap k (Constant (IORef (ChildReadyState (Some k)))) -> IO (DMap k (Constant (IORef (ChildReadyState (Some k))))))
1759+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1760+ -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())
1761+ -- ^ Apply a patch to the DOM
1762+ -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1763+ -> DMap k v
1764+ -> Event t (p k v)
1765+ -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))
1766+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1767+ doc <- askDocument
1768+ initialEnv <- HydrationDomBuilderT ask
1769+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1770+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty
8211771 haveEverBeenReady <- liftIO $ newIORef False
822− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
823− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1772+ placeholders <- liftIO $ newIORef Map.empty
1773+ lastPlaceholder <- createTextNode doc ("" :: Text)
8241774 let applyDomUpdate p = do
825− applyDomUpdate_ placeholders lastPlaceholderRef p
1775+ applyDomUpdate_ placeholders lastPlaceholder p
8261776 markSelfReady
8271777 liftIO $ writeIORef pendingChange $! mempty
8281778 markSelfReady = do
@@ -833,86 +1783,105 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
8331783 old <- liftIO $ readIORef parentUnreadyChildren
8341784 let new = pred old
8351785 liftIO $ writeIORef parentUnreadyChildren $! new
836− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
837− markChildReady :: IORef ChildReadyStateInt -> JSM ()
1786+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1787+ markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()
8381788 markChildReady childReadyState = do
8391789 liftIO (readIORef childReadyState) >>= \case
840− ChildReadyStateInt_Ready -> return ()
841− ChildReadyStateInt_Unready countedAt -> do
842− liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1790+ ChildReadyState_Ready -> return ()
1791+ ChildReadyState_Unready countedAt -> do
1792+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
8431793 case countedAt of
8441794 Nothing -> return ()
845− Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
1795+ Just (Some k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
8461796 (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
1797+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
1798+ let newUnready = DMap.delete k oldUnready
8491799 liftIO $ writeIORef pendingChange (newUnready, p)
850− when (IntMap.null newUnready) $ do
1800+ when (DMap.null newUnready) $ do
8511801 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
1802+ (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))
1803+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1804+ let processChild k (Compose (TraverseChild e _)) = case e of
1805+ Left _ -> pure $ ComposeMaybe Nothing
1806+ Right immediate -> ComposeMaybe <$> do
1807+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1808+ ChildReadyState_Ready -> return Nothing
1809+ ChildReadyState_Unready _ -> do
1810+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
1811+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
1812+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1813+ liftIO $ if DMap.null initialUnready
8611814 then writeIORef haveEverBeenReady True
8621815 else do
8631816 modifyIORef' parentUnreadyChildren succ
8641817 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)
1818+ getHydrationMode >>= \case
1819+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1820+ dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1821+ phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
1822+ liftIO $ writeIORef placeholders $! phs
1823+ insertAfterPreviousNode lastPlaceholder
1824+ HydrationMode_Immediate -> do
1825+ let activate i = do
1826+ append $ toNode $ _traverseChildImmediate_fragment i
1827+ pure $ _traverseChildImmediate_placeholder i
1828+ phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1829+ liftIO $ writeIORef placeholders $! phs
1830+ append $ toNode lastPlaceholder
8711831 requestDomAction_ $ ffor children' $ \p -> do
8721832 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
8731833 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
8741834 let !newP = p <> oldP
8751835 liftIO $ writeIORef pendingChange (newUnready, newP)
876− when (IntMap.null newUnready) $ do
1836+ when (DMap.null newUnready) $ do
8771837 applyDomUpdate newP
1838+ let result0 = DMap.map (_traverseChild_result . getCompose) children0
1839+ result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose
8781840 return (result0, result')
8791841
880−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
881−hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1842+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
1843+hoistTraverseIntMapWithKeyWithAdjust ::
8821844 ( Adjustable t m
8831845 , MonadHold t m
884− , DMap.GCompare k
885− , MonadIO m
8861846 , MonadJSM m
887− , PrimMonad m
8881847 , 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))
1848+ , PrimMonad m
1849+ , Monoid (p (TraverseChild t m Int v'))
1850+ , Functor p
1851+ , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())
1852+ , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')
1853+ , Patch (p (HydrationRunnerT t m ()))
1854+ , Patch (p (TraverseChild t m Int v'))
1855+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
8931856 )
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
1857+ => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))
1858+ -> IntMap v
1859+ -> Event t (p v)
1860+ -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))
1861+ -- ^ The base monad's traversal
1862+ -> (p (TraverseChild t m Int v')
1863+ -> IntMap (IORef (ChildReadyState Int))
1864+ -> IO (IntMap (IORef (ChildReadyState Int))))
1865+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1866+ -> (IORef (IntMap DOM.Text)
1867+ -> DOM.Text
1868+ -> p (TraverseChild t m Int v')
1869+ -> JSM ())
1870+ -- ^ Apply a patch to the DOM
1871+ -> (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1872+ -> IntMap v
1873+ -> Event t (p v)
1874+ -> HydrationDomBuilderT s t m (IntMap v', Event t (p v'))
1875+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1876+ doc <- askDocument
1877+ initialEnv <- HydrationDomBuilderT ask
1878+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1879+ pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty
9111880 haveEverBeenReady <- liftIO $ newIORef False
912− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
913− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1881+ placeholders <- liftIO $ newIORef IntMap.empty
1882+ lastPlaceholder <- createTextNode doc ("" :: Text)
9141883 let applyDomUpdate p = do
915− applyDomUpdate_ placeholders lastPlaceholderRef p
1884+ applyDomUpdate_ placeholders lastPlaceholder p
9161885 markSelfReady
9171886 liftIO $ writeIORef pendingChange $! mempty
9181887 markSelfReady = do
@@ -923,8 +1892,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9231892 old <- liftIO $ readIORef parentUnreadyChildren
9241893 let new = pred old
9251894 liftIO $ writeIORef parentUnreadyChildren $! new
926− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
927− markChildReady :: IORef (ChildReadyState k) -> JSM ()
1895+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1896+ markChildReady :: IORef (ChildReadyState Int) -> JSM ()
9281897 markChildReady childReadyState = do
9291898 liftIO (readIORef childReadyState) >>= \case
9301899 ChildReadyState_Ready -> return ()
@@ -932,82 +1901,191 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9321901 liftIO $ writeIORef childReadyState ChildReadyState_Ready
9331902 case countedAt of
9341903 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
1904+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
9361905 (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
1906+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
1907+ let newUnready = IntMap.delete k oldUnready
9391908 liftIO $ writeIORef pendingChange (newUnready, p)
940− when (DMap.null newUnready) $ do
1909+ when (IntMap.null newUnready) $ do
9411910 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
1911+ (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))
1912+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1913+ let processChild k (TraverseChild e _) = case e of
1914+ Left _ -> pure Nothing
1915+ Right immediate -> do
1916+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1917+ ChildReadyState_Ready -> return Nothing
1918+ ChildReadyState_Unready _ -> do
1919+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k
1920+ return $ Just (_traverseChildImmediate_childReadyState immediate)
1921+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
1922+ liftIO $ if IntMap.null initialUnready
9511923 then writeIORef haveEverBeenReady True
9521924 else do
9531925 modifyIORef' parentUnreadyChildren succ
9541926 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)
1927+ getHydrationMode >>= \case
1928+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1929+ dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children
1930+ phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm
1931+ liftIO $ writeIORef placeholders $! phs
1932+ insertAfterPreviousNode lastPlaceholder
1933+ HydrationMode_Immediate -> do
1934+ let activate i = do
1935+ append $ toNode $ _traverseChildImmediate_fragment i
1936+ pure $ _traverseChildImmediate_placeholder i
1937+ phs <- traverse (either (error "impossible") activate . _traverseChild_mode) children0
1938+ liftIO $ writeIORef placeholders $! phs
1939+ append $ toNode lastPlaceholder
9611940 requestDomAction_ $ ffor children' $ \p -> do
9621941 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
9631942 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
9641943 let !newP = p <> oldP
9651944 liftIO $ writeIORef pendingChange (newUnready, newP)
966− when (DMap.null newUnready) $ do
1945+ when (IntMap.null newUnready) $ do
9671946 applyDomUpdate newP
1947+ let result0 = IntMap.map _traverseChild_result children0
1948+ result' = ffor children' $ fmap $ _traverseChild_result
9681949 return (result0, result')
9691950
1951+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1952+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))
1953+ -> IntMap v
1954+ -> Event DomTimeline (PatchIntMap v)
1955+ -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))
1956+ -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1957+ -> IntMap (IORef (ChildReadyState Int))
1958+ -> IO (IntMap (IORef (ChildReadyState Int))))
1959+ -> (IORef (IntMap DOM.Text)
1960+ -> DOM.Text
1961+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1962+ -> JSM ())
1963+ -> (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
1964+ -> IntMap v
1965+ -> Event DomTimeline (PatchIntMap v)
1966+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1967+ #-}
1968+
1969+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1970+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))
1971+ -> IntMap v
1972+ -> Event DomTimeline (PatchIntMap v)
1973+ -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))
1974+ -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1975+ -> IntMap (IORef (ChildReadyState Int))
1976+ -> IO (IntMap (IORef (ChildReadyState Int))))
1977+ -> (IORef (IntMap DOM.Text)
1978+ -> DOM.Text
1979+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1980+ -> JSM ())
1981+ -> (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1982+ -> IntMap v
1983+ -> Event DomTimeline (PatchIntMap v)
1984+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1985+ #-}
1986+
1987+data TraverseChildImmediate k = TraverseChildImmediate
1988+ { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment
1989+ -- ^ Child is appended to this fragment
1990+ , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text
1991+ -- ^ Placeholder reference
1992+ , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))
1993+ }
1994+
1995+newtype TraverseChildHydration t m = TraverseChildHydration
1996+ { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text
1997+ -- ^ Action to run at switchover, returns the placeholder
1998+ }
1999+
2000+data TraverseChild t m k a = TraverseChild
2001+ { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))
2002+ , _traverseChild_result :: !a
2003+ } deriving Functor
2004+
9702005{-# INLINABLE drawChildUpdate #-}
971−drawChildUpdate :: (MonadIO m, MonadJSM m)
972− => ImmediateDomBuilderEnv t
2006+drawChildUpdate :: (MonadJSM m, Reflex t)
2007+ => HydrationDomBuilderEnv t m
9732008 -> (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)
2009+ -> HydrationDomBuilderT s t m (f a)
2010+ -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)
9762011drawChildUpdate initialEnv markReady child = do
977− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2012+ let doc = _hydrationDomBuilderEnv_document initialEnv
9782013 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)
2014+ liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case
2015+ HydrationMode_Hydrating -> do
2016+ childDelayedRef <- liftIO $ newIORef $ pure ()
2017+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2018+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2019+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
2020+ }
2021+ childDelayed <- liftIO $ readIORef childDelayedRef
2022+ return $ Compose $ TraverseChild
2023+ { _traverseChild_result = result
2024+ , _traverseChild_mode = Left TraverseChildHydration
2025+ { _traverseChildHydration_delayed = do
2026+ placeholder <- createTextNode doc ("" :: Text)
2027+ insertAfterPreviousNode placeholder
2028+ childDelayed
2029+ pure placeholder
2030+ }
2031+ }
2032+ HydrationMode_Immediate -> do
2033+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2034+ df <- createDocumentFragment doc
2035+ placeholder <- createTextNode doc ("" :: Text)
2036+ Node.appendChild_ df placeholder
2037+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2038+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
2039+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2040+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
2041+ }
2042+ u <- liftIO $ readIORef unreadyChildren
2043+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
2044+ return $ Compose $ TraverseChild
2045+ { _traverseChild_result = result
2046+ , _traverseChild_mode = Right TraverseChildImmediate
2047+ { _traverseChildImmediate_fragment = df
2048+ , _traverseChildImmediate_placeholder = placeholder
2049+ , _traverseChildImmediate_childReadyState = childReadyState
2050+ }
2051+ }
9882052
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)
2053+{-# SPECIALIZE drawChildUpdate
2054+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2055+ -> (IORef (ChildReadyState Int) -> JSM ())
2056+ -> HydrationDomBuilderT s DomTimeline HydrationM (Identity a)
2057+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM Int) Identity a)
2058+ #-}
2059+
2060+{-# SPECIALIZE drawChildUpdate
2061+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2062+ -> (IORef (ChildReadyState (Some k)) -> JSM ())
2063+ -> HydrationDomBuilderT s DomTimeline HydrationM (f a)
2064+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM (Some k)) f a)
2065+ #-}
10072066
1008−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
2067+{-# INLINABLE drawChildUpdateInt #-}
2068+drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
2069+ => HydrationDomBuilderEnv t m
2070+ -> (IORef (ChildReadyState k) -> JSM ())
2071+ -> HydrationDomBuilderT s t m v
2072+ -> DomRenderHookT t m (TraverseChild t m k v)
2073+drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdate env mark (Identity <$> m)
2074+
2075+{-# SPECIALIZE drawChildUpdateInt
2076+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2077+ -> (IORef (ChildReadyState k) -> JSM ())
2078+ -> HydrationDomBuilderT s DomTimeline HydrationM v
2079+ -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM k v)
2080+ #-}
2081+
2082+{-# INLINE mkHasFocus #-}
2083+mkHasFocus
2084+ :: (HasDocument m, MonadJSM m, IsNode (RawElement d), MonadHold t m, Reflex t, DOM.IsDocumentOrShadowRoot (RawDocument (DomBuilderSpace m)))
2085+ => Element er d t -> m (Dynamic t Bool)
10092086mkHasFocus e = do
1010− let initialFocus = False --TODO: Actually get the initial focus of the element
2087+ doc <- askDocument
2088+ initialFocus <- Node.isSameNode (toNode $ _element_raw e) . fmap toNode =<< Document.getActiveElement doc
10112089 holdDyn initialFocus $ leftmost
10122090 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
10132091 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
@@ -1016,39 +2094,49 @@ mkHasFocus e = do
10162094insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
10172095insertBefore new existing = do
10182096 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
2097+ 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
10202098
1021−instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
1022− type Performable (ImmediateDomBuilderT t m) = Performable m
2099+type ImmediateDomBuilderT = HydrationDomBuilderT GhcjsDomSpace
2100+
2101+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where
2102+ type Performable (HydrationDomBuilderT s t m) = Performable m
10232103 {-# INLINABLE performEvent_ #-}
10242104 performEvent_ e = lift $ performEvent_ e
10252105 {-# INLINABLE performEvent #-}
10262106 performEvent e = lift $ performEvent e
10272107
1028−instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where
2108+instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where
10292109 {-# INLINABLE getPostBuild #-}
10302110 getPostBuild = lift getPostBuild
10312111
1032−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where
2112+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where
10332113 {-# INLINABLE newEventWithTrigger #-}
10342114 newEventWithTrigger = lift . newEventWithTrigger
10352115 {-# INLINABLE newFanEventWithTrigger #-}
10362116 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
10372117
1038−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where
2118+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT s t m) where
2119+ {-# INLINABLE newTriggerEvent #-}
2120+ newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent
2121+ {-# INLINABLE newTriggerEventWithOnComplete #-}
2122+ newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete
2123+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
2124+ newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f
2125+
2126+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where
10392127 {-# INLINABLE newTriggerEvent #-}
1040− newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
2128+ newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent
10412129 {-# INLINABLE newTriggerEventWithOnComplete #-}
1042− newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
2130+ newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete
10432131 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1044− newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
2132+ newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f
10452133
1046−instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
1047− type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
2134+instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where
2135+ type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m
10482136 askJSContext = lift askJSContext
10492137
1050−instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
1051− type Ref (ImmediateDomBuilderT t m) = Ref m
2138+instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where
2139+ type Ref (HydrationDomBuilderT s t m) = Ref m
10522140 {-# INLINABLE newRef #-}
10532141 newRef = lift . newRef
10542142 {-# INLINABLE readRef #-}
@@ -1056,12 +2144,12 @@ instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
10562144 {-# INLINABLE writeRef #-}
10572145 writeRef r = lift . writeRef r
10582146
1059−instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
2147+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where
10602148 {-# INLINABLE atomicModifyRef #-}
10612149 atomicModifyRef r = lift . atomicModifyRef r
10622150
1063−instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
1064− type JSX (ImmediateDomBuilderT t m) = JSX m
2151+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where
2152+ type JSX (HydrationDomBuilderT s t m) = JSX m
10652153 liftJS = lift . liftJS
10662154
10672155type family EventType en where
@@ -1519,11 +2607,11 @@ getTouchEvent = do
15192607 , _touchEventResult_touches = touches
15202608 }
15212609
1522−instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
2610+instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
15232611 {-# INLINABLE sample #-}
15242612 sample = lift . sample
15252613
1526−instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where
2614+instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where
15272615 {-# INLINABLE hold #-}
15282616 hold v0 v' = lift $ hold v0 v'
15292617 {-# INLINABLE holdDyn #-}
@@ -1545,7 +2633,7 @@ data Window t = Window
15452633 , _window_raw :: DOM.Window
15462634 }
15472635
1548−wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)
2636+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> HydrationDomBuilderT GhcjsDomSpace t m (Window t)
15492637wrapWindow wv _ = do
15502638 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
15512639 return $ Window