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