@@ -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_
195260
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
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 (\r -> Identity <$> r) 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
360+
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
201365 return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)
202− requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity
203− requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
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,746 @@ 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 ssrAttr = "data-ssr" :: DOM.JSString
768+ hasSSRAttribute :: DOM.Element -> HydrationRunnerT t m Bool
769+ hasSSRAttribute e = case cfg ^. namespace of
770+ Nothing -> hasAttribute e ssrAttr <* removeAttribute e ssrAttr
771+ Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr
772+ childDom <- liftIO $ readIORef childDelayedRef
773+ let rawCfg = extractRawElementConfig cfg
774+ doc <- askDocument
775+ addHydrationStep $ do
776+ parent <- askParent
777+ lastHydrationNode <- getPreviousNode
778+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
779+ Nothing -> do -- ran out of nodes, create the element
780+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
781+ e <- makeElement doc elementTag cfg
782+ insertAfterPreviousNode e
783+ pure e
784+ Just node -> DOM.castTo DOM.Element node >>= \case
785+ Nothing -> go (Just node) -- this node is not an element, skip
786+ Just e -> hasSSRAttribute e >>= \case
787+ False -> go (Just node) -- this element was not added by the static renderer, skip
788+ True -> do
789+ t <- Element.getTagName e
790+ -- TODO: check attributes?
791+ if T.toCaseFold elementTag == T.toCaseFold t
792+ then pure e
793+ -- we came to some other statically rendered element, so something has gone wrong
794+ else do
795+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
796+ n <- makeElement doc elementTag cfg
797+ insertAfterPreviousNode n
798+ pure n
799+ e <- go lastHydrationNode
800+ setPreviousNode $ Just $ toNode e
801+ -- Update the parent node used by the children
802+ liftIO $ writeIORef parentRef $ toNode e
803+ liftIO $ writeIORef e' e
804+ -- Setup events, store the result so we can wait on it later
805+ refs <- wrap events e rawCfg
806+ liftIO $ putMVar wrapResult (e, refs)
807+ localRunner childDom Nothing $ toNode e
808+ -- We need the EventSelector to switch to the real event handler after activation
809+ es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
810+ cleanup <- newEmptyMVar
811+ threadId <- forkIO $ do
812+ -- Wait on the data we need from the delayed action
813+ (e, eventTriggerRefs) <- readMVar wrapResult
814+ bracketOnError
815+ -- Run the setup, acquiring the cleanup action
816+ (triggerBody ctx rawCfg events eventTriggerRefs e (WrapArg en) t)
817+ -- Run the cleanup, if we have it - but only when an exception is
818+ -- raised (we might get killed between acquiring the cleanup action
819+ -- from 'triggerBody' and putting it in the MVar)
820+ id
821+ -- Try to put this action into the cleanup MVar
822+ (putMVar cleanup)
823+ pure $ do
824+ tryReadMVar cleanup >>= \case
825+ Nothing -> killThread threadId
826+ Just c -> c
827+ return ((Element es (), result), e')
828+
829+{-# SPECIALIZE hydrateElement
830+ :: Text
831+ -> ElementConfig er DomTimeline HydrationDomSpace
832+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
833+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM ((Element er HydrationDomSpace DomTimeline, a), IORef DOM.Element)
834+ #-}
835+
836+{-# INLINE inputElementImmediate #-}
837+inputElementImmediate
838+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
839+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
840+ , MonadRef m, Ref m ~ IORef )
841+ => InputElementConfig er t s -> HydrationDomBuilderT s t m (InputElement er GhcjsDomSpace t)
842+inputElementImmediate cfg = do
843+ (e@(Element eventSelector domElement), ()) <- elementImmediate "input" (_inputElementConfig_elementConfig cfg) $ return ()
844+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
845+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
846+ v0 <- Input.getValue domInputElement
847+ let getMyValue = Input.getValue domInputElement
848+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
849+ valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
850+ Nothing -> return never
851+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
852+ Input.setValue domInputElement v'
853+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
854+ v <- holdDyn v0 $ leftmost
855+ [ valueChangedBySetValue
856+ , valueChangedByUI
857+ ]
858+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
859+ checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
860+ Input.getChecked domInputElement
861+ checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
862+ Nothing -> return never
863+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
864+ oldChecked <- Input.getChecked domInputElement
865+ Input.setChecked domInputElement newChecked
866+ return $ if newChecked /= oldChecked
867+ then Just newChecked
868+ else Nothing
869+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
870+ [ fmapMaybe id checkedChangedBySetChecked
871+ , checkedChangedByUI
872+ ]
873+ hasFocus <- mkHasFocus e
874+ files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
875+ mfiles <- Input.getFiles domInputElement
876+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
877+ maybe (return []) getMyFiles mfiles
878+ checked <- holdUniqDyn c
879+ return $ InputElement
880+ { _inputElement_value = v
881+ , _inputElement_checked = checked
882+ , _inputElement_checkedChange = checkedChangedByUI
883+ , _inputElement_input = valueChangedByUI
884+ , _inputElement_hasFocus = hasFocus
885+ , _inputElement_element = e
886+ , _inputElement_raw = domInputElement
887+ , _inputElement_files = files
888+ }
889+
890+{-# INLINE inputElementInternal #-}
891+inputElementInternal
892+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
893+ , MonadRef m, Ref m ~ IORef )
894+ => InputElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (InputElement er HydrationDomSpace t)
895+inputElementInternal cfg = getHydrationMode >>= \case
896+ HydrationMode_Immediate -> ffor (inputElementImmediate cfg) $ \result -> result
897+ { _inputElement_element = Element (_element_events $ _inputElement_element result) ()
898+ , _inputElement_raw = ()
899+ }
900+ HydrationMode_Hydrating -> do
901+ ((e, _), domElementRef) <- hydrateElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
902+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
903+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
904+ (focusChange, triggerFocusChange) <- newTriggerEvent
905+ (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent
906+ (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent
907+ (fileChange, triggerFileChange) <- newTriggerEvent
908+ doc <- askDocument
909+ -- Expected initial value from config
910+ let v0 = _inputElementConfig_initialValue cfg
911+ addHydrationStep $ do
912+ domElement <- liftIO $ readIORef domElementRef
913+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
914+ getValue = Input.getValue domInputElement
915+ -- The browser might have messed with the value, or the user could have
916+ -- altered it before activation, so we set it if it isn't what we expect
917+ liftJSM getValue >>= \v0' -> do
918+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
919+ -- Watch for user interaction and trigger event accordingly
920+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
921+ for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
922+ requestDomAction_ $ ffor eSetValue $ \v' -> do
923+ Input.setValue domInputElement v'
924+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
925+ liftIO $ triggerChangeBySetValue v
926+ let focusChange' = leftmost
927+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
928+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
929+ ]
930+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
931+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
932+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
933+ _ <- liftJSM $ domInputElement `on` Events.click $ do
934+ liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
935+ for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
936+ requestDomAction $ ffor eNewchecked $ \newChecked -> do
937+ oldChecked <- Input.getChecked domInputElement
938+ Input.setChecked domInputElement newChecked
939+ when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked
940+ _ <- liftJSM $ domInputElement `on` Events.change $ do
941+ mfiles <- Input.getFiles domInputElement
942+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
943+ liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
944+ return ()
945+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
946+ [ checkedChangedBySetChecked
947+ , checkedChangedByUI
948+ ]
949+ checked <- holdUniqDyn checked'
950+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
951+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
952+ v <- holdDyn v0 $ leftmost
953+ [ valueChangedBySetValue
954+ , valueChangedByUI
955+ ]
956+ files <- holdDyn mempty fileChange
957+ return $ InputElement
958+ { _inputElement_value = v
959+ , _inputElement_checked = checked
960+ , _inputElement_checkedChange = checkedChangedByUI
961+ , _inputElement_input = valueChangedByUI
962+ , _inputElement_hasFocus = hasFocus
963+ , _inputElement_element = e
964+ , _inputElement_raw = ()
965+ , _inputElement_files = files
966+ }
967+
968+{-# INLINE textAreaElementImmediate #-}
969+textAreaElementImmediate
970+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
971+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
972+ , MonadRef m, Ref m ~ IORef )
973+ => TextAreaElementConfig er t s -> HydrationDomBuilderT s t m (TextAreaElement er GhcjsDomSpace t)
974+textAreaElementImmediate cfg = do
975+ (e@(Element eventSelector domElement), _) <- elementImmediate "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
976+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
977+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
978+ v0 <- TextArea.getValue domTextAreaElement
979+ let getMyValue = TextArea.getValue domTextAreaElement
980+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
981+ valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
982+ Nothing -> return never
983+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
984+ TextArea.setValue domTextAreaElement v'
985+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
986+ v <- holdDyn v0 $ leftmost
987+ [ valueChangedBySetValue
988+ , valueChangedByUI
989+ ]
990+ hasFocus <- mkHasFocus e
991+ return $ TextAreaElement
992+ { _textAreaElement_value = v
993+ , _textAreaElement_input = valueChangedByUI
994+ , _textAreaElement_hasFocus = hasFocus
995+ , _textAreaElement_element = e
996+ , _textAreaElement_raw = domTextAreaElement
997+ }
998+
999+{-# INLINE textAreaElementInternal #-}
1000+textAreaElementInternal
1001+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1002+ , MonadRef m, Ref m ~ IORef )
1003+ => TextAreaElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (TextAreaElement er HydrationDomSpace t)
1004+textAreaElementInternal cfg = getHydrationMode >>= \case
1005+ HydrationMode_Immediate -> ffor (textAreaElementImmediate cfg) $ \result -> result
1006+ { _textAreaElement_element = Element (_element_events $ _textAreaElement_element result) ()
1007+ , _textAreaElement_raw = ()
1008+ }
1009+ HydrationMode_Hydrating -> do
1010+ ((e, _), domElementRef) <- hydrateElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
1011+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1012+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1013+ (focusChange, triggerFocusChange) <- newTriggerEvent
1014+ doc <- askDocument
1015+ -- Expected initial value from config
1016+ let v0 = _textAreaElementConfig_initialValue cfg
1017+ addHydrationStep $ do
1018+ domElement <- liftIO $ readIORef domElementRef
1019+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
1020+ getValue = TextArea.getValue domTextAreaElement
1021+ -- The browser might have messed with the value, or the user could have
1022+ -- altered it before activation, so we set it if it isn't what we expect
1023+ liftJSM getValue >>= \v0' -> do
1024+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1025+ -- Watch for user interaction and trigger event accordingly
1026+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
1027+ for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
1028+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1029+ TextArea.setValue domTextAreaElement v'
1030+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1031+ liftIO $ triggerChangeBySetValue v
1032+ let focusChange' = leftmost
1033+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1034+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1035+ ]
1036+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1037+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1038+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1039+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1040+ v <- holdDyn v0 $ leftmost
1041+ [ valueChangedBySetValue
1042+ , valueChangedByUI
1043+ ]
1044+ return $ TextAreaElement
1045+ { _textAreaElement_value = v
1046+ , _textAreaElement_input = valueChangedByUI
1047+ , _textAreaElement_hasFocus = hasFocus
1048+ , _textAreaElement_element = e
1049+ , _textAreaElement_raw = ()
1050+ }
1051+
1052+{-# INLINE selectElementImmediate #-}
1053+selectElementImmediate
1054+ :: ( EventSpec s ~ GhcjsEventSpec, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
1055+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m )
1056+ => SelectElementConfig er t s
1057+ -> HydrationDomBuilderT s t m a
1058+ -> HydrationDomBuilderT s t m (SelectElement er GhcjsDomSpace t, a)
1059+selectElementImmediate cfg child = do
1060+ (e@(Element eventSelector domElement), result) <- elementImmediate "select" (cfg ^. selectElementConfig_elementConfig) child
1061+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1062+ Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
1063+ v0 <- Select.getValue domSelectElement
1064+ let getMyValue = Select.getValue domSelectElement
1065+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Change)
1066+ valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
1067+ Nothing -> return never
1068+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
1069+ Select.setValue domSelectElement v'
1070+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
1071+ v <- holdDyn v0 $ leftmost
1072+ [ valueChangedBySetValue
1073+ , valueChangedByUI
1074+ ]
1075+ hasFocus <- mkHasFocus e
1076+ let wrapped = SelectElement
1077+ { _selectElement_value = v
1078+ , _selectElement_change = valueChangedByUI
1079+ , _selectElement_hasFocus = hasFocus
1080+ , _selectElement_element = e
1081+ , _selectElement_raw = domSelectElement
1082+ }
1083+ return (wrapped, result)
1084+
1085+{-# INLINE selectElementInternal #-}
1086+selectElementInternal
1087+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1088+ , MonadRef m, Ref m ~ IORef )
1089+ => SelectElementConfig er t HydrationDomSpace
1090+ -> HydrationDomBuilderT HydrationDomSpace t m a
1091+ -> HydrationDomBuilderT HydrationDomSpace t m (SelectElement er HydrationDomSpace t, a)
1092+selectElementInternal cfg child = getHydrationMode >>= \case
1093+ HydrationMode_Immediate -> ffor (selectElementImmediate cfg child) $ \(e, result) -> (e
1094+ { _selectElement_element = Element (_element_events $ _selectElement_element e) ()
1095+ , _selectElement_raw = ()
1096+ }, result)
1097+ HydrationMode_Hydrating -> do
1098+ ((e, result), domElementRef) <- hydrateElement "select" (cfg ^. selectElementConfig_elementConfig) child
1099+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1100+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1101+ (focusChange, triggerFocusChange) <- newTriggerEvent
1102+ doc <- askDocument
1103+ -- Expected initial value from config
1104+ let v0 = _selectElementConfig_initialValue cfg
1105+ addHydrationStep $ do
1106+ domElement <- liftIO $ readIORef domElementRef
1107+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1108+ getValue = Select.getValue domSelectElement
1109+ -- The browser might have messed with the value, or the user could have
1110+ -- altered it before activation, so we set it if it isn't what we expect
1111+ liftJSM getValue >>= \v0' -> do
1112+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1113+ -- Watch for user interaction and trigger event accordingly
1114+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)
1115+ for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->
1116+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1117+ Select.setValue domSelectElement v'
1118+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1119+ liftIO $ triggerChangeBySetValue v
1120+ let focusChange' = leftmost
1121+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1122+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1123+ ]
1124+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1125+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1126+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1127+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1128+ v <- holdDyn v0 $ leftmost
1129+ [ valueChangedBySetValue
1130+ , valueChangedByUI
1131+ ]
1132+ return $ (,result) $ SelectElement
1133+ { _selectElement_value = v
1134+ , _selectElement_change = valueChangedByUI
1135+ , _selectElement_hasFocus = hasFocus
1136+ , _selectElement_element = e
1137+ , _selectElement_raw = ()
1138+ }
1139+
1140+{-# INLINE textNodeImmediate #-}
1141+textNodeImmediate
1142+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1143+ => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text
1144+textNodeImmediate (TextNodeConfig !t mSetContents) = do
1145+ p <- getParent
1146+ doc <- askDocument
1147+ n <- createTextNode doc t
1148+ appendChild_ p n
1149+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1150+ pure n
1151+
1152+{-# SPECIALIZE textNodeImmediate
1153+ :: TextNodeConfig DomTimeline
1154+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM DOM.Text
1155+ #-}
1156+
1157+{-# SPECIALIZE textNodeImmediate
1158+ :: TextNodeConfig DomTimeline
1159+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM DOM.Text
1160+ #-}
1161+
1162+{-# INLINE textNodeInternal #-}
1163+textNodeInternal
1164+ :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)
1165+ => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)
1166+textNodeInternal tc@(TextNodeConfig !t mSetContents) = do
1167+ doc <- askDocument
1168+ getHydrationMode >>= \case
1169+ HydrationMode_Immediate -> void $ textNodeImmediate tc
1170+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do
1171+ n <- hydrateTextNode doc =<< sample currentText
1172+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1173+ pure $ TextNode ()
1174+
1175+{-# SPECIALIZE textNodeInternal
1176+ :: TextNodeConfig DomTimeline
1177+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (TextNode HydrationDomSpace DomTimeline)
1178+ #-}
1179+
1180+-- | The static builder mashes adjacent text nodes into one node: we check the
1181+-- text content of each node we come to, comparing it to the content we
1182+-- expect. We also have a special case for empty text nodes - we always create
1183+-- the and add them after the previous node reference.
1184+{-# INLINE hydrateTextNode #-}
1185+hydrateTextNode :: MonadJSM m => Document -> Text -> HydrationRunnerT t m DOM.Text
1186+hydrateTextNode doc t@"" = do
1187+ tn <- createTextNode doc t
1188+ insertAfterPreviousNode tn
1189+ pure tn
1190+hydrateTextNode doc t = do
1191+ n <- join $ go <$> askParent <*> getPreviousNode
1192+ setPreviousNode $ Just $ toNode n
1193+ return n
1194+ where
1195+ go parent mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1196+ Nothing -> do
1197+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1198+ n <- createTextNode doc t
1199+ insertAfterPreviousNode n
1200+ pure n
1201+ Just node -> DOM.castTo DOM.Text node >>= \case
1202+ Nothing -> go parent $ Just node
1203+ Just originalNode -> do
1204+ originalText <- Node.getTextContentUnchecked originalNode
1205+ case T.stripPrefix t originalText of
1206+ Just "" -> return originalNode
1207+ Just _ -> do
1208+ -- If we have the right prefix, we split the text node into a node containing the
1209+ -- required text and a subsequent sibling node containing the rest of the text.
1210+ DOM.splitText_ originalNode $ fromIntegral $ T.length t
1211+ return originalNode
1212+ Nothing -> do
1213+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1214+ n <- createTextNode doc t
1215+ insertAfterPreviousNode n
1216+ pure n
1217+
1218+{-# INLINE commentNodeImmediate #-}
1219+commentNodeImmediate
1220+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1221+ => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment
1222+commentNodeImmediate (CommentNodeConfig !t mSetContents) = do
1223+ p <- getParent
1224+ doc <- askDocument
1225+ n <- createComment doc t
1226+ appendChild_ p n
1227+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1228+ pure n
1229+
1230+{-# INLINE commentNodeInternal #-}
1231+commentNodeInternal
1232+ :: (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)
1233+ => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)
1234+commentNodeInternal tc@(CommentNodeConfig t0 mSetContents) = do
1235+ doc <- askDocument
1236+ getHydrationMode >>= \case
1237+ HydrationMode_Immediate -> void $ commentNodeInternal tc
1238+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do
1239+ t <- sample bt
1240+ void $ hydrateComment doc t mSetContents
1241+ pure $ CommentNode ()
1242+
1243+{-# INLINE hydrateComment #-}
1244+hydrateComment :: (MonadJSM m, Reflex t, MonadFix m) => Document -> Text -> Maybe (Event t Text) -> HydrationRunnerT t m DOM.Comment
1245+hydrateComment doc t mSetContents = do
1246+ parent <- askParent
1247+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1248+ Nothing -> do
1249+ c <- createComment doc t
1250+ insertAfterPreviousNode c
1251+ pure c
1252+ Just node -> DOM.castTo DOM.Comment node >>= \case
1253+ Nothing -> go (Just node)
1254+ Just c -> do
1255+ t' <- Node.getTextContentUnchecked c
1256+ if t == t'
1257+ then pure c
1258+ else do
1259+ c' <- createComment doc t
1260+ insertAfterPreviousNode c'
1261+ pure c'
1262+ n <- go =<< getPreviousNode
1263+ setPreviousNode $ Just $ toNode n
1264+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1265+ pure n
1266+
1267+-- | We leave markers in the static builder as comments, and rip these comments
1268+-- out at hydration time, replacing them with empty text nodes.
1269+{-# INLINABLE skipToAndReplaceComment #-}
1270+skipToAndReplaceComment
1271+ :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1272+ => Text
1273+ -> IORef Text
1274+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1275+skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
1276+ HydrationMode_Immediate -> do
1277+ -- If we're in immediate mode, we don't try to replace an existing comment,
1278+ -- and just return a dummy key
1279+ t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
1280+ append $ toNode t
1281+ textNodeRef <- liftIO $ newIORef t
1282+ keyRef <- liftIO $ newIORef ""
1283+ pure (pure (), textNodeRef, keyRef)
1284+ HydrationMode_Hydrating -> do
1285+ doc <- askDocument
1286+ textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
1287+ keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1288+ let go key0 mLastNode = do
1289+ parent <- askParent
1290+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1291+ DOM.castTo DOM.Comment node >>= \case
1292+ Just comment -> do
1293+ commentText <- Node.getTextContentUnchecked comment
1294+ case T.stripPrefix (prefix <> key0) commentText of
1295+ Just key -> do
1296+ -- Replace the comment with an (invisible) text node
1297+ tn <- createTextNode doc ("" :: Text)
1298+ Node.replaceChild_ parent tn comment
1299+ pure (tn, key)
1300+ Nothing -> do
1301+ go key0 (Just node)
1302+ Nothing -> do
1303+ go key0 (Just node)
1304+ switchComment = do
1305+ key0 <- liftIO $ readIORef key0Ref
1306+ (tn, key) <- go key0 =<< getPreviousNode
1307+ setPreviousNode $ Just $ toNode tn
1308+ liftIO $ do
1309+ writeIORef textNodeRef tn
1310+ writeIORef keyRef key
1311+ pure (switchComment, textNodeRef, keyRef)
1312+
1313+{-# INLINABLE skipToReplaceStart #-}
1314+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)
1315+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
1316+
1317+{-# INLINABLE skipToReplaceEnd #-}
1318+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)
1319+skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
1320+
1321+instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
4421322 notReadyUntil e = do
4431323 eOnce <- headE e
444− env <- ImmediateDomBuilderT ask
445− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1324+ unreadyChildren <- askUnreadyChildren
1325+ commitAction <- askCommitAction
4461326 liftIO $ modifyIORef' unreadyChildren succ
4471327 let ready = do
4481328 old <- liftIO $ readIORef unreadyChildren
4491329 let new = pred old
4501330 liftIO $ writeIORef unreadyChildren $! new
451− when (new == 0) $ _immediateDomBuilderEnv_commitAction env
1331+ when (new == 0) commitAction
4521332 requestDomAction_ $ ready <$ eOnce
4531333 notReady = do
454− env <- ImmediateDomBuilderT ask
455− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1334+ unreadyChildren <- askUnreadyChildren
4561335 liftIO $ modifyIORef' unreadyChildren succ
4571336
458−instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
459− type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace
1337+data HydrationDomSpace
1338+
1339+instance DomSpace HydrationDomSpace where
1340+ type EventSpec HydrationDomSpace = GhcjsEventSpec
1341+ type RawDocument HydrationDomSpace = DOM.Document
1342+ type RawTextNode HydrationDomSpace = ()
1343+ type RawCommentNode HydrationDomSpace = ()
1344+ type RawElement HydrationDomSpace = ()
1345+ type RawInputElement HydrationDomSpace = ()
1346+ type RawTextAreaElement HydrationDomSpace = ()
1347+ type RawSelectElement HydrationDomSpace = ()
1348+ addEventSpecFlags _ en f es = es
1349+ { _ghcjsEventSpec_filters =
1350+ let f' = Just . GhcjsEventFilter . \case
1351+ Nothing -> \evt -> do
1352+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)
1353+ return (f mEventResult, return mEventResult)
1354+ Just (GhcjsEventFilter oldFilter) -> \evt -> do
1355+ (oldFlags, oldContinuation) <- oldFilter evt
1356+ mEventResult <- oldContinuation
1357+ let newFlags = oldFlags <> f mEventResult
1358+ return (newFlags, return mEventResult)
1359+ in DMap.alter f' en $ _ghcjsEventSpec_filters es
1360+ }
1361+
1362+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT HydrationDomSpace t m) where
1363+ type DomBuilderSpace (HydrationDomBuilderT HydrationDomSpace t m) = HydrationDomSpace
1364+ {-# INLINABLE element #-}
1365+ element = elementInternal
4601366 {-# INLINABLE textNode #-}
461− textNode (TextNodeConfig initialContents mSetContents) = do
462− n <- textNodeInternal initialContents
463− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
464− return $ TextNode n
1367+ textNode = textNodeInternal
1368+ {-# INLINABLE commentNode #-}
1369+ commentNode = commentNodeInternal
1370+ {-# INLINABLE inputElement #-}
1371+ inputElement = inputElementInternal
1372+ {-# INLINABLE textAreaElement #-}
1373+ textAreaElement = textAreaElementInternal
1374+ {-# INLINABLE selectElement #-}
1375+ selectElement = selectElementInternal
1376+ placeRawElement () = pure ()
1377+ wrapRawElement () _cfg = pure $ Element (EventSelector $ const never) ()
1378+
1379+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1380+ type DomBuilderSpace (HydrationDomBuilderT GhcjsDomSpace t m) = GhcjsDomSpace
4651381 {-# INLINABLE element #-}
466− element elementTag cfg child = fst <$> makeElement elementTag cfg child
1382+ element = elementImmediate
1383+ {-# INLINABLE textNode #-}
1384+ textNode = fmap TextNode . textNodeImmediate
1385+ {-# INLINABLE commentNode #-}
1386+ commentNode = fmap CommentNode . commentNodeImmediate
4671387 {-# 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− }
1388+ inputElement = inputElementImmediate
5191389 {-# 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− }
1390+ textAreaElement = textAreaElementImmediate
5441391 {-# 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)
1392+ selectElement = selectElementImmediate
5701393 placeRawElement = append . toNode
571− wrapRawElement = wrap
1394+ wrapRawElement e rawCfg = do
1395+ events <- askEvents
1396+ ctx <- askJSM
1397+ eventTriggerRefs <- wrap events e rawCfg
1398+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
1399+ pure $ Element es e
5721400
5731401data FragmentState
5741402 = FragmentState_Unmounted
@@ -588,21 +1416,21 @@ extractFragment fragment = do
5881416 extractBetweenExclusive (_immediateDomFragment_document fragment) before after
5891417 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
5901418
591−instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
592− type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
1419+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1420+ type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment
5931421 buildDomFragment w = do
5941422 df <- createDocumentFragment =<< askDocument
5951423 result <- flip localEnv w $ \env -> env
596− { _immediateDomBuilderEnv_parent = toNode df
1424+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
5971425 }
5981426 state <- liftIO $ newIORef FragmentState_Unmounted
5991427 return (ImmediateDomFragment df state, result)
6001428 mountDomFragment fragment setFragment = do
601− parent <- askParent
1429+ parent <- getParent
6021430 extractFragment fragment
603− before <- textNodeInternal ("" :: Text)
1431+ before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6041432 appendChild_ parent $ _immediateDomFragment_document fragment
605− after <- textNodeInternal ("" :: Text)
1433+ after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6061434 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
6071435 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
6081436 extractFragment previousFragment
@@ -611,12 +1439,19 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
6111439 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
6121440 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
6131441
614−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
1442+instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (DomRenderHookT t m) where
1443+ runWithReplace a0 a' = DomRenderHookT $ runWithReplace (unDomRenderHookT a0) (fmapCheap unDomRenderHookT a')
1444+ traverseIntMapWithKeyWithAdjust f m = DomRenderHookT . traverseIntMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1445+ traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1446+ traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
1447+
1448+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
6151449 {-# INLINABLE runWithReplace #-}
6161450 runWithReplace a0 a' = do
617− initialEnv <- ImmediateDomBuilderT ask
618− before <- textNodeInternal ("" :: Text)
619− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
1451+ initialEnv <- HydrationDomBuilderT ask
1452+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
1453+ (hydrateStart, before, beforeKey) <- skipToReplaceStart
1454+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
6201455 haveEverBeenReady <- liftIO $ newIORef False
6211456 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
6221457 let myCommitAction = do
@@ -627,79 +1462,117 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
6271462 old <- liftIO $ readIORef parentUnreadyChildren
6281463 let new = pred old
6291464 liftIO $ writeIORef parentUnreadyChildren $! new
630− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
1465+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
6311466 -- We draw 'after' in this roundabout way to avoid using MonadFix
6321467 doc <- askDocument
633− after <- createTextNode doc ("" :: Text)
1468+ parent <- getParent
1469+ (hydrateEnd, after) <- skipToReplaceEnd beforeKey
6341470 let drawInitialChild = do
1471+ h <- liftIO $ readIORef hydrating
1472+ p' <- case h of
1473+ HydrationMode_Hydrating -> pure parent
1474+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6351475 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
1476+ let a0' = case h of
1477+ HydrationMode_Hydrating -> a0
1478+ HydrationMode_Immediate -> do
1479+ a <- a0
1480+ insertBefore p' =<< liftIO (readIORef after)
1481+ pure a
1482+ delayed <- case h of
1483+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1484+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1485+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv
1486+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1487+ , _hydrationDomBuilderEnv_commitAction = myCommitAction
1488+ , _hydrationDomBuilderEnv_parent = Left p'
1489+ , _hydrationDomBuilderEnv_delayed = delayed
6431490 }
1491+ dom <- case h of
1492+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1493+ HydrationMode_Immediate -> pure $ pure ()
6441494 liftIO $ readIORef unreadyChildren >>= \case
6451495 0 -> writeIORef haveEverBeenReady True
6461496 _ -> modifyIORef' parentUnreadyChildren succ
647− return result
1497+ return (dom, result)
6481498 a'' <- numberOccurrences a'
649− (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
650− df <- createDocumentFragment doc
1499+ ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
1500+ h <- liftIO $ readIORef hydrating
1501+ p' <- case h of
1502+ HydrationMode_Hydrating -> pure parent
1503+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6511504 unreadyChildren <- liftIO $ newIORef 0
6521505 let commitAction = do
6531506 c <- liftIO $ readIORef currentCohort
6541507 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
655− deleteBetweenExclusive before after
656− insertBefore df after
1508+ !before' <- liftIO $ readIORef before
1509+ !after' <- liftIO $ readIORef after
1510+ deleteBetweenExclusive before' after'
1511+ insertBefore p' after'
6571512 liftIO $ writeIORef currentCohort cohortId
6581513 myCommitAction
659− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
660− { _immediateDomBuilderEnv_parent = toNode df
661− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
662− , _immediateDomBuilderEnv_commitAction = commitAction
663− }
1514+ delayed <- case h of
1515+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1516+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1517+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv
1518+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1519+ , _hydrationDomBuilderEnv_commitAction = case h of
1520+ HydrationMode_Hydrating -> myCommitAction
1521+ HydrationMode_Immediate -> commitAction
1522+ , _hydrationDomBuilderEnv_parent = Left p'
1523+ , _hydrationDomBuilderEnv_delayed = delayed
1524+ }
1525+ dom <- case h of
1526+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1527+ HydrationMode_Immediate -> pure $ pure ()
6641528 uc <- liftIO $ readIORef unreadyChildren
6651529 let commitActionToRunNow = if uc == 0
666− then Just commitAction
1530+ then Just $ commitAction
6671531 else Nothing -- A child will run it when unreadyChildren is decremented to 0
668− return (commitActionToRunNow, result)
669− requestDomAction_ $ fmapMaybe fst child'
1532+ actions = case h of
1533+ HydrationMode_Hydrating -> Left dom
1534+ HydrationMode_Immediate -> Right commitActionToRunNow
1535+ return (actions, result)
1536+ let (hydrate', commitAction) = fanEither $ fmap fst child'
1537+ addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do
1538+ hydrateStart
1539+ join $ sample contents
1540+ hydrateEnd
1541+ requestDomAction_ $ fmapMaybe id commitAction
6701542 return (result0, snd <$> child')
1543+
6711544 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
6721545 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
6731546 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
6741547 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
6751548 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
6761549 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)
1550+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do
1551+ 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)
6791552 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
680− PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
681− readIORef sRef >>= \case
1553+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete
1554+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do
1555+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
6821556 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
6831557 ChildReadyState_Unready _ -> do
684− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
685− return $ PatchDMapWithMove.From_Insert $ Constant sRef
1558+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k
1559+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)
6861560 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
6871561 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)
1562+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState (Some k)))) (ComposeMaybe k) a -> IO (Constant () a)
6891563 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
1564+ writeIORef sRef $ ChildReadyState_Unready $ This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
6911565 return $ Constant ()
6921566 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
6931567 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
6941568 return $ applyAlways p' old
695− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
1569+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) -> do
6961570 let p = unPatchDMapWithMove p_
6971571 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)
1572+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
7001573 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
1574+ let mThisPlaceholder = Map.lookup (This k) phsBefore -- Will be Nothing if this element wasn't present before
1575+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsBefore
7031576 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
7041577 False -> do
7051578 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
@@ -707,13 +1580,22 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7071580 True -> do
7081581 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
7091582 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)
1583+ let !phsAfter = fromMaybe phsBefore $ apply filtered phsBefore
1584+ weakened :: PatchMapWithMove (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1585+ weakened = weakenPatchDMapWithMoveWith (_traverseChild_mode . getCompose) p_
1586+ filtered :: PatchMapWithMove (Some k) DOM.Text
1587+ filtered = PatchMapWithMove $ flip Map.mapMaybe (unPatchMapWithMove weakened) $ \(PatchMapWithMove.NodeInfo from to) -> flip PatchMapWithMove.NodeInfo to <$> case from of
1588+ PatchMapWithMove.From_Insert (Left _hydration) -> Nothing
1589+ PatchMapWithMove.From_Insert (Right immediate) -> Just $ PatchMapWithMove.From_Insert $ _traverseChildImmediate_placeholder immediate
1590+ PatchMapWithMove.From_Delete -> Just $ PatchMapWithMove.From_Delete
1591+ PatchMapWithMove.From_Move k -> Just $ PatchMapWithMove.From_Move k
1592+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a)
7121593 placeFragment k e = do
713− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
1594+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsAfter
7141595 case PatchDMapWithMove._nodeInfo_from e of
715− PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
716− df `insertBefore` nextPlaceholder
1596+ PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of
1597+ Left _ -> pure ()
1598+ Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
7171599 PatchDMapWithMove.From_Delete -> do
7181600 return ()
7191601 PatchDMapWithMove.From_Move fromKey -> do
@@ -724,105 +1606,166 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7241606 liftIO $ writeIORef placeholders $! phsAfter
7251607
7261608{-# 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'))
1609+traverseDMapWithKeyWithAdjust'
1610+ :: 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)
1611+ => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1612+ -> DMap k v
1613+ -> Event t (PatchDMap k v)
1614+ -> HydrationDomBuilderT s t m (DMap k v', Event t (PatchDMap k v'))
7281615traverseDMapWithKeyWithAdjust' = 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)
1616+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some k)) v')) old = do
1617+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)
7311618 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
7321619 Nothing -> return Nothing
733− Just (Compose (_, _, sRef, _)) -> do
734− readIORef sRef >>= \case
1620+ Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing
1621+ Just (Compose (TraverseChild (Right immediate) _)) -> do
1622+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
7351623 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
7361624 ChildReadyState_Unready _ -> do
737− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
738− return $ Just $ Constant sRef
1625+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k
1626+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
7391627 delete _ (Constant sRef) = do
7401628 writeIORef sRef $ ChildReadyState_Unready Nothing
7411629 return $ Constant ()
7421630 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
7431631 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
7441632 return $ applyAlways p' old
745− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
1633+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do
7461634 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
1635+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do
1636+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phs
1637+ -- Delete old node
1638+ forM_ (Map.lookup (This k) phs) $ \thisPlaceholder -> do
1639+ thisPlaceholder `deleteUpTo` nextPlaceholder
1640+ -- Insert new node
1641+ forM_ mv $ \(Compose (TraverseChild e _)) -> case e of
1642+ Left _hydration -> pure ()
1643+ Right immediate -> do
1644+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1645+ let weakened :: PatchMap (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1646+ weakened = weakenPatchDMapWith (_traverseChild_mode . getCompose) $ PatchDMap patch
1647+ filtered :: PatchMap (Some k) DOM.Text
1648+ filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case
1649+ Nothing -> Just Nothing -- deletion
1650+ Just (Left _) -> Nothing
1651+ Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1652+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
7531653
7541654{-# 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'))
1655+traverseIntMapWithKeyWithAdjust'
1656+ :: 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)
1657+ => (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1658+ -> IntMap v
1659+ -> Event t (PatchIntMap v)
1660+ -> HydrationDomBuilderT s t m (IntMap v', Event t (PatchIntMap v'))
7561661traverseIntMapWithKeyWithAdjust' = 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))
1662+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do
1663+ let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))
7591664 new k m = case m of
7601665 Nothing -> return Nothing
761− Just (_, _, sRef, _) -> do
1666+ Just (TraverseChild (Left _hydration) _) -> pure Nothing
1667+ Just (TraverseChild (Right immediate) _) -> do
1668+ let sRef = _traverseChildImmediate_childReadyState immediate
7621669 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
1670+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
1671+ ChildReadyState_Unready _ -> do
1672+ writeIORef sRef $ ChildReadyState_Unready $ Just k
7661673 return $ Just sRef
7671674 delete _ sRef = do
768− writeIORef sRef $ ChildReadyStateInt_Unready Nothing
1675+ writeIORef sRef $ ChildReadyState_Unready Nothing
7691676 return ()
7701677 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
7711678 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
7721679 return $ applyAlways p' old
773− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do
1680+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do
7741681 phs <- liftIO $ readIORef placeholders
7751682 forM_ (IntMap.toList p) $ \(k, mv) -> do
776− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
7771683 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
1684+ -- Delete old node
7781685 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
1686+ -- Insert new node
1687+ forM_ mv $ \(TraverseChild e _) -> case e of
1688+ Left _hydration -> pure ()
1689+ Right immediate -> do
1690+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1691+ let filtered :: PatchIntMap DOM.Text
1692+ filtered = PatchIntMap $ flip IntMap.mapMaybe p $ \case
1693+ Nothing -> Just Nothing -- deletion
1694+ Just tc
1695+ | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1696+ | otherwise -> Nothing
1697+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
1698+
1699+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1700+ :: (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1701+ -> IntMap v
1702+ -> Event DomTimeline (PatchIntMap v)
1703+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1704+ #-}
7811705
782−#if MIN_VERSION_base(4,9,0)
783−data ChildReadyState k
784−#else
785−data ChildReadyState (k :: * -> *)
786−#endif
1706+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1707+ :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
1708+ -> IntMap v
1709+ -> Event DomTimeline (PatchIntMap v)
1710+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1711+ #-}
1712+
1713+data ChildReadyState a
7871714 = ChildReadyState_Ready
788− | ChildReadyState_Unready !(Maybe (Some k))
1715+ | ChildReadyState_Unready !(Maybe a)
7891716 deriving (Show, Read, Eq, Ord)
7901717
791−data ChildReadyStateInt
792− = ChildReadyStateInt_Ready
793− | ChildReadyStateInt_Unready !(Maybe Int)
794− deriving (Show, Read, Eq, Ord)
1718+insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()
1719+insertAfterPreviousNode node = do
1720+ parent <- askParent
1721+ nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode
1722+ Node.insertBefore_ parent node nextNode
1723+ setPreviousNode $ Just $ toNode node
7951724
796−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
797−hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1725+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1726+hoistTraverseWithKeyWithAdjust
1727+ ::
7981728 ( Adjustable t m
1729+ , MonadHold t m
1730+ , DMap.GCompare k
7991731 , MonadIO m
8001732 , MonadJSM m
801− , MonadFix m
8021733 , PrimMonad m
803− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
804− , Functor p
1734+ , MonadFix m
1735+ , Patch (p k v)
1736+ , Patch (p k (Constant Int))
1737+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1738+ , Patch (p k (Compose (TraverseChild t m (Some k)) v'))
1739+ , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v')
1740+ , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))
1741+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
8051742 )
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
1743+ => (forall vv vv'.
1744+ (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
1745+ -> DMap k vv
1746+ -> Event t (p k vv)
1747+ -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))
1748+ -- ^ The base monad's traversal
1749+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')
1750+ -- ^ A way of mapping over the patch type
1751+ -> (p k (Compose (TraverseChild t m (Some k)) v') -> DMap k (Constant (IORef (ChildReadyState (Some k)))) -> IO (DMap k (Constant (IORef (ChildReadyState (Some k))))))
1752+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1753+ -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())
1754+ -- ^ Apply a patch to the DOM
1755+ -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1756+ -> DMap k v
1757+ -> Event t (p k v)
1758+ -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))
1759+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1760+ doc <- askDocument
1761+ initialEnv <- HydrationDomBuilderT ask
1762+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1763+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty
8211764 haveEverBeenReady <- liftIO $ newIORef False
822− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
823− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1765+ placeholders <- liftIO $ newIORef Map.empty
1766+ lastPlaceholder <- createTextNode doc ("" :: Text)
8241767 let applyDomUpdate p = do
825− applyDomUpdate_ placeholders lastPlaceholderRef p
1768+ applyDomUpdate_ placeholders lastPlaceholder p
8261769 markSelfReady
8271770 liftIO $ writeIORef pendingChange $! mempty
8281771 markSelfReady = do
@@ -833,86 +1776,105 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
8331776 old <- liftIO $ readIORef parentUnreadyChildren
8341777 let new = pred old
8351778 liftIO $ writeIORef parentUnreadyChildren $! new
836− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
837− markChildReady :: IORef ChildReadyStateInt -> JSM ()
1779+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1780+ markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()
8381781 markChildReady childReadyState = do
8391782 liftIO (readIORef childReadyState) >>= \case
840− ChildReadyStateInt_Ready -> return ()
841− ChildReadyStateInt_Unready countedAt -> do
842− liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1783+ ChildReadyState_Ready -> return ()
1784+ ChildReadyState_Unready countedAt -> do
1785+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
8431786 case countedAt of
8441787 Nothing -> return ()
845− Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
1788+ Just (This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
8461789 (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
1790+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
1791+ let newUnready = DMap.delete k oldUnready
8491792 liftIO $ writeIORef pendingChange (newUnready, p)
850− when (IntMap.null newUnready) $ do
1793+ when (DMap.null newUnready) $ do
8511794 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
1795+ (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))
1796+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1797+ let processChild k (Compose (TraverseChild e _)) = case e of
1798+ Left _ -> pure $ ComposeMaybe Nothing
1799+ Right immediate -> ComposeMaybe <$> do
1800+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1801+ ChildReadyState_Ready -> return Nothing
1802+ ChildReadyState_Unready _ -> do
1803+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k
1804+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
1805+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1806+ liftIO $ if DMap.null initialUnready
8611807 then writeIORef haveEverBeenReady True
8621808 else do
8631809 modifyIORef' parentUnreadyChildren succ
8641810 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)
1811+ getHydrationMode >>= \case
1812+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1813+ dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1814+ phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
1815+ liftIO $ writeIORef placeholders $! phs
1816+ insertAfterPreviousNode lastPlaceholder
1817+ HydrationMode_Immediate -> do
1818+ let activate i = do
1819+ append $ toNode $ _traverseChildImmediate_fragment i
1820+ pure $ _traverseChildImmediate_placeholder i
1821+ phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1822+ liftIO $ writeIORef placeholders $! phs
1823+ append $ toNode lastPlaceholder
8711824 requestDomAction_ $ ffor children' $ \p -> do
8721825 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
8731826 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
8741827 let !newP = p <> oldP
8751828 liftIO $ writeIORef pendingChange (newUnready, newP)
876− when (IntMap.null newUnready) $ do
1829+ when (DMap.null newUnready) $ do
8771830 applyDomUpdate newP
1831+ let result0 = DMap.map (_traverseChild_result . getCompose) children0
1832+ result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose
8781833 return (result0, result')
8791834
880−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
881−hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1835+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
1836+hoistTraverseIntMapWithKeyWithAdjust ::
8821837 ( Adjustable t m
8831838 , MonadHold t m
884− , DMap.GCompare k
885− , MonadIO m
8861839 , MonadJSM m
887− , PrimMonad m
8881840 , 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))
1841+ , PrimMonad m
1842+ , Monoid (p (TraverseChild t m Int v'))
1843+ , Functor p
1844+ , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())
1845+ , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')
1846+ , Patch (p (HydrationRunnerT t m ()))
1847+ , Patch (p (TraverseChild t m Int v'))
1848+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
8931849 )
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
1850+ => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))
1851+ -> IntMap v
1852+ -> Event t (p v)
1853+ -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))
1854+ -- ^ The base monad's traversal
1855+ -> (p (TraverseChild t m Int v')
1856+ -> IntMap (IORef (ChildReadyState Int))
1857+ -> IO (IntMap (IORef (ChildReadyState Int))))
1858+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1859+ -> (IORef (IntMap DOM.Text)
1860+ -> DOM.Text
1861+ -> p (TraverseChild t m Int v')
1862+ -> JSM ())
1863+ -- ^ Apply a patch to the DOM
1864+ -> (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1865+ -> IntMap v
1866+ -> Event t (p v)
1867+ -> HydrationDomBuilderT s t m (IntMap v', Event t (p v'))
1868+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1869+ doc <- askDocument
1870+ initialEnv <- HydrationDomBuilderT ask
1871+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1872+ pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty
9111873 haveEverBeenReady <- liftIO $ newIORef False
912− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
913− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1874+ placeholders <- liftIO $ newIORef IntMap.empty
1875+ lastPlaceholder <- createTextNode doc ("" :: Text)
9141876 let applyDomUpdate p = do
915− applyDomUpdate_ placeholders lastPlaceholderRef p
1877+ applyDomUpdate_ placeholders lastPlaceholder p
9161878 markSelfReady
9171879 liftIO $ writeIORef pendingChange $! mempty
9181880 markSelfReady = do
@@ -923,8 +1885,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9231885 old <- liftIO $ readIORef parentUnreadyChildren
9241886 let new = pred old
9251887 liftIO $ writeIORef parentUnreadyChildren $! new
926− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
927− markChildReady :: IORef (ChildReadyState k) -> JSM ()
1888+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1889+ markChildReady :: IORef (ChildReadyState Int) -> JSM ()
9281890 markChildReady childReadyState = do
9291891 liftIO (readIORef childReadyState) >>= \case
9301892 ChildReadyState_Ready -> return ()
@@ -932,82 +1894,191 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9321894 liftIO $ writeIORef childReadyState ChildReadyState_Ready
9331895 case countedAt of
9341896 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
1897+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
9361898 (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
1899+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
1900+ let newUnready = IntMap.delete k oldUnready
9391901 liftIO $ writeIORef pendingChange (newUnready, p)
940− when (DMap.null newUnready) $ do
1902+ when (IntMap.null newUnready) $ do
9411903 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
1904+ (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))
1905+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1906+ let processChild k (TraverseChild e _) = case e of
1907+ Left _ -> pure Nothing
1908+ Right immediate -> do
1909+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1910+ ChildReadyState_Ready -> return Nothing
1911+ ChildReadyState_Unready _ -> do
1912+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k
1913+ return $ Just (_traverseChildImmediate_childReadyState immediate)
1914+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
1915+ liftIO $ if IntMap.null initialUnready
9511916 then writeIORef haveEverBeenReady True
9521917 else do
9531918 modifyIORef' parentUnreadyChildren succ
9541919 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)
1920+ getHydrationMode >>= \case
1921+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1922+ dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children
1923+ phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm
1924+ liftIO $ writeIORef placeholders $! phs
1925+ insertAfterPreviousNode lastPlaceholder
1926+ HydrationMode_Immediate -> do
1927+ let activate i = do
1928+ append $ toNode $ _traverseChildImmediate_fragment i
1929+ pure $ _traverseChildImmediate_placeholder i
1930+ phs <- traverse (either (error "impossible") activate . _traverseChild_mode) children0
1931+ liftIO $ writeIORef placeholders $! phs
1932+ append $ toNode lastPlaceholder
9611933 requestDomAction_ $ ffor children' $ \p -> do
9621934 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
9631935 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
9641936 let !newP = p <> oldP
9651937 liftIO $ writeIORef pendingChange (newUnready, newP)
966− when (DMap.null newUnready) $ do
1938+ when (IntMap.null newUnready) $ do
9671939 applyDomUpdate newP
1940+ let result0 = IntMap.map _traverseChild_result children0
1941+ result' = ffor children' $ fmap $ _traverseChild_result
9681942 return (result0, result')
9691943
1944+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1945+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))
1946+ -> IntMap v
1947+ -> Event DomTimeline (PatchIntMap v)
1948+ -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))
1949+ -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1950+ -> IntMap (IORef (ChildReadyState Int))
1951+ -> IO (IntMap (IORef (ChildReadyState Int))))
1952+ -> (IORef (IntMap DOM.Text)
1953+ -> DOM.Text
1954+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1955+ -> JSM ())
1956+ -> (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
1957+ -> IntMap v
1958+ -> Event DomTimeline (PatchIntMap v)
1959+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1960+ #-}
1961+
1962+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1963+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))
1964+ -> IntMap v
1965+ -> Event DomTimeline (PatchIntMap v)
1966+ -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))
1967+ -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1968+ -> IntMap (IORef (ChildReadyState Int))
1969+ -> IO (IntMap (IORef (ChildReadyState Int))))
1970+ -> (IORef (IntMap DOM.Text)
1971+ -> DOM.Text
1972+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1973+ -> JSM ())
1974+ -> (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1975+ -> IntMap v
1976+ -> Event DomTimeline (PatchIntMap v)
1977+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1978+ #-}
1979+
1980+data TraverseChildImmediate k = TraverseChildImmediate
1981+ { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment
1982+ -- ^ Child is appended to this fragment
1983+ , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text
1984+ -- ^ Placeholder reference
1985+ , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))
1986+ }
1987+
1988+newtype TraverseChildHydration t m = TraverseChildHydration
1989+ { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text
1990+ -- ^ Action to run at switchover, returns the placeholder
1991+ }
1992+
1993+data TraverseChild t m k a = TraverseChild
1994+ { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))
1995+ , _traverseChild_result :: !a
1996+ } deriving Functor
1997+
9701998{-# INLINABLE drawChildUpdate #-}
971−drawChildUpdate :: (MonadIO m, MonadJSM m)
972− => ImmediateDomBuilderEnv t
1999+drawChildUpdate :: (MonadJSM m, Reflex t)
2000+ => HydrationDomBuilderEnv t m
9732001 -> (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)
2002+ -> HydrationDomBuilderT s t m (f a)
2003+ -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)
9762004drawChildUpdate initialEnv markReady child = do
977− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2005+ let doc = _hydrationDomBuilderEnv_document initialEnv
9782006 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)
2007+ liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case
2008+ HydrationMode_Hydrating -> do
2009+ childDelayedRef <- liftIO $ newIORef $ pure ()
2010+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2011+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2012+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
2013+ }
2014+ childDelayed <- liftIO $ readIORef childDelayedRef
2015+ return $ Compose $ TraverseChild
2016+ { _traverseChild_result = result
2017+ , _traverseChild_mode = Left TraverseChildHydration
2018+ { _traverseChildHydration_delayed = do
2019+ placeholder <- createTextNode doc ("" :: Text)
2020+ insertAfterPreviousNode placeholder
2021+ childDelayed
2022+ pure placeholder
2023+ }
2024+ }
2025+ HydrationMode_Immediate -> do
2026+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2027+ df <- createDocumentFragment doc
2028+ placeholder <- createTextNode doc ("" :: Text)
2029+ Node.appendChild_ df placeholder
2030+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2031+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
2032+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2033+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
2034+ }
2035+ u <- liftIO $ readIORef unreadyChildren
2036+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
2037+ return $ Compose $ TraverseChild
2038+ { _traverseChild_result = result
2039+ , _traverseChild_mode = Right TraverseChildImmediate
2040+ { _traverseChildImmediate_fragment = df
2041+ , _traverseChildImmediate_placeholder = placeholder
2042+ , _traverseChildImmediate_childReadyState = childReadyState
2043+ }
2044+ }
9882045
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)
2046+{-# SPECIALIZE drawChildUpdate
2047+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2048+ -> (IORef (ChildReadyState Int) -> JSM ())
2049+ -> HydrationDomBuilderT s DomTimeline HydrationM (Identity a)
2050+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM Int) Identity a)
2051+ #-}
2052+
2053+{-# SPECIALIZE drawChildUpdate
2054+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2055+ -> (IORef (ChildReadyState (Some k)) -> JSM ())
2056+ -> HydrationDomBuilderT s DomTimeline HydrationM (f a)
2057+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM (Some k)) f a)
2058+ #-}
10072059
1008−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
2060+{-# INLINABLE drawChildUpdateInt #-}
2061+drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
2062+ => HydrationDomBuilderEnv t m
2063+ -> (IORef (ChildReadyState k) -> JSM ())
2064+ -> HydrationDomBuilderT s t m v
2065+ -> DomRenderHookT t m (TraverseChild t m k v)
2066+drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdate env mark (Identity <$> m)
2067+
2068+{-# SPECIALIZE drawChildUpdateInt
2069+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2070+ -> (IORef (ChildReadyState k) -> JSM ())
2071+ -> HydrationDomBuilderT s DomTimeline HydrationM v
2072+ -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM k v)
2073+ #-}
2074+
2075+{-# INLINE mkHasFocus #-}
2076+mkHasFocus
2077+ :: (HasDocument m, MonadJSM m, IsNode (RawElement d), MonadHold t m, Reflex t, DOM.IsDocumentOrShadowRoot (RawDocument (DomBuilderSpace m)))
2078+ => Element er d t -> m (Dynamic t Bool)
10092079mkHasFocus e = do
1010− let initialFocus = False --TODO: Actually get the initial focus of the element
2080+ doc <- askDocument
2081+ initialFocus <- Node.isSameNode (toNode $ _element_raw e) . fmap toNode =<< Document.getActiveElement doc
10112082 holdDyn initialFocus $ leftmost
10122083 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
10132084 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
@@ -1016,39 +2087,49 @@ mkHasFocus e = do
10162087insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
10172088insertBefore new existing = do
10182089 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
2090+ 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
10202091
1021−instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
1022− type Performable (ImmediateDomBuilderT t m) = Performable m
2092+type ImmediateDomBuilderT = HydrationDomBuilderT GhcjsDomSpace
2093+
2094+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where
2095+ type Performable (HydrationDomBuilderT s t m) = Performable m
10232096 {-# INLINABLE performEvent_ #-}
10242097 performEvent_ e = lift $ performEvent_ e
10252098 {-# INLINABLE performEvent #-}
10262099 performEvent e = lift $ performEvent e
10272100
1028−instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where
2101+instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where
10292102 {-# INLINABLE getPostBuild #-}
10302103 getPostBuild = lift getPostBuild
10312104
1032−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where
2105+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where
10332106 {-# INLINABLE newEventWithTrigger #-}
10342107 newEventWithTrigger = lift . newEventWithTrigger
10352108 {-# INLINABLE newFanEventWithTrigger #-}
10362109 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
10372110
1038−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where
2111+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT s t m) where
2112+ {-# INLINABLE newTriggerEvent #-}
2113+ newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent
2114+ {-# INLINABLE newTriggerEventWithOnComplete #-}
2115+ newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete
2116+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
2117+ newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f
2118+
2119+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where
10392120 {-# INLINABLE newTriggerEvent #-}
1040− newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
2121+ newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent
10412122 {-# INLINABLE newTriggerEventWithOnComplete #-}
1042− newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
2123+ newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete
10432124 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1044− newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
2125+ newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f
10452126
1046−instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
1047− type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
2127+instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where
2128+ type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m
10482129 askJSContext = lift askJSContext
10492130
1050−instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
1051− type Ref (ImmediateDomBuilderT t m) = Ref m
2131+instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where
2132+ type Ref (HydrationDomBuilderT s t m) = Ref m
10522133 {-# INLINABLE newRef #-}
10532134 newRef = lift . newRef
10542135 {-# INLINABLE readRef #-}
@@ -1056,12 +2137,12 @@ instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
10562137 {-# INLINABLE writeRef #-}
10572138 writeRef r = lift . writeRef r
10582139
1059−instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
2140+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where
10602141 {-# INLINABLE atomicModifyRef #-}
10612142 atomicModifyRef r = lift . atomicModifyRef r
10622143
1063−instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
1064− type JSX (ImmediateDomBuilderT t m) = JSX m
2144+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where
2145+ type JSX (HydrationDomBuilderT s t m) = JSX m
10652146 liftJS = lift . liftJS
10662147
10672148type family EventType en where
@@ -1519,11 +2600,11 @@ getTouchEvent = do
15192600 , _touchEventResult_touches = touches
15202601 }
15212602
1522−instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
2603+instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
15232604 {-# INLINABLE sample #-}
15242605 sample = lift . sample
15252606
1526−instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where
2607+instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where
15272608 {-# INLINABLE hold #-}
15282609 hold v0 v' = lift $ hold v0 v'
15292610 {-# INLINABLE holdDyn #-}
@@ -1545,7 +2626,7 @@ data Window t = Window
15452626 , _window_raw :: DOM.Window
15462627 }
15472628
1548−wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)
2629+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> HydrationDomBuilderT GhcjsDomSpace t m (Window t)
15492630wrapWindow wv _ = do
15502631 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
15512632 return $ Window