git.iko.soy/patch
on 538e879 help sign in
patch/src/Reflex/Collection.hs
120 lines 7.8 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE UndecidableInstances #-}
10#ifdef USE_REFLEX_OPTIMIZER
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12#endif
13module Reflex.Collection
14 (
15 -- * Widgets on Collections
16 listHoldWithKey
17 , listWithKey
18 , listWithKey'
19 , listWithKeyShallowDiff
20 , listViewWithKey
21 , selectViewListWithKey
22 , selectViewListWithKey_
23 -- * List Utils
24 , list
25 , simpleList
26 ) where
28import Control.Monad.Identity
29import Data.Align
30import Data.Functor.Misc
31import Data.Map (Map)
32import qualified Data.Map as Map
33import Data.Map.Misc
34import Data.These
36import Reflex.Class
37import Reflex.Dynamic
38import Reflex.PostBuild.Class
40listHoldWithKey :: forall t m k v a. (Ord k, Adjustable t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
41listHoldWithKey m0 m' f = do
42 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
43 dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
44 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
45 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
47--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
48listWithKey :: forall t k v m a. (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
49listWithKey vals mkChild = do
50 postBuild <- getPostBuild
51 let childValChangedSelector = fanMap $ updated vals
52 -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
53 -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
54 -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
55 diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
56 This _ -> Just Nothing
57 These _ _ -> Nothing
58 That new -> Just $ Just new
59 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
60 let changeVals :: Event t (Map k (Maybe v))
61 changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
62 [ updated vals
63 , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work
64 ]
65 listHoldWithKey Map.empty changeVals $ \k v ->
66 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
68{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
69listWithKey' :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
70listWithKey' = listWithKeyShallowDiff
72-- | 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.
73listWithKeyShallowDiff :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
74listWithKeyShallowDiff initialVals valsChanged mkChild = do
75 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
76 sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged
77 let relevantPatch patch _ = case patch of
78 Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
79 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
80 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
81 mkChild k v $ select childValChangedSelector $ Const2 k
83--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
84-- | Create a dynamically-changing set of Event-valued widgets.
85-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.
86listViewWithKey :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
87listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
89listViewWithKey' :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
90listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
92-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
93selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
94 => Dynamic t k -- ^ Current selection key
95 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
96 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
97 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
98selectViewListWithKey selection vals mkChild = do
99 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
100 selectChild <- listWithKey vals $ \k v -> do
101 let selected = demuxed selectionDemux k
102 selectSelf <- mkChild k v selected
103 return $ fmap ((,) k) selectSelf
104 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
106selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
107 => Dynamic t k -- ^ Current selection key
108 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
109 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
110 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
111selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
113-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
114-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
115list :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
116list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
118-- | Create a dynamically-changing set of widgets from a Dynamic list.
119simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
120simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs