@@ -46,46 +46,11 @@ module Reflex.Dom.Builder.Hydration
4646 , askEvents
4747 , append
4848 , textNodeInternal
49− , deleteBetweenExclusive
50− , extractBetweenExclusive
51− , deleteBetweenInclusive
52− , extractBetweenInclusive
53− , deleteUpTo
54− , extractUpTo
5549 , SupportsHydrationDomBuilder
56− , collectUpTo
57− , collectUpToGivenParent
5850 , EventFilterTriggerRef (..)
5951 , wrap
6052 , makeElement
61− , GhcjsDomHandler (..)
62− , GhcjsDomHandler1 (..)
63− , GhcjsDomEvent (..)
64− , GhcjsEventFilter (..)
65− , Pair1 (..)
66− , Maybe1 (..)
67− , GhcjsEventSpec (..)
68− , HasDocument (..)
69− , ghcjsEventSpec_filters
70− , ghcjsEventSpec_handler
71− , GhcjsEventHandler (..)
72−#ifndef USE_TEMPLATE_HASKELL
73− , phantom2
74−#endif
7553 , drawChildUpdate
76− , ChildReadyState (..)
77− , ChildReadyStateInt (..)
78− , mkHasFocus
79− , insertBefore
80− , EventType
81− , defaultDomEventHandler
82− , defaultDomWindowEventHandler
83− , withIsEvent
84− , showEventName
85− , elementOnEventName
86− , windowOnEventName
87− , wrapDomEvent
88− , subscribeDomEvent
8954 -- * Internal
9055 , traverseDMapWithKeyWithAdjust'
9156 , hoistTraverseWithKeyWithAdjust
@@ -98,7 +63,7 @@ import Reflex.Adjustable.Class
9863import Reflex.Class as Reflex
9964import qualified Reflex.Spider.Internal as Spider
10065import Reflex.Dom.Builder.Class
101−import Reflex.Dom.Builder.Immediate hiding (askParent, append, extractBetweenExclusive, extractUpTo, collectUpToGivenParent, askEvents, wrap, makeElement, textNodeInternal, commentNodeInternal, wrapDomEvent, mkHasFocus, insertBefore, deleteBetweenExclusive, traverseIntMapWithKeyWithAdjust', traverseDMapWithKeyWithAdjust', hoistTraverseWithKeyWithAdjust, deleteUpTo, collectUpTo, hoistTraverseIntMapWithKeyWithAdjust, drawChildUpdate, subscribeDomEvent)
66+import Reflex.Dom.Builder.Immediate hiding (askEvents, askParent, append, wrap, makeElement, textNodeInternal, commentNodeInternal, traverseIntMapWithKeyWithAdjust', traverseDMapWithKeyWithAdjust', hoistTraverseWithKeyWithAdjust, hoistTraverseIntMapWithKeyWithAdjust, drawChildUpdate)
10267import Reflex.Dynamic
10368import Reflex.Host.Class
10469import qualified Reflex.Patch.DMap as PatchDMap
@@ -232,8 +197,6 @@ data HydrationDomBuilderEnv = HydrationDomBuilderEnv
232197 -- ^ Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
233198 , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode)
234199 -- ^ In hydration mode? Should be switched to `HydrationMode_Immediate` after hydration is finished
235− , _hydrationDomBuilderEnv_prerenderDepth :: {-# UNPACK #-} !(IORef Word)
236− -- ^ TODO
237200 }
238201
239202data DOM t m
@@ -264,7 +227,6 @@ runDOMTree = \case
264227
265228-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events
266229-- State contains reference to the previous node sibling, if any.
267−-- TODO: This probably doesn't need to be a full transformer of `m`, seems like we only need (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m)
268230newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT (Maybe Node) (ReaderT Node (DomRenderHookT t m)) a }
269231 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
270232#if MIN_VERSION_base(4,9,1)
@@ -273,13 +235,19 @@ newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT
273235 )
274236
275237localRunner :: Monad m => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a
276−localRunner (HydrationRunnerT m) prev = HydrationRunnerT . lift . lift . runReaderT (evalStateT m prev)
238+localRunner (HydrationRunnerT m) prev parent = HydrationRunnerT . lift $ local (\_ -> parent) (evalStateT m prev)
277239
278240runHydrationRunnerT
279241 :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
280242 => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
281243runHydrationRunnerT (HydrationRunnerT m) prev parent = runDomRenderHookT (runReaderT (evalStateT m prev) parent)
282244
245+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
246+ {-# INLINABLE newEventWithTrigger #-}
247+ newEventWithTrigger = lift . newEventWithTrigger
248+ {-# INLINABLE newFanEventWithTrigger #-}
249+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
250+
283251instance MonadTrans (HydrationRunnerT t) where
284252 lift = HydrationRunnerT . lift . lift . lift
285253
@@ -288,9 +256,6 @@ hydrateDOM dom = getHydrationMode >>= \case
288256 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify (dom :)
289257 HydrationMode_Immediate -> pure ()
290258
291−-- TODO probably can separate these two monads entirely, they have grown apart
292−-- over the course of refactoring
293−
294259-- | A monad for DomBuilder which just gets the results of children and pushes
295260-- work into an action that is delayed until after postBuild (to match the
296261-- static builder). The action runs in 'HydrationRunnerT', which performs the
@@ -404,10 +369,6 @@ getPreviousNode = HydrationRunnerT get
404369setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()
405370setPreviousNode = HydrationRunnerT . put
406371
407−{-# INLINABLE getPrerenderDepth #-}
408−getPrerenderDepth :: MonadIO m => HydrationDomBuilderT t m Word
409−getPrerenderDepth = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_prerenderDepth)
410−
411372{-# INLINABLE getParent #-}
412373getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node
413374getParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)
@@ -428,7 +389,6 @@ getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationD
428389askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
429390askEvents = HydrationDomBuilderT . lift . lift . DomRenderHookT . lift $ TriggerEventT.askEvents
430391
431−
432392{-# INLINABLE makeNodeInternal #-}
433393makeNodeInternal
434394 :: forall node t m. (MonadJSM m, IsNode node, Typeable node)
@@ -469,74 +429,8 @@ hydrateNode check constructor = do
469429 setPreviousNode $ Just $ toNode n
470430 return n
471431
472−
473−-- | s and e must both be children of the same node and s must precede e;
474−-- all nodes between s and e will be removed, but s and e will not be removed
475−deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
476−deleteBetweenExclusive s e = do
477− df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
478− extractBetweenExclusive df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
479−
480−-- | s and e must both be children of the same node and s must precede e; all
481−-- nodes between s and e will be moved into the given DocumentFragment, but s
482−-- and e will not be moved
483−extractBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
484−extractBetweenExclusive df s e = liftJSM $ do
485− f <- eval ("(function(df,s,e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })" :: Text)
486− void $ call f f (df, s, e)
487−
488−-- | s and e must both be children of the same node and s must precede e;
489−-- all nodes between s and e will be removed, including s and e
490−deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
491−deleteBetweenInclusive s e = do
492− df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
493− extractBetweenInclusive df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
494−
495−-- | s and e must both be children of the same node and s must precede e; all
496−-- nodes between s and e will be moved into the given DocumentFragment,
497−-- including s and e
498−extractBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
499−extractBetweenInclusive df s e = liftJSM $ do
500− f <- eval ("(function(df,s,e) { var x = s; var next; for(;;) { next = x['nextSibling']; df['appendChild'](x); if(e===x) { break; }; x = next; } })" :: Text)
501− void $ call f f (df, s, e)
502−
503−-- | s and e must both be children of the same node and s must precede e;
504−-- s and all nodes between s and e will be removed, but e will not be removed
505−{-# INLINABLE deleteUpTo #-}
506−deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
507−deleteUpTo s e = do
508− df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
509− extractUpTo df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
510−
511−extractUpTo :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
512−#ifdef ghcjs_HOST_OS
513−--NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2017-09-04)
514−foreign import javascript unsafe
515− "(function() { var x = $2; while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })()"
516− extractUpTo_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO ()
517−extractUpTo df s e = liftJSM $ extractUpTo_ df (toNode s) (toNode e)
518−#else
519−extractUpTo df s e = liftJSM $ do
520− f <- eval ("(function(df,s,e){ var x = s; var y; for(;;) { y = x['nextSibling']; df['appendChild'](x); if(e===y) { break; } x = y; } })" :: Text)
521− void $ call f f (df, s, e)
522−#endif
523−
524432type 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))
525433
526−{-# INLINABLE collectUpTo #-}
527−collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
528−collectUpTo s e = do
529− currentParent <- getParentNodeUnchecked e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
530− collectUpToGivenParent currentParent s e
531−
532−{-# INLINABLE collectUpToGivenParent #-}
533−collectUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m DOM.DocumentFragment
534−collectUpToGivenParent currentParent s e = do
535− doc <- getOwnerDocumentUnchecked currentParent
536− df <- createDocumentFragment doc
537− extractUpTo df s e
538− return df
539−
540434-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself
541435{-# INLINABLE wrap #-}
542436wrap
@@ -626,15 +520,8 @@ makeElement elementTag cfg child = do
626520 let env' = env { _hydrationDomBuilderEnv_parent = parent}
627521 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') []
628522 wrapResult <- liftIO newEmptyMVar
629− prerenderDepth <- getPrerenderDepth
630523 let activateElement = do
631− e <- case prerenderDepth of
632− 0 -> hydrateNode hasSSRAttribute DOM.Element
633− _ -> do
634− e <- buildElement
635− maybe (askParent >>= \p -> Node.appendChild_ p e) (insertAfter e) =<< getPreviousNode
636− setPreviousNode $ Just $ toNode e
637− pure e
524+ e <- hydrateNode hasSSRAttribute DOM.Element
638525 -- Update the parent node used by the children
639526 liftIO $ writeIORef parent $ toNode e
640527 -- Setup events, store the result so we can wait on it later
@@ -674,16 +561,9 @@ textNodeInternal !t mSetContents = getHydrationMode >>= \case
674561 pure n
675562 HydrationMode_Hydrating -> do
676563 doc <- askDocument
677− prerenderDepth <- getPrerenderDepth
678564 let activateText = do
679565 liftIO $ putStrLn $ "Action: Text: " <> show (DOM.toJSString t)
680− n <- case prerenderDepth of
681− 0 -> hydrateNode (const $ pure True) DOM.Text
682− _ -> do
683− tn <- createTextNode doc t
684− maybe (askParent >>= \p -> Node.appendChild_ p tn) (insertAfter tn) =<< getPreviousNode
685− setPreviousNode $ Just $ toNode tn
686− pure tn
566+ n <- hydrateNode (const $ pure True) DOM.Text
687567 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
688568 hydrateDOM $ DOM_Node activateText
689569 pure $ error "textNodeInternal: DOM.Text"
@@ -697,16 +577,9 @@ commentNodeInternal !t mSetContents = getHydrationMode >>= \case
697577 pure n
698578 HydrationMode_Hydrating -> do
699579 doc <- askDocument
700− prerenderDepth <- getPrerenderDepth
701580 let activateComment = do
702581 liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)
703− n <- case prerenderDepth of
704− 0 -> hydrateNode (const $ pure True) DOM.Comment
705− _ -> do
706− tn <- createComment doc t
707− maybe (askParent >>= \p -> Node.appendChild_ p tn) (insertAfter tn) =<< getPreviousNode
708− setPreviousNode $ Just $ toNode tn
709− pure tn
582+ n <- hydrateNode (const $ pure True) DOM.Comment
710583 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
711584 hydrateDOM $ DOM_Node activateComment
712585 pure $ error "commentNodeInternal: DOM.Comment"
@@ -1446,25 +1319,12 @@ drawChildUpdateInt initialEnv markReady child = do
14461319 , placeholder, childReadyState, result
14471320 )
14481321
1449−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
1450−mkHasFocus e = do
1451− let initialFocus = False --TODO: Actually get the initial focus of the element
1452− holdDyn initialFocus $ leftmost
1453− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1454− , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1455− ]
1456−
14571322insertAfter :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
14581323insertAfter new existing = do
14591324 liftIO $ putStrLn "insertAfter"
14601325 p <- getParentNodeUnchecked existing
14611326 Node.getNextSibling existing >>= DOM.insertBefore_ p new
14621327
1463−insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1464−insertBefore new existing = do
1465− p <- getParentNodeUnchecked existing
1466− 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
1467−
14681328instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where
14691329 type Performable (HydrationDomBuilderT t m) = Performable m
14701330 {-# INLINABLE performEvent_ #-}
@@ -1482,12 +1342,6 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDo
14821342 {-# INLINABLE newFanEventWithTrigger #-}
14831343 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
14841344
1485−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where
1486− {-# INLINABLE newEventWithTrigger #-}
1487− newEventWithTrigger = lift . newEventWithTrigger
1488− {-# INLINABLE newFanEventWithTrigger #-}
1489− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
1490−
14911345instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT t m) where
14921346 {-# INLINABLE newTriggerEvent #-}
14931347 newTriggerEvent = HydrationDomBuilderT . lift . lift $ newTriggerEvent
@@ -1525,23 +1379,6 @@ instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT t m) where
15251379 type JSX (HydrationDomBuilderT t m) = JSX m
15261380 liftJS = lift . liftJS
15271381
1528−{-# INLINABLE wrapDomEvent #-}
1529−wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)
1530−wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
1531−
1532−{-# INLINABLE subscribeDomEvent #-}
1533−subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
1534− -> EventM e event (Maybe a)
1535− -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
1536− -> EventTrigger t a
1537− -> JSM (JSM ())
1538−subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
1539− mv <- getValue
1540− forM_ mv $ \v -> liftIO $ do
1541− --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
1542− etr <- newIORef $ Just et
1543− writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]
1544−
15451382instance MonadSample t m => MonadSample t (HydrationDomBuilderT t m) where
15461383 {-# INLINABLE sample #-}
15471384 sample = lift . sample