@@ -5,6 +5,7 @@
55{-# LANGUAGE EmptyDataDecls #-}
66{-# LANGUAGE FlexibleContexts #-}
77{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE GADTs #-}
89{-# LANGUAGE GeneralizedNewtypeDeriving #-}
910{-# LANGUAGE LambdaCase #-}
1011{-# LANGUAGE MultiParamTypeClasses #-}
@@ -83,6 +84,8 @@ import Reflex.Class as Reflex
8384import Reflex.Dom.Builder.Class
8485import Reflex.Dynamic
8586import Reflex.Host.Class
87+import qualified Reflex.Patch.DMap as PatchDMap
88+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
8689import Reflex.PerformEvent.Class
8790import Reflex.PostBuild.Class
8891import Reflex.TriggerEvent.Base hiding (askEvents)
@@ -105,10 +108,12 @@ import Data.Dependent.Sum
105108import Data.Functor.Compose
106109import Data.Functor.Constant
107110import Data.Functor.Misc
111+import Data.Functor.Product
108112import Data.IORef
109113import qualified Data.Map as Map
110114import Data.Maybe
111−import Data.Monoid
115+import Data.Monoid hiding (Product)
116+import Data.Some (Some)
112117import qualified Data.Some as Some
113118import Data.Text (Text)
114119import qualified Data.Text as T
@@ -142,13 +147,15 @@ import Reflex.Requester.Class
142147
143148data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
144149
145−data ImmediateDomBuilderEnv t m
150+data ImmediateDomBuilderEnv t
146151 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
147152 , _immediateDomBuilderEnv_parent :: Node
148153 , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]
154+ , _immediateDomBuilderEnv_unreadyChildren :: IORef Word -- Number of children who still aren't fully rendered
155+ , _immediateDomBuilderEnv_commitAction :: JSM () -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
149156 }
150157
151−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t m) (RequesterT t JSM Identity m) a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
158+newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity m) a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
152159
153160#ifndef __GHCJS__
154161instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
@@ -172,7 +179,7 @@ instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilder
172179 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
173180
174181{-# INLINABLE runImmediateDomBuilderT #-}
175−runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t m -> m a
182+runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t -> m a
176183runImmediateDomBuilderT (ImmediateDomBuilderT a) env = do
177184 rec (x, req) <- runRequesterT (runReaderT a env) rsp
178185 rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
@@ -274,9 +281,9 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR
274281wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
275282wrap e cfg = do
276283 events <- askEvents
277− mapM_ (requestDomAction_ . fmap (imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
284+ forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
278285 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
279− Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv)) (_rawElementConfig_modifyAttributes cfg)
286+ Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
280287 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
281288 triggerRef <- liftIO $ newIORef Nothing
282289 _ <- elementOnEventName en e $ do
@@ -309,13 +316,16 @@ wrap e cfg = do
309316 --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
310317 ref <- newIORef $ Just t
311318 writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
312− return $ Element es e
319+ return $ Element
320+ { _element_events = es
321+ , _element_raw = e
322+ }
313323
314324{-# INLINABLE makeElement #-}
315325makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
316326makeElement elementTag cfg child = do
317− doc <- askDocument
318327 env <- ImmediateDomBuilderT ask
328+ let doc = _immediateDomBuilderEnv_document env
319329 e <- liftJSM $ case cfg ^. namespace of
320330 Nothing -> createElementUnchecked doc (Just elementTag)
321331 Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)
@@ -507,96 +517,307 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
507517 return (wrapped, result)
508518 placeRawElement = append
509519 wrapRawElement = wrap
520+ notReadyUntil e = do
521+ eOnce <- headE e
522+ env <- ImmediateDomBuilderT ask
523+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
524+ liftIO $ modifyIORef' unreadyChildren succ
525+ let ready = do
526+ old <- liftIO $ readIORef unreadyChildren
527+ let new = pred old
528+ liftIO $ writeIORef unreadyChildren $! new
529+ when (new == 0) $ _immediateDomBuilderEnv_commitAction env
530+ requestDomAction_ $ ready <$ eOnce
531+ notReady = do
532+ env <- ImmediateDomBuilderT ask
533+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
534+ liftIO $ modifyIORef' unreadyChildren succ
535+
536+data FragmentState
537+ = FragmentState_Unmounted
538+ | FragmentState_Mounted (DOM.Text, DOM.Text)
539+
540+data ImmediateDomFragment = ImmediateDomFragment
541+ { _immediateDomFragment_document :: DOM.DocumentFragment
542+ , _immediateDomFragment_state :: IORef FragmentState
543+ }
544+
545+extractFragment :: MonadJSM m => ImmediateDomFragment -> m ()
546+extractFragment fragment = do
547+ state <- liftIO $ readIORef $ _immediateDomFragment_state fragment
548+ case state of
549+ FragmentState_Unmounted -> return ()
550+ FragmentState_Mounted (before, after) -> do
551+ extractBetweenExclusive (_immediateDomFragment_document fragment) before after
552+ liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
553+
554+instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
555+ type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
556+ buildDomFragment w = do
557+ initialEnv <- ImmediateDomBuilderT ask
558+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
559+ result <- lift $ runImmediateDomBuilderT w $ initialEnv
560+ { _immediateDomBuilderEnv_parent = toNode df
561+ }
562+ state <- liftIO $ newIORef FragmentState_Unmounted
563+ return (ImmediateDomFragment df state, result)
564+ mountDomFragment fragment setFragment = do
565+ parent <- askParent
566+ extractFragment fragment
567+ before <- textNodeInternal ("" :: Text)
568+ appendChild_ parent $ Just $ _immediateDomFragment_document fragment
569+ after <- textNodeInternal ("" :: Text)
570+ xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
571+ performEvent_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
572+ extractFragment previousFragment
573+ extractFragment childFragment
574+ insertBefore (_immediateDomFragment_document childFragment) after
575+ liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
576+ liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
510577
511578instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where
512579 runWithReplace a0 a' = do
513580 initialEnv <- ImmediateDomBuilderT ask
514581 before <- textNodeInternal ("" :: Text)
582+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
583+ haveEverBeenReady <- liftIO $ newIORef False
584+ let myCommitAction = do
585+ liftIO (readIORef haveEverBeenReady) >>= \case
586+ True -> return ()
587+ False -> do
588+ liftIO $ writeIORef haveEverBeenReady True
589+ old <- liftIO $ readIORef parentUnreadyChildren
590+ let new = pred old
591+ liftIO $ writeIORef parentUnreadyChildren $! new
592+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
515593 -- We draw 'after' in this roundabout way to avoid using MonadFix
516594 after <- createTextNodeUnchecked (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
517595 let drawInitialChild = do
518− result <- a0
519− append after
596+ unreadyChildren <- liftIO $ newIORef 0
597+ let f = do
598+ result <- a0
599+ append after
600+ return result
601+ result <- runImmediateDomBuilderT f $ initialEnv
602+ { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
603+ , _immediateDomBuilderEnv_commitAction = myCommitAction
604+ }
605+ liftIO $ readIORef unreadyChildren >>= \case
606+ 0 -> writeIORef haveEverBeenReady True
607+ _ -> modifyIORef' parentUnreadyChildren succ
520608 return result
521− (result0, result') <- ImmediateDomBuilderT $ lift $ runWithReplace (runReaderT (unImmediateDomBuilderT drawInitialChild) initialEnv) $ ffor a' $ \child -> do
609+ currentCohort <- liftIO $ newIORef (0 :: Int)
610+ a'' <- numberOccurrences a'
611+ (result0, result') <- lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
522612 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
523− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
613+ unreadyChildren <- liftIO $ newIORef 0
614+ let commitAction = do
615+ c <- liftIO $ readIORef currentCohort
616+ when (c < cohortId) $ do -- If a newer cohort has already been committed, just ignore this
617+ deleteBetweenExclusive before after
618+ insertBefore df after
619+ liftIO $ writeIORef currentCohort cohortId
620+ myCommitAction
621+ result <- runImmediateDomBuilderT child $ initialEnv
524622 { _immediateDomBuilderEnv_parent = toNode df
623+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
624+ , _immediateDomBuilderEnv_commitAction = commitAction
525625 }
526− let update = do
527− deleteBetweenExclusive before after
528− insertBefore df after
529− return (result, update)
530− requestDomAction_ $ snd <$> result'
531− return (result0, fst <$> result')
532− traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
533− initialEnv <- ImmediateDomBuilderT ask
534− (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
535− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
536− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
537− result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r
538− placeholders' = fforCheap children' $ weakenPatchDMapWith $ \(Compose (_, ph, _)) -> ph
539− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
540− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
541− lastPlaceholder <- textNodeInternal ("" :: Text)
542− requestDomAction_ $ flip push children' $ \(PatchDMap p) -> do
543− phs <- sample placeholders
544− if DMap.null p then return Nothing else return $ Just $ do
545− let g :: DSum k (ComposeMaybe (Compose ((,,) DOM.DocumentFragment DOM.Text) v')) -> JSM ()
546− g (k :=> ComposeMaybe mv) = do
547− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
548− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
549− forM_ mv $ \(Compose (df, _, _)) -> df `insertBefore` nextPlaceholder
550− mapM_ g $ DMap.toList p
626+
627+ liftIO (readIORef unreadyChildren) >>= \case
628+ 0 -> liftJSM commitAction
629+ _ -> return () -- Whoever decrements it to 0 will handle it
630+ return result
551631 return (result0, result')
552− traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
553− initialEnv <- ImmediateDomBuilderT ask
554− (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
555− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
556− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
557− result' = ffor children' $ mapPatchDMapWithMove $ \(Compose (_, _, r)) -> r
558− placeholders' = fforCheap children' $ weakenPatchDMapWithMoveWith $ \(Compose (_, ph, _)) -> ph
559− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
560− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
561− lastPlaceholder <- textNodeInternal ("" :: Text)
562− requestDomAction_ $ flip push children' $ \p_ -> do
632+ traverseDMapWithKeyWithAdjust = do
633+ let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
634+ let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
635+ new k (ComposeMaybe m) = ComposeMaybe <$> case m of
636+ Nothing -> return Nothing
637+ Just (Compose (_, _, sRef, _)) -> do
638+ readIORef sRef >>= \case
639+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
640+ ChildReadyState_Unready _ -> do
641+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
642+ return $ Just $ Constant sRef
643+ delete _ (Constant sRef) = do
644+ writeIORef sRef $ ChildReadyState_Unready Nothing
645+ return $ Constant ()
646+ p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
647+ _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
648+ return $ applyAlways p' old
649+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
650+ phs <- liftIO $ readIORef placeholders
651+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
652+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
653+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
654+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
655+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
656+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
657+ traverseDMapWithKeyWithAdjustWithMove = do
658+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
659+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
660+ new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
661+ PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
662+ readIORef sRef >>= \case
663+ ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
664+ ChildReadyState_Unready _ -> do
665+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
666+ return $ PatchDMapWithMove.From_Insert $ Constant sRef
667+ PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
668+ PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
669+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
670+ deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do
671+ writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
672+ return $ Constant ()
673+ p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
674+ _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
675+ return $ applyAlways p' old
676+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
563677 let p = unPatchDMapWithMove p_
564− phsBefore <- sample placeholders
565− if DMap.null p then return Nothing else return $ Just $ do
566− let collectIfMoved :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
567− collectIfMoved k e = do
568− let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
569− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
570− case dmapEditMoved e of
571− False -> do
572− mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
573− return $ Constant Nothing
574− True -> do
575− Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
576− collected <- DMap.traverseWithKey collectIfMoved p
577− let phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
578− let placeFragment :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant () a)
579− placeFragment k e = do
580− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
581− case e of
582− DMapEdit_Insert _ (Compose (df, _, _)) -> do
583− df `insertBefore` nextPlaceholder
584− DMapEdit_Delete _ -> do
585− return ()
586− DMapEdit_Move _ fromKey -> do
587− Just (Constant mdf) <- return $ DMap.lookup fromKey collected
588− mapM_ (`insertBefore` nextPlaceholder) mdf
589− return $ Constant ()
590− 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
591− return ()
592− return (result0, result')
593−
594−drawChildUpdate :: (MonadJSM m, PerformEvent t m, MonadFix m, MonadJSM (Performable m)) => ImmediateDomBuilderEnv t m -> ImmediateDomBuilderT t m (v' a) -> RequesterT t JSM Identity m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)
595−drawChildUpdate initialEnv child = do
678+ phsBefore <- liftIO $ readIORef placeholders
679+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
680+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
681+ collectIfMoved k e = do
682+ let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
683+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
684+ case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
685+ False -> do
686+ mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
687+ return $ Constant Nothing
688+ True -> do
689+ Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
690+ collected <- DMap.traverseWithKey collectIfMoved p
691+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
692+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
693+ placeFragment k e = do
694+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
695+ case PatchDMapWithMove._nodeInfo_from e of
696+ PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
697+ df `insertBefore` nextPlaceholder
698+ PatchDMapWithMove.From_Delete -> do
699+ return ()
700+ PatchDMapWithMove.From_Move fromKey -> do
701+ Just (Constant mdf) <- return $ DMap.lookup fromKey collected
702+ mapM_ (`insertBefore` nextPlaceholder) mdf
703+ return $ Constant ()
704+ 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
705+ liftIO $ writeIORef placeholders $! phsAfter
706+
707+data ChildReadyState k
708+ = ChildReadyState_Ready
709+ | ChildReadyState_Unready !(Maybe (Some k))
710+ deriving (Show, Read, Eq, Ord)
711+
712+hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
713+ ( PerformEvent t m
714+ , MonadAdjust t m
715+ , MonadHold t m
716+ , DMap.GCompare k
717+ , MonadIO (Performable m)
718+ , MonadIO m
719+ , MonadJSM m
720+ , PrimMonad m
721+ , MonadFix m
722+ , Patch (p k v)
723+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
724+ , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
725+ , Patch (p k (Constant Int))
726+ )
727+ => (forall vv vv'.
728+ (forall a. k a -> vv a -> RequesterT t JSM Identity m (vv' a))
729+ -> DMap k vv
730+ -> Event t (p k vv)
731+ -> RequesterT t JSM Identity m (DMap k vv', Event t (p k vv'))
732+ ) -- ^ The base monad's traversal
733+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
734+ -> (p k (Compose ((,,,) 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
735+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM
736+ -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))
737+ -> DMap k v
738+ -> Event t (p k v)
739+ -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))
740+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
741+ initialEnv <- ImmediateDomBuilderT ask
742+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
743+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
744+ haveEverBeenReady <- liftIO $ newIORef False
745+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
746+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
747+ let applyDomUpdate = applyDomUpdate_ placeholders lastPlaceholderRef
748+ let markSelfReady = do
749+ liftIO (readIORef haveEverBeenReady) >>= \case
750+ True -> return ()
751+ False -> do
752+ liftIO $ writeIORef haveEverBeenReady True
753+ old <- liftIO $ readIORef parentUnreadyChildren
754+ let new = pred old
755+ liftIO $ writeIORef parentUnreadyChildren $! new
756+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
757+ markChildReady :: IORef (ChildReadyState k) -> JSM ()
758+ markChildReady childReadyState = do
759+ liftIO (readIORef childReadyState) >>= \case
760+ ChildReadyState_Ready -> return ()
761+ ChildReadyState_Unready countedAt -> do
762+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
763+ case countedAt of
764+ Nothing -> return ()
765+ Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
766+ (oldUnready, p) <- liftIO $ readIORef pendingChange
767+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
768+ let newUnready = DMap.delete k oldUnready
769+ liftIO $ writeIORef pendingChange (newUnready, p)
770+ when (DMap.null newUnready) $ do
771+ applyDomUpdate p
772+ markSelfReady
773+ (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
774+ let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
775+ readIORef sRef >>= \case
776+ ChildReadyState_Ready -> return Nothing
777+ ChildReadyState_Unready _ -> do
778+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
779+ return $ Just $ Constant sRef
780+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
781+ liftIO $ if DMap.null initialUnready
782+ then writeIORef haveEverBeenReady True
783+ else do
784+ modifyIORef' parentUnreadyChildren succ
785+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
786+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
787+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
788+ result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
789+ liftIO $ writeIORef placeholders $! placeholders0
790+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0
791+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
792+ -- Note: the numbering here must match the numbering of dm''
793+ requestDomAction_ $ ffor children' $ \p -> do
794+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange
795+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready
796+ let !newP = p <> oldP
797+ liftIO $ writeIORef pendingChange (newUnready, newP)
798+ when (DMap.null newUnready) $ do
799+ applyDomUpdate newP
800+ markSelfReady
801+ liftIO $ writeIORef pendingChange $! mempty
802+ return (result0, result')
803+
804+drawChildUpdate :: (MonadIO m, MonadJSM m)
805+ => ImmediateDomBuilderEnv t
806+ -> (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
807+ -> ImmediateDomBuilderT t m (v' a)
808+ -> RequesterT t JSM Identity m (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
809+drawChildUpdate initialEnv markReady child = do
810+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
811+ unreadyChildren <- liftIO $ newIORef 0
596812 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
597− runReaderT (unImmediateDomBuilderT $ Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv
813+ (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
598814 { _immediateDomBuilderEnv_parent = toNode df
815+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
816+ , _immediateDomBuilderEnv_commitAction = markReady childReadyState
599817 }
818+ u <- liftIO $ readIORef unreadyChildren
819+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
820+ return $ Compose (df, placeholder, childReadyState, result)
600821
601822mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
602823mkHasFocus e = do