@@ -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,191 +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.Class as Reflex
94−import Reflex.Dom.Builder.Class
95−import Reflex.Dynamic
96−import Reflex.DynamicWriter (DynamicWriterT)
97−import Reflex.EventWriter (EventWriterT)
98−import Reflex.Host.Class
99−import qualified Reflex.Patch.DMap as PatchDMap
100−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
101−import Reflex.PerformEvent.Class
102−import Reflex.PostBuild.Base
103−import Reflex.PostBuild.Class
104−import Reflex.TriggerEvent.Base hiding (askEvents)
105−import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
106−import Reflex.TriggerEvent.Class
107−import Reflex.Query.Base (QueryT)
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
108116
109117import Control.Concurrent
110−import Control.Lens hiding (element, ix)
118+import Control.Exception (bracketOnError)
119+import Control.Lens (Identity(..), imapM_, iforM_, (^.), makeLenses)
111120import Control.Monad.Exception
112121import Control.Monad.Primitive
113122import Control.Monad.Reader
114123import Control.Monad.Ref
115−import Control.Monad.State.Strict (StateT)
116−import qualified Control.Monad.State as Lazy (StateT)
117−#ifndef USE_TEMPLATE_HASKELL
118−import Data.Functor.Contravariant (phantom)
119−#endif
124+import Control.Monad.State.Strict (StateT, mapStateT, get, modify', gets, runStateT)
120125import Data.Bitraversable
121126import Data.Default
122127import Data.Dependent.Map (DMap)
123−import qualified Data.Dependent.Map as DMap
124128import Data.Dependent.Sum
129+import Data.FastMutableIntMap (PatchIntMap (..))
130+import Data.Foldable (for_, traverse_)
125131import Data.Functor.Compose
126132import Data.Functor.Constant
127133import Data.Functor.Misc
128134import Data.Functor.Product
129135import Data.IORef
130−import qualified Data.Map as Map
136+import Data.IntMap.Strict (IntMap)
131137import Data.Maybe
132−import Data.Monoid hiding (Product)
133−import Data.Some (Some)
134−import qualified Data.Some as Some
138+import Data.Monoid ((<>))
139+import Data.Some (Some(..))
135140import 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
136176import qualified Data.Text as T
137177import qualified GHCJS.DOM as DOM
138−import GHCJS.DOM.RequestAnimationFrameCallback
139−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
140−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
141180import qualified GHCJS.DOM.Element as Element
142181import qualified GHCJS.DOM.Event as Event
143−import qualified GHCJS.DOM.GlobalEventHandlers as Events
144−import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
145−import GHCJS.DOM.EventM (EventM, event, on)
146182import qualified GHCJS.DOM.EventM as DOM
147183import qualified GHCJS.DOM.FileList as FileList
184+import qualified GHCJS.DOM.GlobalEventHandlers as Events
148185import qualified GHCJS.DOM.HTMLInputElement as Input
149186import qualified GHCJS.DOM.HTMLSelectElement as Select
150187import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
151−import GHCJS.DOM.MouseEvent
188+import qualified GHCJS.DOM.Node as Node
189+import qualified GHCJS.DOM.Text as DOM
152190import qualified GHCJS.DOM.Touch as Touch
153191import qualified GHCJS.DOM.TouchEvent as TouchEvent
154192import qualified GHCJS.DOM.TouchList as TouchList
155−import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
156−import qualified GHCJS.DOM.Node as DOM (insertBefore_)
157−import GHCJS.DOM.Types
158− (liftJSM, askJSM, runJSM, JSM, MonadJSM,
159− FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
160− ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)
161193import qualified GHCJS.DOM.Types as DOM
162−import GHCJS.DOM.UIEvent
163−import GHCJS.DOM.KeyboardEvent as KeyboardEvent
164194import qualified GHCJS.DOM.Window as Window
165−import Language.Javascript.JSaddle (call, eval)
166−import Data.IntMap.Strict (IntMap)
167−import qualified Data.IntMap.Strict as IntMap
168−import Data.FastMutableIntMap (PatchIntMap (..))
169−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)
170199
171−import Reflex.Requester.Base
172−import Reflex.Requester.Class
173−import Foreign.JavaScript.Internal.Utils
200+#ifndef USE_TEMPLATE_HASKELL
201+import Data.Functor.Contravariant (phantom)
202+import Control.Lens (Lens', Getter)
203+#endif
174204
175205#ifndef ghcjs_HOST_OS
176206import GHCJS.DOM.Types (MonadJSM (..))
177207
178−instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
179− 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'
180219#endif
181220
182−data ImmediateDomBuilderEnv t
183− = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document
184− , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node
185− , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
186− , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
187− }
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+ }
188236
189−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 }
190243 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
191244#if MIN_VERSION_base(4,9,1)
192245 , MonadAsyncException
193246#endif
194247 )
195248
196−instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
197− 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
198251 primitive = lift . primitive
199252
200−instance MonadTrans (ImmediateDomBuilderT t) where
201− lift = ImmediateDomBuilderT . lift . lift . lift
253+instance MonadTrans (HydrationDomBuilderT s t) where
254+ lift = HydrationDomBuilderT . lift . lift
202255
203−instance (Reflex t, MonadFix m) => DomRenderHook t (ImmediateDomBuilderT t m) where
204− withRenderHook hook (ImmediateDomBuilderT a) = do
205− e <- ImmediateDomBuilderT ask
206− ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do
207− (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp
208− return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)
209− requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity
210− requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
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_
211260
212−{-# INLINABLE runImmediateDomBuilderT #-}
213−runImmediateDomBuilderT
261+-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.
262+-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.
263+newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT HydrationState (ReaderT Node (DomRenderHookT t m)) a }
264+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
265+#if MIN_VERSION_base(4,9,1)
266+ , MonadAsyncException
267+#endif
268+ )
269+
270+data HydrationState = HydrationState
271+ { _hydrationState_previousNode :: !(Maybe Node)
272+ , _hydrationState_failed :: !Bool
273+ }
274+
275+{-# INLINABLE localRunner #-}
276+localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a
277+localRunner (HydrationRunnerT m) s parent = do
278+ s0 <- HydrationRunnerT get
279+ (a, s') <- HydrationRunnerT $ lift $ local (\_ -> parent) $ runStateT m (s0 { _hydrationState_previousNode = s })
280+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
281+ HydrationRunnerT $ modify' $ \hs -> hs { _hydrationState_failed = _hydrationState_failed s' }
282+ pure a
283+
284+{-# INLINABLE runHydrationRunnerT #-}
285+runHydrationRunnerT
286+ :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
287+ => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
288+runHydrationRunnerT (HydrationRunnerT m) s parent events = flip runDomRenderHookT events $ flip runReaderT parent $ do
289+ (a, s') <- runStateT m (HydrationState s False)
290+ traverse_ removeSubsequentNodes $ _hydrationState_previousNode s'
291+ when (_hydrationState_failed s') $ liftIO $ putStrLn "reflex-dom warning: hydration failed: the DOM was not as expected at switchover time. This may be due to invalid HTML which the browser has altered upon parsing, some external JS altering the DOM, or the page being served from an outdated cache."
292+ pure a
293+
294+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
295+ {-# INLINABLE newEventWithTrigger #-}
296+ newEventWithTrigger = lift . newEventWithTrigger
297+ {-# INLINABLE newFanEventWithTrigger #-}
298+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
299+
300+instance MonadTrans (HydrationRunnerT t) where
301+ {-# INLINABLE lift #-}
302+ lift = HydrationRunnerT . lift . lift . lift
303+
304+instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where
305+ {-# INLINABLE sample #-}
306+ sample = lift . sample
307+
308+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where
309+ withRenderHook hook = HydrationRunnerT . mapStateT (mapReaderT (withRenderHook hook)) . unHydrationRunnerT
310+ requestDomAction = HydrationRunnerT . lift . lift . requestDomAction
311+ requestDomAction_ = HydrationRunnerT . lift . lift . requestDomAction_
312+
313+-- | Add a hydration step which depends on some computation that should only be
314+-- done *before* the switchover to immediate mode - this is most likely some
315+-- form of 'hold' which we want to remove after hydration is done
316+{-# INLINABLE addHydrationStepWithSetup #-}
317+addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()
318+addHydrationStepWithSetup setup f = getHydrationMode >>= \case
319+ HydrationMode_Immediate -> pure ()
320+ HydrationMode_Hydrating -> do
321+ switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
322+ (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
323+ addHydrationStep (f s)
324+
325+-- | Add a hydration step
326+{-# INLINABLE addHydrationStep #-}
327+addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT s t m ()
328+addHydrationStep m = do
329+ delayedRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_delayed
330+ liftIO $ modifyIORef' delayedRef (>> m)
331+
332+-- | Shared behavior for HydrationDomBuilderT and HydrationRunnerT
333+newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t JSM Identity (TriggerEventT t m) a }
334+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
335+#if MIN_VERSION_base(4,9,1)
336+ , MonadAsyncException
337+#endif
338+ )
339+
340+{-# INLINABLE runDomRenderHookT #-}
341+runDomRenderHookT
342+ :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)
343+ => DomRenderHookT t m a
344+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
345+ -> m a
346+runDomRenderHookT (DomRenderHookT a) events = do
347+ flip runTriggerEventT events $ do
348+ rec (result, req) <- runRequesterT a rsp
349+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
350+ traverseRequesterData (fmap Identity) rm
351+ return result
352+ where
353+ runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
354+ v <- synchronously x
355+ void . liftIO $ f v
356+
357+instance MonadTrans (DomRenderHookT t) where
358+ {-# INLINABLE lift #-}
359+ lift = DomRenderHookT . lift . lift
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
365+ return (ffor req $ \rm -> hook $ traverseRequesterData (fmap Identity) rm, x)
366+ requestDomAction = DomRenderHookT . requestingIdentity
367+ requestDomAction_ = DomRenderHookT . requesting_
368+
369+{-# INLINABLE runHydrationDomBuilderT #-}
370+runHydrationDomBuilderT
214371 :: ( MonadFix m
215372 , PerformEvent t m
216373 , MonadReflexCreateTrigger t m
@@ -219,64 +376,76 @@ runImmediateDomBuilderT
219376 , MonadRef m
220377 , Ref m ~ IORef
221378 )
222− => ImmediateDomBuilderT t m a
223− -> ImmediateDomBuilderEnv t
379+ => HydrationDomBuilderT s t m a
380+ -> HydrationDomBuilderEnv t m
224381 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
225382 -> m a
226−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan =
227− flip runTriggerEventT eventChan $ do
228− rec (x, req) <- runRequesterT (runReaderT a env) rsp
229− rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
230− traverseRequesterData (\r -> Identity <$> r) rm
231− return x
232− where
233− runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
234− v <- synchronously x
235− void . liftIO $ f v
383+runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)
236384
237−class Monad m => HasDocument m where
238− askDocument :: m Document
239− default askDocument :: (m ~ f m', MonadTrans f, Monad m', HasDocument m') => m Document
240− askDocument = lift askDocument
241−
242−instance HasDocument m => HasDocument (ReaderT r m)
243−instance HasDocument m => HasDocument (StateT s m)
244−instance HasDocument m => HasDocument (Lazy.StateT s m)
245−instance HasDocument m => HasDocument (EventWriterT t w m)
246−instance HasDocument m => HasDocument (DynamicWriterT t w m)
247−instance HasDocument m => HasDocument (PostBuildT t m)
248−instance HasDocument m => HasDocument (RequesterT t request response m)
249−instance HasDocument m => HasDocument (QueryT t q m)
250−
251−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
252386 {-# INLINABLE askDocument #-}
253− askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document
387+ askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
254388
255389{-# INLINABLE askParent #-}
256−askParent :: Monad m => ImmediateDomBuilderT t m Node
257−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)
258396
259397{-# INLINABLE askEvents #-}
260−askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
261−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
262400
263−localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
264−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
265404
266405{-# INLINABLE append #-}
267−append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()
406+append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT s t m ()
268407append n = do
269− p <- askParent
408+ p <- getParent
270409 liftJSM $ appendChild_ p n
271410 return ()
272411
273−{-# INLINABLE textNodeInternal #-}
274−textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
275−textNodeInternal !t = do
276− doc <- askDocument
277− n <- liftJSM $ createTextNode doc t
278− append $ toNode n
279− 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]
280449
281450-- | s and e must both be children of the same node and s must precede e;
282451-- all nodes between s and e will be removed, but s and e will not be removed
@@ -314,7 +483,7 @@ extractUpTo df s e = liftJSM $ do
314483 void $ call f f (df, s, e)
315484#endif
316485
317−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))
318487
319488{-# INLINABLE collectUpTo #-}
320489collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
@@ -332,10 +501,15 @@ collectUpToGivenParent currentParent s e = do
332501
333502newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
334503
335−{-# INLINABLE wrap #-}
336−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)
337−wrap e cfg = do
338− 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
339513 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
340514 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
341515 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
@@ -352,46 +526,74 @@ wrap e cfg = do
352526 mv <- liftJSM k --TODO: Only do this when the event is subscribed
353527 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
354528 return $ en :=> EventFilterTriggerRef triggerRef
355− es <- do
356− let h :: GhcjsEventHandler er
357− !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
358− ctx <- askJSM
359− newFanEventWithTrigger $ \(WrapArg en) t ->
360− case DMap.lookup en eventTriggerRefs of
361− Just (EventFilterTriggerRef r) -> do
362− writeIORef r $ Just t
363− return $ do
364− writeIORef r Nothing
365− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
366− evt <- DOM.event
367− mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)
368− case mv of
369− Nothing -> return ()
370− Just v -> liftIO $ do
371− --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
372− ref <- newIORef $ Just t
373− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
374− return $ Element
375− { _element_events = es
376− , _element_raw = e
377− }
378−
379−{-# INLINABLE makeElement #-}
380−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)
381−makeElement elementTag cfg child = do
382− doc <- askDocument
383− e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
384− Nothing -> createElement doc elementTag
385− Just ens -> createElementNS doc (Just ens) elementTag
386− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
387− Nothing -> lift $ setAttribute e n v
388− Just ans -> lift $ setAttributeNS e (Just ans) n v
389− result <- flip localEnv child $ \env -> env
390− { _immediateDomBuilderEnv_parent = toNode e
391− }
392− append $ toNode e
393− wrapped <- wrap e $ extractRawElementConfig cfg
394− 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+ #-}
395597
396598newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
397599
@@ -403,9 +605,10 @@ data GhcjsDomSpace
403605
404606instance DomSpace GhcjsDomSpace where
405607 type EventSpec GhcjsDomSpace = GhcjsEventSpec
608+ type RawDocument GhcjsDomSpace = DOM.Document
406609 type RawTextNode GhcjsDomSpace = DOM.Text
610+ type RawCommentNode GhcjsDomSpace = DOM.Comment
407611 type RawElement GhcjsDomSpace = DOM.Element
408− type RawFile GhcjsDomSpace = DOM.File
409612 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement
410613 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement
411614 type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement
@@ -437,15 +640,11 @@ data GhcjsEventSpec er = GhcjsEventSpec
437640newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }
438641
439642#ifndef USE_TEMPLATE_HASKELL
440−phantom2 :: (Functor f, Contravariant f) => f a -> f b
441−phantom2 = phantom
442−{-# INLINE phantom2 #-}
443−
444643ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))
445644ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a
446645{-# INLINE ghcjsEventSpec_filters #-}
447646ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))
448−ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom2 (f b)
647+ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom (f b)
449648{-# INLINE ghcjsEventSpec_handler #-}
450649#endif
451650
@@ -458,137 +657,753 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
458657 runReaderT (defaultDomEventHandler e en) evt
459658 }
460659
461−instance SupportsImmediateDomBuilder t m => NotReady t (ImmediateDomBuilderT t m) where
660+{-# INLINE makeElement #-}
661+makeElement :: MonadJSM m => Document -> Text -> ElementConfig er t s -> m DOM.Element
662+makeElement doc elementTag cfg = do
663+ e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
664+ Nothing -> createElement doc elementTag
665+ Just ens -> createElementNS doc (Just ens) elementTag
666+ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
667+ Nothing -> setAttribute e n v
668+ Just ans -> setAttributeNS e (Just ans) n v
669+ pure e
670+
671+{-# INLINE elementImmediate #-}
672+elementImmediate
673+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
674+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m )
675+ => Text
676+ -> ElementConfig er t s
677+ -> HydrationDomBuilderT s t m a
678+ -> HydrationDomBuilderT s t m (Element er GhcjsDomSpace t, a)
679+elementImmediate elementTag cfg child = do
680+ doc <- askDocument
681+ ctx <- askJSM
682+ events <- askEvents
683+ parent <- getParent
684+ e <- makeElement doc elementTag cfg
685+ appendChild_ parent e
686+ -- Run the child builder with updated parent and previous sibling references
687+ result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child
688+ let rawCfg = extractRawElementConfig cfg
689+ eventTriggerRefs <- wrap events e rawCfg
690+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
691+ return (Element es e, result)
692+
693+{-# SPECIALIZE elementImmediate
694+ :: Text
695+ -> ElementConfig er DomTimeline HydrationDomSpace
696+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
697+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)
698+ #-}
699+
700+{-# SPECIALIZE elementImmediate
701+ :: Text
702+ -> ElementConfig er DomTimeline GhcjsDomSpace
703+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM a
704+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)
705+ #-}
706+
707+-- For specialisation
708+
709+-- | The Reflex timeline for interacting with the DOM
710+type DomTimeline =
711+#ifdef PROFILE_REFLEX
712+ ProfiledTimeline
713+#endif
714+ Spider
715+
716+-- | The ReflexHost the DOM lives in
717+type DomHost =
718+#ifdef PROFILE_REFLEX
719+ ProfiledM
720+#endif
721+ (SpiderHost Global)
722+
723+type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))
724+type HydrationM = DomCoreWidget ()
725+
726+{-# INLINE elementInternal #-}
727+elementInternal
728+ :: (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
729+ => Text
730+ -> ElementConfig er t HydrationDomSpace
731+ -> HydrationDomBuilderT HydrationDomSpace t m a
732+ -> HydrationDomBuilderT HydrationDomSpace t m (Element er HydrationDomSpace t, a)
733+elementInternal elementTag cfg child = getHydrationMode >>= \case
734+ HydrationMode_Immediate -> do
735+ (Element es _, result) <- elementImmediate elementTag cfg child
736+ return (Element es (), result)
737+ HydrationMode_Hydrating -> fst <$> hydrateElement elementTag cfg child
738+
739+{-# SPECIALIZE elementInternal
740+ :: Text
741+ -> ElementConfig er DomTimeline HydrationDomSpace
742+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
743+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
744+ #-}
745+
746+{-# INLINE hydrateElement #-}
747+hydrateElement
748+ :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
749+ => Text
750+ -> ElementConfig er t HydrationDomSpace
751+ -> HydrationDomBuilderT HydrationDomSpace t m a
752+ -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)
753+hydrateElement elementTag cfg child = do
754+ ctx <- askJSM
755+ events <- askEvents
756+ -- Schedule everything for after postBuild, except for getting the result itself
757+ parentRef <- liftIO $ newIORef $ error "Parent not yet initialized"
758+ e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"
759+ env <- HydrationDomBuilderT ask
760+ childDelayedRef <- liftIO $ newIORef $ pure ()
761+ let env' = env
762+ { _hydrationDomBuilderEnv_parent = Right parentRef
763+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
764+ }
765+ result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
766+ wrapResult <- liftIO newEmptyMVar
767+ let skipAttr = "data-hydration-skip" :: DOM.JSString
768+ ssrAttr = "data-ssr" :: DOM.JSString
769+ shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
770+ shouldSkip e = case cfg ^. namespace of
771+ Nothing -> do
772+ skip <- hasAttribute e skipAttr
773+ ssr <- hasAttribute e ssrAttr
774+ pure $ skip || not ssr
775+ Just ns -> do
776+ skip <- hasAttributeNS e (Just ns) skipAttr
777+ ssr <- hasAttributeNS e (Just ns) ssrAttr
778+ pure $ skip || not ssr
779+ childDom <- liftIO $ readIORef childDelayedRef
780+ let rawCfg = extractRawElementConfig cfg
781+ doc <- askDocument
782+ addHydrationStep $ do
783+ parent <- askParent
784+ lastHydrationNode <- getPreviousNode
785+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
786+ Nothing -> do -- ran out of nodes, create the element
787+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
788+ e <- makeElement doc elementTag cfg
789+ insertAfterPreviousNode e
790+ pure e
791+ Just node -> DOM.castTo DOM.Element node >>= \case
792+ Nothing -> go (Just node) -- this node is not an element, skip
793+ Just e -> shouldSkip e >>= \case
794+ True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
795+ False -> do
796+ t <- Element.getTagName e
797+ -- TODO: check attributes?
798+ if T.toCaseFold elementTag == T.toCaseFold t
799+ then pure e
800+ -- we came to some other statically rendered element, so something has gone wrong
801+ else do
802+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
803+ n <- makeElement doc elementTag cfg
804+ insertAfterPreviousNode n
805+ pure n
806+ e <- go lastHydrationNode
807+ setPreviousNode $ Just $ toNode e
808+ -- Update the parent node used by the children
809+ liftIO $ writeIORef parentRef $ toNode e
810+ liftIO $ writeIORef e' e
811+ -- Setup events, store the result so we can wait on it later
812+ refs <- wrap events e rawCfg
813+ liftIO $ putMVar wrapResult (e, refs)
814+ localRunner childDom Nothing $ toNode e
815+ -- We need the EventSelector to switch to the real event handler after activation
816+ es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
817+ cleanup <- newEmptyMVar
818+ threadId <- forkIO $ do
819+ -- Wait on the data we need from the delayed action
820+ (e, eventTriggerRefs) <- readMVar wrapResult
821+ bracketOnError
822+ -- Run the setup, acquiring the cleanup action
823+ (triggerBody ctx rawCfg events eventTriggerRefs e (WrapArg en) t)
824+ -- Run the cleanup, if we have it - but only when an exception is
825+ -- raised (we might get killed between acquiring the cleanup action
826+ -- from 'triggerBody' and putting it in the MVar)
827+ id
828+ -- Try to put this action into the cleanup MVar
829+ (putMVar cleanup)
830+ pure $ do
831+ tryReadMVar cleanup >>= \case
832+ Nothing -> killThread threadId
833+ Just c -> c
834+ return ((Element es (), result), e')
835+
836+{-# SPECIALIZE hydrateElement
837+ :: Text
838+ -> ElementConfig er DomTimeline HydrationDomSpace
839+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
840+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM ((Element er HydrationDomSpace DomTimeline, a), IORef DOM.Element)
841+ #-}
842+
843+{-# INLINE inputElementImmediate #-}
844+inputElementImmediate
845+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
846+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
847+ , MonadRef m, Ref m ~ IORef )
848+ => InputElementConfig er t s -> HydrationDomBuilderT s t m (InputElement er GhcjsDomSpace t)
849+inputElementImmediate cfg = do
850+ (e@(Element eventSelector domElement), ()) <- elementImmediate "input" (_inputElementConfig_elementConfig cfg) $ return ()
851+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
852+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
853+ v0 <- Input.getValue domInputElement
854+ let getMyValue = Input.getValue domInputElement
855+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
856+ valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
857+ Nothing -> return never
858+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
859+ Input.setValue domInputElement v'
860+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
861+ v <- holdDyn v0 $ leftmost
862+ [ valueChangedBySetValue
863+ , valueChangedByUI
864+ ]
865+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
866+ checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
867+ Input.getChecked domInputElement
868+ checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
869+ Nothing -> return never
870+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
871+ oldChecked <- Input.getChecked domInputElement
872+ Input.setChecked domInputElement newChecked
873+ return $ if newChecked /= oldChecked
874+ then Just newChecked
875+ else Nothing
876+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
877+ [ fmapMaybe id checkedChangedBySetChecked
878+ , checkedChangedByUI
879+ ]
880+ hasFocus <- mkHasFocus e
881+ files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
882+ mfiles <- Input.getFiles domInputElement
883+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
884+ maybe (return []) getMyFiles mfiles
885+ checked <- holdUniqDyn c
886+ return $ InputElement
887+ { _inputElement_value = v
888+ , _inputElement_checked = checked
889+ , _inputElement_checkedChange = checkedChangedByUI
890+ , _inputElement_input = valueChangedByUI
891+ , _inputElement_hasFocus = hasFocus
892+ , _inputElement_element = e
893+ , _inputElement_raw = domInputElement
894+ , _inputElement_files = files
895+ }
896+
897+{-# INLINE inputElementInternal #-}
898+inputElementInternal
899+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
900+ , MonadRef m, Ref m ~ IORef )
901+ => InputElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (InputElement er HydrationDomSpace t)
902+inputElementInternal cfg = getHydrationMode >>= \case
903+ HydrationMode_Immediate -> ffor (inputElementImmediate cfg) $ \result -> result
904+ { _inputElement_element = Element (_element_events $ _inputElement_element result) ()
905+ , _inputElement_raw = ()
906+ }
907+ HydrationMode_Hydrating -> do
908+ ((e, _), domElementRef) <- hydrateElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
909+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
910+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
911+ (focusChange, triggerFocusChange) <- newTriggerEvent
912+ (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent
913+ (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent
914+ (fileChange, triggerFileChange) <- newTriggerEvent
915+ doc <- askDocument
916+ -- Expected initial value from config
917+ let v0 = _inputElementConfig_initialValue cfg
918+ addHydrationStep $ do
919+ domElement <- liftIO $ readIORef domElementRef
920+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
921+ getValue = Input.getValue domInputElement
922+ -- The browser might have messed with the value, or the user could have
923+ -- altered it before activation, so we set it if it isn't what we expect
924+ liftJSM getValue >>= \v0' -> do
925+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
926+ -- Watch for user interaction and trigger event accordingly
927+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
928+ for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->
929+ requestDomAction_ $ ffor eSetValue $ \v' -> do
930+ Input.setValue domInputElement v'
931+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
932+ liftIO $ triggerChangeBySetValue v
933+ let focusChange' = leftmost
934+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
935+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
936+ ]
937+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
938+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
939+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
940+ _ <- liftJSM $ domInputElement `on` Events.click $ do
941+ liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement
942+ for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->
943+ requestDomAction $ ffor eNewchecked $ \newChecked -> do
944+ oldChecked <- Input.getChecked domInputElement
945+ Input.setChecked domInputElement newChecked
946+ when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked
947+ _ <- liftJSM $ domInputElement `on` Events.change $ do
948+ mfiles <- Input.getFiles domInputElement
949+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
950+ liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles
951+ return ()
952+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
953+ [ checkedChangedBySetChecked
954+ , checkedChangedByUI
955+ ]
956+ checked <- holdUniqDyn checked'
957+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
958+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
959+ v <- holdDyn v0 $ leftmost
960+ [ valueChangedBySetValue
961+ , valueChangedByUI
962+ ]
963+ files <- holdDyn mempty fileChange
964+ return $ InputElement
965+ { _inputElement_value = v
966+ , _inputElement_checked = checked
967+ , _inputElement_checkedChange = checkedChangedByUI
968+ , _inputElement_input = valueChangedByUI
969+ , _inputElement_hasFocus = hasFocus
970+ , _inputElement_element = e
971+ , _inputElement_raw = ()
972+ , _inputElement_files = files
973+ }
974+
975+{-# INLINE textAreaElementImmediate #-}
976+textAreaElementImmediate
977+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
978+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
979+ , MonadRef m, Ref m ~ IORef )
980+ => TextAreaElementConfig er t s -> HydrationDomBuilderT s t m (TextAreaElement er GhcjsDomSpace t)
981+textAreaElementImmediate cfg = do
982+ (e@(Element eventSelector domElement), _) <- elementImmediate "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
983+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
984+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
985+ v0 <- TextArea.getValue domTextAreaElement
986+ let getMyValue = TextArea.getValue domTextAreaElement
987+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)
988+ valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
989+ Nothing -> return never
990+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
991+ TextArea.setValue domTextAreaElement v'
992+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
993+ v <- holdDyn v0 $ leftmost
994+ [ valueChangedBySetValue
995+ , valueChangedByUI
996+ ]
997+ hasFocus <- mkHasFocus e
998+ return $ TextAreaElement
999+ { _textAreaElement_value = v
1000+ , _textAreaElement_input = valueChangedByUI
1001+ , _textAreaElement_hasFocus = hasFocus
1002+ , _textAreaElement_element = e
1003+ , _textAreaElement_raw = domTextAreaElement
1004+ }
1005+
1006+{-# INLINE textAreaElementInternal #-}
1007+textAreaElementInternal
1008+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1009+ , MonadRef m, Ref m ~ IORef )
1010+ => TextAreaElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (TextAreaElement er HydrationDomSpace t)
1011+textAreaElementInternal cfg = getHydrationMode >>= \case
1012+ HydrationMode_Immediate -> ffor (textAreaElementImmediate cfg) $ \result -> result
1013+ { _textAreaElement_element = Element (_element_events $ _textAreaElement_element result) ()
1014+ , _textAreaElement_raw = ()
1015+ }
1016+ HydrationMode_Hydrating -> do
1017+ ((e, _), domElementRef) <- hydrateElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
1018+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1019+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1020+ (focusChange, triggerFocusChange) <- newTriggerEvent
1021+ doc <- askDocument
1022+ -- Expected initial value from config
1023+ let v0 = _textAreaElementConfig_initialValue cfg
1024+ addHydrationStep $ do
1025+ domElement <- liftIO $ readIORef domElementRef
1026+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
1027+ getValue = TextArea.getValue domTextAreaElement
1028+ -- The browser might have messed with the value, or the user could have
1029+ -- altered it before activation, so we set it if it isn't what we expect
1030+ liftJSM getValue >>= \v0' -> do
1031+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1032+ -- Watch for user interaction and trigger event accordingly
1033+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)
1034+ for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->
1035+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1036+ TextArea.setValue domTextAreaElement v'
1037+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1038+ liftIO $ triggerChangeBySetValue v
1039+ let focusChange' = leftmost
1040+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1041+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1042+ ]
1043+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1044+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1045+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1046+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1047+ v <- holdDyn v0 $ leftmost
1048+ [ valueChangedBySetValue
1049+ , valueChangedByUI
1050+ ]
1051+ return $ TextAreaElement
1052+ { _textAreaElement_value = v
1053+ , _textAreaElement_input = valueChangedByUI
1054+ , _textAreaElement_hasFocus = hasFocus
1055+ , _textAreaElement_element = e
1056+ , _textAreaElement_raw = ()
1057+ }
1058+
1059+{-# INLINE selectElementImmediate #-}
1060+selectElementImmediate
1061+ :: ( EventSpec s ~ GhcjsEventSpec, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
1062+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m )
1063+ => SelectElementConfig er t s
1064+ -> HydrationDomBuilderT s t m a
1065+ -> HydrationDomBuilderT s t m (SelectElement er GhcjsDomSpace t, a)
1066+selectElementImmediate cfg child = do
1067+ (e@(Element eventSelector domElement), result) <- elementImmediate "select" (cfg ^. selectElementConfig_elementConfig) child
1068+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1069+ Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
1070+ v0 <- Select.getValue domSelectElement
1071+ let getMyValue = Select.getValue domSelectElement
1072+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Change)
1073+ valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
1074+ Nothing -> return never
1075+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
1076+ Select.setValue domSelectElement v'
1077+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
1078+ v <- holdDyn v0 $ leftmost
1079+ [ valueChangedBySetValue
1080+ , valueChangedByUI
1081+ ]
1082+ hasFocus <- mkHasFocus e
1083+ let wrapped = SelectElement
1084+ { _selectElement_value = v
1085+ , _selectElement_change = valueChangedByUI
1086+ , _selectElement_hasFocus = hasFocus
1087+ , _selectElement_element = e
1088+ , _selectElement_raw = domSelectElement
1089+ }
1090+ return (wrapped, result)
1091+
1092+{-# INLINE selectElementInternal #-}
1093+selectElementInternal
1094+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m
1095+ , MonadRef m, Ref m ~ IORef )
1096+ => SelectElementConfig er t HydrationDomSpace
1097+ -> HydrationDomBuilderT HydrationDomSpace t m a
1098+ -> HydrationDomBuilderT HydrationDomSpace t m (SelectElement er HydrationDomSpace t, a)
1099+selectElementInternal cfg child = getHydrationMode >>= \case
1100+ HydrationMode_Immediate -> ffor (selectElementImmediate cfg child) $ \(e, result) -> (e
1101+ { _selectElement_element = Element (_element_events $ _selectElement_element e) ()
1102+ , _selectElement_raw = ()
1103+ }, result)
1104+ HydrationMode_Hydrating -> do
1105+ ((e, result), domElementRef) <- hydrateElement "select" (cfg ^. selectElementConfig_elementConfig) child
1106+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
1107+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
1108+ (focusChange, triggerFocusChange) <- newTriggerEvent
1109+ doc <- askDocument
1110+ -- Expected initial value from config
1111+ let v0 = _selectElementConfig_initialValue cfg
1112+ addHydrationStep $ do
1113+ domElement <- liftIO $ readIORef domElementRef
1114+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
1115+ getValue = Select.getValue domSelectElement
1116+ -- The browser might have messed with the value, or the user could have
1117+ -- altered it before activation, so we set it if it isn't what we expect
1118+ liftJSM getValue >>= \v0' -> do
1119+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
1120+ -- Watch for user interaction and trigger event accordingly
1121+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)
1122+ for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->
1123+ requestDomAction_ $ ffor eSetValue $ \v' -> do
1124+ Select.setValue domSelectElement v'
1125+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
1126+ liftIO $ triggerChangeBySetValue v
1127+ let focusChange' = leftmost
1128+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1129+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1130+ ]
1131+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
1132+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
1133+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
1134+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
1135+ v <- holdDyn v0 $ leftmost
1136+ [ valueChangedBySetValue
1137+ , valueChangedByUI
1138+ ]
1139+ return $ (,result) $ SelectElement
1140+ { _selectElement_value = v
1141+ , _selectElement_change = valueChangedByUI
1142+ , _selectElement_hasFocus = hasFocus
1143+ , _selectElement_element = e
1144+ , _selectElement_raw = ()
1145+ }
1146+
1147+{-# INLINE textNodeImmediate #-}
1148+textNodeImmediate
1149+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1150+ => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text
1151+textNodeImmediate (TextNodeConfig !t mSetContents) = do
1152+ p <- getParent
1153+ doc <- askDocument
1154+ n <- createTextNode doc t
1155+ appendChild_ p n
1156+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1157+ pure n
1158+
1159+{-# SPECIALIZE textNodeImmediate
1160+ :: TextNodeConfig DomTimeline
1161+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM DOM.Text
1162+ #-}
1163+
1164+{-# SPECIALIZE textNodeImmediate
1165+ :: TextNodeConfig DomTimeline
1166+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM DOM.Text
1167+ #-}
1168+
1169+{-# INLINE textNodeInternal #-}
1170+textNodeInternal
1171+ :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)
1172+ => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)
1173+textNodeInternal tc@(TextNodeConfig !t mSetContents) = do
1174+ doc <- askDocument
1175+ getHydrationMode >>= \case
1176+ HydrationMode_Immediate -> void $ textNodeImmediate tc
1177+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do
1178+ n <- hydrateTextNode doc =<< sample currentText
1179+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1180+ pure $ TextNode ()
1181+
1182+{-# SPECIALIZE textNodeInternal
1183+ :: TextNodeConfig DomTimeline
1184+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (TextNode HydrationDomSpace DomTimeline)
1185+ #-}
1186+
1187+-- | The static builder mashes adjacent text nodes into one node: we check the
1188+-- text content of each node we come to, comparing it to the content we
1189+-- expect. We also have a special case for empty text nodes - we always create
1190+-- the and add them after the previous node reference.
1191+{-# INLINE hydrateTextNode #-}
1192+hydrateTextNode :: MonadJSM m => Document -> Text -> HydrationRunnerT t m DOM.Text
1193+hydrateTextNode doc t@"" = do
1194+ tn <- createTextNode doc t
1195+ insertAfterPreviousNode tn
1196+ pure tn
1197+hydrateTextNode doc t = do
1198+ n <- join $ go <$> askParent <*> getPreviousNode
1199+ setPreviousNode $ Just $ toNode n
1200+ return n
1201+ where
1202+ go parent mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1203+ Nothing -> do
1204+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1205+ n <- createTextNode doc t
1206+ insertAfterPreviousNode n
1207+ pure n
1208+ Just node -> DOM.castTo DOM.Text node >>= \case
1209+ Nothing -> go parent $ Just node
1210+ Just originalNode -> do
1211+ originalText <- Node.getTextContentUnchecked originalNode
1212+ case T.stripPrefix t originalText of
1213+ Just "" -> return originalNode
1214+ Just _ -> do
1215+ -- If we have the right prefix, we split the text node into a node containing the
1216+ -- required text and a subsequent sibling node containing the rest of the text.
1217+ DOM.splitText_ originalNode $ fromIntegral $ T.length t
1218+ return originalNode
1219+ Nothing -> do
1220+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1221+ n <- createTextNode doc t
1222+ insertAfterPreviousNode n
1223+ pure n
1224+
1225+{-# INLINE commentNodeImmediate #-}
1226+commentNodeImmediate
1227+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)
1228+ => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment
1229+commentNodeImmediate (CommentNodeConfig !t mSetContents) = do
1230+ p <- getParent
1231+ doc <- askDocument
1232+ n <- createComment doc t
1233+ appendChild_ p n
1234+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1235+ pure n
1236+
1237+{-# INLINE commentNodeInternal #-}
1238+commentNodeInternal
1239+ :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Reflex t, Adjustable t m, MonadHold t m, MonadSample t m)
1240+ => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)
1241+commentNodeInternal tc@(CommentNodeConfig t0 mSetContents) = do
1242+ doc <- askDocument
1243+ getHydrationMode >>= \case
1244+ HydrationMode_Immediate -> void $ commentNodeInternal tc
1245+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do
1246+ t <- sample bt
1247+ void $ hydrateComment doc t mSetContents
1248+ pure $ CommentNode ()
1249+
1250+{-# INLINE hydrateComment #-}
1251+hydrateComment :: (MonadJSM m, Reflex t, MonadFix m) => Document -> Text -> Maybe (Event t Text) -> HydrationRunnerT t m DOM.Comment
1252+hydrateComment doc t mSetContents = do
1253+ parent <- askParent
1254+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1255+ Nothing -> do
1256+ c <- createComment doc t
1257+ insertAfterPreviousNode c
1258+ pure c
1259+ Just node -> DOM.castTo DOM.Comment node >>= \case
1260+ Nothing -> go (Just node)
1261+ Just c -> do
1262+ t' <- Node.getTextContentUnchecked c
1263+ if t == t'
1264+ then pure c
1265+ else do
1266+ c' <- createComment doc t
1267+ insertAfterPreviousNode c'
1268+ pure c'
1269+ n <- go =<< getPreviousNode
1270+ setPreviousNode $ Just $ toNode n
1271+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1272+ pure n
1273+
1274+-- | We leave markers in the static builder as comments, and rip these comments
1275+-- out at hydration time, replacing them with empty text nodes.
1276+{-# INLINABLE skipToAndReplaceComment #-}
1277+skipToAndReplaceComment
1278+ :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1279+ => Text
1280+ -> IORef Text
1281+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1282+skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
1283+ HydrationMode_Immediate -> do
1284+ -- If we're in immediate mode, we don't try to replace an existing comment,
1285+ -- and just return a dummy key
1286+ t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
1287+ append $ toNode t
1288+ textNodeRef <- liftIO $ newIORef t
1289+ keyRef <- liftIO $ newIORef ""
1290+ pure (pure (), textNodeRef, keyRef)
1291+ HydrationMode_Hydrating -> do
1292+ doc <- askDocument
1293+ textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
1294+ keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1295+ let go key0 mLastNode = do
1296+ parent <- askParent
1297+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1298+ DOM.castTo DOM.Comment node >>= \case
1299+ Just comment -> do
1300+ commentText <- Node.getTextContentUnchecked comment
1301+ case T.stripPrefix (prefix <> key0) commentText of
1302+ Just key -> do
1303+ -- Replace the comment with an (invisible) text node
1304+ tn <- createTextNode doc ("" :: Text)
1305+ Node.replaceChild_ parent tn comment
1306+ pure (tn, key)
1307+ Nothing -> do
1308+ go key0 (Just node)
1309+ Nothing -> do
1310+ go key0 (Just node)
1311+ switchComment = do
1312+ key0 <- liftIO $ readIORef key0Ref
1313+ (tn, key) <- go key0 =<< getPreviousNode
1314+ setPreviousNode $ Just $ toNode tn
1315+ liftIO $ do
1316+ writeIORef textNodeRef tn
1317+ writeIORef keyRef key
1318+ pure (switchComment, textNodeRef, keyRef)
1319+
1320+{-# INLINABLE skipToReplaceStart #-}
1321+skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1322+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
1323+
1324+{-# INLINABLE skipToReplaceEnd #-}
1325+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)
1326+skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
1327+
1328+instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
4621329 notReadyUntil e = do
4631330 eOnce <- headE e
464− env <- ImmediateDomBuilderT ask
465− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1331+ unreadyChildren <- askUnreadyChildren
1332+ commitAction <- askCommitAction
4661333 liftIO $ modifyIORef' unreadyChildren succ
4671334 let ready = do
4681335 old <- liftIO $ readIORef unreadyChildren
4691336 let new = pred old
4701337 liftIO $ writeIORef unreadyChildren $! new
471− when (new == 0) $ _immediateDomBuilderEnv_commitAction env
1338+ when (new == 0) commitAction
4721339 requestDomAction_ $ ready <$ eOnce
4731340 notReady = do
474− env <- ImmediateDomBuilderT ask
475− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1341+ unreadyChildren <- askUnreadyChildren
4761342 liftIO $ modifyIORef' unreadyChildren succ
4771343
478−instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
479− type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace
1344+data HydrationDomSpace
1345+
1346+instance DomSpace HydrationDomSpace where
1347+ type EventSpec HydrationDomSpace = GhcjsEventSpec
1348+ type RawDocument HydrationDomSpace = DOM.Document
1349+ type RawTextNode HydrationDomSpace = ()
1350+ type RawCommentNode HydrationDomSpace = ()
1351+ type RawElement HydrationDomSpace = ()
1352+ type RawInputElement HydrationDomSpace = ()
1353+ type RawTextAreaElement HydrationDomSpace = ()
1354+ type RawSelectElement HydrationDomSpace = ()
1355+ addEventSpecFlags _ en f es = es
1356+ { _ghcjsEventSpec_filters =
1357+ let f' = Just . GhcjsEventFilter . \case
1358+ Nothing -> \evt -> do
1359+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)
1360+ return (f mEventResult, return mEventResult)
1361+ Just (GhcjsEventFilter oldFilter) -> \evt -> do
1362+ (oldFlags, oldContinuation) <- oldFilter evt
1363+ mEventResult <- oldContinuation
1364+ let newFlags = oldFlags <> f mEventResult
1365+ return (newFlags, return mEventResult)
1366+ in DMap.alter f' en $ _ghcjsEventSpec_filters es
1367+ }
1368+
1369+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT HydrationDomSpace t m) where
1370+ type DomBuilderSpace (HydrationDomBuilderT HydrationDomSpace t m) = HydrationDomSpace
1371+ {-# INLINABLE element #-}
1372+ element = elementInternal
4801373 {-# INLINABLE textNode #-}
481− textNode (TextNodeConfig initialContents mSetContents) = do
482− n <- textNodeInternal initialContents
483− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
484− return $ TextNode n
1374+ textNode = textNodeInternal
1375+ {-# INLINABLE commentNode #-}
1376+ commentNode = commentNodeInternal
1377+ {-# INLINABLE inputElement #-}
1378+ inputElement = inputElementInternal
1379+ {-# INLINABLE textAreaElement #-}
1380+ textAreaElement = textAreaElementInternal
1381+ {-# INLINABLE selectElement #-}
1382+ selectElement = selectElementInternal
1383+ placeRawElement () = pure ()
1384+ wrapRawElement () _cfg = pure $ Element (EventSelector $ const never) ()
1385+
1386+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1387+ type DomBuilderSpace (HydrationDomBuilderT GhcjsDomSpace t m) = GhcjsDomSpace
4851388 {-# INLINABLE element #-}
486− element elementTag cfg child = fst <$> makeElement elementTag cfg child
1389+ element = elementImmediate
1390+ {-# INLINABLE textNode #-}
1391+ textNode = fmap TextNode . textNodeImmediate
1392+ {-# INLINABLE commentNode #-}
1393+ commentNode = fmap CommentNode . commentNodeImmediate
4871394 {-# INLINABLE inputElement #-}
488− inputElement cfg = do
489− ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
490− let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
491− Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
492− v0 <- Input.getValue domInputElement
493− let getMyValue = Input.getValue domInputElement
494− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
495− valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
496− Nothing -> return never
497− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
498− Input.setValue domInputElement v'
499− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
500− v <- holdDyn v0 $ leftmost
501− [ valueChangedBySetValue
502− , valueChangedByUI
503− ]
504− Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
505− checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
506− Input.getChecked domInputElement
507− checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
508− Nothing -> return never
509− Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
510− oldChecked <- Input.getChecked domInputElement
511− Input.setChecked domInputElement newChecked
512− return $ if newChecked /= oldChecked
513− then Just newChecked
514− else Nothing
515− c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
516− [ fmapMaybe id checkedChangedBySetChecked
517− , checkedChangedByUI
518− ]
519− let initialFocus = False --TODO: Is this correct?
520− hasFocus <- holdDyn initialFocus $ leftmost
521− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
522− , True <$ Reflex.select (_element_events e) (WrapArg Focus)
523− ]
524− files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
525− mfiles <- Input.getFiles domInputElement
526− let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
527− maybe (return []) getMyFiles mfiles
528− checked <- holdUniqDyn c
529− return $ InputElement
530− { _inputElement_value = v
531− , _inputElement_checked = checked
532− , _inputElement_checkedChange = checkedChangedByUI
533− , _inputElement_input = valueChangedByUI
534− , _inputElement_hasFocus = hasFocus
535− , _inputElement_element = e
536− , _inputElement_raw = domInputElement
537− , _inputElement_files = files
538− }
1395+ inputElement = inputElementImmediate
5391396 {-# INLINABLE textAreaElement #-}
540− textAreaElement cfg = do --TODO
541− ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
542− let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
543− TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
544− v0 <- TextArea.getValue domTextAreaElement
545− let getMyValue = TextArea.getValue domTextAreaElement
546− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
547− valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
548− Nothing -> return never
549− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
550− TextArea.setValue domTextAreaElement v'
551− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
552− v <- holdDyn v0 $ leftmost
553− [ valueChangedBySetValue
554− , valueChangedByUI
555− ]
556− hasFocus <- mkHasFocus e
557− return $ TextAreaElement
558− { _textAreaElement_value = v
559− , _textAreaElement_input = valueChangedByUI
560− , _textAreaElement_hasFocus = hasFocus
561− , _textAreaElement_element = e
562− , _textAreaElement_raw = domTextAreaElement
563− }
1397+ textAreaElement = textAreaElementImmediate
5641398 {-# INLINABLE selectElement #-}
565− selectElement cfg child = do
566− ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
567− let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
568− Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
569− v0 <- Select.getValue domSelectElement
570− let getMyValue = Select.getValue domSelectElement
571− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
572− valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
573− Nothing -> return never
574− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
575− Select.setValue domSelectElement v'
576− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
577− v <- holdDyn v0 $ leftmost
578− [ valueChangedBySetValue
579− , valueChangedByUI
580− ]
581− hasFocus <- mkHasFocus e
582− let wrapped = SelectElement
583− { _selectElement_value = v
584− , _selectElement_change = valueChangedByUI
585− , _selectElement_hasFocus = hasFocus
586− , _selectElement_element = e
587− , _selectElement_raw = domSelectElement
588− }
589− return (wrapped, result)
1399+ selectElement = selectElementImmediate
5901400 placeRawElement = append . toNode
591− wrapRawElement = wrap
1401+ wrapRawElement e rawCfg = do
1402+ events <- askEvents
1403+ ctx <- askJSM
1404+ eventTriggerRefs <- wrap events e rawCfg
1405+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
1406+ pure $ Element es e
5921407
5931408data FragmentState
5941409 = FragmentState_Unmounted
@@ -608,21 +1423,21 @@ extractFragment fragment = do
6081423 extractBetweenExclusive (_immediateDomFragment_document fragment) before after
6091424 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
6101425
611−instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
612− type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
1426+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1427+ type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment
6131428 buildDomFragment w = do
6141429 df <- createDocumentFragment =<< askDocument
6151430 result <- flip localEnv w $ \env -> env
616− { _immediateDomBuilderEnv_parent = toNode df
1431+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
6171432 }
6181433 state <- liftIO $ newIORef FragmentState_Unmounted
6191434 return (ImmediateDomFragment df state, result)
6201435 mountDomFragment fragment setFragment = do
621− parent <- askParent
1436+ parent <- getParent
6221437 extractFragment fragment
623− before <- textNodeInternal ("" :: Text)
1438+ before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6241439 appendChild_ parent $ _immediateDomFragment_document fragment
625− after <- textNodeInternal ("" :: Text)
1440+ after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
6261441 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
6271442 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
6281443 extractFragment previousFragment
@@ -631,12 +1446,19 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
6311446 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
6321447 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
6331448
634−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
1449+instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (DomRenderHookT t m) where
1450+ runWithReplace a0 a' = DomRenderHookT $ runWithReplace (unDomRenderHookT a0) (fmapCheap unDomRenderHookT a')
1451+ traverseIntMapWithKeyWithAdjust f m = DomRenderHookT . traverseIntMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1452+ traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
1453+ traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
1454+
1455+instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Adjustable t (HydrationDomBuilderT s t m) where
6351456 {-# INLINABLE runWithReplace #-}
6361457 runWithReplace a0 a' = do
637− initialEnv <- ImmediateDomBuilderT ask
638− before <- textNodeInternal ("" :: Text)
639− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
1458+ initialEnv <- HydrationDomBuilderT ask
1459+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
1460+ (hydrateStart, before, beforeKey) <- skipToReplaceStart
1461+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
6401462 haveEverBeenReady <- liftIO $ newIORef False
6411463 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
6421464 let myCommitAction = do
@@ -647,79 +1469,117 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
6471469 old <- liftIO $ readIORef parentUnreadyChildren
6481470 let new = pred old
6491471 liftIO $ writeIORef parentUnreadyChildren $! new
650− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
1472+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
6511473 -- We draw 'after' in this roundabout way to avoid using MonadFix
6521474 doc <- askDocument
653− after <- createTextNode doc ("" :: Text)
1475+ parent <- getParent
1476+ (hydrateEnd, after) <- skipToReplaceEnd beforeKey
6541477 let drawInitialChild = do
1478+ h <- liftIO $ readIORef hydrating
1479+ p' <- case h of
1480+ HydrationMode_Hydrating -> pure parent
1481+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6551482 unreadyChildren <- liftIO $ newIORef 0
656− let f = do
657− result <- a0
658− append $ toNode after
659− return result
660− result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
661− { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
662− , _immediateDomBuilderEnv_commitAction = myCommitAction
1483+ let a0' = case h of
1484+ HydrationMode_Hydrating -> a0
1485+ HydrationMode_Immediate -> do
1486+ a <- a0
1487+ insertBefore p' =<< liftIO (readIORef after)
1488+ pure a
1489+ delayed <- case h of
1490+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1491+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1492+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv
1493+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1494+ , _hydrationDomBuilderEnv_commitAction = myCommitAction
1495+ , _hydrationDomBuilderEnv_parent = Left p'
1496+ , _hydrationDomBuilderEnv_delayed = delayed
6631497 }
1498+ dom <- case h of
1499+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1500+ HydrationMode_Immediate -> pure $ pure ()
6641501 liftIO $ readIORef unreadyChildren >>= \case
6651502 0 -> writeIORef haveEverBeenReady True
6661503 _ -> modifyIORef' parentUnreadyChildren succ
667− return result
1504+ return (dom, result)
6681505 a'' <- numberOccurrences a'
669− (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
670− df <- createDocumentFragment doc
1506+ ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
1507+ h <- liftIO $ readIORef hydrating
1508+ p' <- case h of
1509+ HydrationMode_Hydrating -> pure parent
1510+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
6711511 unreadyChildren <- liftIO $ newIORef 0
6721512 let commitAction = do
6731513 c <- liftIO $ readIORef currentCohort
6741514 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
675− deleteBetweenExclusive before after
676− insertBefore df after
1515+ !before' <- liftIO $ readIORef before
1516+ !after' <- liftIO $ readIORef after
1517+ deleteBetweenExclusive before' after'
1518+ insertBefore p' after'
6771519 liftIO $ writeIORef currentCohort cohortId
6781520 myCommitAction
679− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
680− { _immediateDomBuilderEnv_parent = toNode df
681− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
682− , _immediateDomBuilderEnv_commitAction = commitAction
683− }
1521+ delayed <- case h of
1522+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1523+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
1524+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv
1525+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1526+ , _hydrationDomBuilderEnv_commitAction = case h of
1527+ HydrationMode_Hydrating -> myCommitAction
1528+ HydrationMode_Immediate -> commitAction
1529+ , _hydrationDomBuilderEnv_parent = Left p'
1530+ , _hydrationDomBuilderEnv_delayed = delayed
1531+ }
1532+ dom <- case h of
1533+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1534+ HydrationMode_Immediate -> pure $ pure ()
6841535 uc <- liftIO $ readIORef unreadyChildren
6851536 let commitActionToRunNow = if uc == 0
686− then Just commitAction
1537+ then Just $ commitAction
6871538 else Nothing -- A child will run it when unreadyChildren is decremented to 0
688− return (commitActionToRunNow, result)
689− requestDomAction_ $ fmapMaybe fst child'
1539+ actions = case h of
1540+ HydrationMode_Hydrating -> Left dom
1541+ HydrationMode_Immediate -> Right commitActionToRunNow
1542+ return (actions, result)
1543+ let (hydrate', commitAction) = fanEither $ fmap fst child'
1544+ addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do
1545+ hydrateStart
1546+ join $ sample contents
1547+ hydrateEnd
1548+ requestDomAction_ $ fmapMaybe id commitAction
6901549 return (result0, snd <$> child')
1550+
6911551 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
6921552 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
6931553 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
6941554 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
6951555 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
6961556 traverseDMapWithKeyWithAdjustWithMove = do
697− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
698− let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
1557+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do
1558+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState (Some k)))) a)
6991559 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
700− PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
701− readIORef sRef >>= \case
1560+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete
1561+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do
1562+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
7021563 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
7031564 ChildReadyState_Unready _ -> do
704− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
705− return $ PatchDMapWithMove.From_Insert $ Constant sRef
1565+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
1566+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)
7061567 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
7071568 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
708− deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
1569+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState (Some k)))) (ComposeMaybe k) a -> IO (Constant () a)
7091570 deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do
710− writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
1571+ writeIORef sRef $ ChildReadyState_Unready $ Some <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
7111572 return $ Constant ()
7121573 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
7131574 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
7141575 return $ applyAlways p' old
715− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
1576+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) -> do
7161577 let p = unPatchDMapWithMove p_
7171578 phsBefore <- liftIO $ readIORef placeholders
718− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
719− let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
1579+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
7201580 collectIfMoved k e = do
721− let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
722− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
1581+ let mThisPlaceholder = Map.lookup (Some k) phsBefore -- Will be Nothing if this element wasn't present before
1582+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phsBefore
7231583 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
7241584 False -> do
7251585 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
@@ -727,13 +1587,22 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7271587 True -> do
7281588 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
7291589 collected <- DMap.traverseWithKey collectIfMoved p
730− let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
731− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
1590+ let !phsAfter = fromMaybe phsBefore $ apply filtered phsBefore
1591+ weakened :: PatchMapWithMove (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1592+ weakened = weakenPatchDMapWithMoveWith (_traverseChild_mode . getCompose) p_
1593+ filtered :: PatchMapWithMove (Some k) DOM.Text
1594+ filtered = PatchMapWithMove $ flip Map.mapMaybe (unPatchMapWithMove weakened) $ \(PatchMapWithMove.NodeInfo from to) -> flip PatchMapWithMove.NodeInfo to <$> case from of
1595+ PatchMapWithMove.From_Insert (Left _hydration) -> Nothing
1596+ PatchMapWithMove.From_Insert (Right immediate) -> Just $ PatchMapWithMove.From_Insert $ _traverseChildImmediate_placeholder immediate
1597+ PatchMapWithMove.From_Delete -> Just $ PatchMapWithMove.From_Delete
1598+ PatchMapWithMove.From_Move k -> Just $ PatchMapWithMove.From_Move k
1599+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a)
7321600 placeFragment k e = do
733− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
1601+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phsAfter
7341602 case PatchDMapWithMove._nodeInfo_from e of
735− PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
736− df `insertBefore` nextPlaceholder
1603+ PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of
1604+ Left _ -> pure ()
1605+ Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
7371606 PatchDMapWithMove.From_Delete -> do
7381607 return ()
7391608 PatchDMapWithMove.From_Move fromKey -> do
@@ -744,105 +1613,166 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
7441613 liftIO $ writeIORef placeholders $! phsAfter
7451614
7461615{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
747−traverseDMapWithKeyWithAdjust' :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k) => (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> ImmediateDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
1616+traverseDMapWithKeyWithAdjust'
1617+ :: forall s t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1618+ => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1619+ -> DMap k v
1620+ -> Event t (PatchDMap k v)
1621+ -> HydrationDomBuilderT s t m (DMap k v', Event t (PatchDMap k v'))
7481622traverseDMapWithKeyWithAdjust' = do
749− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
750− let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
1623+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some k)) v')) old = do
1624+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)
7511625 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
7521626 Nothing -> return Nothing
753− Just (Compose (_, _, sRef, _)) -> do
754− readIORef sRef >>= \case
1627+ Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing
1628+ Just (Compose (TraverseChild (Right immediate) _)) -> do
1629+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
7551630 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
7561631 ChildReadyState_Unready _ -> do
757− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
758− return $ Just $ Constant sRef
1632+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
1633+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
7591634 delete _ (Constant sRef) = do
7601635 writeIORef sRef $ ChildReadyState_Unready Nothing
7611636 return $ Constant ()
7621637 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
7631638 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
7641639 return $ applyAlways p' old
765− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
1640+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do
7661641 phs <- liftIO $ readIORef placeholders
767− forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
768− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
769− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
770− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
771− forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
772− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
1642+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do
1643+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phs
1644+ -- Delete old node
1645+ forM_ (Map.lookup (Some k) phs) $ \thisPlaceholder -> do
1646+ thisPlaceholder `deleteUpTo` nextPlaceholder
1647+ -- Insert new node
1648+ forM_ mv $ \(Compose (TraverseChild e _)) -> case e of
1649+ Left _hydration -> pure ()
1650+ Right immediate -> do
1651+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1652+ let weakened :: PatchMap (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))
1653+ weakened = weakenPatchDMapWith (_traverseChild_mode . getCompose) $ PatchDMap patch
1654+ filtered :: PatchMap (Some k) DOM.Text
1655+ filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case
1656+ Nothing -> Just Nothing -- deletion
1657+ Just (Left _) -> Nothing
1658+ Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1659+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
7731660
7741661{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
775−traverseIntMapWithKeyWithAdjust' :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m) => (IntMap.Key -> v -> ImmediateDomBuilderT t m v') -> IntMap v -> Event t (PatchIntMap v) -> ImmediateDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))
1662+traverseIntMapWithKeyWithAdjust'
1663+ :: forall s t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1664+ => (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1665+ -> IntMap v
1666+ -> Event t (PatchIntMap v)
1667+ -> HydrationDomBuilderT s t m (IntMap v', Event t (PatchIntMap v'))
7761668traverseIntMapWithKeyWithAdjust' = do
777− let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do
778− let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))
1669+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do
1670+ let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))
7791671 new k m = case m of
7801672 Nothing -> return Nothing
781− Just (_, _, sRef, _) -> do
1673+ Just (TraverseChild (Left _hydration) _) -> pure Nothing
1674+ Just (TraverseChild (Right immediate) _) -> do
1675+ let sRef = _traverseChildImmediate_childReadyState immediate
7821676 readIORef sRef >>= \case
783− ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready
784− ChildReadyStateInt_Unready _ -> do
785− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
1677+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
1678+ ChildReadyState_Unready _ -> do
1679+ writeIORef sRef $ ChildReadyState_Unready $ Just k
7861680 return $ Just sRef
7871681 delete _ sRef = do
788− writeIORef sRef $ ChildReadyStateInt_Unready Nothing
1682+ writeIORef sRef $ ChildReadyState_Unready Nothing
7891683 return ()
7901684 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
7911685 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
7921686 return $ applyAlways p' old
793− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do
1687+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do
7941688 phs <- liftIO $ readIORef placeholders
7951689 forM_ (IntMap.toList p) $ \(k, mv) -> do
796− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
7971690 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
1691+ -- Delete old node
7981692 forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
799− forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder
800− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs
1693+ -- Insert new node
1694+ forM_ mv $ \(TraverseChild e _) -> case e of
1695+ Left _hydration -> pure ()
1696+ Right immediate -> do
1697+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1698+ let filtered :: PatchIntMap DOM.Text
1699+ filtered = PatchIntMap $ flip IntMap.mapMaybe p $ \case
1700+ Nothing -> Just Nothing -- deletion
1701+ Just tc
1702+ | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1703+ | otherwise -> Nothing
1704+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
1705+
1706+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1707+ :: (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1708+ -> IntMap v
1709+ -> Event DomTimeline (PatchIntMap v)
1710+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1711+ #-}
8011712
802−#if MIN_VERSION_base(4,9,0)
803−data ChildReadyState k
804−#else
805−data ChildReadyState (k :: * -> *)
806−#endif
1713+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1714+ :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
1715+ -> IntMap v
1716+ -> Event DomTimeline (PatchIntMap v)
1717+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1718+ #-}
1719+
1720+data ChildReadyState a
8071721 = ChildReadyState_Ready
808− | ChildReadyState_Unready !(Maybe (Some k))
1722+ | ChildReadyState_Unready !(Maybe a)
8091723 deriving (Show, Read, Eq, Ord)
8101724
811−data ChildReadyStateInt
812− = ChildReadyStateInt_Ready
813− | ChildReadyStateInt_Unready !(Maybe Int)
814− deriving (Show, Read, Eq, Ord)
1725+insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()
1726+insertAfterPreviousNode node = do
1727+ parent <- askParent
1728+ nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode
1729+ Node.insertBefore_ parent node nextNode
1730+ setPreviousNode $ Just $ toNode node
8151731
816−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
817−hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1732+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1733+hoistTraverseWithKeyWithAdjust
1734+ ::
8181735 ( Adjustable t m
1736+ , MonadHold t m
1737+ , DMap.GCompare k
8191738 , MonadIO m
8201739 , MonadJSM m
821− , MonadFix m
8221740 , PrimMonad m
823− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
824− , Functor p
1741+ , MonadFix m
1742+ , Patch (p k v)
1743+ , Patch (p k (Constant Int))
1744+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1745+ , Patch (p k (Compose (TraverseChild t m (Some k)) v'))
1746+ , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v')
1747+ , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))
1748+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
8251749 )
826− => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
827− -> IntMap v
828− -> Event t (p v)
829− -> 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')))
830− ) -- ^ The base monad's traversal
831− -> (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
832− -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM
833− -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')
834− -> IntMap v
835− -> Event t (p v)
836− -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))
837−hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
838− initialEnv <- ImmediateDomBuilderT ask
839− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
840− pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
1750+ => (forall vv vv'.
1751+ (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
1752+ -> DMap k vv
1753+ -> Event t (p k vv)
1754+ -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))
1755+ -- ^ The base monad's traversal
1756+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')
1757+ -- ^ A way of mapping over the patch type
1758+ -> (p k (Compose (TraverseChild t m (Some k)) v') -> DMap k (Constant (IORef (ChildReadyState (Some k)))) -> IO (DMap k (Constant (IORef (ChildReadyState (Some k))))))
1759+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1760+ -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())
1761+ -- ^ Apply a patch to the DOM
1762+ -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
1763+ -> DMap k v
1764+ -> Event t (p k v)
1765+ -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))
1766+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1767+ doc <- askDocument
1768+ initialEnv <- HydrationDomBuilderT ask
1769+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1770+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty
8411771 haveEverBeenReady <- liftIO $ newIORef False
842− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
843− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1772+ placeholders <- liftIO $ newIORef Map.empty
1773+ lastPlaceholder <- createTextNode doc ("" :: Text)
8441774 let applyDomUpdate p = do
845− applyDomUpdate_ placeholders lastPlaceholderRef p
1775+ applyDomUpdate_ placeholders lastPlaceholder p
8461776 markSelfReady
8471777 liftIO $ writeIORef pendingChange $! mempty
8481778 markSelfReady = do
@@ -853,86 +1783,105 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
8531783 old <- liftIO $ readIORef parentUnreadyChildren
8541784 let new = pred old
8551785 liftIO $ writeIORef parentUnreadyChildren $! new
856− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
857− markChildReady :: IORef ChildReadyStateInt -> JSM ()
1786+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1787+ markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()
8581788 markChildReady childReadyState = do
8591789 liftIO (readIORef childReadyState) >>= \case
860− ChildReadyStateInt_Ready -> return ()
861− ChildReadyStateInt_Unready countedAt -> do
862− liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1790+ ChildReadyState_Ready -> return ()
1791+ ChildReadyState_Unready countedAt -> do
1792+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
8631793 case countedAt of
8641794 Nothing -> return ()
865− Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
1795+ Just (Some k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
8661796 (oldUnready, p) <- liftIO $ readIORef pendingChange
867− when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
868− let newUnready = IntMap.delete k oldUnready
1797+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
1798+ let newUnready = DMap.delete k oldUnready
8691799 liftIO $ writeIORef pendingChange (newUnready, p)
870− when (IntMap.null newUnready) $ do
1800+ when (DMap.null newUnready) $ do
8711801 applyDomUpdate p
872− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
873− let processChild k (_, _, sRef, _) = do
874− readIORef sRef >>= \case
875− ChildReadyStateInt_Ready -> return Nothing
876− ChildReadyStateInt_Unready _ -> do
877− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
878− return $ Just sRef
879− initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
880− liftIO $ if IntMap.null initialUnready
1802+ (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))
1803+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1804+ let processChild k (Compose (TraverseChild e _)) = case e of
1805+ Left _ -> pure $ ComposeMaybe Nothing
1806+ Right immediate -> ComposeMaybe <$> do
1807+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1808+ ChildReadyState_Ready -> return Nothing
1809+ ChildReadyState_Unready _ -> do
1810+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
1811+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
1812+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1813+ liftIO $ if DMap.null initialUnready
8811814 then writeIORef haveEverBeenReady True
8821815 else do
8831816 modifyIORef' parentUnreadyChildren succ
8841817 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
885− let result0 = IntMap.map (\(_, _, _, v) -> v) children0
886− placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
887− result' = ffor children' $ fmap $ \(_, _, _, r) -> r
888− liftIO $ writeIORef placeholders $! placeholders0
889− _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
890− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
1818+ getHydrationMode >>= \case
1819+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1820+ dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
1821+ phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
1822+ liftIO $ writeIORef placeholders $! phs
1823+ insertAfterPreviousNode lastPlaceholder
1824+ HydrationMode_Immediate -> do
1825+ let activate i = do
1826+ append $ toNode $ _traverseChildImmediate_fragment i
1827+ pure $ _traverseChildImmediate_placeholder i
1828+ phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0
1829+ liftIO $ writeIORef placeholders $! phs
1830+ append $ toNode lastPlaceholder
8911831 requestDomAction_ $ ffor children' $ \p -> do
8921832 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
8931833 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
8941834 let !newP = p <> oldP
8951835 liftIO $ writeIORef pendingChange (newUnready, newP)
896− when (IntMap.null newUnready) $ do
1836+ when (DMap.null newUnready) $ do
8971837 applyDomUpdate newP
1838+ let result0 = DMap.map (_traverseChild_result . getCompose) children0
1839+ result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose
8981840 return (result0, result')
8991841
900−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
901−hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1842+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
1843+hoistTraverseIntMapWithKeyWithAdjust ::
9021844 ( Adjustable t m
9031845 , MonadHold t m
904− , DMap.GCompare k
905− , MonadIO m
9061846 , MonadJSM m
907− , PrimMonad m
9081847 , MonadFix m
909− , Patch (p k v)
910− , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
911− , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
912− , Patch (p k (Constant Int))
1848+ , PrimMonad m
1849+ , Monoid (p (TraverseChild t m Int v'))
1850+ , Functor p
1851+ , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())
1852+ , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')
1853+ , Patch (p (HydrationRunnerT t m ()))
1854+ , Patch (p (TraverseChild t m Int v'))
1855+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document
9131856 )
914− => (forall vv vv'.
915− (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))
916− -> DMap k vv
917− -> Event t (p k vv)
918− -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))
919− ) -- ^ The base monad's traversal
920− -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
921− -> (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
922− -> (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
923− -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))
924− -> DMap k v
925− -> Event t (p k v)
926− -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))
927−hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
928− initialEnv <- ImmediateDomBuilderT ask
929− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
930− pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
1857+ => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))
1858+ -> IntMap v
1859+ -> Event t (p v)
1860+ -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))
1861+ -- ^ The base monad's traversal
1862+ -> (p (TraverseChild t m Int v')
1863+ -> IntMap (IORef (ChildReadyState Int))
1864+ -> IO (IntMap (IORef (ChildReadyState Int))))
1865+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1866+ -> (IORef (IntMap DOM.Text)
1867+ -> DOM.Text
1868+ -> p (TraverseChild t m Int v')
1869+ -> JSM ())
1870+ -- ^ Apply a patch to the DOM
1871+ -> (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
1872+ -> IntMap v
1873+ -> Event t (p v)
1874+ -> HydrationDomBuilderT s t m (IntMap v', Event t (p v'))
1875+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1876+ doc <- askDocument
1877+ initialEnv <- HydrationDomBuilderT ask
1878+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1879+ pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty
9311880 haveEverBeenReady <- liftIO $ newIORef False
932− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
933− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1881+ placeholders <- liftIO $ newIORef IntMap.empty
1882+ lastPlaceholder <- createTextNode doc ("" :: Text)
9341883 let applyDomUpdate p = do
935− applyDomUpdate_ placeholders lastPlaceholderRef p
1884+ applyDomUpdate_ placeholders lastPlaceholder p
9361885 markSelfReady
9371886 liftIO $ writeIORef pendingChange $! mempty
9381887 markSelfReady = do
@@ -943,8 +1892,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9431892 old <- liftIO $ readIORef parentUnreadyChildren
9441893 let new = pred old
9451894 liftIO $ writeIORef parentUnreadyChildren $! new
946− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
947− markChildReady :: IORef (ChildReadyState k) -> JSM ()
1895+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1896+ markChildReady :: IORef (ChildReadyState Int) -> JSM ()
9481897 markChildReady childReadyState = do
9491898 liftIO (readIORef childReadyState) >>= \case
9501899 ChildReadyState_Ready -> return ()
@@ -952,82 +1901,191 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
9521901 liftIO $ writeIORef childReadyState ChildReadyState_Ready
9531902 case countedAt of
9541903 Nothing -> return ()
955− Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
1904+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
9561905 (oldUnready, p) <- liftIO $ readIORef pendingChange
957− when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
958− let newUnready = DMap.delete k oldUnready
1906+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
1907+ let newUnready = IntMap.delete k oldUnready
9591908 liftIO $ writeIORef pendingChange (newUnready, p)
960− when (DMap.null newUnready) $ do
1909+ when (IntMap.null newUnready) $ do
9611910 applyDomUpdate p
962− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
963− let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
964− readIORef sRef >>= \case
965− ChildReadyState_Ready -> return Nothing
966− ChildReadyState_Unready _ -> do
967− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
968− return $ Just $ Constant sRef
969− initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
970− liftIO $ if DMap.null initialUnready
1911+ (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))
1912+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1913+ let processChild k (TraverseChild e _) = case e of
1914+ Left _ -> pure Nothing
1915+ Right immediate -> do
1916+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
1917+ ChildReadyState_Ready -> return Nothing
1918+ ChildReadyState_Unready _ -> do
1919+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k
1920+ return $ Just (_traverseChildImmediate_childReadyState immediate)
1921+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
1922+ liftIO $ if IntMap.null initialUnready
9711923 then writeIORef haveEverBeenReady True
9721924 else do
9731925 modifyIORef' parentUnreadyChildren succ
9741926 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
975− let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
976− placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
977− result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
978− liftIO $ writeIORef placeholders $! placeholders0
979− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
980− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
1927+ getHydrationMode >>= \case
1928+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1929+ dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children
1930+ phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm
1931+ liftIO $ writeIORef placeholders $! phs
1932+ insertAfterPreviousNode lastPlaceholder
1933+ HydrationMode_Immediate -> do
1934+ let activate i = do
1935+ append $ toNode $ _traverseChildImmediate_fragment i
1936+ pure $ _traverseChildImmediate_placeholder i
1937+ phs <- traverse (either (error "impossible") activate . _traverseChild_mode) children0
1938+ liftIO $ writeIORef placeholders $! phs
1939+ append $ toNode lastPlaceholder
9811940 requestDomAction_ $ ffor children' $ \p -> do
9821941 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
9831942 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
9841943 let !newP = p <> oldP
9851944 liftIO $ writeIORef pendingChange (newUnready, newP)
986− when (DMap.null newUnready) $ do
1945+ when (IntMap.null newUnready) $ do
9871946 applyDomUpdate newP
1947+ let result0 = IntMap.map _traverseChild_result children0
1948+ result' = ffor children' $ fmap $ _traverseChild_result
9881949 return (result0, result')
9891950
1951+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1952+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))
1953+ -> IntMap v
1954+ -> Event DomTimeline (PatchIntMap v)
1955+ -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))
1956+ -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1957+ -> IntMap (IORef (ChildReadyState Int))
1958+ -> IO (IntMap (IORef (ChildReadyState Int))))
1959+ -> (IORef (IntMap DOM.Text)
1960+ -> DOM.Text
1961+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1962+ -> JSM ())
1963+ -> (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
1964+ -> IntMap v
1965+ -> Event DomTimeline (PatchIntMap v)
1966+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1967+ #-}
1968+
1969+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1970+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int v'))
1971+ -> IntMap v
1972+ -> Event DomTimeline (PatchIntMap v)
1973+ -> DomRenderHookT DomTimeline HydrationM (IntMap (TraverseChild DomTimeline HydrationM Int v'), Event DomTimeline (PatchIntMap (TraverseChild DomTimeline HydrationM Int v'))))
1974+ -> (PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1975+ -> IntMap (IORef (ChildReadyState Int))
1976+ -> IO (IntMap (IORef (ChildReadyState Int))))
1977+ -> (IORef (IntMap DOM.Text)
1978+ -> DOM.Text
1979+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1980+ -> JSM ())
1981+ -> (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1982+ -> IntMap v
1983+ -> Event DomTimeline (PatchIntMap v)
1984+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1985+ #-}
1986+
1987+data TraverseChildImmediate k = TraverseChildImmediate
1988+ { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment
1989+ -- ^ Child is appended to this fragment
1990+ , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text
1991+ -- ^ Placeholder reference
1992+ , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))
1993+ }
1994+
1995+newtype TraverseChildHydration t m = TraverseChildHydration
1996+ { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text
1997+ -- ^ Action to run at switchover, returns the placeholder
1998+ }
1999+
2000+data TraverseChild t m k a = TraverseChild
2001+ { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))
2002+ , _traverseChild_result :: !a
2003+ } deriving Functor
2004+
9902005{-# INLINABLE drawChildUpdate #-}
991−drawChildUpdate :: (MonadIO m, MonadJSM m)
992− => ImmediateDomBuilderEnv t
2006+drawChildUpdate :: (MonadJSM m, Reflex t)
2007+ => HydrationDomBuilderEnv t m
9932008 -> (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
994− -> ImmediateDomBuilderT t m (v' a)
995− -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
2009+ -> HydrationDomBuilderT s t m (f a)
2010+ -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)
9962011drawChildUpdate initialEnv markReady child = do
997− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2012+ let doc = _hydrationDomBuilderEnv_document initialEnv
9982013 unreadyChildren <- liftIO $ newIORef 0
999− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
1000− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
1001− { _immediateDomBuilderEnv_parent = toNode df
1002− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
1003− , _immediateDomBuilderEnv_commitAction = markReady childReadyState
1004− }
1005− u <- liftIO $ readIORef unreadyChildren
1006− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1007− return $ Compose (df, placeholder, childReadyState, result)
2014+ liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case
2015+ HydrationMode_Hydrating -> do
2016+ childDelayedRef <- liftIO $ newIORef $ pure ()
2017+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2018+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2019+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
2020+ }
2021+ childDelayed <- liftIO $ readIORef childDelayedRef
2022+ return $ Compose $ TraverseChild
2023+ { _traverseChild_result = result
2024+ , _traverseChild_mode = Left TraverseChildHydration
2025+ { _traverseChildHydration_delayed = do
2026+ placeholder <- createTextNode doc ("" :: Text)
2027+ insertAfterPreviousNode placeholder
2028+ childDelayed
2029+ pure placeholder
2030+ }
2031+ }
2032+ HydrationMode_Immediate -> do
2033+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2034+ df <- createDocumentFragment doc
2035+ placeholder <- createTextNode doc ("" :: Text)
2036+ Node.appendChild_ df placeholder
2037+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2038+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
2039+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
2040+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
2041+ }
2042+ u <- liftIO $ readIORef unreadyChildren
2043+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
2044+ return $ Compose $ TraverseChild
2045+ { _traverseChild_result = result
2046+ , _traverseChild_mode = Right TraverseChildImmediate
2047+ { _traverseChildImmediate_fragment = df
2048+ , _traverseChildImmediate_placeholder = placeholder
2049+ , _traverseChildImmediate_childReadyState = childReadyState
2050+ }
2051+ }
10082052
1009−{-# INLINABLE drawChildUpdateInt #-}
1010−drawChildUpdateInt :: (MonadIO m, MonadJSM m)
1011− => ImmediateDomBuilderEnv t
1012− -> (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
1013− -> ImmediateDomBuilderT t m v'
1014− -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
1015−drawChildUpdateInt initialEnv markReady child = do
1016− childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing
1017− unreadyChildren <- liftIO $ newIORef 0
1018− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
1019− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
1020− { _immediateDomBuilderEnv_parent = toNode df
1021− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
1022− , _immediateDomBuilderEnv_commitAction = markReady childReadyState
1023− }
1024− u <- liftIO $ readIORef unreadyChildren
1025− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1026− return (df, placeholder, childReadyState, result)
2053+{-# SPECIALIZE drawChildUpdate
2054+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2055+ -> (IORef (ChildReadyState Int) -> JSM ())
2056+ -> HydrationDomBuilderT s DomTimeline HydrationM (Identity a)
2057+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM Int) Identity a)
2058+ #-}
2059+
2060+{-# SPECIALIZE drawChildUpdate
2061+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2062+ -> (IORef (ChildReadyState (Some k)) -> JSM ())
2063+ -> HydrationDomBuilderT s DomTimeline HydrationM (f a)
2064+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM (Some k)) f a)
2065+ #-}
10272066
1028−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
2067+{-# INLINABLE drawChildUpdateInt #-}
2068+drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
2069+ => HydrationDomBuilderEnv t m
2070+ -> (IORef (ChildReadyState k) -> JSM ())
2071+ -> HydrationDomBuilderT s t m v
2072+ -> DomRenderHookT t m (TraverseChild t m k v)
2073+drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdate env mark (Identity <$> m)
2074+
2075+{-# SPECIALIZE drawChildUpdateInt
2076+ :: HydrationDomBuilderEnv DomTimeline HydrationM
2077+ -> (IORef (ChildReadyState k) -> JSM ())
2078+ -> HydrationDomBuilderT s DomTimeline HydrationM v
2079+ -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM k v)
2080+ #-}
2081+
2082+{-# INLINE mkHasFocus #-}
2083+mkHasFocus
2084+ :: (HasDocument m, MonadJSM m, IsNode (RawElement d), MonadHold t m, Reflex t, DOM.IsDocumentOrShadowRoot (RawDocument (DomBuilderSpace m)))
2085+ => Element er d t -> m (Dynamic t Bool)
10292086mkHasFocus e = do
1030− let initialFocus = False --TODO: Actually get the initial focus of the element
2087+ doc <- askDocument
2088+ initialFocus <- Node.isSameNode (toNode $ _element_raw e) . fmap toNode =<< Document.getActiveElement doc
10312089 holdDyn initialFocus $ leftmost
10322090 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
10332091 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
@@ -1036,39 +2094,49 @@ mkHasFocus e = do
10362094insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
10372095insertBefore new existing = do
10382096 p <- getParentNodeUnchecked existing
1039− DOM.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly
2097+ Node.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly
10402098
1041−instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
1042− type Performable (ImmediateDomBuilderT t m) = Performable m
2099+type ImmediateDomBuilderT = HydrationDomBuilderT GhcjsDomSpace
2100+
2101+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where
2102+ type Performable (HydrationDomBuilderT s t m) = Performable m
10432103 {-# INLINABLE performEvent_ #-}
10442104 performEvent_ e = lift $ performEvent_ e
10452105 {-# INLINABLE performEvent #-}
10462106 performEvent e = lift $ performEvent e
10472107
1048−instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where
2108+instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where
10492109 {-# INLINABLE getPostBuild #-}
10502110 getPostBuild = lift getPostBuild
10512111
1052−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where
2112+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where
10532113 {-# INLINABLE newEventWithTrigger #-}
10542114 newEventWithTrigger = lift . newEventWithTrigger
10552115 {-# INLINABLE newFanEventWithTrigger #-}
10562116 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
10572117
1058−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where
2118+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT s t m) where
2119+ {-# INLINABLE newTriggerEvent #-}
2120+ newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent
2121+ {-# INLINABLE newTriggerEventWithOnComplete #-}
2122+ newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete
2123+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
2124+ newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f
2125+
2126+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where
10592127 {-# INLINABLE newTriggerEvent #-}
1060− newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
2128+ newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent
10612129 {-# INLINABLE newTriggerEventWithOnComplete #-}
1062− newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
2130+ newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete
10632131 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1064− newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
2132+ newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f
10652133
1066−instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
1067− type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
2134+instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where
2135+ type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m
10682136 askJSContext = lift askJSContext
10692137
1070−instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
1071− type Ref (ImmediateDomBuilderT t m) = Ref m
2138+instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where
2139+ type Ref (HydrationDomBuilderT s t m) = Ref m
10722140 {-# INLINABLE newRef #-}
10732141 newRef = lift . newRef
10742142 {-# INLINABLE readRef #-}
@@ -1076,12 +2144,12 @@ instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
10762144 {-# INLINABLE writeRef #-}
10772145 writeRef r = lift . writeRef r
10782146
1079−instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
2147+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where
10802148 {-# INLINABLE atomicModifyRef #-}
10812149 atomicModifyRef r = lift . atomicModifyRef r
10822150
1083−instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
1084− type JSX (ImmediateDomBuilderT t m) = JSX m
2151+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where
2152+ type JSX (HydrationDomBuilderT s t m) = JSX m
10852153 liftJS = lift . liftJS
10862154
10872155type family EventType en where
@@ -1539,11 +2607,11 @@ getTouchEvent = do
15392607 , _touchEventResult_touches = touches
15402608 }
15412609
1542−instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
2610+instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
15432611 {-# INLINABLE sample #-}
15442612 sample = lift . sample
15452613
1546−instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where
2614+instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where
15472615 {-# INLINABLE hold #-}
15482616 hold v0 v' = lift $ hold v0 v'
15492617 {-# INLINABLE holdDyn #-}
@@ -1565,7 +2633,7 @@ data Window t = Window
15652633 , _window_raw :: DOM.Window
15662634 }
15672635
1568−wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)
2636+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> HydrationDomBuilderT GhcjsDomSpace t m (Window t)
15692637wrapWindow wv _ = do
15702638 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
15712639 return $ Window