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