@@ -2,7 +2,8 @@
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE DefaultSignatures #-}
5+{-# LANGUAGE DeriveFunctor #-}
6+{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE EmptyDataDecls #-}
7{-# LANGUAGE EmptyDataDecls #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE FlexibleInstances #-}
@@ -11,14 +12,15 @@
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE OverloadedStrings #-}
14{-# LANGUAGE OverloadedStrings #-}
15+{-# LANGUAGE PatternGuards #-}
14{-# LANGUAGE PolyKinds #-}
16{-# LANGUAGE PolyKinds #-}
15{-# LANGUAGE RankNTypes #-}
17{-# LANGUAGE RankNTypes #-}
16{-# LANGUAGE RecursiveDo #-}
18{-# LANGUAGE RecursiveDo #-}
17{-# LANGUAGE ScopedTypeVariables #-}
19{-# LANGUAGE ScopedTypeVariables #-}
18−{-# LANGUAGE StandaloneDeriving #-}
19#ifdef USE_TEMPLATE_HASKELL
20#ifdef USE_TEMPLATE_HASKELL
20{-# LANGUAGE TemplateHaskell #-}
21{-# LANGUAGE TemplateHaskell #-}
23+{-# LANGUAGE TupleSections #-}
22{-# LANGUAGE TypeFamilies #-}
24{-# LANGUAGE TypeFamilies #-}
23{-# LANGUAGE TypeOperators #-}
25{-# LANGUAGE TypeOperators #-}
24{-# LANGUAGE UndecidableInstances #-}
26{-# LANGUAGE UndecidableInstances #-}
@@ -26,191 +28,346 @@
26{-# LANGUAGE ForeignFunctionInterface #-}
28{-# LANGUAGE ForeignFunctionInterface #-}
27{-# LANGUAGE JavaScriptFFI #-}
29{-# LANGUAGE JavaScriptFFI #-}
31+-- | This is a builder to be used on the client side. It can be run in two modes:
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
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").
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.
29module Reflex.Dom.Builder.Immediate
46module Reflex.Dom.Builder.Immediate
30− ( EventTriggerRef (..)
47+ ( HydrationDomBuilderT (..)
31− , ImmediateDomBuilderEnv (..)
48+ , HydrationDomBuilderEnv (..)
50+ , HydrationRunnerT (..)
51+ , runHydrationRunnerT
32− , ImmediateDomBuilderT (..)
52+ , ImmediateDomBuilderT
33− , runImmediateDomBuilderT
53+ , runHydrationDomBuilderT
56+ , addHydrationStepWithSetup
58+ , insertAfterPreviousNode
34− , askParent
60+ , askParent
35− , askEvents
61+ , askEvents
37− , textNodeInternal
63+ , textNodeInternal
64+ , removeSubsequentNodes
38− , deleteBetweenExclusive
65+ , deleteBetweenExclusive
39− , extractBetweenExclusive
66+ , extractBetweenExclusive
40− , deleteUpTo
67+ , deleteUpTo
41− , extractUpTo
68+ , extractUpTo
42− , SupportsImmediateDomBuilder
69+ , SupportsHydrationDomBuilder
43− , collectUpTo
70+ , collectUpTo
44− , collectUpToGivenParent
71+ , collectUpToGivenParent
72+ , EventTriggerRef (..)
45− , EventFilterTriggerRef (..)
73+ , EventFilterTriggerRef (..)
47− , makeElement
75+ , elementInternal
48− , GhcjsDomHandler (..)
78+ , GhcjsDomHandler (..)
49− , GhcjsDomHandler1 (..)
79+ , GhcjsDomHandler1 (..)
50− , GhcjsDomEvent (..)
80+ , GhcjsDomEvent (..)
52− , GhcjsEventFilter (..)
81+ , GhcjsEventFilter (..)
53− , Pair1 (..)
82+ , Pair1 (..)
54− , Maybe1 (..)
83+ , Maybe1 (..)
55− , GhcjsEventSpec (..)
84+ , GhcjsEventSpec (..)
56− , HasDocument (..)
85+ , HasDocument (..)
57− , ghcjsEventSpec_filters
86+ , ghcjsEventSpec_filters
58− , ghcjsEventSpec_handler
87+ , ghcjsEventSpec_handler
59− , GhcjsEventHandler (..)
88+ , GhcjsEventHandler (..)
60−#ifndef USE_TEMPLATE_HASKELL
63− , drawChildUpdate
89+ , drawChildUpdate
64− , ChildReadyState (..)
90+ , ChildReadyState (..)
65− , ChildReadyStateInt (..)
66− , mkHasFocus
91+ , mkHasFocus
67− , insertBefore
92+ , insertBefore
68− , EventType
93+ , EventType
69− , defaultDomEventHandler
94+ , defaultDomEventHandler
70− , defaultDomWindowEventHandler
95+ , defaultDomWindowEventHandler
71− , withIsEvent
96+ , withIsEvent
72− , showEventName
97+ , showEventName
73− , elementOnEventName
98+ , elementOnEventName
74− , windowOnEventName
99+ , windowOnEventName
75− , wrapDomEvent
100+ , wrapDomEvent
76− , subscribeDomEvent
101+ , subscribeDomEvent
77− , wrapDomEventMaybe
102+ , wrapDomEventMaybe
78− , wrapDomEventsMaybe
103+ , wrapDomEventsMaybe
79− , getKeyEvent
104+ , getKeyEvent
80− , getMouseEventCoords
105+ , getMouseEventCoords
81− , getTouchEvent
106+ , getTouchEvent
82− , WindowConfig (..)
107+ , WindowConfig (..)
83− , Window (..)
108+ , Window (..)
84− , wrapWindow
109+ , wrapWindow
85− -- * Internal
110+ -- * Internal
86− , traverseDMapWithKeyWithAdjust'
111+ , traverseDMapWithKeyWithAdjust'
87− , hoistTraverseWithKeyWithAdjust
112+ , hoistTraverseWithKeyWithAdjust
88− , traverseIntMapWithKeyWithAdjust'
113+ , traverseIntMapWithKeyWithAdjust'
89− , hoistTraverseIntMapWithKeyWithAdjust
114+ , hoistTraverseIntMapWithKeyWithAdjust
92−import Foreign.JavaScript.TH
93−import Reflex.Class as Reflex
94−import Reflex.Dom.Builder.Class
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)
109import Control.Concurrent
117import Control.Concurrent
110−import Control.Lens hiding (element, ix)
118+import Control.Exception (bracketOnError)
119+import Control.Lens (Identity(..), imapM_, iforM_, (^.), makeLenses)
111import Control.Monad.Exception
120import Control.Monad.Exception
112import Control.Monad.Primitive
121import Control.Monad.Primitive
113import Control.Monad.Reader
122import Control.Monad.Reader
114import Control.Monad.Ref
123import Control.Monad.Ref
115−import Control.Monad.State.Strict (StateT)
124+import Control.Monad.State.Strict (StateT, mapStateT, get, modify', gets, runStateT)
116−import qualified Control.Monad.State as Lazy (StateT)
117−#ifndef USE_TEMPLATE_HASKELL
118−import Data.Functor.Contravariant (phantom)
120import Data.Bitraversable
125import Data.Bitraversable
121import Data.Default
126import Data.Default
122import Data.Dependent.Map (DMap)
127import Data.Dependent.Map (DMap)
123−import qualified Data.Dependent.Map as DMap
124import Data.Dependent.Sum
128import Data.Dependent.Sum
129+import Data.FastMutableIntMap (PatchIntMap (..))
130+import Data.Foldable (for_, traverse_)
125import Data.Functor.Compose
131import Data.Functor.Compose
126import Data.Functor.Constant
132import Data.Functor.Constant
127import Data.Functor.Misc
133import Data.Functor.Misc
128import Data.Functor.Product
134import Data.Functor.Product
129import Data.IORef
135import Data.IORef
130−import qualified Data.Map as Map
136+import Data.IntMap.Strict (IntMap)
131import Data.Maybe
137import Data.Maybe
132−import Data.Monoid hiding (Product)
138+import Data.Monoid ((<>))
133−import Data.Some (Some)
139+import Data.Some (Some(..))
134−import qualified Data.Some as Some
135import Data.Text (Text)
140import 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
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
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
136import qualified Data.Text as T
176import qualified Data.Text as T
137import qualified GHCJS.DOM as DOM
177import qualified GHCJS.DOM as DOM
138−import GHCJS.DOM.RequestAnimationFrameCallback
178+import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
139−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
179+import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
140−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
141import qualified GHCJS.DOM.Element as Element
180import qualified GHCJS.DOM.Element as Element
142import qualified GHCJS.DOM.Event as Event
181import 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)
146import qualified GHCJS.DOM.EventM as DOM
182import qualified GHCJS.DOM.EventM as DOM
147import qualified GHCJS.DOM.FileList as FileList
183import qualified GHCJS.DOM.FileList as FileList
184+import qualified GHCJS.DOM.GlobalEventHandlers as Events
148import qualified GHCJS.DOM.HTMLInputElement as Input
185import qualified GHCJS.DOM.HTMLInputElement as Input
149import qualified GHCJS.DOM.HTMLSelectElement as Select
186import qualified GHCJS.DOM.HTMLSelectElement as Select
150import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
187import 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
152import qualified GHCJS.DOM.Touch as Touch
190import qualified GHCJS.DOM.Touch as Touch
153import qualified GHCJS.DOM.TouchEvent as TouchEvent
191import qualified GHCJS.DOM.TouchEvent as TouchEvent
154import qualified GHCJS.DOM.TouchList as TouchList
192import 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)
161import qualified GHCJS.DOM.Types as DOM
193import qualified GHCJS.DOM.Types as DOM
162−import GHCJS.DOM.UIEvent
163−import GHCJS.DOM.KeyboardEvent as KeyboardEvent
164import qualified GHCJS.DOM.Window as Window
194import qualified GHCJS.DOM.Window as Window
165−import Language.Javascript.JSaddle (call, eval)
195+import qualified Reflex.Patch.DMap as PatchDMap
166−import Data.IntMap.Strict (IntMap)
196+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
167−import qualified Data.IntMap.Strict as IntMap
197+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
168−import Data.FastMutableIntMap (PatchIntMap (..))
198+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
169−import qualified Data.FastMutableIntMap as FastMutableIntMap
171−import Reflex.Requester.Base
200+#ifndef USE_TEMPLATE_HASKELL
172−import Reflex.Requester.Class
201+import Data.Functor.Contravariant (phantom)
173−import Foreign.JavaScript.Internal.Utils
202+import Control.Lens (Lens', Getter)
175#ifndef ghcjs_HOST_OS
205#ifndef ghcjs_HOST_OS
176import GHCJS.DOM.Types (MonadJSM (..))
206import GHCJS.DOM.Types (MonadJSM (..))
178−instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
208+instance MonadJSM m => MonadJSM (HydrationRunnerT t m) where
209+ {-# INLINABLE liftJSM' #-}
210+ liftJSM' = lift . liftJSM'
212+instance MonadJSM m => MonadJSM (HydrationDomBuilderT s t m) where
213+ {-# INLINABLE liftJSM' #-}
214+ liftJSM' = lift . liftJSM'
216+instance MonadJSM m => MonadJSM (DomRenderHookT t m) where
217+ {-# INLINABLE liftJSM' #-}
179− liftJSM' = ImmediateDomBuilderT . liftJSM'
218+ liftJSM' = lift . liftJSM'
182−data ImmediateDomBuilderEnv t
221+data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv
183− = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document
222+ { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
184− , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node
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)
185− , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
228+ -- ^ Number of children who still aren't fully rendered
229+ , _hydrationDomBuilderEnv_commitAction :: !(JSM ())
186− , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
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 ()))
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 }
190 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
243 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
191#if MIN_VERSION_base(4,9,1)
244#if MIN_VERSION_base(4,9,1)
192 , MonadAsyncException
245 , MonadAsyncException
196−instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
249+instance PrimMonad m => PrimMonad (HydrationDomBuilderT s t m) where
197− type PrimState (ImmediateDomBuilderT x m) = PrimState m
250+ type PrimState (HydrationDomBuilderT s t m) = PrimState m
198 primitive = lift . primitive
251 primitive = lift . primitive
200−instance MonadTrans (ImmediateDomBuilderT t) where
253+instance MonadTrans (HydrationDomBuilderT s t) where
201− lift = ImmediateDomBuilderT . lift . lift . lift
254+ lift = HydrationDomBuilderT . lift . lift
203−instance (Reflex t, MonadFix m) => DomRenderHook t (ImmediateDomBuilderT t m) where
256+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT s t m) where
204− withRenderHook hook (ImmediateDomBuilderT a) = do
257+ withRenderHook hook = HydrationDomBuilderT . mapReaderT (withRenderHook hook) . unHydrationDomBuilderT
205− e <- ImmediateDomBuilderT ask
258+ requestDomAction = HydrationDomBuilderT . lift . requestDomAction
206− ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do
259+ requestDomAction_ = HydrationDomBuilderT . lift . requestDomAction_
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_
212−{-# INLINABLE runImmediateDomBuilderT #-}
261+-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.
213−runImmediateDomBuilderT
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
270+data HydrationState = HydrationState
271+ { _hydrationState_previousNode :: !(Maybe Node)
272+ , _hydrationState_failed :: !Bool
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' }
284+{-# INLINABLE 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."
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
300+instance MonadTrans (HydrationRunnerT t) where
301+ {-# INLINABLE lift #-}
302+ lift = HydrationRunnerT . lift . lift . lift
304+instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where
305+ {-# INLINABLE sample #-}
306+ sample = lift . sample
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_
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)
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)
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
340+{-# INLINABLE 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]
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
353+ runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
354+ v <- synchronously x
357+instance MonadTrans (DomRenderHookT t) where
358+ {-# INLINABLE lift #-}
359+ lift = DomRenderHookT . lift . lift
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_
369+{-# INLINABLE runHydrationDomBuilderT #-}
370+runHydrationDomBuilderT
214 :: ( MonadFix m
371 :: ( MonadFix m
215 , PerformEvent t m
372 , PerformEvent t m
216 , MonadReflexCreateTrigger t m
373 , MonadReflexCreateTrigger t m
@@ -219,64 +376,76 @@ runImmediateDomBuilderT
219 , MonadRef m
376 , MonadRef m
220 , Ref m ~ IORef
377 , Ref m ~ IORef
222− => ImmediateDomBuilderT t m a
379+ => HydrationDomBuilderT s t m a
223− -> ImmediateDomBuilderEnv t
380+ -> HydrationDomBuilderEnv t m
224 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
381 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
226−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan =
383+runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)
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
233− runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
234− v <- synchronously x
237−class Monad m => HasDocument m where
385+instance (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, Monad m) => HasDocument (HydrationDomBuilderT s t m) where
238− askDocument :: m Document
239− default askDocument :: (m ~ f m', MonadTrans f, Monad m', HasDocument m') => m Document
240− askDocument = lift askDocument
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)
251−instance Monad m => HasDocument (ImmediateDomBuilderT t m) where
252 {-# INLINABLE askDocument #-}
386 {-# INLINABLE askDocument #-}
253− askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document
387+ askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
255{-# INLINABLE askParent #-}
389{-# INLINABLE askParent #-}
256−askParent :: Monad m => ImmediateDomBuilderT t m Node
390+askParent :: Monad m => HydrationRunnerT t m DOM.Node
257−askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent
391+askParent = HydrationRunnerT ask
393+{-# INLINABLE getParent #-}
394+getParent :: MonadIO m => HydrationDomBuilderT s t m DOM.Node
395+getParent = either pure (liftIO . readIORef) =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
259{-# INLINABLE askEvents #-}
397{-# INLINABLE askEvents #-}
260−askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
398+askEvents :: Monad m => HydrationDomBuilderT s t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
261−askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents
399+askEvents = HydrationDomBuilderT . lift . DomRenderHookT . lift $ TriggerEventT.askEvents
263−localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
401+{-# INLINABLE localEnv #-}
264−localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT
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
266{-# INLINABLE append #-}
405{-# INLINABLE append #-}
267−append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()
406+append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT s t m ()
268append n = do
407append n = do
269− p <- askParent
408+ p <- getParent
270 liftJSM $ appendChild_ p n
409 liftJSM $ appendChild_ p n
271 return ()
410 return ()
273−{-# INLINABLE textNodeInternal #-}
412+{-# SPECIALIZE append
274−textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
413+ :: DOM.Node
275−textNodeInternal !t = do
414+ -> HydrationDomBuilderT s Spider HydrationM ()
276− doc <- askDocument
415+ #-}
277− n <- liftJSM $ createTextNode doc t
416+
278− append $ toNode n
417+data HydrationMode
279− return n
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)
424+{-# INLINABLE getPreviousNode #-}
425+getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)
426+getPreviousNode = HydrationRunnerT $ gets _hydrationState_previousNode
428+{-# INLINABLE setPreviousNode #-}
429+setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
430+setPreviousNode n = HydrationRunnerT $ modify' (\hs -> hs { _hydrationState_previousNode = n })
432+{-# INLINABLE askUnreadyChildren #-}
433+askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)
434+askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
436+{-# INLINABLE askCommitAction #-}
437+askCommitAction :: Monad m => HydrationDomBuilderT s t m (JSM ())
438+askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction
440+{-# INLINABLE getHydrationMode #-}
441+getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode
442+getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)
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)
281-- | s and e must both be children of the same node and s must precede e;
450-- | s and e must both be children of the same node and s must precede e;
282-- all nodes between s and e will be removed, but s and e will not be removed
451-- 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
314 void $ call f f (df, s, e)
483 void $ call f f (df, s, e)
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))
319{-# INLINABLE collectUpTo #-}
488{-# INLINABLE collectUpTo #-}
320collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
489collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
@@ -332,10 +501,15 @@ collectUpToGivenParent currentParent s e = do
333newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
502newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
335−{-# INLINABLE wrap #-}
504+-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself
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)
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]
510+ -> RawElementConfig er t s
511+ -> m (DMap EventName (EventFilterTriggerRef t er))
337−wrap e cfg = do
512+wrap events e cfg = do
339 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
513 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
340 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
514 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
341 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
515 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
@@ -352,46 +526,74 @@ wrap e cfg = do
352 mv <- liftJSM k --TODO: Only do this when the event is subscribed
526 mv <- liftJSM k --TODO: Only do this when the event is subscribed
353 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
527 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
354 return $ en :=> EventFilterTriggerRef triggerRef
528 return $ en :=> EventFilterTriggerRef triggerRef
355− es <- do
529+ return eventTriggerRefs
356− let h :: GhcjsEventHandler er
530+
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
531+{-# SPECIALIZE wrap
358− ctx <- askJSM
532+ :: Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
359− newFanEventWithTrigger $ \(WrapArg en) t ->
533+ -> DOM.Element
534+ -> RawElementConfig er DomTimeline HydrationDomSpace
535+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (DMap EventName (EventFilterTriggerRef DomTimeline er))
539+ :: Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
541+ -> RawElementConfig er DomTimeline GhcjsDomSpace
542+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (DMap EventName (EventFilterTriggerRef DomTimeline er))
545+{-# INLINE triggerBody #-}
547+ :: forall s er t x. EventSpec s ~ GhcjsEventSpec
549+ -> RawElementConfig er t s
550+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
551+ -> DMap EventName (EventFilterTriggerRef t er)
553+ -> WrapArg er EventName x
360− case DMap.lookup en eventTriggerRefs of
556+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
361− Just (EventFilterTriggerRef r) -> do
557+ Just (EventFilterTriggerRef r) -> do
362− writeIORef r $ Just t
558+ writeIORef r $ Just t
363− return $ do
559+ return $ do
364− writeIORef r Nothing
560+ writeIORef r Nothing
365− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
561+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
366− evt <- DOM.event
562+ evt <- DOM.event
367− mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)
563+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
368− case mv of
564+ case mv of
369− Nothing -> return ()
565+ Nothing -> return ()
370− Just v -> liftIO $ do
566+ 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
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
372− ref <- newIORef $ Just t
568+ ref <- newIORef $ Just t
373− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
569+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
374− return $ Element
570+ where
375− { _element_events = es
571+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
376− , _element_raw = e
572+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
377− }
573+ handler :: GhcjsEventHandler er
378−
574+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
379−{-# INLINABLE makeElement #-}
575+
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)
576+{-# SPECIALIZE triggerBody
381−makeElement elementTag cfg child = do
577+ :: DOM.JSContextRef
382− doc <- askDocument
578+ -> RawElementConfig er DomTimeline HydrationDomSpace
383− e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
579+ -> Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
384− Nothing -> createElement doc elementTag
580+ -> DMap EventName (EventFilterTriggerRef DomTimeline er)
385− Just ens -> createElementNS doc (Just ens) elementTag
581+ -> DOM.Element
386− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
582+ -> WrapArg er EventName x
387− Nothing -> lift $ setAttribute e n v
583+ -> EventTrigger DomTimeline x
388− Just ans -> lift $ setAttributeNS e (Just ans) n v
584+ -> IO (IO ())
389− result <- flip localEnv child $ \env -> env
585+ #-}
390− { _immediateDomBuilderEnv_parent = toNode e
586+
391− }
587+{-# SPECIALIZE triggerBody
392− append $ toNode e
588+ :: DOM.JSContextRef
393− wrapped <- wrap e $ extractRawElementConfig cfg
589+ -> RawElementConfig er DomTimeline GhcjsDomSpace
394− return ((wrapped, result), e)
590+ -> Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
591+ -> DMap EventName (EventFilterTriggerRef DomTimeline er)
593+ -> WrapArg er EventName x
594+ -> EventTrigger DomTimeline x
396newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
598newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
@@ -403,9 +605,10 @@ data GhcjsDomSpace
404instance DomSpace GhcjsDomSpace where
606instance DomSpace GhcjsDomSpace where
405 type EventSpec GhcjsDomSpace = GhcjsEventSpec
607 type EventSpec GhcjsDomSpace = GhcjsEventSpec
608+ type RawDocument GhcjsDomSpace = DOM.Document
406 type RawTextNode GhcjsDomSpace = DOM.Text
609 type RawTextNode GhcjsDomSpace = DOM.Text
610+ type RawCommentNode GhcjsDomSpace = DOM.Comment
407 type RawElement GhcjsDomSpace = DOM.Element
611 type RawElement GhcjsDomSpace = DOM.Element
408− type RawFile GhcjsDomSpace = DOM.File
409 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement
612 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement
410 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement
613 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement
411 type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement
614 type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement
@@ -437,15 +640,11 @@ data GhcjsEventSpec er = GhcjsEventSpec
437newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }
640newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }
439#ifndef USE_TEMPLATE_HASKELL
642#ifndef USE_TEMPLATE_HASKELL
440−phantom2 :: (Functor f, Contravariant f) => f a -> f b
442−{-# INLINE phantom2 #-}
444ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))
643ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))
445ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a
644ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a
446{-# INLINE ghcjsEventSpec_filters #-}
645{-# INLINE ghcjsEventSpec_filters #-}
447ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))
646ghcjsEventSpec_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)
449{-# INLINE ghcjsEventSpec_handler #-}
648{-# INLINE ghcjsEventSpec_handler #-}
@@ -458,137 +657,753 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
458 runReaderT (defaultDomEventHandler e en) evt
657 runReaderT (defaultDomEventHandler e en) evt
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
671+{-# INLINE elementImmediate #-}
673+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec
674+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m )
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
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)
693+{-# SPECIALIZE elementImmediate
695+ -> ElementConfig er DomTimeline HydrationDomSpace
696+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
697+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)
700+{-# SPECIALIZE elementImmediate
702+ -> ElementConfig er DomTimeline GhcjsDomSpace
703+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM a
704+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (Element er GhcjsDomSpace DomTimeline, a)
707+-- For specialisation
709+-- | The Reflex timeline for interacting with the DOM
711+#ifdef PROFILE_REFLEX
716+-- | The ReflexHost the DOM lives in
718+#ifdef PROFILE_REFLEX
723+type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))
724+type HydrationM = DomCoreWidget ()
726+{-# INLINE elementInternal #-}
728+ :: (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
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
739+{-# SPECIALIZE elementInternal
741+ -> ElementConfig er DomTimeline HydrationDomSpace
742+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
743+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
746+{-# INLINE hydrateElement #-}
748+ :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
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
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 ()
762+ { _hydrationDomBuilderEnv_parent = Right parentRef
763+ , _hydrationDomBuilderEnv_delayed = childDelayedRef
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
772+ skip <- hasAttribute e skipAttr
773+ ssr <- hasAttribute e ssrAttr
774+ pure $ skip || not ssr
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
782+ addHydrationStep $ do
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
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
796+ t <- Element.getTagName e
797+ -- TODO: check attributes?
798+ if T.toCaseFold elementTag == T.toCaseFold t
800+ -- we came to some other statically rendered element, so something has gone wrong
802+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
803+ n <- makeElement doc elementTag cfg
804+ insertAfterPreviousNode 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
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)
828+ -- Try to put this action into the cleanup MVar
831+ tryReadMVar cleanup >>= \case
832+ Nothing -> killThread threadId
834+ return ((Element es (), result), e')
836+{-# SPECIALIZE hydrateElement
838+ -> ElementConfig er DomTimeline HydrationDomSpace
839+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM a
840+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM ((Element er HydrationDomSpace DomTimeline, a), IORef DOM.Element)
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
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
876+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
877+ [ fmapMaybe id checkedChangedBySetChecked
878+ , checkedChangedByUI
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
897+{-# INLINE 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 = ()
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
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)
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
952+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
953+ [ checkedChangedBySetChecked
954+ , checkedChangedByUI
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
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
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
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
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 = ()
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
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)
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
1051+ return $ TextAreaElement
1052+ { _textAreaElement_value = v
1053+ , _textAreaElement_input = valueChangedByUI
1054+ , _textAreaElement_hasFocus = hasFocus
1055+ , _textAreaElement_element = e
1056+ , _textAreaElement_raw = ()
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
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
1090+ return (wrapped, result)
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 = ()
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
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)
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
1139+ return $ (,result) $ SelectElement
1140+ { _selectElement_value = v
1141+ , _selectElement_change = valueChangedByUI
1142+ , _selectElement_hasFocus = hasFocus
1143+ , _selectElement_element = e
1144+ , _selectElement_raw = ()
1147+{-# INLINE 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
1154+ n <- createTextNode doc t
1156+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1159+{-# SPECIALIZE textNodeImmediate
1160+ :: TextNodeConfig DomTimeline
1161+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM DOM.Text
1164+{-# SPECIALIZE textNodeImmediate
1165+ :: TextNodeConfig DomTimeline
1166+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM DOM.Text
1169+{-# INLINE 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
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
1182+{-# SPECIALIZE textNodeInternal
1183+ :: TextNodeConfig DomTimeline
1184+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (TextNode HydrationDomSpace DomTimeline)
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
1197+hydrateTextNode doc t = do
1198+ n <- join $ go <$> askParent <*> getPreviousNode
1199+ setPreviousNode $ Just $ toNode n
1202+ go parent mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1204+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1205+ n <- createTextNode doc t
1206+ insertAfterPreviousNode 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
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
1220+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1221+ n <- createTextNode doc t
1222+ insertAfterPreviousNode n
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
1232+ n <- createComment doc t
1234+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1237+{-# INLINE 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
1243+ getHydrationMode >>= \case
1244+ HydrationMode_Immediate -> void $ commentNodeInternal tc
1245+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t0) (hold t0) mSetContents) $ \bt -> do
1247+ void $ hydrateComment doc t mSetContents
1248+ pure $ CommentNode ()
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
1256+ c <- createComment doc t
1257+ insertAfterPreviousNode c
1259+ Just node -> DOM.castTo DOM.Comment node >>= \case
1260+ Nothing -> go (Just node)
1262+ t' <- Node.getTextContentUnchecked c
1266+ c' <- createComment doc t
1267+ insertAfterPreviousNode c'
1269+ n <- go =<< getPreviousNode
1270+ setPreviousNode $ Just $ toNode n
1271+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
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)
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
1288+ textNodeRef <- liftIO $ newIORef t
1289+ keyRef <- liftIO $ newIORef ""
1290+ pure (pure (), textNodeRef, keyRef)
1291+ HydrationMode_Hydrating -> do
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
1300+ commentText <- Node.getTextContentUnchecked comment
1301+ case T.stripPrefix (prefix <> key0) commentText of
1303+ -- Replace the comment with an (invisible) text node
1304+ tn <- createTextNode doc ("" :: Text)
1305+ Node.replaceChild_ parent tn comment
1308+ go key0 (Just node)
1310+ go key0 (Just node)
1312+ key0 <- liftIO $ readIORef key0Ref
1313+ (tn, key) <- go key0 =<< getPreviousNode
1314+ setPreviousNode $ Just $ toNode tn
1316+ writeIORef textNodeRef tn
1317+ writeIORef keyRef key
1318+ pure (switchComment, textNodeRef, keyRef)
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 "")
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
1328+instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
462 notReadyUntil e = do
1329 notReadyUntil e = do
463 eOnce <- headE e
1330 eOnce <- headE e
464− env <- ImmediateDomBuilderT ask
1331+ unreadyChildren <- askUnreadyChildren
465− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
1332+ commitAction <- askCommitAction
466 liftIO $ modifyIORef' unreadyChildren succ
1333 liftIO $ modifyIORef' unreadyChildren succ
467 let ready = do
1334 let ready = do
468 old <- liftIO $ readIORef unreadyChildren
1335 old <- liftIO $ readIORef unreadyChildren
469 let new = pred old
1336 let new = pred old
470 liftIO $ writeIORef unreadyChildren $! new
1337 liftIO $ writeIORef unreadyChildren $! new
471− when (new == 0) $ _immediateDomBuilderEnv_commitAction env
1338+ when (new == 0) commitAction
472 requestDomAction_ $ ready <$ eOnce
1339 requestDomAction_ $ ready <$ eOnce
473 notReady = do
1340 notReady = do
474− env <- ImmediateDomBuilderT ask
1341+ unreadyChildren <- askUnreadyChildren
475− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
476 liftIO $ modifyIORef' unreadyChildren succ
1342 liftIO $ modifyIORef' unreadyChildren succ
478−instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
1344+data HydrationDomSpace
479− type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace
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
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
480 {-# INLINABLE textNode #-}
1373 {-# INLINABLE textNode #-}
481− textNode (TextNodeConfig initialContents mSetContents) = do
482− n <- textNodeInternal initialContents
1374+ textNode = textNodeInternal
483− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
1375+ {-# INLINABLE commentNode #-}
484− return $ TextNode n
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) ()
1386+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
1387+ type DomBuilderSpace (HydrationDomBuilderT GhcjsDomSpace t m) = GhcjsDomSpace
485 {-# INLINABLE element #-}
1388 {-# 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
487 {-# INLINABLE inputElement #-}
1394 {-# INLINABLE inputElement #-}
488− inputElement cfg = do
1395+ inputElement = inputElementImmediate
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
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
515− c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
516− [ fmapMaybe id checkedChangedBySetChecked
517− , checkedChangedByUI
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)
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
539 {-# INLINABLE textAreaElement #-}
1396 {-# INLINABLE textAreaElement #-}
540− textAreaElement cfg = do --TODO
1397+ textAreaElement = textAreaElementImmediate
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
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
564 {-# INLINABLE selectElement #-}
1398 {-# INLINABLE selectElement #-}
565− selectElement cfg child = do
1399+ selectElement = selectElementImmediate
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
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
589− return (wrapped, result)
590 placeRawElement = append . toNode
1400 placeRawElement = append . toNode
591− wrapRawElement = wrap
1401+ wrapRawElement e rawCfg = do
1402+ events <- askEvents
1404+ eventTriggerRefs <- wrap events e rawCfg
1405+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e
1406+ pure $ Element es e
593data FragmentState
1408data FragmentState
594 = FragmentState_Unmounted
1409 = FragmentState_Unmounted
@@ -608,21 +1423,21 @@ extractFragment fragment = do
608 extractBetweenExclusive (_immediateDomFragment_document fragment) before after
1423 extractBetweenExclusive (_immediateDomFragment_document fragment) before after
609 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
1424 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
611−instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
1426+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where
612− type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
1427+ type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment
613 buildDomFragment w = do
1428 buildDomFragment w = do
614 df <- createDocumentFragment =<< askDocument
1429 df <- createDocumentFragment =<< askDocument
615 result <- flip localEnv w $ \env -> env
1430 result <- flip localEnv w $ \env -> env
616− { _immediateDomBuilderEnv_parent = toNode df
1431+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
618 state <- liftIO $ newIORef FragmentState_Unmounted
1433 state <- liftIO $ newIORef FragmentState_Unmounted
619 return (ImmediateDomFragment df state, result)
1434 return (ImmediateDomFragment df state, result)
620 mountDomFragment fragment setFragment = do
1435 mountDomFragment fragment setFragment = do
621− parent <- askParent
1436+ parent <- getParent
622 extractFragment fragment
1437 extractFragment fragment
623− before <- textNodeInternal ("" :: Text)
1438+ before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
624 appendChild_ parent $ _immediateDomFragment_document fragment
1439 appendChild_ parent $ _immediateDomFragment_document fragment
625− after <- textNodeInternal ("" :: Text)
1440+ after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
626 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
1441 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
627 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
1442 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
628 extractFragment previousFragment
1443 extractFragment previousFragment
@@ -631,12 +1446,19 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
631 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
1446 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
632 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
1447 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
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
634−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
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
635 {-# INLINABLE runWithReplace #-}
1456 {-# INLINABLE runWithReplace #-}
636 runWithReplace a0 a' = do
1457 runWithReplace a0 a' = do
637− initialEnv <- ImmediateDomBuilderT ask
1458+ initialEnv <- HydrationDomBuilderT ask
638− before <- textNodeInternal ("" :: Text)
1459+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
1460+ (hydrateStart, before, beforeKey) <- skipToReplaceStart
639− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
1461+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
640 haveEverBeenReady <- liftIO $ newIORef False
1462 haveEverBeenReady <- liftIO $ newIORef False
641 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
1463 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
642 let myCommitAction = do
1464 let myCommitAction = do
@@ -647,79 +1469,117 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
647 old <- liftIO $ readIORef parentUnreadyChildren
1469 old <- liftIO $ readIORef parentUnreadyChildren
648 let new = pred old
1470 let new = pred old
649 liftIO $ writeIORef parentUnreadyChildren $! new
1471 liftIO $ writeIORef parentUnreadyChildren $! new
650− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
1472+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
651 -- We draw 'after' in this roundabout way to avoid using MonadFix
1473 -- We draw 'after' in this roundabout way to avoid using MonadFix
652 doc <- askDocument
1474 doc <- askDocument
653− after <- createTextNode doc ("" :: Text)
1475+ parent <- getParent
1476+ (hydrateEnd, after) <- skipToReplaceEnd beforeKey
654 let drawInitialChild = do
1477 let drawInitialChild = do
1478+ h <- liftIO $ readIORef hydrating
1480+ HydrationMode_Hydrating -> pure parent
1481+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
655 unreadyChildren <- liftIO $ newIORef 0
1482 unreadyChildren <- liftIO $ newIORef 0
656− let f = do
1483+ let a0' = case h of
657− result <- a0
1484+ HydrationMode_Hydrating -> a0
658− append $ toNode after
1485+ HydrationMode_Immediate -> do
659− return result
1486+ a <- a0
1487+ insertBefore p' =<< liftIO (readIORef after)
1489+ delayed <- case h of
1490+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1491+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
660− result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
1492+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv
661− { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
1493+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
662− , _immediateDomBuilderEnv_commitAction = myCommitAction
1494+ , _hydrationDomBuilderEnv_commitAction = myCommitAction
1495+ , _hydrationDomBuilderEnv_parent = Left p'
1496+ , _hydrationDomBuilderEnv_delayed = delayed
1499+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1500+ HydrationMode_Immediate -> pure $ pure ()
664 liftIO $ readIORef unreadyChildren >>= \case
1501 liftIO $ readIORef unreadyChildren >>= \case
665 0 -> writeIORef haveEverBeenReady True
1502 0 -> writeIORef haveEverBeenReady True
666 _ -> modifyIORef' parentUnreadyChildren succ
1503 _ -> modifyIORef' parentUnreadyChildren succ
667− return result
1504+ return (dom, result)
668 a'' <- numberOccurrences a'
1505 a'' <- numberOccurrences a'
669− (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
1506+ ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
1507+ h <- liftIO $ readIORef hydrating
1509+ HydrationMode_Hydrating -> pure parent
670− df <- createDocumentFragment doc
1510+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
671 unreadyChildren <- liftIO $ newIORef 0
1511 unreadyChildren <- liftIO $ newIORef 0
672 let commitAction = do
1512 let commitAction = do
673 c <- liftIO $ readIORef currentCohort
1513 c <- liftIO $ readIORef currentCohort
674 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
1514 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
1515+ !before' <- liftIO $ readIORef before
1516+ !after' <- liftIO $ readIORef after
675− deleteBetweenExclusive before after
1517+ deleteBetweenExclusive before' after'
676− insertBefore df after
1518+ insertBefore p' after'
677 liftIO $ writeIORef currentCohort cohortId
1519 liftIO $ writeIORef currentCohort cohortId
678 myCommitAction
1520 myCommitAction
1521+ delayed <- case h of
1522+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()
1523+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv
679− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
1524+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv
680− { _immediateDomBuilderEnv_parent = toNode df
1525+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
681− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
1526+ , _hydrationDomBuilderEnv_commitAction = case h of
682− , _immediateDomBuilderEnv_commitAction = commitAction
1527+ HydrationMode_Hydrating -> myCommitAction
1528+ HydrationMode_Immediate -> commitAction
1529+ , _hydrationDomBuilderEnv_parent = Left p'
1530+ , _hydrationDomBuilderEnv_delayed = delayed
1533+ HydrationMode_Hydrating -> liftIO $ readIORef delayed
1534+ HydrationMode_Immediate -> pure $ pure ()
684 uc <- liftIO $ readIORef unreadyChildren
1535 uc <- liftIO $ readIORef unreadyChildren
685 let commitActionToRunNow = if uc == 0
1536 let commitActionToRunNow = if uc == 0
686− then Just commitAction
1537+ then Just $ commitAction
687 else Nothing -- A child will run it when unreadyChildren is decremented to 0
1538 else Nothing -- A child will run it when unreadyChildren is decremented to 0
1539+ actions = case h of
1540+ HydrationMode_Hydrating -> Left dom
688− return (commitActionToRunNow, result)
1541+ HydrationMode_Immediate -> Right commitActionToRunNow
1542+ return (actions, result)
1543+ let (hydrate', commitAction) = fanEither $ fmap fst child'
1544+ addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do
1546+ join $ sample contents
689− requestDomAction_ $ fmapMaybe fst child'
1548+ requestDomAction_ $ fmapMaybe id commitAction
690 return (result0, snd <$> child')
1549 return (result0, snd <$> child')
691 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
1551 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
692 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
1552 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
693 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
1553 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
694 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
1554 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
695 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
1555 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
696 traverseDMapWithKeyWithAdjustWithMove = do
1556 traverseDMapWithKeyWithAdjustWithMove = do
697− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
1557+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some 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)
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)
699 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
1559 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
700− PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
1560+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete
701− readIORef sRef >>= \case
1561+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do
1562+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
702 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
1563 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
703 ChildReadyState_Unready _ -> do
1564 ChildReadyState_Unready _ -> do
704− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1565+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
705− return $ PatchDMapWithMove.From_Insert $ Constant sRef
1566+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)
706 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
1567 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
707 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
1568 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)
709 deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do
1570 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
711 return $ Constant ()
1572 return $ Constant ()
712 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
1573 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
713 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
1574 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
714 return $ applyAlways p' old
1575 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
716 let p = unPatchDMapWithMove p_
1577 let p = unPatchDMapWithMove p_
717 phsBefore <- liftIO $ readIORef placeholders
1578 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)
720 collectIfMoved k e = do
1580 collectIfMoved k e = do
721− let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
1581+ let mThisPlaceholder = Map.lookup (Some k) phsBefore -- Will be Nothing if this element wasn't present before
722− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
1582+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phsBefore
723 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
1583 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
724 False -> do
1584 False -> do
725 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
1585 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
@@ -727,13 +1587,22 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
727 True -> do
1587 True -> do
728 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
1588 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
729 collected <- DMap.traverseWithKey collectIfMoved p
1589 collected <- DMap.traverseWithKey collectIfMoved p
730− let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
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
731− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
1599+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a)
732 placeFragment k e = do
1600 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
734 case PatchDMapWithMove._nodeInfo_from e of
1602 case PatchDMapWithMove._nodeInfo_from e of
735− PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
1603+ PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of
736− df `insertBefore` nextPlaceholder
1605+ Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder
737 PatchDMapWithMove.From_Delete -> do
1606 PatchDMapWithMove.From_Delete -> do
738 return ()
1607 return ()
739 PatchDMapWithMove.From_Move fromKey -> do
1608 PatchDMapWithMove.From_Move fromKey -> do
@@ -744,105 +1613,166 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
744 liftIO $ writeIORef placeholders $! phsAfter
1613 liftIO $ writeIORef placeholders $! phsAfter
746{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
1615{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
1616+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'))
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))
1620+ -> Event t (PatchDMap k v)
1621+ -> HydrationDomBuilderT s t m (DMap k v', Event t (PatchDMap k v'))
748traverseDMapWithKeyWithAdjust' = do
1622traverseDMapWithKeyWithAdjust' = do
749− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
1623+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some 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)
1624+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)
751 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
1625 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
752 Nothing -> return Nothing
1626 Nothing -> return Nothing
753− Just (Compose (_, _, sRef, _)) -> do
1627+ Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing
754− readIORef sRef >>= \case
1628+ Just (Compose (TraverseChild (Right immediate) _)) -> do
1629+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
755 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
1630 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
756 ChildReadyState_Unready _ -> do
1631 ChildReadyState_Unready _ -> do
757− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1632+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
758− return $ Just $ Constant sRef
1633+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
759 delete _ (Constant sRef) = do
1634 delete _ (Constant sRef) = do
760 writeIORef sRef $ ChildReadyState_Unready Nothing
1635 writeIORef sRef $ ChildReadyState_Unready Nothing
761 return $ Constant ()
1636 return $ Constant ()
762 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
1637 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
763 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
1638 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
764 return $ applyAlways p' old
1639 return $ applyAlways p' old
765− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
1640+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do
766 phs <- liftIO $ readIORef placeholders
1641 phs <- liftIO $ readIORef placeholders
767− forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
1642+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do
768− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
769− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
1643+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some k) phs
1645+ forM_ (Map.lookup (Some k) phs) $ \thisPlaceholder -> do
770− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
1646+ thisPlaceholder `deleteUpTo` nextPlaceholder
1648+ forM_ mv $ \(Compose (TraverseChild e _)) -> case e of
1649+ Left _hydration -> pure ()
1650+ Right immediate -> do
771− forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
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
772− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
1659+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
774{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
1661{-# 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')
1666+ -> Event t (PatchIntMap v)
1667+ -> HydrationDomBuilderT s t m (IntMap v', Event t (PatchIntMap v'))
776traverseIntMapWithKeyWithAdjust' = do
1668traverseIntMapWithKeyWithAdjust' = do
777− let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do
1669+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do
778− let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))
1670+ let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))
779 new k m = case m of
1671 new k m = case m of
780 Nothing -> return Nothing
1672 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
782 readIORef sRef >>= \case
1676 readIORef sRef >>= \case
783− ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready
1677+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
784− ChildReadyStateInt_Unready _ -> do
1678+ ChildReadyState_Unready _ -> do
785− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
1679+ writeIORef sRef $ ChildReadyState_Unready $ Just k
786 return $ Just sRef
1680 return $ Just sRef
787 delete _ sRef = do
1681 delete _ sRef = do
788− writeIORef sRef $ ChildReadyStateInt_Unready Nothing
1682+ writeIORef sRef $ ChildReadyState_Unready Nothing
789 return ()
1683 return ()
790 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
1684 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
791 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
1685 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
792 return $ applyAlways p' old
1686 return $ applyAlways p' old
793− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do
1687+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do
794 phs <- liftIO $ readIORef placeholders
1688 phs <- liftIO $ readIORef placeholders
795 forM_ (IntMap.toList p) $ \(k, mv) -> do
1689 forM_ (IntMap.toList p) $ \(k, mv) -> do
796− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
797 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
1690 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
798 forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
1692 forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
1694+ forM_ mv $ \(TraverseChild e _) -> case e of
1695+ Left _hydration -> pure ()
1696+ Right immediate -> do
799− forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder
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
1702+ | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate
1703+ | otherwise -> Nothing
800− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs
1704+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs
1706+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
1707+ :: (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1709+ -> Event DomTimeline (PatchIntMap v)
1710+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
802−#if MIN_VERSION_base(4,9,0)
1713+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'
803−data ChildReadyState k
1714+ :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
804−#else
1715+ -> IntMap v
805−data ChildReadyState (k :: * -> *)
1716+ -> Event DomTimeline (PatchIntMap v)
806−#endif
1717+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1720+data ChildReadyState a
807 = ChildReadyState_Ready
1721 = ChildReadyState_Ready
808− | ChildReadyState_Unready !(Maybe (Some k))
1722+ | ChildReadyState_Unready !(Maybe a)
809 deriving (Show, Read, Eq, Ord)
1723 deriving (Show, Read, Eq, Ord)
811−data ChildReadyStateInt
1725+insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()
812− = ChildReadyStateInt_Ready
1726+insertAfterPreviousNode node = do
813− | ChildReadyStateInt_Unready !(Maybe Int)
1727+ parent <- askParent
814− deriving (Show, Read, Eq, Ord)
1728+ nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode
1729+ Node.insertBefore_ parent node nextNode
1730+ setPreviousNode $ Just $ toNode node
816−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
1732+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
817−hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
1733+hoistTraverseWithKeyWithAdjust
818 ( Adjustable t m
1735 ( Adjustable t m
819 , MonadIO m
1738 , MonadIO m
820 , MonadJSM m
1739 , MonadJSM m
822 , PrimMonad m
1740 , PrimMonad m
823− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
1741+ , MonadFix m
824− , Functor p
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
826− => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
1750+ => (forall vv vv'.
827− -> IntMap v
1751+ (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
828− -> Event t (p v)
1753+ -> Event t (p k vv)
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')))
1754+ -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))
830− ) -- ^ The base monad's traversal
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))))))
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
1759+ -- ^ 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
1760+ -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())
833− -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')
1761+ -- ^ Apply a patch to the DOM
834− -> IntMap v
1762+ -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
835− -> Event t (p v)
1764+ -> Event t (p k v)
836− -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))
1765+ -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))
837−hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1766+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
838− initialEnv <- ImmediateDomBuilderT ask
1767+ doc <- askDocument
1768+ initialEnv <- HydrationDomBuilderT ask
839− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
1769+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
840− pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
1770+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty
841 haveEverBeenReady <- liftIO $ newIORef False
1771 haveEverBeenReady <- liftIO $ newIORef False
842− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
1772+ placeholders <- liftIO $ newIORef Map.empty
843− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1773+ lastPlaceholder <- createTextNode doc ("" :: Text)
844 let applyDomUpdate p = do
1774 let applyDomUpdate p = do
845− applyDomUpdate_ placeholders lastPlaceholderRef p
1775+ applyDomUpdate_ placeholders lastPlaceholder p
846 markSelfReady
1776 markSelfReady
847 liftIO $ writeIORef pendingChange $! mempty
1777 liftIO $ writeIORef pendingChange $! mempty
848 markSelfReady = do
1778 markSelfReady = do
@@ -853,86 +1783,105 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
853 old <- liftIO $ readIORef parentUnreadyChildren
1783 old <- liftIO $ readIORef parentUnreadyChildren
854 let new = pred old
1784 let new = pred old
855 liftIO $ writeIORef parentUnreadyChildren $! new
1785 liftIO $ writeIORef parentUnreadyChildren $! new
856− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
1786+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
857− markChildReady :: IORef ChildReadyStateInt -> JSM ()
1787+ markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()
858 markChildReady childReadyState = do
1788 markChildReady childReadyState = do
859 liftIO (readIORef childReadyState) >>= \case
1789 liftIO (readIORef childReadyState) >>= \case
860− ChildReadyStateInt_Ready -> return ()
1790+ ChildReadyState_Ready -> return ()
861− ChildReadyStateInt_Unready countedAt -> do
1791+ ChildReadyState_Unready countedAt -> do
862− liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1792+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
863 case countedAt of
1793 case countedAt of
864 Nothing -> return ()
1794 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
866 (oldUnready, p) <- liftIO $ readIORef pendingChange
1796 (oldUnready, p) <- liftIO $ readIORef pendingChange
867− when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
1797+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
868− let newUnready = IntMap.delete k oldUnready
1798+ let newUnready = DMap.delete k oldUnready
869 liftIO $ writeIORef pendingChange (newUnready, p)
1799 liftIO $ writeIORef pendingChange (newUnready, p)
870− when (IntMap.null newUnready) $ do
1800+ when (DMap.null newUnready) $ do
871 applyDomUpdate p
1801 applyDomUpdate p
1802+ (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))
872− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1803+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
873− let processChild k (_, _, sRef, _) = do
1804+ let processChild k (Compose (TraverseChild e _)) = case e of
874− readIORef sRef >>= \case
1805+ Left _ -> pure $ ComposeMaybe Nothing
875− ChildReadyStateInt_Ready -> return Nothing
1806+ Right immediate -> ComposeMaybe <$> do
876− ChildReadyStateInt_Unready _ -> do
1807+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
877− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
1808+ ChildReadyState_Ready -> return Nothing
878− return $ Just sRef
1809+ ChildReadyState_Unready _ -> do
1810+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some k
1811+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)
879− initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
1812+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
880− liftIO $ if IntMap.null initialUnready
1813+ liftIO $ if DMap.null initialUnready
881 then writeIORef haveEverBeenReady True
1814 then writeIORef haveEverBeenReady True
883 modifyIORef' parentUnreadyChildren succ
1816 modifyIORef' parentUnreadyChildren succ
884 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
1817 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
1818+ getHydrationMode >>= \case
886− placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
1819+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
887− result' = ffor children' $ fmap $ \(_, _, _, r) -> r
1820+ dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children
888− liftIO $ writeIORef placeholders $! placeholders0
1821+ phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm
889− _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
1822+ liftIO $ writeIORef placeholders $! phs
890− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
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
891 requestDomAction_ $ ffor children' $ \p -> do
1831 requestDomAction_ $ ffor children' $ \p -> do
892 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
1832 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
893 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
1833 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
894 let !newP = p <> oldP
1834 let !newP = p <> oldP
895 liftIO $ writeIORef pendingChange (newUnready, newP)
1835 liftIO $ writeIORef pendingChange (newUnready, newP)
896− when (IntMap.null newUnready) $ do
1836+ when (DMap.null newUnready) $ do
897 applyDomUpdate newP
1837 applyDomUpdate newP
1838+ let result0 = DMap.map (_traverseChild_result . getCompose) children0
1839+ result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose
898 return (result0, result')
1840 return (result0, result')
900−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
1842+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
901−hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
1843+hoistTraverseIntMapWithKeyWithAdjust ::
902 ( Adjustable t m
1844 ( Adjustable t m
903 , MonadHold t m
1845 , MonadHold t m
906 , MonadJSM m
1846 , MonadJSM m
908 , MonadFix m
1847 , MonadFix m
909− , Patch (p k v)
1848+ , PrimMonad m
910− , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1849+ , Monoid (p (TraverseChild t m Int v'))
911− , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
1850+ , Functor p
912− , Patch (p k (Constant Int))
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
914− => (forall vv vv'.
1857+ => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))
915− (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))
1858+ -> IntMap v
917− -> Event t (p k vv)
1859+ -> Event t (p v)
918− -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))
1860+ -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))
919− ) -- ^ The base monad's traversal
1861+ -- ^ 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
1862+ -> (p (TraverseChild t m Int v')
1863+ -> IntMap (IORef (ChildReadyState Int))
1864+ -> IO (IntMap (IORef (ChildReadyState Int))))
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
1865+ -- ^ 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
1866+ -> (IORef (IntMap DOM.Text)
923− -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))
1867+ -> DOM.Text
924− -> DMap k v
1868+ -> p (TraverseChild t m Int v')
1870+ -- ^ Apply a patch to the DOM
1871+ -> (IntMap.Key -> v -> HydrationDomBuilderT s t m v')
925− -> Event t (p k v)
1873+ -> Event t (p v)
926− -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))
1874+ -> HydrationDomBuilderT s t m (IntMap v', Event t (p 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
1875+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
928− initialEnv <- ImmediateDomBuilderT ask
1876+ doc <- askDocument
1877+ initialEnv <- HydrationDomBuilderT ask
929− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
1878+ let parentUnreadyChildren = _hydrationDomBuilderEnv_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
1879+ pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty
931 haveEverBeenReady <- liftIO $ newIORef False
1880 haveEverBeenReady <- liftIO $ newIORef False
932− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
1881+ placeholders <- liftIO $ newIORef IntMap.empty
933− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1882+ lastPlaceholder <- createTextNode doc ("" :: Text)
934 let applyDomUpdate p = do
1883 let applyDomUpdate p = do
935− applyDomUpdate_ placeholders lastPlaceholderRef p
1884+ applyDomUpdate_ placeholders lastPlaceholder p
936 markSelfReady
1885 markSelfReady
937 liftIO $ writeIORef pendingChange $! mempty
1886 liftIO $ writeIORef pendingChange $! mempty
938 markSelfReady = do
1887 markSelfReady = do
@@ -943,8 +1892,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
943 old <- liftIO $ readIORef parentUnreadyChildren
1892 old <- liftIO $ readIORef parentUnreadyChildren
944 let new = pred old
1893 let new = pred old
945 liftIO $ writeIORef parentUnreadyChildren $! new
1894 liftIO $ writeIORef parentUnreadyChildren $! new
946− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
1895+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
947− markChildReady :: IORef (ChildReadyState k) -> JSM ()
1896+ markChildReady :: IORef (ChildReadyState Int) -> JSM ()
948 markChildReady childReadyState = do
1897 markChildReady childReadyState = do
949 liftIO (readIORef childReadyState) >>= \case
1898 liftIO (readIORef childReadyState) >>= \case
950 ChildReadyState_Ready -> return ()
1899 ChildReadyState_Ready -> return ()
@@ -952,82 +1901,191 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
952 liftIO $ writeIORef childReadyState ChildReadyState_Ready
1901 liftIO $ writeIORef childReadyState ChildReadyState_Ready
953 case countedAt of
1902 case countedAt of
954 Nothing -> return ()
1903 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
956 (oldUnready, p) <- liftIO $ readIORef pendingChange
1905 (oldUnready, p) <- liftIO $ readIORef pendingChange
957− when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
1906+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
958− let newUnready = DMap.delete k oldUnready
1907+ let newUnready = IntMap.delete k oldUnready
959 liftIO $ writeIORef pendingChange (newUnready, p)
1908 liftIO $ writeIORef pendingChange (newUnready, p)
960− when (DMap.null newUnready) $ do
1909+ when (IntMap.null newUnready) $ do
961 applyDomUpdate p
1910 applyDomUpdate p
1911+ (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))
962− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1912+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
963− let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
1913+ let processChild k (TraverseChild e _) = case e of
964− readIORef sRef >>= \case
1914+ Left _ -> pure Nothing
1915+ Right immediate -> do
1916+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case
965− ChildReadyState_Ready -> return Nothing
1917+ ChildReadyState_Ready -> return Nothing
966− ChildReadyState_Unready _ -> do
1918+ ChildReadyState_Unready _ -> do
967− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1919+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k
968− return $ Just $ Constant sRef
1920+ return $ Just (_traverseChildImmediate_childReadyState immediate)
969− initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1921+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
970− liftIO $ if DMap.null initialUnready
1922+ liftIO $ if IntMap.null initialUnready
971 then writeIORef haveEverBeenReady True
1923 then writeIORef haveEverBeenReady True
973 modifyIORef' parentUnreadyChildren succ
1925 modifyIORef' parentUnreadyChildren succ
974 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
1926 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
1927+ getHydrationMode >>= \case
976− placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
1928+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
977− result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
1929+ dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children
978− liftIO $ writeIORef placeholders $! placeholders0
1930+ phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm
979− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
1931+ liftIO $ writeIORef placeholders $! phs
980− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
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
981 requestDomAction_ $ ffor children' $ \p -> do
1940 requestDomAction_ $ ffor children' $ \p -> do
982 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
1941 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
983 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
1942 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
984 let !newP = p <> oldP
1943 let !newP = p <> oldP
985 liftIO $ writeIORef pendingChange (newUnready, newP)
1944 liftIO $ writeIORef pendingChange (newUnready, newP)
986− when (DMap.null newUnready) $ do
1945+ when (IntMap.null newUnready) $ do
987 applyDomUpdate newP
1946 applyDomUpdate newP
1947+ let result0 = IntMap.map _traverseChild_result children0
1948+ result' = ffor children' $ fmap $ _traverseChild_result
988 return (result0, result')
1949 return (result0, result')
1951+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1952+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int 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)
1961+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1963+ -> (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM v')
1965+ -> Event DomTimeline (PatchIntMap v)
1966+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
1969+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust
1970+ :: ((IntMap.Key -> v -> DomRenderHookT DomTimeline HydrationM (TraverseChild DomTimeline HydrationM Int 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)
1979+ -> PatchIntMap (TraverseChild DomTimeline HydrationM Int v')
1981+ -> (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM v')
1983+ -> Event DomTimeline (PatchIntMap v)
1984+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM (IntMap v', Event DomTimeline (PatchIntMap v'))
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))
1995+newtype TraverseChildHydration t m = TraverseChildHydration
1996+ { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text
1997+ -- ^ Action to run at switchover, returns the placeholder
2000+data TraverseChild t m k a = TraverseChild
2001+ { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))
2002+ , _traverseChild_result :: !a
990{-# INLINABLE drawChildUpdate #-}
2005{-# INLINABLE drawChildUpdate #-}
991−drawChildUpdate :: (MonadIO m, MonadJSM m)
2006+drawChildUpdate :: (MonadJSM m, Reflex t)
992− => ImmediateDomBuilderEnv t
2007+ => HydrationDomBuilderEnv t m
993 -> (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
2008 -> (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)
2009+ -> HydrationDomBuilderT s t m (f a)
995− -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
2010+ -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)
996drawChildUpdate initialEnv markReady child = do
2011drawChildUpdate initialEnv markReady child = do
997− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
2012+ let doc = _hydrationDomBuilderEnv_document initialEnv
998 unreadyChildren <- liftIO $ newIORef 0
2013 unreadyChildren <- liftIO $ newIORef 0
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
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
2032+ HydrationMode_Immediate -> do
2033+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
999− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
2034+ df <- createDocumentFragment doc
1000− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
2035+ placeholder <- createTextNode doc ("" :: Text)
1001− { _immediateDomBuilderEnv_parent = toNode df
2036+ Node.appendChild_ df placeholder
1002− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
2037+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv
2038+ { _hydrationDomBuilderEnv_parent = Left $ toNode df
2039+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1003− , _immediateDomBuilderEnv_commitAction = markReady childReadyState
2040+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1005− u <- liftIO $ readIORef unreadyChildren
2042+ u <- liftIO $ readIORef unreadyChildren
1006− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
2043+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1007− return $ Compose (df, placeholder, childReadyState, result)
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
1009−{-# INLINABLE drawChildUpdateInt #-}
2053+{-# SPECIALIZE drawChildUpdate
1010−drawChildUpdateInt :: (MonadIO m, MonadJSM m)
2054+ :: HydrationDomBuilderEnv DomTimeline HydrationM
1011− => ImmediateDomBuilderEnv t
2055+ -> (IORef (ChildReadyState Int) -> JSM ())
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
2056+ -> HydrationDomBuilderT s DomTimeline HydrationM (Identity a)
1013− -> ImmediateDomBuilderT t m v'
2057+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM Int) Identity a)
1014− -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
2058+ #-}
1015−drawChildUpdateInt initialEnv markReady child = do
2059+
1016− childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing
2060+{-# SPECIALIZE drawChildUpdate
1017− unreadyChildren <- liftIO $ newIORef 0
2061+ :: HydrationDomBuilderEnv DomTimeline HydrationM
1018− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
2062+ -> (IORef (ChildReadyState (Some k)) -> JSM ())
1019− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
2063+ -> HydrationDomBuilderT s DomTimeline HydrationM (f a)
1020− { _immediateDomBuilderEnv_parent = toNode df
2064+ -> DomRenderHookT DomTimeline HydrationM (Compose (TraverseChild DomTimeline HydrationM (Some k)) f a)
1021− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
2065+ #-}
1022− , _immediateDomBuilderEnv_commitAction = markReady childReadyState
1024− u <- liftIO $ readIORef unreadyChildren
1025− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1026− return (df, placeholder, childReadyState, result)
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)
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)
2082+{-# INLINE mkHasFocus #-}
2084+ :: (HasDocument m, MonadJSM m, IsNode (RawElement d), MonadHold t m, Reflex t, DOM.IsDocumentOrShadowRoot (RawDocument (DomBuilderSpace m)))
1028−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
2085+ => Element er d t -> m (Dynamic t Bool)
1029mkHasFocus e = do
2086mkHasFocus 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
1031 holdDyn initialFocus $ leftmost
2089 holdDyn initialFocus $ leftmost
1032 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
2090 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1033 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
2091 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
@@ -1036,39 +2094,49 @@ mkHasFocus e = do
1036insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
2094insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1037insertBefore new existing = do
2095insertBefore new existing = do
1038 p <- getParentNodeUnchecked existing
2096 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
2099+type ImmediateDomBuilderT = HydrationDomBuilderT GhcjsDomSpace
1041−instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
2101+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where
1042− type Performable (ImmediateDomBuilderT t m) = Performable m
2102+ type Performable (HydrationDomBuilderT s t m) = Performable m
1043 {-# INLINABLE performEvent_ #-}
2103 {-# INLINABLE performEvent_ #-}
1044 performEvent_ e = lift $ performEvent_ e
2104 performEvent_ e = lift $ performEvent_ e
1045 {-# INLINABLE performEvent #-}
2105 {-# INLINABLE performEvent #-}
1046 performEvent e = lift $ performEvent e
2106 performEvent e = lift $ performEvent e
1048−instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where
2108+instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where
1049 {-# INLINABLE getPostBuild #-}
2109 {-# INLINABLE getPostBuild #-}
1050 getPostBuild = lift getPostBuild
2110 getPostBuild = lift getPostBuild
1052−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where
2112+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where
1053 {-# INLINABLE newEventWithTrigger #-}
2113 {-# INLINABLE newEventWithTrigger #-}
1054 newEventWithTrigger = lift . newEventWithTrigger
2114 newEventWithTrigger = lift . newEventWithTrigger
1055 {-# INLINABLE newFanEventWithTrigger #-}
2115 {-# INLINABLE newFanEventWithTrigger #-}
1056 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
2116 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
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
2126+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where
1059 {-# INLINABLE newTriggerEvent #-}
2127 {-# INLINABLE newTriggerEvent #-}
1060− newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent
2128+ newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent
1061 {-# INLINABLE newTriggerEventWithOnComplete #-}
2129 {-# INLINABLE newTriggerEventWithOnComplete #-}
1062− newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
2130+ newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete
1063 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
2131 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1064− newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
2132+ newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f
1066−instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
2134+instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where
1067− type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
2135+ type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m
1068 askJSContext = lift askJSContext
2136 askJSContext = lift askJSContext
1070−instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
2138+instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where
1071− type Ref (ImmediateDomBuilderT t m) = Ref m
2139+ type Ref (HydrationDomBuilderT s t m) = Ref m
1072 {-# INLINABLE newRef #-}
2140 {-# INLINABLE newRef #-}
1073 newRef = lift . newRef
2141 newRef = lift . newRef
1074 {-# INLINABLE readRef #-}
2142 {-# INLINABLE readRef #-}
@@ -1076,12 +2144,12 @@ instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
1076 {-# INLINABLE writeRef #-}
2144 {-# INLINABLE writeRef #-}
1077 writeRef r = lift . writeRef r
2145 writeRef r = lift . writeRef r
1079−instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
2147+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where
1080 {-# INLINABLE atomicModifyRef #-}
2148 {-# INLINABLE atomicModifyRef #-}
1081 atomicModifyRef r = lift . atomicModifyRef r
2149 atomicModifyRef r = lift . atomicModifyRef r
1083−instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
2151+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where
1084− type JSX (ImmediateDomBuilderT t m) = JSX m
2152+ type JSX (HydrationDomBuilderT s t m) = JSX m
1085 liftJS = lift . liftJS
2153 liftJS = lift . liftJS
1087type family EventType en where
2155type family EventType en where
@@ -1539,11 +2607,11 @@ getTouchEvent = do
1539 , _touchEventResult_touches = touches
2607 , _touchEventResult_touches = touches
1542−instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
2610+instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
1543 {-# INLINABLE sample #-}
2611 {-# INLINABLE sample #-}
1544 sample = lift . sample
2612 sample = lift . sample
1546−instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where
2614+instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where
1547 {-# INLINABLE hold #-}
2615 {-# INLINABLE hold #-}
1548 hold v0 v' = lift $ hold v0 v'
2616 hold v0 v' = lift $ hold v0 v'
1549 {-# INLINABLE holdDyn #-}
2617 {-# INLINABLE holdDyn #-}
@@ -1565,7 +2633,7 @@ data Window t = Window
1565 , _window_raw :: DOM.Window
2633 , _window_raw :: DOM.Window
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)
1569wrapWindow wv _ = do
2637wrapWindow wv _ = do
1570 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
2638 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
1571 return $ Window
2639 return $ Window