@@ -1,3 +1,4 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE CPP #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE DataKinds #-}
@@ -487,7 +488,6 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB
487488 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
488489 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
489490
490−
491491instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where
492492 runWithReplace a0 a' = do
493493 initialEnv <- ImmediateDomBuilderT ask
@@ -520,7 +520,7 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, Perfo
520520 _ -> modifyIORef' parentUnreadyChildren succ
521521 return result
522522 currentCohort <- liftIO $ newIORef 0
523− a'' <- zipListWithEvent (,) [1..] a'
523+ a'' <- zipListWithEvent (,) [1 :: Int ..] a'
524524 (result0, result') <- lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
525525 Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
526526 unreadyChildren <- liftIO $ newIORef 0
@@ -543,24 +543,78 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, Perfo
543543 return (result0, result')
544544 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
545545 initialEnv <- ImmediateDomBuilderT ask
546− (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
547− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
548− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
549− result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r
550− placeholders' = fforCheap children' $ weakenPatchDMapWith $ \(Compose (_, ph, _)) -> ph
551− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
552− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
553− lastPlaceholder <- textNodeInternal ("" :: Text)
554− performEvent_ $ flip push children' $ \(PatchDMap p) -> do
555− phs <- sample placeholders
556− if DMap.null p then return Nothing else return $ Just $ do
557− let g :: DSum k (ComposeMaybe (Compose ((,,) DOM.DocumentFragment DOM.Text) v')) -> Performable m ()
558− g (k :=> ComposeMaybe mv) = do
559− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
560− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
561− forM_ mv $ \(Compose (df, _, _)) -> df `insertBefore` nextPlaceholder
562− mapM_ g $ DMap.toList p
546+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
547+ pendingChange :: IORef (DMap k (Constant Int), PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v')) <- liftIO $ newIORef mempty
548+ haveEverBeenReady <- liftIO $ newIORef False
549+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
550+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
551+ let markSelfReady = do
552+ readIORef haveEverBeenReady >>= \case
553+ True -> return ()
554+ False -> do
555+ writeIORef haveEverBeenReady True
556+ old <- readIORef parentUnreadyChildren
557+ let new = pred old
558+ writeIORef parentUnreadyChildren $! new
559+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
560+ markChildReady :: forall a. Int -> k a -> IO ()
561+ markChildReady markingCohortId k = do
562+ (oldUnready, p) <- readIORef pendingChange
563+ when (not (DMap.null oldUnready)) $ do
564+ let clearUnreadiness = \case
565+ Nothing -> Nothing
566+ old@(Just (Constant pendingCohortId)) -> case pendingCohortId `compare` markingCohortId of
567+ LT -> trace "Warning: marking a child as ready before it is in pendingChange" Nothing -- Should never happen; we're trying to mark something as done before it's been added to pendingChange
568+ EQ -> Nothing -- We're marking the currently pending child as done
569+ GT -> old -- We're marking a child as done that has already been superceded
570+ newUnready = DMap.alter clearUnreadiness k oldUnready
571+ writeIORef pendingChange $! (newUnready, p)
572+ when (DMap.null newUnready) $ do
573+ applyDomUpdate p
574+ markSelfReady
575+ -- Once a cohort is ready, we actually insert it into the DOM
576+ applyDomUpdate :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') -> IO ()
577+ applyDomUpdate (PatchDMap p) = liftIO $ do
578+ phs <- readIORef placeholders
579+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
580+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
581+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
582+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
583+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
584+ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
585+ dm'' <- zipListWithEvent (\cohortId -> mapPatchDMap (\v -> Compose (cohortId, v))) [1 :: Int ..] dm'
586+ (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k (Compose (cohortId, v)) -> drawChildUpdate initialEnv (markChildReady cohortId k) $ f k v) (DMap.map (\v -> Compose (0, v)) dm0) dm''
587+ let !initialUnready = DMap.mapMaybeWithKey (\_ (Compose (_, _, alreadyReady, _)) -> if alreadyReady then Nothing else Just $ Constant 0) children0
588+ liftIO $ if DMap.null initialUnready
589+ then writeIORef haveEverBeenReady True
590+ else do
591+ modifyIORef' parentUnreadyChildren succ
592+ writeIORef pendingChange $! (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
593+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
594+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
595+ result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, _, r)) -> r
596+ liftIO $ writeIORef placeholders $! placeholders0
597+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0
598+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
599+ -- Note: the numbering here must match the numbering of dm''
600+ children'' <- zipListWithEvent (,) [1 :: Int ..] children'
601+ performEvent_ $ ffor children'' $ \(cohortId, p) -> liftIO $ do
602+ (oldUnready, oldP) <- readIORef pendingChange
603+ let updatedChildToUnreadiness :: forall x. ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') x -> ComposeMaybe (Constant Int) x
604+ updatedChildToUnreadiness = \case
605+ ComposeMaybe Nothing -> ComposeMaybe Nothing -- The child is being deleted, so it's ready
606+ ComposeMaybe (Just (Compose (_, _, alreadyReady, _)))
607+ | alreadyReady -> ComposeMaybe Nothing -- The child is being added and is already ready
608+ | otherwise -> ComposeMaybe $ Just $ Constant cohortId -- The child is being added and is not ready
609+ childrenPatchToUnreadyPatch (PatchDMap m) = PatchDMap $ DMap.map updatedChildToUnreadiness m
610+ !newUnready = fromMaybe oldUnready $ apply (childrenPatchToUnreadyPatch p) oldUnready
611+ !newP = p <> oldP
612+ writeIORef pendingChange $! (newUnready, newP)
613+ when (DMap.null newUnready) $ do
614+ applyDomUpdate newP
615+ writeIORef pendingChange $! mempty
563616 return (result0, result')
617+{-
564618 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
565619 initialEnv <- ImmediateDomBuilderT ask
566620 (children0, children') <- lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
@@ -602,11 +656,23 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, Perfo
602656 mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time
603657 return ()
604658 return (result0, result')
605−
606−drawChildUpdate :: MonadIO m => ImmediateDomBuilderEnv t -> ImmediateDomBuilderT t m (v' a) -> m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)
607−drawChildUpdate initialEnv child = do
659+-}
660+
661+drawChildUpdate :: MonadIO m
662+ => ImmediateDomBuilderEnv t
663+ -> IO () -- This will NOT be called if the child is ready at initialization time; instead, a True will be returned for that item
664+ -> ImmediateDomBuilderT t m (v' a)
665+ -> m (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v' a)
666+drawChildUpdate initialEnv markReady child = do
667+ unreadyChildren <- liftIO $ newIORef 0
608668 Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
609− runImmediateDomBuilderT (Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv { _immediateDomBuilderEnv_parent = toNode df }
669+ (placeholder, result) <- runImmediateDomBuilderT ((,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
670+ { _immediateDomBuilderEnv_parent = toNode df
671+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
672+ , _immediateDomBuilderEnv_commitAction = markReady
673+ }
674+ u <- liftIO $ readIORef unreadyChildren
675+ return $ Compose (df, placeholder, u == 0, result)
610676
611677mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
612678mkHasFocus e = do