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