ce93639 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Working for traverseDMapWithKeyWithAdjust

ce93639Ryan Trinkle10 years ago

src/Reflex/Dom/Builder/Immediate.hs+89−23

compare with develop

unifiedsplit

@@ -1,3 +1,4 @@

1+{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

@@ -487,7 +488,6 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB

487 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

488 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

488 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

489 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

489

490

490−

491instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where

492 runWithReplace a0 a' = do

493 initialEnv <- ImmediateDomBuilderT ask

@@ -520,7 +520,7 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, Perfo

520 _ -> modifyIORef' parentUnreadyChildren succ

521 return result

522 currentCohort <- liftIO $ newIORef 0

523− a'' <- zipListWithEvent (,) [1..] a'

523+ a'' <- zipListWithEvent (,) [1 :: Int ..] a'

524 (result0, result') <- lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

525 Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

526 unreadyChildren <- liftIO $ newIORef 0

@@ -543,24 +543,78 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, MonadFix m, Perfo

543 return (result0, result')

544 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

545 initialEnv <- ImmediateDomBuilderT ask

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'

546− (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate initialEnv $ f k v) dm0 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

547− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0

593+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0

548− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0

594+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0

549− result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r

595+ result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, _, r)) -> r

550− placeholders' = fforCheap children' $ weakenPatchDMapWith $ \(Compose (_, ph, _)) -> ph

596+ liftIO $ writeIORef placeholders $! placeholders0

551− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'

552− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0

597+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0

553− lastPlaceholder <- textNodeInternal ("" :: Text)

598+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)

599+ -- Note: the numbering here must match the numbering of dm''

600+ children'' <- zipListWithEvent (,) [1 :: Int ..] children'

554− performEvent_ $ flip push children' $ \(PatchDMap p) -> do

601+ performEvent_ $ ffor children'' $ \(cohortId, p) -> liftIO $ do

555− phs <- sample placeholders

602+ (oldUnready, oldP) <- readIORef pendingChange

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 ()

603+ let updatedChildToUnreadiness :: forall x. ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v') x -> ComposeMaybe (Constant Int) x

558− g (k :=> ComposeMaybe mv) = do

604+ updatedChildToUnreadiness = \case

559− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

605+ ComposeMaybe Nothing -> ComposeMaybe Nothing -- The child is being deleted, so it's ready

560− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

606+ ComposeMaybe (Just (Compose (_, _, alreadyReady, _)))

561− forM_ mv $ \(Compose (df, _, _)) -> df `insertBefore` nextPlaceholder

607+ | alreadyReady -> ComposeMaybe Nothing -- The child is being added and is already ready

562− mapM_ g $ DMap.toList p

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

563 return (result0, result')

616 return (result0, result')

617+{-

564 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

618 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

565 initialEnv <- ImmediateDomBuilderT ask

619 initialEnv <- ImmediateDomBuilderT ask

566 (children0, children') <- lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'

620 (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

602 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

656 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

603 return ()

657 return ()

604 return (result0, result')

658 return (result0, result')

605−

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)

606−drawChildUpdate :: MonadIO m => ImmediateDomBuilderEnv t -> ImmediateDomBuilderT t m (v' a) -> m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)

665+ -> m (Compose ((,,,) DOM.DocumentFragment DOM.Text Bool) v' a)

607−drawChildUpdate initialEnv child = do

666+drawChildUpdate initialEnv markReady child = do

667+ unreadyChildren <- liftIO $ newIORef 0

608 Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

668 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)

610

676

611mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

677mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

612mkHasFocus e = do

678mkHasFocus e = do