@@ -128,6 +128,7 @@ import Data.Monoid hiding (Product)
128128import Data.Some (Some)
129129import qualified Data.Some as Some
130130import Data.Text (Text)
131+import qualified Data.Text as T
131132import qualified GHCJS.DOM as DOM
132133import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
133134import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
@@ -145,8 +146,10 @@ import GHCJS.DOM.MouseEvent
145146import qualified GHCJS.DOM.Touch as Touch
146147import qualified GHCJS.DOM.TouchEvent as TouchEvent
147148import qualified GHCJS.DOM.TouchList as TouchList
148−import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
149+import GHCJS.DOM.Node (appendChild_, getChildNodes, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
149150import qualified GHCJS.DOM.Node as DOM (insertBefore_)
151+import qualified GHCJS.DOM.Node as Node
152+import qualified GHCJS.DOM.NodeList as NodeList
150153import GHCJS.DOM.Types
151154 (liftJSM, askJSM, runJSM, JSM, MonadJSM,
152155 FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
@@ -155,7 +158,7 @@ import qualified GHCJS.DOM.Types as DOM
155158import GHCJS.DOM.UIEvent
156159import GHCJS.DOM.KeyboardEvent as KeyboardEvent
157160import qualified GHCJS.DOM.Window as Window
158−import Language.Javascript.JSaddle (call, eval)
161+import Language.Javascript.JSaddle (call, eval, jsg, js1)
159162import Data.IntMap.Strict (IntMap)
160163import qualified Data.IntMap.Strict as IntMap
161164import Data.FastMutableIntMap (PatchIntMap (..))
@@ -172,11 +175,19 @@ instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
172175 liftJSM' = ImmediateDomBuilderT . liftJSM'
173176#endif
174177
178+{- Hydration:
179+ - Fence off `prerender` and totally replace immediately
180+ - Fence off `runWithReplace` and hydrate at postBuild
181+ - Otherwise hydrate at build time, skipping elements without SSR attribute, stripping the attrs as we go
182+-}
183+
175184data ImmediateDomBuilderEnv t
176185 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document
177186 , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node
178187 , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
179188 , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
189+ , _immediateDomBuilderEnv_hydrating :: {-# UNPACK #-} !(IORef Bool) -- In hydration mode?
190+ , _immediateDomBuilderEnv_hydrationNode :: {-# UNPACK #-} !(IORef (Maybe Node)) -- Hydration node index
180191 }
181192
182193newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }
@@ -249,21 +260,76 @@ append n = do
249260 liftJSM $ appendChild_ p n
250261 return ()
251262
263+getHydrationMode :: MonadIO m => ImmediateDomBuilderT t m Bool
264+getHydrationMode = do
265+ ref <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrating
266+ liftIO $ readIORef ref
267+
252268{-# INLINABLE textNodeInternal #-}
253269textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
254270textNodeInternal !t = do
255271 doc <- askDocument
256− n <- liftJSM $ createTextNode doc t
257− append $ toNode n
258− return n
272+-- n <- liftJSM $ createTextNode doc t
273+-- append $ toNode n
274+-- return n
275+ parent <- askParent
276+ getHydrationMode >>= \case
277+ False -> do
278+ liftIO $ print $ "Not in hydration mode, creating text node: " <> DOM.toJSString t
279+ n <- liftJSM $ createTextNode doc t -- not in hydration mode, create as usual
280+ append $ toNode n
281+ pure n
282+ True -> do
283+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
284+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
285+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
286+ Nothing -> do
287+ liftIO $ print $ "No node found, building text node: " <> DOM.toJSString t
288+ tn <- liftJSM $ createTextNode doc t
289+ append $ toNode tn -- we can append because there's no node at this index (we have exhausted all previous nodes)
290+ pure tn
291+ Just node -> DOM.castTo DOM.Text node >>= \case
292+ Nothing -> do
293+ liftIO $ putStrLn $ "Not a text node, skipping"
294+ go (Just node)
295+ Just tn -> do
296+ liftIO $ print $ "Using existing text node: instead of building " <> DOM.toJSString t
297+ pure tn
298+ n <- go lastHydrationNode
299+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode n)
300+ pure n
259301
260302{-# INLINABLE commentNodeInternal #-}
261303commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Comment
262304commentNodeInternal !t = do
263305 doc <- askDocument
264− n <- liftJSM $ createComment doc t
265− append $ toNode n
266− return n
306+ parent <- askParent
307+
308+ getHydrationMode >>= \case
309+ False -> do
310+ liftIO $ print $ "Not in hydration mode, creating comment node: " <> DOM.toJSString t
311+ n <- liftJSM $ createComment doc t -- not in hydration mode, create as usual
312+ append $ toNode n
313+ pure n
314+ True -> do
315+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
316+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
317+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
318+ Nothing -> do
319+ liftIO $ print $ "No node found, building comment node: " <> DOM.toJSString t
320+ tn <- liftJSM $ createComment doc t
321+ append $ toNode tn -- we can append because there's no node at this index (we have exhausted all previous nodes)
322+ pure tn
323+ Just node -> DOM.castTo DOM.Comment node >>= \case
324+ Nothing -> do
325+ liftIO $ putStrLn $ "Not a comment node, skipping"
326+ go (Just node)
327+ Just tn -> do
328+ liftIO $ print $ "Using existing comment node: instead of building " <> DOM.toJSString t
329+ pure tn
330+ n <- go lastHydrationNode
331+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode n)
332+ pure n
267333
268334-- | s and e must both be children of the same node and s must precede e;
269335-- all nodes between s and e will be removed, but s and e will not be removed
@@ -367,16 +433,45 @@ wrap e cfg = do
367433makeElement :: 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)
368434makeElement elementTag cfg child = do
369435 doc <- askDocument
370− e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
371− Nothing -> createElement doc elementTag
372− Just ens -> createElementNS doc (Just ens) elementTag
373− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
374− Nothing -> lift $ setAttribute e n v
375− Just ans -> lift $ setAttributeNS e (Just ans) n v
376− result <- flip localEnv child $ \env -> env
377− { _immediateDomBuilderEnv_parent = toNode e
378− }
379− append $ toNode e
436+ parent <- askParent
437+ let buildElement = do
438+ e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
439+ Nothing -> createElement doc elementTag
440+ Just ens -> createElementNS doc (Just ens) elementTag
441+ ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
442+ Nothing -> lift $ setAttribute e n v
443+ Just ans -> lift $ setAttributeNS e (Just ans) n v
444+ pure e
445+ e <- getHydrationMode >>= \case
446+ False -> do
447+ liftIO $ print $ "Not in hydration mode, creating " <> elementTag
448+ e <- buildElement -- not in hydration mode, create as usual
449+ append $ toNode e
450+ pure e
451+ True -> do
452+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
453+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
454+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
455+ Nothing -> do
456+ liftIO $ print $ "No node found, building element: " <> elementTag
457+ e <- buildElement
458+ append $ toNode e -- we can append because there's no node at this index (we have exhausted all previous nodes)
459+ pure e
460+ Just node -> DOM.castTo DOM.Element node >>= \case
461+ Nothing -> do
462+ liftIO $ putStrLn $ "Not an element, skipping"
463+ go (Just node) -- TODO maybe check for SSR attribute?
464+ Just e -> do
465+ tn <- Element.getTagName e
466+ liftIO $ print $ "Using existing element: " <> tn <> " instead of building " <> elementTag
467+ pure e
468+ e <- go lastHydrationNode
469+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode e)
470+ pure e
471+
472+ -- TODO: prerender needs completely replacing
473+ childNode <- liftIO $ newIORef Nothing
474+ result <- localEnv (\env -> env { _immediateDomBuilderEnv_parent = toNode e, _immediateDomBuilderEnv_hydrationNode = childNode }) child
380475 wrapped <- wrap e $ extractRawElementConfig cfg
381476 return ((wrapped, result), e)
382477
@@ -625,11 +720,62 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
625720 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
626721 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
627722
723+localNoHydration :: MonadIO m => ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a
724+localNoHydration m = do
725+ h <- liftIO $ newIORef False
726+ localEnv (\env -> env { _immediateDomBuilderEnv_hydrating = h }) m
727+
728+skipToCommentId :: (MonadJSM m, IsNode a) => Text -> ImmediateDomBuilderT t m a -> (a -> Maybe DOM.Node -> ImmediateDomBuilderT t m ()) -> ImmediateDomBuilderT t m (a, Text)
729+skipToCommentId prefix buildElement replaceOrCreate = do
730+ doc <- askDocument
731+ parent <- askParent
732+ lastHydrationNodeRef <- ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_hydrationNode
733+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
734+ let go mLastNode = maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
735+ Nothing -> do
736+ liftIO $ print $ "No node found, building comment"
737+ a <- buildElement
738+ replaceOrCreate a Nothing
739+ pure (a, "")
740+ Just node -> DOM.castTo DOM.Comment node >>= \case
741+ Just comment -> do
742+ commentText <- Node.getTextContentUnchecked comment
743+ case T.stripPrefix prefix commentText of
744+ Just key -> do
745+ new <- buildElement
746+ replaceOrCreate new (Just node)
747+ pure (new, key)
748+ Nothing -> do
749+ liftIO $ putStrLn $ "Not a comment, skipping"
750+ go (Just node)
751+ Nothing -> do
752+ liftIO $ putStrLn $ "Not a comment, skipping"
753+ go (Just node)
754+ (a, key) <- go lastHydrationNode
755+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode a)
756+ pure (a, key)
757+
758+skipToReplaceStart :: MonadJSM m => ImmediateDomBuilderT t m (DOM.Text, Text)
759+skipToReplaceStart = do
760+ doc <- askDocument
761+ parent <- askParent
762+ skipToCommentId "replace-start" (liftJSM $ createTextNode doc ("" :: Text)) $ \new -> \case
763+ Nothing -> void $ append $ toNode new
764+ Just node -> void $ liftJSM $ Node.replaceChild parent new node
765+
766+skipToReplaceEnd :: MonadJSM m => Text -> ImmediateDomBuilderT t m DOM.Text
767+skipToReplaceEnd key = do
768+ doc <- askDocument
769+ parent <- askParent
770+ fmap fst $ skipToCommentId "replace-end" (liftJSM $ createTextNode doc ("" :: Text)) $ \new -> \case
771+ Nothing -> void $ append $ toNode new
772+ Just node -> void $ liftJSM $ Node.replaceChild parent new node
773+
628774instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where
629775 {-# INLINABLE runWithReplace #-}
630776 runWithReplace a0 a' = do
631777 initialEnv <- ImmediateDomBuilderT ask
632− before <- textNodeInternal ("" :: Text)
778+ (before, beforeKey) <- skipToReplaceStart
633779 let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
634780 haveEverBeenReady <- liftIO $ newIORef False
635781 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
@@ -644,14 +790,17 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
644790 when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
645791 -- We draw 'after' in this roundabout way to avoid using MonadFix
646792 doc <- askDocument
647− after <- createTextNode doc ("" :: Text)
793+ after <- skipToReplaceEnd beforeKey
648794 let drawInitialChild = do
649795 unreadyChildren <- liftIO $ newIORef 0
650− let f = do
651− result <- a0
652− append $ toNode after
653− return result
654− result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv
796+-- let f = do
797+-- result <- a0
798+-- append $ toNode after
799+-- Node.getNextSibling (toNode result) >>= \case
800+-- Nothing -> append (toNode after)
801+-- Just next -> insertBefore (toNode after) next
802+-- return result
803+ result <- runReaderT (unImmediateDomBuilderT a0) initialEnv
655804 { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
656805 , _immediateDomBuilderEnv_commitAction = myCommitAction
657806 }
@@ -670,11 +819,12 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
670819 insertBefore df after
671820 liftIO $ writeIORef currentCohort cohortId
672821 myCommitAction
673− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
674− { _immediateDomBuilderEnv_parent = toNode df
675− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
676− , _immediateDomBuilderEnv_commitAction = commitAction
677− }
822+ let env = initialEnv
823+ { _immediateDomBuilderEnv_parent = toNode df
824+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
825+ , _immediateDomBuilderEnv_commitAction = commitAction
826+ }
827+ result <- runReaderT (unImmediateDomBuilderT child) env
678828 uc <- liftIO $ readIORef unreadyChildren
679829 let commitActionToRunNow = if uc == 0
680830 then Just commitAction
@@ -1027,6 +1177,11 @@ mkHasFocus e = do
10271177 , True <$ Reflex.select (_element_events e) (WrapArg Focus)
10281178 ]
10291179
1180+insertAfter :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1181+insertAfter new existing = do
1182+ p <- getParentNodeUnchecked existing
1183+ Node.getNextSibling existing >>= DOM.insertBefore_ p new
1184+
10301185insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
10311186insertBefore new existing = do
10321187 p <- getParentNodeUnchecked existing