on develop help sign in
Working runWithReplace
commitded3a9eaec65e33e258266309eadd11a2d21beb5 authorTom Smalley <tfsmalley@gmail.com> dateWed 7 Nov 2018, 17:39 (8 years ago) parentb95a071
1 file changed+24−29
reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+24−29
reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+24−29
@@ -724,72 +724,67 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM
724724 pure (toNode t)
725725 let drawInitialChild = do
726726 liftIO $ putStrLn "drawInitialChild"
727− df <- createDocumentFragment doc
727+ p <- liftIO (readIORef hydrating) >>= \case
728+ HydrationMode_Hydrating -> pure parent
729+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
728730 unreadyChildren <- liftIO $ newIORef 0
729731 hydrationNode <- liftIO $ newIORef Nothing
730− hydrationResult <- liftIO $ newIORef []
731− localHydrationMode <- liftIO $ newIORef HydrationMode_Immediate
732+ r <- liftIO $ newIORef []
732733 result <- runReaderT (unHydrationDomBuilderT a0) initialEnv
733734 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
734735 , _hydrationDomBuilderEnv_commitAction = myCommitAction
735736 , _hydrationDomBuilderEnv_hydrationNode = hydrationNode
736− , _hydrationDomBuilderEnv_parent = toNode df
737− , _hydrationDomBuilderEnv_hydrationMode = localHydrationMode
737+ , _hydrationDomBuilderEnv_parent = p
738+ , _hydrationDomBuilderEnv_hydrationResult = r
738739 }
740+ h' <- liftIO $ readIORef r
739741 liftIO $ readIORef unreadyChildren >>= \case
740742 0 -> writeIORef haveEverBeenReady True
741743 _ -> modifyIORef' parentUnreadyChildren succ
742744 liftIO $ putStrLn "drawInitialChild: end"
743− return result
745+ return (h', result)
744746 a'' <- numberOccurrences a'
745747 (result0, child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
746− df <- createDocumentFragment doc
748+ p <- liftIO (readIORef hydrating) >>= \case
749+ HydrationMode_Hydrating -> pure parent
750+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc
747751 unreadyChildren <- liftIO $ newIORef 0
748752 let commitAction = do
749753 liftIO $ putStrLn "Committing runWithReplace update"
750754 c <- liftIO $ readIORef currentCohort
751755 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
752756 deleteBetweenExclusive before after
753− insertBefore df after
757+ insertBefore p after
754758 liftIO $ writeIORef currentCohort cohortId
755759 myCommitAction
756760 hydrationNode <- liftIO $ newIORef (Just $ toNode before)
757− h <- liftIO $ readIORef hydrating
758− let child' = runReaderT (unHydrationDomBuilderT child) $ initialEnv
761+ r <- liftIO $ newIORef []
762+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv
759763 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
760764 , _hydrationDomBuilderEnv_commitAction = commitAction
761765 , _hydrationDomBuilderEnv_hydrationNode = hydrationNode
762− , _hydrationDomBuilderEnv_parent = toNode df
766+ , _hydrationDomBuilderEnv_parent = p
767+ , _hydrationDomBuilderEnv_hydrationResult = r
763768 }
764769 uc <- liftIO $ readIORef unreadyChildren
765− result <- case h of
766− HydrationMode_Hydrating -> pure Nothing
767− HydrationMode_Immediate -> do
768− liftIO $ putStrLn "Running child in immediate mode"
769− Just <$> child'
770+ h <- liftIO $ readIORef hydrating
771+ h' <- liftIO $ readIORef r
770772 let commitActionToRunNow = if uc == 0
771773 then Just $ commitAction
772774 else Nothing -- A child will run it when unreadyChildren is decremented to 0
773775 commitActionToRunNow' = if h == HydrationMode_Hydrating then Nothing else commitActionToRunNow
774− hydrationAction = if h == HydrationMode_Hydrating then Just child' else Nothing
776+ hydrationAction = if h == HydrationMode_Hydrating then Just h' else Nothing
775777 return (hydrationAction, commitActionToRunNow', result)
776− let drawInitialChild' = do
777− unreadyChildren <- liftIO $ newIORef 0
778− hydrationNode <- liftIO $ newIORef (Just $ toNode before)
779− result <- runReaderT (unHydrationDomBuilderT a0) initialEnv
780− { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
781− , _hydrationDomBuilderEnv_commitAction = myCommitAction
782− , _hydrationDomBuilderEnv_hydrationNode = hydrationNode
783− }
784− return result
785778 env <- HydrationDomBuilderT ask
786779 let f :: RequesterT t JSM Identity (TriggerEventT t m) x -> m ()
787780 f = void . flip runHydrationDomBuilderT env . HydrationDomBuilderT . lift
788− beh <- hold (f drawInitialChild') (fmapMaybe (\(h,_,_) -> f <$> h) child')
781+ g :: [Behavior t (m ())] -> Behavior t (m ())
782+ g = fmap (void . sequence) . sequence
783+ beh <- hold (g $ fst result0) (fmapMaybe (\(h,_,_) -> g <$> h) child')
789784 hydrationResultRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationResult
790− liftIO $ modifyIORef' hydrationResultRef (beh :)
785+ liftIO $ modifyIORef' hydrationResultRef (join beh :)
791786 requestDomAction_ $ fmapMaybe (\(_,c,_) -> c) child'
792− return (result0, fmapMaybe (\(_,_,r) -> r) child')
787+ return (snd result0, fmap (\(_,_,r) -> r) child')
793788
794789 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
795790 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'