@@ -24,6 +24,7 @@ import Reflex.Class as Reflex
24import Reflex.Dom.Builder.Class
24import Reflex.Dom.Builder.Class
25import Reflex.Dynamic
25import Reflex.Dynamic
26import Reflex.Host.Class
26import Reflex.Host.Class
27+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
27import Reflex.PerformEvent.Class
28import Reflex.PerformEvent.Class
28import Reflex.PostBuild.Class
29import Reflex.PostBuild.Class
29import Reflex.TriggerEvent.Base hiding (askEvents)
30import Reflex.TriggerEvent.Base hiding (askEvents)
@@ -541,79 +542,146 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, Perfo
541 _ -> return () -- Whoever decrements it to 0 will handle it
542 _ -> return () -- Whoever decrements it to 0 will handle it
542 return result
543 return result
543 return (result0, result')
544 return (result0, result')
544− traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
545+ traverseDMapWithKeyWithAdjust = do
546+ let updatedChildToUnreadiness :: forall x v'. Int -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') x -> ComposeMaybe (Constant Int) x
547+ updatedChildToUnreadiness cohortId = \case
548+ ComposeMaybe Nothing -> ComposeMaybe Nothing -- The child is being deleted, so it's ready
549+ ComposeMaybe (Just (Compose (_, _, alreadyReady, _)))
550+ | alreadyReady -> ComposeMaybe Nothing -- The child is being added and is already ready
551+ | otherwise -> ComposeMaybe $ Just $ Constant cohortId -- The child is being added and is not ready
552+ childrenPatchToUnreadyPatch cohortId (PatchDMap m) = PatchDMap $ DMap.map (updatedChildToUnreadiness cohortId) m
553+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap childrenPatchToUnreadyPatch $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
554+ phs <- readIORef placeholders
555+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
556+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
557+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
558+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
559+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
560+ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
561+ traverseDMapWithKeyWithAdjustWithMove = do
562+ let updatedChildToUnreadiness :: forall x k v'. Int -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') x -> PatchDMapWithMove.NodeInfo k (Constant Int) x
563+ updatedChildToUnreadiness cohortId = PatchDMapWithMove.nodeInfoMapFrom $ \case
564+ PatchDMapWithMove.From_Insert (Compose (_, _, alreadyReady, _))
565+ | alreadyReady -> PatchDMapWithMove.From_Delete -- The child is being added and is already ready
566+ | otherwise -> PatchDMapWithMove.From_Insert $ Constant cohortId -- The child is being added and is not ready
567+ PatchDMapWithMove.From_Delete -> PatchDMapWithMove.From_Delete -- The child is being deleted, so it's ready
568+ PatchDMapWithMove.From_Move k -> PatchDMapWithMove.From_Move k -- The child is being moved, so its ready status should be moved
569+ childrenPatchToUnreadyPatch cohortId = unsafePatchDMapWithMove . DMap.map (updatedChildToUnreadiness cohortId) . unPatchDMapWithMove
570+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove childrenPatchToUnreadyPatch $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v')) -> do
571+ let p = unPatchDMapWithMove p_
572+ phsBefore <- readIORef placeholders
573+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
574+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') a -> IO (Constant (Maybe DOM.DocumentFragment) a)
575+ collectIfMoved k e = do
576+ let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
577+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
578+ case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
580+ mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
581+ return $ Constant Nothing
583+ Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
584+ collected <- DMap.traverseWithKey collectIfMoved p
585+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
586+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') a -> IO (Constant () a)
587+ placeFragment k e = do
588+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
589+ case PatchDMapWithMove._nodeInfo_from e of
590+ PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
591+ df `insertBefore` nextPlaceholder
592+ PatchDMapWithMove.From_Delete -> do
594+ PatchDMapWithMove.From_Move fromKey -> do
595+ Just (Constant mdf) <- return $ DMap.lookup fromKey collected
596+ mapM_ (`insertBefore` nextPlaceholder) mdf
597+ return $ Constant ()
598+ 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
599+ writeIORef placeholders $! phsAfter
601+hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
606+ , MonadIO (Performable m)
610+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
611+ , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v'))
612+ , Patch (p k (Constant Int))
615+ (forall a. k a -> vv a -> m (vv' a))
618+ -> m (DMap k vv', Event t (p k vv'))
619+ ) -- ^ The base monad's traversal
620+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
621+ -> (Int -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') -> p k (Constant Int)) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
622+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') -> IO ()) -- ^ Apply a patch to the DOM
623+ -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))
626+ -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))
627+hoistTraverseWithKeyWithAdjust base mapPatch childrenPatchToUnreadyPatch applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
545− initialEnv <- ImmediateDomBuilderT ask
628+ initialEnv <- ImmediateDomBuilderT ask
546− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
629+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
547− pendingChange :: IORef (DMap k (Constant Int), PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v')) <- liftIO $ newIORef mempty
630+ pendingChange :: IORef (DMap k (Constant Int), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v')) <- liftIO $ newIORef mempty
548− haveEverBeenReady <- liftIO $ newIORef False
631+ haveEverBeenReady <- liftIO $ newIORef False
549− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
632+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
550− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
633+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
634+ let applyDomUpdate = applyDomUpdate_ placeholders lastPlaceholderRef
551− let markSelfReady = do
635+ let markSelfReady = do
552− readIORef haveEverBeenReady >>= \case
636+ readIORef haveEverBeenReady >>= \case
553− True -> return ()
637+ True -> return ()
554− False -> do
638+ False -> do
555− writeIORef haveEverBeenReady True
639+ writeIORef haveEverBeenReady True
556− old <- readIORef parentUnreadyChildren
640+ old <- readIORef parentUnreadyChildren
557− let new = pred old
641+ let new = pred old
558− writeIORef parentUnreadyChildren $! new
642+ writeIORef parentUnreadyChildren $! new
559− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
643+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
560− markChildReady :: forall a. Int -> k a -> IO ()
644+ markChildReady :: forall a. Int -> k a -> IO ()
561− markChildReady markingCohortId k = do
645+ markChildReady markingCohortId k = do
562− (oldUnready, p) <- readIORef pendingChange
646+ (oldUnready, p) <- readIORef pendingChange
563− when (not (DMap.null oldUnready)) $ do
647+ when (not (DMap.null oldUnready)) $ do
564− let clearUnreadiness = \case
648+ let clearUnreadiness = \case
565− Nothing -> Nothing
649+ Nothing -> Nothing
566− old@(Just (Constant pendingCohortId)) -> case pendingCohortId `compare` markingCohortId of
650+ 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
651+ 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
652+ 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
653+ GT -> old -- We're marking a child as done that has already been superceded
570− newUnready = DMap.alter clearUnreadiness k oldUnready
654+ newUnready = DMap.alter clearUnreadiness k oldUnready
571− writeIORef pendingChange $! (newUnready, p)
655+ writeIORef pendingChange $! (newUnready, p)
572− when (DMap.null newUnready) $ do
656+ when (DMap.null newUnready) $ do
573− applyDomUpdate p
657+ applyDomUpdate p
574− markSelfReady
658+ 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'
659+ dm'' <- zipListWithEvent (\cohortId -> mapPatch (\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''
660+ (children0, children') <- lift $ base (\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
661+ let !initialUnready = DMap.mapMaybeWithKey (\_ (Compose (_, _, alreadyReady, _)) -> if alreadyReady then Nothing else Just $ Constant 0) children0
588− liftIO $ if DMap.null initialUnready
662+ liftIO $ if DMap.null initialUnready
589− then writeIORef haveEverBeenReady True
663+ then writeIORef haveEverBeenReady True
591− modifyIORef' parentUnreadyChildren succ
665+ 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
666+ 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
667+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
594− placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
668+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
595− result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, _, r)) -> r
669+ result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
596− liftIO $ writeIORef placeholders $! placeholders0
670+ liftIO $ writeIORef placeholders $! placeholders0
597− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0
671+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0
598− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
672+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
599− -- Note: the numbering here must match the numbering of dm''
673+ -- Note: the numbering here must match the numbering of dm''
600− children'' <- zipListWithEvent (,) [1 :: Int ..] children'
674+ children'' <- zipListWithEvent (,) [1 :: Int ..] children'
601− performEvent_ $ ffor children'' $ \(cohortId, p) -> liftIO $ do
675+ performEvent_ $ ffor children'' $ \(cohortId, p) -> liftIO $ do
602− (oldUnready, oldP) <- readIORef pendingChange
676+ (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
677+ let !newUnready = fromMaybe oldUnready $ apply (childrenPatchToUnreadyPatch cohortId p) oldUnready
611− !newP = p <> oldP
678+ !newP = p <> oldP
612− writeIORef pendingChange $! (newUnready, newP)
679+ writeIORef pendingChange $! (newUnready, newP)
613− when (DMap.null newUnready) $ do
680+ when (DMap.null newUnready) $ do
614− applyDomUpdate newP
681+ applyDomUpdate newP
615− writeIORef pendingChange $! mempty
683+ writeIORef pendingChange $! mempty
616− return (result0, result')
684+ return (result0, result')
618 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
686 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
619 initialEnv <- ImmediateDomBuilderT ask
687 initialEnv <- ImmediateDomBuilderT ask
@@ -645,11 +713,11 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, Perfo
645 placeFragment k e = do
713 placeFragment k e = do
646 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
714 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
647 case e of
715 case e of
648− DMapEdit_Insert _ (Compose (df, _, _)) -> do
716+ PatchDMapWithMove.From_Insert _ (Compose (df, _, _)) -> do
649 df `insertBefore` nextPlaceholder
717 df `insertBefore` nextPlaceholder
650− DMapEdit_Delete _ -> do
718+ PatchDMapWithMove.From_Delete _ -> do
651 return ()
719 return ()
652− DMapEdit_Move _ fromKey -> do
720+ PatchDMapWithMove.From_Move _ fromKey -> do
653 Just (Constant mdf) <- return $ DMap.lookup fromKey collected
721 Just (Constant mdf) <- return $ DMap.lookup fromKey collected
654 mapM_ (`insertBefore` nextPlaceholder) mdf
722 mapM_ (`insertBefore` nextPlaceholder) mdf
655 return $ Constant ()
723 return $ Constant ()