git.iko.soy/patch
on c641dcf help sign in
patch/src/Reflex/Collection.hs
220 lines 8.2 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.Adjustable.Class
38import Reflex.Dynamic
39import Reflex.PostBuild.Class
41listHoldWithKey
42 :: forall t m k v a
43 . (Ord k, Adjustable t m, MonadHold t m)
44 => Map k v
45 -> Event t (Map k (Maybe v))
46 -> (k -> v -> m a)
47 -> m (Dynamic t (Map k a))
48listHoldWithKey m0 m' f = do
49 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
50 dm' = fmap
51 (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey
52 (\k v -> ComposeMaybe $ fmap (f k) v)
53 )
54 m'
55 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
57 --TODO: Move the dmapToMap to the righthand side so it doesn't get
58 --fully redone every time
59 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'
61--TODO: Something better than Dynamic t (Map k v) - we want something
62--where the Events carry diffs, not the whole value
63listWithKey
64 :: forall t k v m a
65 . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m)
66 => Dynamic t (Map k v)
67 -> (k -> Dynamic t v -> m a)
68 -> m (Dynamic t (Map k a))
69listWithKey vals mkChild = do
70 postBuild <- getPostBuild
71 let childValChangedSelector = fanMap $ updated vals
73 -- We keep track of changes to children values in the mkChild
74 -- function we pass to listHoldWithKey The other changes we need
75 -- to keep track of are child insertions and
76 -- deletions. diffOnlyKeyChanges keeps track of insertions and
77 -- deletions but ignores value changes, since they're already
78 -- accounted for.
79 diffOnlyKeyChanges olds news =
80 flip Map.mapMaybe (align olds news) $ \case
81 This _ -> Just Nothing
82 These _ _ -> Nothing
83 That new -> Just $ Just new
84 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
85 let changeVals :: Event t (Map k (Maybe v))
86 changeVals =
87 attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
88 [ updated vals
90 -- TODO: This should probably be added to the
91 -- attachWith, not to the updated; if we were using
92 -- diffMap instead of diffMapNoEq, I think it might not
93 -- work
94 , tag (current vals) postBuild
95 ]
96 listHoldWithKey Map.empty changeVals $ \k v ->
97 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
99{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
100listWithKey'
101 :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m)
102 => Map k v
103 -> Event t (Map k (Maybe v))
104 -> (k -> v -> Event t v -> m a)
105 -> m (Dynamic t (Map k a))
106listWithKey' = listWithKeyShallowDiff
108-- | Display the given map of items (in key order) using the builder
109-- function provided, and update it with the given event. 'Nothing'
110-- update entries will delete the corresponding children, and 'Just'
111-- entries will create them if they do not exist or send an update
112-- event to them if they do.
113listWithKeyShallowDiff
114 :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m)
115 => Map k v
116 -> Event t (Map k (Maybe v))
117 -> (k -> v -> Event t v -> m a)
118 -> m (Dynamic t (Map k a))
119listWithKeyShallowDiff initialVals valsChanged mkChild = do
120 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
121 sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged
122 let relevantPatch patch _ = case patch of
124 -- Even if we let a Nothing through when the element doesn't
125 -- already exist, this doesn't cause a problem because it is
126 -- ignored
127 Nothing -> Just Nothing
129 -- We don't want to let spurious re-creations of items through
130 Just _ -> Nothing
131 listHoldWithKey
132 initialVals
133 (attachWith (flip (Map.differenceWith relevantPatch))
134 (current sentVals)
135 valsChanged
136 )
137 $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k
139--TODO: Something better than Dynamic t (Map k v) - we want something
140--where the Events carry diffs, not the whole value
141-- | Create a dynamically-changing set of Event-valued widgets. This
142-- is like 'listWithKey', specialized for widgets returning @/Event t a/@.
143-- 'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in
144-- this scenario, but 'listViewWithKey' flattens this to
145-- @/Event t (Map k a)/@ via 'switch'.
146listViewWithKey
147 :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)
148 => Dynamic t (Map k v)
149 -> (k -> Dynamic t v -> m (Event t a))
150 -> m (Event t (Map k a))
151listViewWithKey vals mkChild =
152 switch . fmap mergeMap <$> listViewWithKey' vals mkChild
154listViewWithKey'
155 :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)
156 => Dynamic t (Map k v)
157 -> (k -> Dynamic t v -> m a)
158 -> m (Behavior t (Map k a))
159listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
161-- | Create a dynamically-changing set of widgets, one of which is
162-- selected at any time.
163selectViewListWithKey
164 :: forall t m k v a
165 . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
166 => Dynamic t k
167 -- ^ Current selection key
168 -> Dynamic t (Map k v)
169 -- ^ Dynamic key/value map
170 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))
171 -- ^ Function to create a widget for a given key from Dynamic value
172 -- and Dynamic Bool indicating if this widget is currently selected
173 -> m (Event t (k, a))
174 -- ^ Event that fires when any child's return Event fires. Contains
175 -- key of an arbitrary firing widget.
176selectViewListWithKey selection vals mkChild = do
177 -- For good performance, this value must be shared across all children
178 let selectionDemux = demux selection
179 selectChild <- listWithKey vals $ \k v -> do
180 let selected = demuxed selectionDemux k
181 selectSelf <- mkChild k v selected
182 return $ fmap ((,) k) selectSelf
183 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
185selectViewListWithKey_
186 :: forall t m k v a
187 . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
188 => Dynamic t k
189 -- ^ Current selection key
190 -> Dynamic t (Map k v)
191 -- ^ Dynamic key/value map
192 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))
193 -- ^ Function to create a widget for a given key from Dynamic value
194 -- and Dynamic Bool indicating if this widget is currently selected
195 -> m (Event t k)
196 -- ^ Event that fires when any child's return Event fires. Contains
197 -- key of an arbitrary firing widget.
198selectViewListWithKey_ selection vals mkChild =
199 fmap fst <$> selectViewListWithKey selection vals mkChild
201-- | Create a dynamically-changing set of widgets from a Dynamic
202-- key/value map. Unlike the 'withKey' variants, the child widgets
203-- are insensitive to which key they're associated with.
204list
205 :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)
206 => Dynamic t (Map k v)
207 -> (Dynamic t v -> m a)
208 -> m (Dynamic t (Map k a))
209list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
211-- | Create a dynamically-changing set of widgets from a Dynamic list.
212simpleList
213 :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)
214 => Dynamic t [v]
215 -> (Dynamic t v -> m a)
216 -> m (Dynamic t [a])
217simpleList xs mkChild =
218 fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap
219 (Map.fromList . zip [(1 :: Int) ..])
220 xs