git.iko.soy/reflex-dom
on develop help sign in
Avoid retaining extra events
28af89fRyan Trinkle
src/Reflex/Dom/DynamicWriter.hs+23−20
compare with develop
unifiedsplit
@@ -74,11 +74,11 @@ incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(Pa
74mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
74mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
75mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
75mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
76
76
77−incrementalReplaceableMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Replaceable t v)) -> Incremental t PatchMap (Map k v)
77+holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map k v))
78−incrementalReplaceableMap m =
78+holdIncrementalReplaceableMap m0 m' = do
79− let vals = unsafeBuildIncremental (sample $ currentIncremental m) $ updatedIncremental m <> valChanges
79+ rec vals <- holdIncremental m0 $ m' <> valChanges
80− valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
80+ let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
81− in mapIncrementalMapValues _replaceable_value vals
81+ return $ mapIncrementalMapValues _replaceable_value vals
82
82
83mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
83mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
84mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
84mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
@@ -114,14 +114,25 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWrit
114runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
114runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
115runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
115runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
116
116
117−mconcatIncrementalReplaceableDynMap :: (Reflex t, Monoid v, Ord k) => Incremental t PatchMap (Map k (Replaceable t (Dynamic t v))) -> Dynamic t v
117+mconcatIncrementalReplaceableDynMap :: forall m t k v. (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k) => Map k (Replaceable t (Dynamic t v)) -> Event t (PatchMap (Map k (Replaceable t (Dynamic t v)))) -> Event t () -> m (Replaceable t (Dynamic t v))
118+mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
119+ rec vals <- holdIncremental m0 $ m' <> valChanges
120+ let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
121+ let i = mapIncrementalMapValues _replaceable_value vals
122+ noMoreAdditions <- holdDyn False $ True <$ additionsCeased
123+ let replaceSelf nma x = do
124+ guard nma
125+ case Map.toList x of
126+ [] -> return Nothing -- Delete self
127+ [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
128+ _ -> mzero
118−mconcatIncrementalReplaceableDynMap = fmap (mconcat . Map.elems) . incrementalToDynamic . mergeDynIncremental . incrementalReplaceableMap
129+ result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
119−
130+ return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
131+
120−runDynamicWriterT :: (Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
132+runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
121runDynamicWriterT (DynamicWriterT a) = do
133runDynamicWriterT (DynamicWriterT a) = do
122 (result, ws) <- runStateT a []
134 (result, ws) <- runStateT a []
123− i <- holdIncremental (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never
135+ Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
124− let w = mconcatIncrementalReplaceableDynMap i
125 return (result, w)
136 return (result, w)
126
137
127class Monad m => MonadDynamicWriter t w m | m -> t w where
138class Monad m => MonadDynamicWriter t w m | m -> t w where
@@ -177,15 +188,7 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (
177 let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
188 let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
178 return (myNextId, PatchMap $ Map.fromList numbered)
189 return (myNextId, PatchMap $ Map.fromList numbered)
179 newNextId = fst <$> numberedNewChildren
190 newNextId = fst <$> numberedNewChildren
180− replaceableMap <- holdIncremental Map.empty $ snd <$> numberedNewChildren
191+ mconcatIncrementalReplaceableDynMap Map.empty (snd <$> numberedNewChildren) additionsCeased
181− noMoreAdditions <- holdDyn False $ True <$ additionsCeased
182− let replaceSelf nma i = do
183− guard nma
184− case Map.toList i of
185− [] -> return Nothing -- Delete self
186− [(_, n)] -> return $ Just n
187− _ -> mzero
188− return $ Replaceable (mconcatIncrementalReplaceableDynMap replaceableMap) $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic replaceableMap
189 rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
192 rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
190 p <- DynamicWriterT $ do
193 p <- DynamicWriterT $ do
191 modify (children:)
194 modify (children:)
src/Reflex/Dom/PerformEvent/Base.hs+7−8
@@ -55,13 +55,11 @@ instance (ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t
55 return [EventTriggerRef reResultTrigger :=> Identity result]
55 return [EventTriggerRef reResultTrigger :=> Identity result]
56 return eResult
56 return eResult
57
57
58−instance (ReflexHost t, Monad (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where
58+instance (ReflexHost t, Monad (HostFrame t), MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where
59 {-# INLINABLE deletable #-}
59 {-# INLINABLE deletable #-}
60 deletable d a = PerformEventT $ do
60 deletable d a = PerformEventT $ do
61− (result, reverseEventsToPerform) <- lift $ runStateT (unPerformEventT a) []
61+ (result, eventToPerform) <- lift $ runPerformEventT a
62− let (numberedEvents, _) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)
63− eventToPerform <- lift $ mergePerformEventsAndAdd (DMap.fromList numberedEvents) never
64− modify (align eventToPerform d :)
62+ modify (align (fmap (PerformEventT . lift) eventToPerform) d :)
65 return result
63 return result
66
64
67instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
65instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
@@ -81,7 +79,7 @@ mergePerformEventsAndAdd :: forall t m. ReflexHost t
81 -> HostFrame t (Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity]))
79 -> HostFrame t (Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity]))
82mergePerformEventsAndAdd initial eAddNew = do
80mergePerformEventsAndAdd initial eAddNew = do
83 rec events :: Incremental t PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t))
81 rec events :: Incremental t PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t))
84− <- holdIncremental initial $ eAddNew <> eDelete
82+ <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings
85 let event = mergeWith DMap.union [mergeIncremental events, coincidence (fmap (\(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m) eAddNew)]
83 let event = mergeWith DMap.union [mergeIncremental events, coincidence (fmap (\(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m) eAddNew)]
86 eventToPerform :: Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity])
84 eventToPerform :: Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity])
87 eventToPerform = ffor event $
85 eventToPerform = ffor event $
@@ -109,8 +107,9 @@ runPerformEventT (PerformEventT a) = do
109 (followups, reverseNewEventsToPerform) <- runStateT r []
107 (followups, reverseNewEventsToPerform) <- runStateT r []
110 oldN <- readRef nextNumberRef
108 oldN <- readRef nextNumberRef
111 let (numberedNewEvents, newN) = numberWith (\n e -> Const2 n :=> Compose (Just e)) (reverse reverseNewEventsToPerform) oldN
109 let (numberedNewEvents, newN) = numberWith (\n e -> Const2 n :=> Compose (Just e)) (reverse reverseNewEventsToPerform) oldN
110+ if newN == oldN then return followups else do
112− writeRef nextNumberRef newN
111+ writeRef nextNumberRef newN
113− return $ (EventTriggerRef reAddNewTrigger :=> Identity (PatchDMap (DMap.fromList numberedNewEvents))) : followups --TODO: Don't fire eAddNew when the list is empty
112+ return $ (EventTriggerRef reAddNewTrigger :=> Identity (PatchDMap (DMap.fromList numberedNewEvents))) : followups
114 eventToPerform <- mergePerformEventsAndAdd (DMap.fromList numberedEvents) eAddNew
113 eventToPerform <- mergePerformEventsAndAdd (DMap.fromList numberedEvents) eAddNew
115 return (result, runResult <$> eventToPerform)
114 return (result, runResult <$> eventToPerform)
116
115