@@ -59,6 +59,7 @@ import Control.Monad.Primitive
5959import Control.Monad.Reader
6060import Control.Monad.Ref
6161import Control.Monad.State.Strict
62+import Data.Default
6263import Data.Dependent.Map (DMap)
6364import Data.Dependent.Sum
6465import Data.FastMutableIntMap (PatchIntMap (..))
@@ -188,11 +189,11 @@ addHydrationStepWithSetup setup f = getHydrationMode >>= \case
188189 HydrationDomBuilderT $ modify' (>> f s)
189190
190191-- | Add a hydration step
191−addHydrationStep :: (MonadIO m, Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m)) => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()
192+addHydrationStep
193+ :: (MonadIO m, Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))
194+ => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()
192195addHydrationStep m = getHydrationMode >>= \case
193− HydrationMode_Immediate -> do
194− events <- askEvents
195− lift $ runHydrationRunnerT m Nothing undefined events
196+ HydrationMode_Immediate -> lift . runHydrationRunnerT m Nothing undefined =<< askEvents
196197 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify' (>> m)
197198
198199-- | A monad for DomBuilder which just gets the results of children and pushes
@@ -387,6 +388,35 @@ wrap events e cfg = do
387388 return $ en :=> EventFilterTriggerRef triggerRef
388389 return eventTriggerRefs
389390
391+triggerBody
392+ :: forall er t x. DOM.JSContextRef
393+ -> ElementConfig er t GhcjsDomSpace
394+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
395+ -> DMap EventName (EventFilterTriggerRef t er)
396+ -> DOM.Element
397+ -> WrapArg er EventName x
398+ -> EventTrigger t x
399+ -> IO (IO ())
400+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
401+ Just (EventFilterTriggerRef r) -> do
402+ writeIORef r $ Just t
403+ return $ do
404+ writeIORef r Nothing
405+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
406+ evt <- DOM.event
407+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
408+ case mv of
409+ Nothing -> return ()
410+ Just v -> liftIO $ do
411+ --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
412+ ref <- newIORef $ Just t
413+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
414+ where
415+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
416+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
417+ handler :: GhcjsEventHandler er
418+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg
419+
390420{-# INLINABLE makeElement #-}
391421makeElement
392422 :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m)
@@ -413,25 +443,6 @@ makeElement elementTag cfg child = do
413443 hasSSRAttribute e = case cfg ^. namespace of
414444 Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr
415445 Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr
416− -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't
417− -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
418− handler :: GhcjsEventHandler er
419− !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg
420− triggerBody :: DMap EventName (EventFilterTriggerRef t er) -> DOM.Element -> WrapArg er EventName x -> EventTrigger t x -> IO (IO ())
421− triggerBody eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of
422− Just (EventFilterTriggerRef r) -> do
423− writeIORef r $ Just t
424− return $ do
425− writeIORef r Nothing
426− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
427− evt <- DOM.event
428− mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)
429− case mv of
430− Nothing -> return ()
431− Just v -> liftIO $ do
432− --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
433− ref <- newIORef $ Just t
434− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
435446 getHydrationMode >>= \case
436447 HydrationMode_Immediate -> do
437448 e <- makeNodeInternal buildElement
@@ -439,7 +450,7 @@ makeElement elementTag cfg child = do
439450 -- Run the child builder with updated parent and previous sibling references
440451 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = p }) child
441452 eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg
442− es <- newFanEventWithTrigger $ triggerBody eventTriggerRefs e
453+ es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e
443454 e' <- liftIO $ newIORef e
444455 return ((Element es e, result), e')
445456 HydrationMode_Hydrating -> do
@@ -469,7 +480,7 @@ makeElement elementTag cfg child = do
469480 (e, eventTriggerRefs) <- readMVar wrapResult
470481 bracketOnError
471482 -- Run the setup, acquiring the cleanup action
472− (triggerBody eventTriggerRefs e (WrapArg en) t)
483+ (triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t)
473484 -- Run the cleanup, if we have it - but only when an exception is
474485 -- raised (we might get killed between acquiring the cleanup action
475486 -- from 'triggerBody' and putting it in the MVar)
@@ -768,33 +779,73 @@ instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT
768779
769780 {-# INLINABLE selectElement #-}
770781 selectElement cfg child = do
771− ((e, result), _domElement') <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
772− let domElement = undefined :: DOM.HTMLSelectElement
773− let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
774− Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
775− v0 <- Select.getValue domSelectElement
776− let getMyValue = Select.getValue domSelectElement
777− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
778− valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
779− Nothing -> return never
780− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
781− Select.setValue domSelectElement v'
782− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
782+ ((e, result), domElementRef) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
783+
784+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent
785+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent
786+
787+ (focusChange, triggerFocusChange) <- newTriggerEvent
788+
789+ doc <- askDocument
790+
791+ -- Expected initial value from config
792+ let v0 = _selectElementConfig_initialValue cfg
793+
794+ addHydrationStep $ do
795+ domElement <- liftIO $ readIORef domElementRef
796+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
797+ getValue = Select.getValue domSelectElement
798+
799+ -- The browser might have messed with the value, or the user could have
800+ -- altered it before activation, so we set it if it isn't what we expect
801+ liftJSM getValue >>= \v0' -> do
802+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'
803+
804+ -- Watch for user interaction and trigger event accordingly
805+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)
806+
807+ for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->
808+ requestDomAction_ $ ffor eSetValue $ \v' -> do
809+ Select.setValue domSelectElement v'
810+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow
811+ liftIO $ triggerChangeBySetValue v
812+
813+ let focusChange' = leftmost
814+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
815+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
816+ ]
817+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc
818+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'
819+
820+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover
821+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange
822+
783823 v <- holdDyn v0 $ leftmost
784824 [ valueChangedBySetValue
785825 , valueChangedByUI
786826 ]
787− hasFocus <- mkHasFocus e
788− let wrapped = SelectElement
789− { _selectElement_value = v
790− , _selectElement_change = valueChangedByUI
791− , _selectElement_hasFocus = hasFocus
792− , _selectElement_element = e
793− , _selectElement_raw = domSelectElement
827+
828+ return $ flip (,) result $ SelectElement
829+ { _selectElement_value = v
830+ , _selectElement_change = valueChangedByUI
831+ , _selectElement_hasFocus = hasFocus
832+ , _selectElement_element = e
833+ , _selectElement_raw = undefined -- TODO domSelectElement
834+ }
835+
836+ placeRawElement e = getHydrationMode >>= \case
837+ HydrationMode_Immediate -> append $ toNode e
838+ HydrationMode_Hydrating -> addHydrationStep $ insertAfterPreviousNode e
839+ wrapRawElement e rawCfg = do
840+ ctx <- askJSM
841+ events <- askEvents
842+ let cfg = (def :: ElementConfig EventResult t GhcjsDomSpace)
843+ { _elementConfig_modifyAttributes = _rawElementConfig_modifyAttributes rawCfg
844+ , _elementConfig_eventSpec = _rawElementConfig_eventSpec rawCfg
794845 }
795− return (wrapped, result)
796− placeRawElement _ = return () -- append . toNode
797− wrapRawElement e _ = return $ Element (EventSelector $ const never) e -- TODO
846+ eventTriggerRefs <- wrap events e rawCfg
847+ es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e
848+ return $ Element es e
798849
799850data FragmentState
800851 = FragmentState_Unmounted
@@ -842,7 +893,7 @@ instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjus
842893 traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m
843894 traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m
844895
845−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ref m ~ IORef, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadRef m) => Adjustable t (HydrationDomBuilderT t m) where
896+instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (HydrationDomBuilderT t m) where
846897 {-# INLINABLE runWithReplace #-}
847898 runWithReplace a0 a' = do
848899 initialEnv <- HydrationDomBuilderT ask
@@ -932,15 +983,15 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
932983 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
933984 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
934985 traverseDMapWithKeyWithAdjustWithMove = do
935− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
936− let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
986+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseDMapChild t m k) v')) old = do
987+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseDMapChild t m k) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
937988 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
938− PatchDMapWithMove.From_Insert (Compose (_, _, _, sRef, _)) -> do
939− readIORef sRef >>= \case
989+ PatchDMapWithMove.From_Insert (Compose (TraverseDMapChild (Right myTypeImmediate) _)) -> do
990+ readIORef (_traverseDMapChildImmediate_childReadyState myTypeImmediate) >>= \case
940991 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
941992 ChildReadyState_Unready _ -> do
942− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
943− return $ PatchDMapWithMove.From_Insert $ Constant sRef
993+ writeIORef (_traverseDMapChildImmediate_childReadyState myTypeImmediate) $ ChildReadyState_Unready $ Just $ Some.This k
994+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseDMapChildImmediate_childReadyState myTypeImmediate)
944995 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
945996 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
946997 deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
@@ -950,11 +1001,10 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
9501001 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
9511002 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
9521003 return $ applyAlways p' old
953− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
1004+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseDMapChild t m k) v')) -> do
9541005 let p = unPatchDMapWithMove p_
9551006 phsBefore <- liftIO $ readIORef placeholders
956− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
957− let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
1007+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseDMapChild t m k) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
9581008 collectIfMoved k e = do
9591009 let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
9601010 nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
@@ -965,13 +1015,14 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
9651015 True -> do
9661016 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
9671017 collected <- DMap.traverseWithKey collectIfMoved p
968− let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, _, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
969− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
1018+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (_traverseDMapChildImmediate_placeholder . error "FIXME" . _traverseDMapChild_mode . getCompose) p_) phsBefore --TODO: Don't recompute this
1019+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseDMapChild t m k) v') a -> JSM (Constant () a)
9701020 placeFragment k e = do
9711021 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
9721022 case PatchDMapWithMove._nodeInfo_from e of
973− PatchDMapWithMove.From_Insert (Compose (_, df, _, _, _)) -> do
974− df `insertBefore` nextPlaceholder
1023+ PatchDMapWithMove.From_Insert (Compose (TraverseDMapChild x _)) -> case x of
1024+ Left _ -> pure ()
1025+ Right immediate -> _traverseDMapChildImmediate_fragment immediate `insertBefore` nextPlaceholder
9751026 PatchDMapWithMove.From_Delete -> do
9761027 return ()
9771028 PatchDMapWithMove.From_Move fromKey -> do
@@ -983,40 +1034,54 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
9831034
9841035{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
9851036traverseDMapWithKeyWithAdjust'
986− :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k)
1037+ :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k)
9871038 => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
9881039 -> DMap k v
9891040 -> Event t (PatchDMap k v)
9901041 -> HydrationDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
9911042traverseDMapWithKeyWithAdjust' = do
992− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
993− let new :: forall a. k a -> ComposeMaybe (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
1043+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseDMapChild t m k) v')) old = do
1044+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseDMapChild t m k) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
9941045 new k (ComposeMaybe m) = ComposeMaybe <$> case m of
9951046 Nothing -> return Nothing
996− Just (Compose (_, _, _, sRef, _)) -> do
997− readIORef sRef >>= \case
1047+ Just (Compose (TraverseDMapChild (Left hydration) _)) -> pure Nothing
1048+ Just (Compose (TraverseDMapChild (Right immediate) _)) -> do
1049+ readIORef (_traverseDMapChildImmediate_childReadyState immediate) >>= \case
9981050 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
9991051 ChildReadyState_Unready _ -> do
1000− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1001− return $ Just $ Constant sRef
1052+ writeIORef (_traverseDMapChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some.This k
1053+ return $ Just $ Constant (_traverseDMapChildImmediate_childReadyState immediate)
10021054 delete _ (Constant sRef) = do
10031055 writeIORef sRef $ ChildReadyState_Unready Nothing
10041056 return $ Constant ()
10051057 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
10061058 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
10071059 return $ applyAlways p' old
1008− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
1060+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do
10091061 phs <- liftIO $ readIORef placeholders
1010− forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
1011− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
1062+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do
10121063 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
1013− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
1014− forM_ mv $ \(Compose (_, df, _, _, _)) -> df `insertBefore` nextPlaceholder
1015− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, _, ph, _, _)) -> ph) $ PatchDMap p) phs
1064+ -- Delete old node
1065+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> do
1066+ thisPlaceholder `deleteUpTo` nextPlaceholder
1067+ -- Insert new node
1068+ forM_ mv $ \(Compose (TraverseDMapChild e _)) -> case e of
1069+ Left _hydration -> pure ()
1070+ Right immediate -> do
1071+ _traverseDMapChildImmediate_fragment immediate `insertBefore` nextPlaceholder
1072+ let weakened :: PatchMap (Some.Some k) (Either (TraverseDMapChildHydration t m) (TraverseDMapChildImmediate k))
1073+ weakened = weakenPatchDMapWith (_traverseDMapChild_mode . getCompose) $ PatchDMap patch
1074+ filtered :: PatchMap (Some.Some k) DOM.Text
1075+ filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case
1076+ Nothing -> Just Nothing -- deletion
1077+ Just (Left _) -> Nothing
1078+ Just (Right immediate) -> Just $ Just $ _traverseDMapChildImmediate_placeholder immediate
1079+ a = apply filtered phs
1080+ liftIO $ writeIORef placeholders $! fromMaybe phs a
10161081
10171082{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
10181083traverseIntMapWithKeyWithAdjust'
1019− :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m)
1084+ :: forall t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m)
10201085 => (IntMap.Key -> v -> HydrationDomBuilderT t m v')
10211086 -> IntMap v
10221087 -> Event t (PatchIntMap v)
@@ -1050,14 +1115,13 @@ traverseIntMapWithKeyWithAdjust' = do
10501115{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
10511116hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
10521117 ( Adjustable t m
1053− , MonadIO m
1118+ , MonadHold t m
10541119 , MonadJSM m
10551120 , MonadFix m
10561121 , PrimMonad m
10571122 , Monoid (p (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
10581123 , Functor p
10591124 , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())
1060− , MonadHold t m
10611125 , Patch (p (HydrationRunnerT t m ()))
10621126 )
10631127 => ( (IntMap.Key -> v -> DomRenderHookT t m (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
@@ -1072,7 +1136,6 @@ hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
10721136 -> Event t (p v)
10731137 -> HydrationDomBuilderT t m (IntMap v', Event t (p v'))
10741138hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
1075− (_hydrateStart, _, key) <- skipToReplaceStart
10761139 initialEnv <- HydrationDomBuilderT ask
10771140 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
10781141 pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (HydrationRunnerT t m (), DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
@@ -1139,7 +1202,6 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
11391202 getHydrationMode >>= \case
11401203 HydrationMode_Immediate -> void $ IntMap.traverseWithKey (\_ (_, df, _, _, _) -> void $ append $ toNode df) children0
11411204 _ -> pure ()
1142− (_hydrateEnd, _lastPlaceholderRef) <- skipToReplaceEnd key
11431205 requestDomAction_ $ ffor children' $ \p -> do
11441206 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
11451207 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1156,6 +1218,24 @@ insertAfterPreviousNode node = do
11561218 Node.insertBefore_ parent node nextNode
11571219 setPreviousNode $ Just $ toNode node
11581220
1221+data TraverseDMapChildImmediate k = TraverseDMapChildImmediate
1222+ { _traverseDMapChildImmediate_fragment :: DOM.DocumentFragment
1223+ -- ^ Child is appended to this fragment
1224+ , _traverseDMapChildImmediate_placeholder :: DOM.Text
1225+ -- ^ Placeholder reference
1226+ , _traverseDMapChildImmediate_childReadyState :: IORef (ChildReadyState k)
1227+ }
1228+
1229+newtype TraverseDMapChildHydration t m = TraverseDMapChildHydration
1230+ { _traverseDMapChildHydration_delayed :: HydrationRunnerT t m DOM.Text
1231+ -- ^ Action to run at switchover, returns the placeholder
1232+ }
1233+
1234+data TraverseDMapChild t m k a = TraverseDMapChild
1235+ { _traverseDMapChild_mode :: Either (TraverseDMapChildHydration t m) (TraverseDMapChildImmediate k)
1236+ , _traverseDMapChild_result :: a
1237+ }
1238+
11591239{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
11601240hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
11611241 ( Adjustable t m
@@ -1166,35 +1246,39 @@ hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
11661246 , PrimMonad m
11671247 , MonadFix m
11681248 , Patch (p k v)
1169− , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1170− , Patch (p k (Const (HydrationRunnerT t m ())))
1171− , PatchTarget (p k (Const (HydrationRunnerT t m ()))) ~ DMap k (Const (HydrationRunnerT t m ()))
1172− , Monoid (p k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
11731249 , Patch (p k (Constant Int))
1250+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
1251+ , Patch (p k (Compose (TraverseDMapChild t m k) v'))
1252+ , PatchTarget (p k (Compose (TraverseDMapChild t m k) v')) ~ DMap k (Compose (TraverseDMapChild t m k) v')
1253+ , Monoid (p k (Compose (TraverseDMapChild t m k) v'))
11741254 )
11751255 => (forall vv vv'.
11761256 (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))
11771257 -> DMap k vv
11781258 -> Event t (p k vv)
11791259 -> DomRenderHookT t m (DMap k vv', Event t (p k vv'))
1180− ) -- ^ The base monad's traversal
1181− -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
1182− -> (p k (Compose ((,,,,) (HydrationRunnerT t m ()) 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
1183− -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM
1260+ )
1261+ -- ^ The base monad's traversal
1262+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')
1263+ -- ^ A way of mapping over the patch type
1264+ -> (p k (Compose (TraverseDMapChild t m k) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k)))))
1265+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1266+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseDMapChild t m k) v') -> JSM ())
1267+ -- ^ Apply a patch to the DOM
11841268 -> (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
11851269 -> DMap k v
11861270 -> Event t (p k v)
11871271 -> HydrationDomBuilderT t m (DMap k v', Event t (p k v'))
11881272hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
1189−-- (hydrateStart, _, key) <- skipToReplaceStart -- TODO
1273+ doc <- askDocument
11901274 initialEnv <- HydrationDomBuilderT ask
11911275 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1192− pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
1276+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose (TraverseDMapChild t m k) v')) <- liftIO $ newIORef mempty
11931277 haveEverBeenReady <- liftIO $ newIORef False
1194− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
1195− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1278+ placeholders <- liftIO $ newIORef Map.empty
1279+ lastPlaceholder <- createTextNode doc ("" :: Text)
11961280 let applyDomUpdate p = do
1197− applyDomUpdate_ placeholders lastPlaceholderRef p
1281+ applyDomUpdate_ placeholders lastPlaceholder p
11981282 markSelfReady
11991283 liftIO $ writeIORef pendingChange $! mempty
12001284 markSelfReady = do
@@ -1221,38 +1305,36 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
12211305 liftIO $ writeIORef pendingChange (newUnready, p)
12221306 when (DMap.null newUnready) $ do
12231307 applyDomUpdate p
1224− (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1225− let processChild k (Compose (_, _, _, sRef, _)) = ComposeMaybe <$> do
1226− readIORef sRef >>= \case
1227− ChildReadyState_Ready -> return Nothing
1228− ChildReadyState_Unready _ -> do
1229− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1230− return $ Just $ Constant sRef
1308+ (children0 :: DMap k (Compose (TraverseDMapChild t m k) v'), children' :: Event t (p k (Compose (TraverseDMapChild t m k) v')))
1309+ <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1310+ let processChild k (Compose (TraverseDMapChild e _)) = case e of
1311+ Left _ -> pure $ ComposeMaybe Nothing
1312+ Right immediate -> ComposeMaybe <$> do
1313+ readIORef (_traverseDMapChildImmediate_childReadyState immediate) >>= \case
1314+ ChildReadyState_Ready -> return Nothing
1315+ ChildReadyState_Unready _ -> do
1316+ writeIORef (_traverseDMapChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ Some.This k
1317+ return $ Just $ Constant (_traverseDMapChildImmediate_childReadyState immediate)
12311318 initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
12321319 liftIO $ if DMap.null initialUnready
12331320 then writeIORef haveEverBeenReady True
12341321 else do
12351322 modifyIORef' parentUnreadyChildren succ
12361323 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
1237− let result0 = DMap.map (\(Compose (_, _, _, _, v)) -> v) children0
1238− placeholders0 = weakenDMapWith (\(Compose (_, _, ph, _, _)) -> ph) children0
1239− delayed0 :: DMap k (Const (HydrationRunnerT t m ()))
1240− delayed0 = DMap.map (\(Compose (delayed, _, _, _, _)) -> Const delayed) children0
1241− delayed' :: Event t (p k (Const (HydrationRunnerT t m ())))
1242− delayed' = ffor children' $ mapPatch $ \(Compose (d, _, _, _, _)) -> Const d
1243− result' = ffor children' $ mapPatch $ \(Compose (_, _, _, _, r)) -> r
1244− doc <- askDocument
1245− let setFinalPlaceholder = do
1246− ph <- createTextNode doc ("" :: Text)
1247− insertAfterPreviousNode ph
1248− liftIO $ writeIORef lastPlaceholderRef ph
1249− addHydrationStepWithSetup (accumMaybeB (flip apply) delayed0 delayed') $ \delayed -> do
1250− _ <- join $ sample (traverse (\(_ :=> Const d) -> d) . DMap.toList <$> delayed)
1251− setFinalPlaceholder
1252− liftIO $ writeIORef placeholders $! placeholders0
12531324 getHydrationMode >>= \case
1254− HydrationMode_Immediate -> void $ DMap.traverseWithKey (\_ (Compose (_, df, _, _, _)) -> Constant () <$ append (toNode df)) children0
1255− _ -> pure ()
1325+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do
1326+ dm :: DMap k (Compose (TraverseDMapChild t m k) v') <- sample $ currentIncremental children
1327+ phs <- traverse id $ weakenDMapWith (either _traverseDMapChildHydration_delayed (pure . _traverseDMapChildImmediate_placeholder) . _traverseDMapChild_mode . getCompose) dm
1328+ liftIO $ writeIORef placeholders $! phs
1329+ insertAfterPreviousNode lastPlaceholder
1330+ HydrationMode_Immediate -> do
1331+ let activate i = do
1332+ append $ toNode $ _traverseDMapChildImmediate_fragment i
1333+ pure $ _traverseDMapChildImmediate_placeholder i
1334+ phs <- traverse id $ weakenDMapWith ((either (error "delayed") activate) . _traverseDMapChild_mode . getCompose) children0
1335+ liftIO $ writeIORef placeholders $! phs
1336+ append $ toNode lastPlaceholder
1337+
12561338 requestDomAction_ $ ffor children' $ \p -> do
12571339 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
12581340 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1260,6 +1342,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
12601342 liftIO $ writeIORef pendingChange (newUnready, newP)
12611343 when (DMap.null newUnready) $ do
12621344 applyDomUpdate newP
1345+ let result0 = DMap.map (_traverseDMapChild_result . getCompose) children0
1346+ result' = ffor children' $ mapPatch $ _traverseDMapChild_result . getCompose
12631347 return (result0, result')
12641348
12651349{-# INLINABLE drawChildUpdate #-}
@@ -1267,35 +1351,47 @@ drawChildUpdate :: (MonadIO m, MonadJSM m, Reflex t)
12671351 => HydrationDomBuilderEnv t
12681352 -> (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
12691353 -> HydrationDomBuilderT t m (v' a)
1270− -> DomRenderHookT t m (Compose ((,,,,) (HydrationRunnerT t m ()) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
1271−drawChildUpdate initialEnv markReady child = do
1272− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
1273− let doc = _hydrationDomBuilderEnv_document initialEnv
1274− unreadyChildren <- liftIO $ newIORef 0
1275− hydrationMode <- liftIO $ readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv
1276− placeholder <- createTextNode doc ("" :: Text)
1277− (p, delayed) <- case hydrationMode of
1278− HydrationMode_Hydrating -> pure
1279− ( Left $ _hydrationDomBuilderEnv_parent initialEnv
1280− , insertAfterPreviousNode placeholder
1281− )
1282− HydrationMode_Immediate -> do
1283− df <- createDocumentFragment doc
1284− Node.appendChild_ df placeholder
1285− pure (Right df, pure ())
1286− p' <- either pure (liftIO . newIORef . toNode) p
1287− (result, finalState) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1288− { _hydrationDomBuilderEnv_parent = p'
1289− , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1290− , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1354+ -> DomRenderHookT t m (Compose (TraverseDMapChild t m k) v' a)
1355+drawChildUpdate initialEnv markReady child = liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case
1356+ HydrationMode_Hydrating -> do
1357+ let doc = _hydrationDomBuilderEnv_document initialEnv
1358+ unreadyChildren <- liftIO $ newIORef 0
1359+ (result, childDelayed) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1360+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1361+ }
1362+ let delayed = do
1363+ placeholder <- createTextNode doc ("" :: Text)
1364+ insertAfterPreviousNode placeholder
1365+ pure placeholder
1366+ return $ Compose $ TraverseDMapChild
1367+ { _traverseDMapChild_result = result
1368+ , _traverseDMapChild_mode = Left TraverseDMapChildHydration
1369+ { _traverseDMapChildHydration_delayed = delayed <* childDelayed
12911370 }
1292− u <- liftIO $ readIORef unreadyChildren
1293− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1294− return $ Compose
1295− ( delayed >> finalState
1296− , either (const $ error "drawChildUpdate: Tried to use document fragment in hydration mode") id p
1297− , placeholder, childReadyState, result
1298− )
1371+ }
1372+ HydrationMode_Immediate -> do
1373+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
1374+ let doc = _hydrationDomBuilderEnv_document initialEnv
1375+ unreadyChildren <- liftIO $ newIORef 0
1376+ df <- createDocumentFragment doc
1377+ placeholder <- createTextNode doc ("" :: Text)
1378+ Node.appendChild_ df placeholder
1379+ parentRef <- liftIO . newIORef $ toNode df
1380+ (result, _s) <- flip runStateT (pure ()) $ runReaderT (unHydrationDomBuilderT child) initialEnv
1381+ { _hydrationDomBuilderEnv_parent = parentRef
1382+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1383+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1384+ }
1385+ u <- liftIO $ readIORef unreadyChildren
1386+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1387+ return $ Compose $ TraverseDMapChild
1388+ { _traverseDMapChild_result = result
1389+ , _traverseDMapChild_mode = Right TraverseDMapChildImmediate
1390+ { _traverseDMapChildImmediate_fragment = df
1391+ , _traverseDMapChildImmediate_placeholder = placeholder
1392+ , _traverseDMapChildImmediate_childReadyState = childReadyState
1393+ }
1394+ }
12991395
13001396{-# INLINABLE drawChildUpdateInt #-}
13011397drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)