@@ -152,78 +152,55 @@ widgetHoldInternal child0 newChild = do
152152 build c
153153 return (result0, fmap fst newChildBuilt)
154154
155+diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
156+diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
157+ This _ -> Just Nothing
158+ These old new -> Just $ Just new
159+ That new -> Just $ Just new
160+
161+applyMap :: Ord k => Map k v -> Map k (Maybe v) -> Map k v
162+applyMap olds diffs = flip Map.mapMaybe (align olds diffs) $ \case
163+ This old -> Just old
164+ These _ new -> new
165+ That new -> new
166+
155167--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
156−-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
157−listWithKey :: (Ord k, MonadWidget t m)
158− => Dynamic t (Map k v) -- ^ Dynamic key/value map
159− -> (k -> Dynamic t v -> m a) -- ^ Function to create a widget for a given key from Dynamic value
160− -> m (Dynamic t (Map k a)) -- ^ Dynamic map from keys to widget results
168+listWithKey :: forall t k v m a. (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
161169listWithKey vals mkChild = do
162− doc <- askDocument
163− endPlaceholder <- text' ""
164− (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
165− performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
166− children <- hold Map.empty newChildren
167− addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
168− runWidget <- getRunWidget
169− let buildChild df k v = runWidget df $ do
170− childStart <- text' ""
171− result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
172− childEnd <- text' ""
173− return (result, (childStart, childEnd))
174− schedulePostBuild $ do
175− Just df <- liftIO $ documentCreateDocumentFragment doc
176− curVals <- sample $ current vals
177− initialState <- iforM curVals $ \k v -> do
178− (result, postBuild, voidAction) <- buildChild df k v
179− return ((result, voidAction), postBuild)
180− runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
181− sequence_ $ fmap snd initialState
182− Just p <- liftIO $ nodeGetParentNode endPlaceholder
183− _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
184− return ()
185− addVoidAction $ flip fmap (updated vals) $ \newVals -> do
186− curState <- sample children
187− --TODO: Should we remove the parent from the DOM first to avoid reflows?
188− (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
189− This ((_, (start, end)), _) -> do
190− liftIO $ deleteBetweenInclusive start end
191− return Nothing
192− That v -> do
193− Just df <- liftIO $ documentCreateDocumentFragment doc
194− (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
195− let s = (childResult, childVoidAction)
196− modify (>>childPostBuild)
197− let placeholder = case Map.lookupGT k curState of
198− Nothing -> endPlaceholder
199− Just (_, ((_, (start, _)), _)) -> start
200− Just p <- liftIO $ nodeGetParentNode placeholder
201− _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
202− return $ Just s
203− These state _ -> do
204− return $ Just state
205− runFrameWithTriggerRef newChildrenTriggerRef newState
206− postBuild
207− holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
208−
209−-- | Create a dynamically-changing set of widgets from a key/value map with update Events.
210−listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m)
211− => Map k v -- ^ Initial key/value map
212− -> Event t (Map k (Maybe v)) -- ^ Event of map updates
213− -> (k -> v -> Event t v -> m a) -- ^ Function to create a widget for a given key from initial value and update Event
214− -> m (Dynamic t (Map k a)) -- ^ Dynamic map from keys to widget results
215−listWithKey' initialVals valsChanged mkChild = do
170+ postBuild <- getPostBuild
171+ rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals
172+ let changeVals :: Event t (Map k (Maybe v))
173+ changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
174+ [ updated vals
175+ , tag (current vals) postBuild
176+ ]
177+ listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
178+ mkChild k =<< holdDyn v0 dv
179+
180+{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
181+listWithKey' :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
182+listWithKey' = listWithKeyShallowDiff
183+
184+-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.
185+listWithKeyShallowDiff :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
186+listWithKeyShallowDiff initialVals valsChanged mkChild = do
187+ let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
188+ sentVals <- foldDyn (flip applyMap) Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged
189+ listHoldWithKey initialVals (attachWith (flip Map.difference) (current sentVals) valsChanged) $ \k v ->
190+ mkChild k v $ select childValChangedSelector $ Const2 k
191+
192+-- | Display the given map of items using the builder function provided, and update it with the given event. 'Nothing' entries will delete the corresponding children, and 'Just' entries will create or replace them. Since child events do not take any signal arguments, they are always rebuilt. To update a child without rebuilding, either embed signals in the map's values, or refer to them directly in the builder function.
193+listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
194+listHoldWithKey initialVals valsChanged mkChild = do
216195 doc <- askDocument
217196 endPlaceholder <- text' ""
218197 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
219198-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
220199 runWidget <- getRunWidget
221− let childValChangedSelector :: EventSelector t (Const2 k v)
222− childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
223− buildChild df k v = runWidget df $ wrapChild k v
200+ let buildChild df k v = runWidget df $ wrapChild k v
224201 wrapChild k v = do
225202 childStart <- text' ""
226− result <- mkChild k v $ select childValChangedSelector $ Const2 k
203+ result <- mkChild k v
227204 childEnd <- text' ""
228205 return (result, (childStart, childEnd))
229206 Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
@@ -273,55 +250,7 @@ listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dyna
273250listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
274251
275252listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
276−listViewWithKey' vals mkChild = do
277− doc <- askDocument
278− endPlaceholder <- text' ""
279− (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
280− performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
281− children <- hold Map.empty newChildren
282− addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
283− runWidget <- getRunWidget
284− let buildChild df k v = runWidget df $ do
285− childStart <- text' ""
286− result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
287− childEnd <- text' ""
288− return (result, (childStart, childEnd))
289− schedulePostBuild $ do
290− Just df <- liftIO $ documentCreateDocumentFragment doc
291− curVals <- sample $ current vals
292− initialState <- iforM curVals $ \k v -> do
293− (result, postBuild, voidAction) <- buildChild df k v
294− return ((result, voidAction), postBuild)
295− runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
296− sequence_ $ fmap snd initialState
297− Just p <- liftIO $ nodeGetParentNode endPlaceholder
298− _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
299− return ()
300− addVoidAction $ flip fmap (updated vals) $ \newVals -> do
301− curState <- sample children
302− --TODO: Should we remove the parent from the DOM first to avoid reflows?
303− (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
304− This ((_, (start, end)), _) -> do
305− liftIO $ deleteBetweenInclusive start end
306− return Nothing
307− That v -> do
308− Just df <- liftIO $ documentCreateDocumentFragment doc
309− (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
310− let s = (childResult, childVoidAction)
311− modify (>>childPostBuild)
312− let placeholder = case Map.lookupGT k curState of
313− Nothing -> endPlaceholder
314− Just (_, ((_, (start, _)), _)) -> start
315− mp <- liftIO $ nodeGetParentNode placeholder
316− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just placeholder) --TODO: Should this really be ignored if mp is Nothing, or should we ensure that mp is never Nothing
317− return $ Just s
318− These state _ -> do
319− return $ Just state
320− runFrameWithTriggerRef newChildrenTriggerRef newState
321− postBuild
322− return $ fmap (fmap (fst . fst)) children
323−
324−--TODO: Deduplicate the various list*WithKey* implementations
253+listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
325254
326255-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
327256selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)