-
Notifications
You must be signed in to change notification settings - Fork 12
/
Collection.hs
248 lines (227 loc) · 10.2 KB
/
Collection.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE DoRec, ScopedTypeVariables, DeriveFunctor #-}
-- | Collection signals with incremental updates.
module FRP.Euphoria.Collection
( CollectionUpdate (..)
, Collection
, simpleCollection
, watchCollection
, listToCollection
, mapToCollection
, followCollectionKey
, collectionToDiscreteList
) where
import Control.Applicative
import Data.EnumMap (EnumMap)
import qualified Data.EnumMap as EnumMap
import Data.List
import Data.Maybe (mapMaybe)
import Data.Monoid
import FRP.Euphoria.Event
-- | Represents an incremental change to a collection of items.
data CollectionUpdate k a
= AddItem k a
| RemoveItem k
deriving (Functor)
-- | An FRP interface for representing an incrementally updated
-- collection of items. The items are identified by a unique key.
-- Items may be added or removed from the current collection.
--
-- This type is useful because it allows you to manage the incremental
-- state updates to something that needs a collection of items without
-- having to rebuild it completely every time the collection changes.
-- Consider the type Signal [a] -- functionally, it also represents a
-- collection of items that changes over time. However, there is no
-- state carried between changes. If, for example, we have a GUI
-- widget that lists items whose content is represented as a Signal
-- [a], we would have to destroy and rebuild the widget's internal
-- state every time the list contents change. But with the Collection
-- type, we can add or remove from the GUI widget only the necessary
-- items. This is useful both from a performance (most existing GUI
-- toolkits exhibit worse performance when adding and removing all
-- items with every change) and behavior standpoint, because the GUI
-- toolkit can, for example, remember which items the user had
-- selected between list updates.
--
-- Usage of 'Collection' implies there could be some caching/state by
-- the consumer of the Events, otherwise one might as well use a
-- Signal [a].
type Collection k a = Discrete ([(k, a)], Event (CollectionUpdate k a))
-- | A collection whose items are created by an event, and removed by
-- another event.
simpleCollection :: (Enum k)
=> k
-- ^ The initial value for the unique keys. 'succ'
-- will be used to get further keys.
-> Event (a, Event ())
-- ^ An Event that introduces a new item and its
-- subsequent removal Event. The item will be removed
-- from the collection when the Event () fires.
-> SignalGen (Collection k a)
simpleCollection initialK evs =
simpleCollectionUpdates initialK evs >>= accumCollection
simpleCollectionUpdates :: (Enum k) => k
-> Event (a, Event ())
-> SignalGen (Event (CollectionUpdate k a))
simpleCollectionUpdates initialK evs = do
let addKey (a, ev) k = (succ k, (k, a, ev))
newEvents <- scanAccumE initialK (addKey <$> evs)
let addItem (k, _a, ev) = EnumMap.insert k ev
rec
removalEvent' <- delayE removalEvent
removalEvents <- accumD EnumMap.empty
((addItem <$> newEvents) `mappend` (EnumMap.delete <$> removalEvent'))
removalEvent <- switchD $ EnumMap.foldWithKey
(\k ev ev' -> (k <$ ev) `mappend` ev') mempty <$> removalEvents
let -- updateAddItem :: (Enum k) => (k, a, Event ()) -> CollectionUpdate k a
updateAddItem (k, a, _) = AddItem k a
memoE $ (updateAddItem <$> newEvents) `mappend` (RemoveItem <$> removalEvent)
-- Turns adds the necessary state for holding the existing [(k, a)]
-- and creating the unique Event stream for each change of the
-- collection.
accumCollection :: (Enum k)
=> Event (CollectionUpdate k a)
-> SignalGen (Collection k a)
accumCollection ev = do
let toMapOp (AddItem k a) = EnumMap.insert k a
toMapOp (RemoveItem k) = EnumMap.delete k
mapping <- accumD EnumMap.empty (toMapOp <$> ev)
let -- f :: (Enum k) => EnumMap k a -> SGen ([(k, a)], Event (CollectionUpdate k a))
f m = do
ev' <- dropStepE ev
return (EnumMap.toList m, ev')
generatorD $ f <$> mapping
-- | Prints add/remove diagnostics for a Collection. Useful for debugging
watchCollection :: (Show k, Show a)
=> Collection k a -> SignalGen (Event (IO ()))
watchCollection coll = do
ev1 <- takeE 1 =<< preservesD coll
now <- onCreation ()
let f (items, ev) = ((putStrLn . showUpdate) <$> ev) `mappend`
(mapM_ (putStrLn . showExisting) items <$ now)
showUpdate (AddItem k a) = "Add: " ++ show k ++ ", " ++ show a
showUpdate (RemoveItem k) = "Remove: " ++ show k
showExisting (k, a) = "Existing: " ++ show k ++ ", " ++ show a
switchD =<< stepperD mempty (f <$> ev1)
-- | A somewhat inefficient but easy-to-use way of turning a list of
-- items into a Collection. Probably should only be used for temporary
-- hacks. Will perform badly with large lists.
listToCollection :: (Enum k, Eq a)
=> k
-> Discrete [a]
-> SignalGen (Collection k a)
listToCollection initialK valsD = do
valsE <- preservesD valsD
evs <- scanAccumE (initialK, EnumMap.empty) (stepListCollState <$> valsE)
accumCollection (flattenE evs)
-- This could obviously be implemented more efficiently.
stepListCollState :: (Enum k, Eq a) => [a]
-> (k, EnumMap k a)
-> ((k, EnumMap k a), [CollectionUpdate k a])
stepListCollState xs (initialK, existingMap) = ((k', newMap'), removeUpdates ++ addUpdates)
where
keyvals = EnumMap.toList existingMap
newItems = xs \\ map snd keyvals
removedKeys = map fst $ deleteFirstsBy
(\(_, x) (_, y) -> x == y)
keyvals
(map (\x -> (initialK, x)) xs)
(newMap, removeUpdates) = foldl
(\(em, upds) k -> (EnumMap.delete k em, upds ++ [RemoveItem k]))
(existingMap, []) removedKeys
(k', newMap', addUpdates) = foldl
(\(k, em, upds) x -> (succ k, EnumMap.insert k x em, upds ++ [AddItem k x]))
(initialK, newMap, []) newItems
data MapCollEvent k a
= MCNew k a
| MCChange k a
| MCRemove k
mapCollDiff :: (Enum k, Eq a) => EnumMap k a -> EnumMap k a -> [MapCollEvent k a]
mapCollDiff prevmap newmap = newEvs ++ removeEvs ++ changeEvs
where
newStuff = newmap EnumMap.\\ prevmap
removedStuff = prevmap EnumMap.\\ newmap
keptStuff = newmap `EnumMap.intersection` prevmap
changedStuff = mapMaybe f (EnumMap.toList keptStuff)
where f (k, v1) = case EnumMap.lookup k prevmap of
Nothing -> Nothing
Just v2 | v1 /= v2 -> Just (k, v1)
| otherwise -> Nothing
makeNew (k, v) = MCNew k v
makeRemove (k, _) = MCRemove k
makeChange (k, v) = MCChange k v
newEvs = map makeNew (EnumMap.toList newStuff)
removeEvs = map makeRemove (EnumMap.toList removedStuff)
changeEvs = map makeChange changedStuff
dispatchCollEvent :: (Enum k, Eq k, Eq a)
=> Event (MapCollEvent k a)
-> SignalGen (Collection k (Discrete a))
dispatchCollEvent mapcollE = do
let f (MCChange k a) = Just (k, a)
f _ = Nothing
changeEv <- memoE $ filterNothingE (f <$> mapcollE)
let g (MCNew k a) = Just $
AddItem k <$> followCollItem a k changeEv
g (MCRemove k) = Just $ return $ RemoveItem k
g (MCChange _ _) = Nothing
updateEv <- generatorE $ filterNothingE (g <$> mapcollE)
accumCollection updateEv
followCollItem :: (Eq k) => a -> k
-> Event (k, a)
-> SignalGen (Discrete a)
followCollItem val k1 ev = stepperD val (filterNothingE (f <$> ev))
where f (k2, v) | k1 == k2 = Just v
| otherwise = Nothing
-- | Turns mapping of values into a collection of first-class FRP
-- values that are updated. If items are added to the EnumMap, then
-- they will be added to the Collection. Likewise, if they are removed
-- from the mapping, they will be removed from the collection. Keys
-- that are present in both but have new values will have their
-- Discrete value updated, and keys with values that are still present
-- will not have their Discrete values updated.
mapToCollection :: forall k a.
(Enum k, Eq k, Eq a)
=> Discrete (EnumMap k a)
-> SignalGen (Collection k (Discrete a))
mapToCollection mapD = do
m1 <- delayD EnumMap.empty mapD
let collDiffs :: Discrete [MapCollEvent k a]
collDiffs = mapCollDiff <$> m1 <*> mapD
dispatchCollEvent . flattenE =<< preservesD collDiffs
-- | Look for a key in a collection, and give its (potentially
-- nonexistant) value over time.
followCollectionKey :: forall k a. (Eq k)
=> k
-> Collection k a
-> SignalGen (Discrete (Maybe a))
followCollectionKey k coll = do
collAsNow <- takeE 1 =<< preservesD coll
:: SignalGen (Event ([(k, a)], Event (CollectionUpdate k a)))
let existing :: Event (CollectionUpdate k a)
existing = flattenE $ initialAdds . fst <$> collAsNow
further :: Event (Event (CollectionUpdate k a))
further = snd <$> collAsNow
further' <- switchD =<< stepperD mempty further
:: SignalGen (Event (CollectionUpdate k a))
accumMatchingItem (== k) (existing `mappend` further')
-- Turn the existing items into AddItems for our state accumulation
initialAdds :: [(k, a)] -> [CollectionUpdate k a]
initialAdds = map (uncurry AddItem)
-- Accumulate CollectionUpdates, and keep the newest value whose key
-- is True for the given function.
accumMatchingItem :: forall k a.
(k -> Bool)
-> Event (CollectionUpdate k a)
-> SignalGen (Discrete (Maybe a))
accumMatchingItem f updateE =
stepperD Nothing $ filterNothingE (g <$> updateE)
where
g :: CollectionUpdate k a -> Maybe (Maybe a)
g (AddItem k a) | f k = Just (Just a)
| otherwise = Nothing
g (RemoveItem k) | f k = Just Nothing
| otherwise = Nothing
-- | Extracts a 'Discrete' which represents the current state of
-- a collection.
collectionToDiscreteList :: Collection k a -> Discrete [(k, a)]
collectionToDiscreteList = fmap fst