git.iko.soy/patch
on f79064d help sign in
patch/src/Reflex/Collection.hs
222 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
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#if defined(MIN_VERSION_semialign)
31import Prelude hiding (zip, zipWith)
32#endif
34import Control.Monad.Identity
35import Data.Align
36import Data.Functor.Misc
37import Data.Map (Map)
38import qualified Data.Map as Map
39import Data.Map.Misc
40import Data.These
42import Reflex.Class
43import Reflex.Adjustable.Class
44import Reflex.Dynamic
45import Reflex.PostBuild.Class
47-- | Create a set of widgets based on the provided 'Map'. When the
48-- input 'Event' fires, remove widgets for keys with the value 'Nothing'
49-- and add/replace widgets for keys with 'Just' values.
50listHoldWithKey
51 :: forall t m k v a
52 . (Ord k, Adjustable t m, MonadHold t m)
53 => Map k v
54 -> Event t (Map k (Maybe v))
55 -> (k -> v -> m a)
56 -> m (Dynamic t (Map k a))
57listHoldWithKey m0 m' f = do
58 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
59 dm' = fmap
60 (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey
61 (\k v -> ComposeMaybe $ fmap (f k) v)
62 )
63 m'
64 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
66 --TODO: Move the dmapToMap to the righthand side so it doesn't get
67 --fully redone every time
68 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'
70--TODO: Something better than Dynamic t (Map k v) - we want something
71--where the Events carry diffs, not the whole value
72listWithKey
73 :: forall t k v m a
74 . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m)
75 => Dynamic t (Map k v)
76 -> (k -> Dynamic t v -> m a)
77 -> m (Dynamic t (Map k a))
78listWithKey vals mkChild = do
79 postBuild <- getPostBuild
80 let childValChangedSelector = fanMap $ updated vals
82 -- We keep track of changes to children values in the mkChild
83 -- function we pass to listHoldWithKey The other changes we need
84 -- to keep track of are child insertions and
85 -- deletions. diffOnlyKeyChanges keeps track of insertions and
86 -- deletions but ignores value changes, since they're already
87 -- accounted for.
88 diffOnlyKeyChanges olds news =
89 flip Map.mapMaybe (align olds news) $ \case
90 This _ -> Just Nothing
91 These _ _ -> Nothing
92 That new -> Just $ Just new
93 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
94 let changeVals :: Event t (Map k (Maybe v))
95 changeVals =
96 attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
97 [ updated vals
99 -- TODO: This should probably be added to the
100 -- attachWith, not to the updated; if we were using
101 -- diffMap instead of diffMapNoEq, I think it might not
102 -- work
103 , tag (current vals) postBuild
104 ]
105 listHoldWithKey Map.empty changeVals $ \k v ->
106 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
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
185-- | Like 'selectViewListWithKey' but discards the value of the list
186-- item widget's output 'Event'.
187selectViewListWithKey_
188 :: forall t m k v a
189 . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
190 => Dynamic t k
191 -- ^ Current selection key
192 -> Dynamic t (Map k v)
193 -- ^ Dynamic key/value map
194 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))
195 -- ^ Function to create a widget for a given key from Dynamic value
196 -- and Dynamic Bool indicating if this widget is currently selected
197 -> m (Event t k)
198 -- ^ Event that fires when any child's return Event fires. Contains
199 -- key of an arbitrary firing widget.
200selectViewListWithKey_ selection vals mkChild =
201 fmap fst <$> selectViewListWithKey selection vals mkChild
203-- | Create a dynamically-changing set of widgets from a Dynamic
204-- key/value map. Unlike the 'withKey' variants, the child widgets
205-- are insensitive to which key they're associated with.
206list
207 :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)
208 => Dynamic t (Map k v)
209 -> (Dynamic t v -> m a)
210 -> m (Dynamic t (Map k a))
211list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
213-- | Create a dynamically-changing set of widgets from a Dynamic list.
214simpleList
215 :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)
216 => Dynamic t [v]
217 -> (Dynamic t v -> m a)
218 -> m (Dynamic t [a])
219simpleList xs mkChild =
220 fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap
221 (Map.fromList . zip [(1 :: Int) ..])
222 xs