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