git.iko.soy/reflex
on 0f5b87d help sign in
reflex/src/Reflex/Patch.hs
387 lines 18 kB history raw
1-- | This module defines the 'Patch' class, which is used by Reflex to manage
2-- changes to 'Reflex.Class.Incremental' values.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DeriveFoldable #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveTraversable #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE Rank2Types #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TypeFamilies #-}
16module Reflex.Patch
17 ( Patch (..)
18 , PatchDMap (..)
19 , mapPatchDMap
20 , traversePatchDMap
21 , traversePatchDMapWithKey
22 , weakenPatchDMapWith
23 , patchDMapToPatchMapWith
24 , const2PatchDMapWith
25 , ComposeMaybe (..)
26 , PatchMap (..)
27 , patchMapNewElements
28 , Group (..)
29 , Additive
30 , AdditivePatch (..)
31 , PatchMapWithMove
32 , unPatchMapWithMove
33 , unsafePatchMapWithMove
34 , patchMapWithMoveNewElements
35 , MapEdit (..)
36 , mapEditMoved
37 , mapEditSetMoved
38 , PatchDMapWithMove
39 , unPatchDMapWithMove
40 , unsafePatchDMapWithMove
41 , patchThatSortsMapWith
42 , patchThatChangesAndSortsMapWith
43 , mapPatchDMapWithMove
44 , traversePatchDMapWithMove
45 , traversePatchDMapWithMoveWithKey
46 , weakenPatchDMapWithMoveWith
47 , patchDMapWithMoveToPatchMapWithMoveWith
48 , const2PatchDMapWithMoveWith
49 , DMapEdit (..)
50 , dmapEditMoved
51 -- * Test functions
52 , validPatchMapWithMove
53 , knownValidPatchMapWithMove
54 , knownInvalidPatchMapWithMove
55 ) where
57import Control.Arrow
58import Control.Monad.Identity
59import Control.Monad.State
60import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
61import qualified Data.Dependent.Map as DMap
62import Data.Foldable
63import Data.Function
64import Data.Functor.Constant
65import Data.Functor.Misc
66import Data.List
67import Data.Map (Map)
68import qualified Data.Map as Map
69import Data.Maybe
70import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))
71import qualified Data.Set as Set
72import Data.Some (Some)
73import qualified Data.Some as Some
74import Data.Tuple
76-- | A 'Patch' type represents a kind of change made to a datastructure.
77class Patch p where
78 type PatchTarget p :: *
79 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
80 -- 'Nothing'.
81 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
83-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
84-- make the 'f' parameter have a nominal type role. We need f to be
85-- representational so that we can use safe 'coerce'.
86newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }
88deriving instance Functor f => Functor (ComposeMaybe f)
90instance Patch (Identity a) where
91 type PatchTarget (Identity a) = a
92 apply (Identity a) _ = Just a
94-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
95-- deleted.
96newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))
98deriving instance GCompare k => Semigroup (PatchDMap k v)
100deriving instance GCompare k => Monoid (PatchDMap k v)
102instance GCompare k => Patch (PatchDMap k v) where
103 type PatchTarget (PatchDMap k v) = DMap k v
104 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
105 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
106 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
107 nothingToJust = \case
108 Nothing -> Just $ Constant ()
109 Just _ -> Nothing
111mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
112mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
114traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
115traversePatchDMap f = traversePatchDMapWithKey $ const f
117traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
118traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
120weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
121weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
123patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
124patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
126const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
127const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
128 where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)
129 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
131-- | A set of changes to a 'Map'. Any element may be inserted/updated or
132-- deleted.
133newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
135instance Ord k => Patch (PatchMap k v) where
136 type PatchTarget (PatchMap k v) = Map k v
137 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
138 where insertions = Map.mapMaybeWithKey (const id) p
139 deletions = Map.mapMaybeWithKey (const nothingToJust) p
140 nothingToJust = \case
141 Nothing -> Just ()
142 Just _ -> Nothing
144instance Ord k => Semigroup (PatchMap k v) where
145 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
146 -- PatchMap is idempotent, so stimes n is id for every n
147#if MIN_VERSION_semigroups(0,17,0)
148 stimes = stimesIdempotentMonoid
149#else
150 times1p n x = case compare n 0 of
151 LT -> error "stimesIdempotentMonoid: negative multiplier"
152 EQ -> mempty
153 GT -> x
154#endif
156instance Ord k => Monoid (PatchMap k v) where
157 mempty = PatchMap mempty
158 mappend = (<>)
160instance Functor (PatchMap k) where
161 fmap f = PatchMap . fmap (fmap f) . unPatchMap
163-- | Returns all the new elements that will be added to the 'Map'
164patchMapNewElements :: PatchMap k v -> [v]
165patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
167---- Patches based on commutative groups
169-- | A 'Group' is a 'Monoid' where every element has an inverse.
170class (Semigroup q, Monoid q) => Group q where
171 negateG :: q -> q
172 (~~) :: q -> q -> q
173 r ~~ s = r <> negateG s
175-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
176class Semigroup q => Additive q where
178-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
179newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
181instance Additive p => Patch (AdditivePatch p) where
182 type PatchTarget (AdditivePatch p) = p
183 apply (AdditivePatch p) q = Just $ p <> q
185data MapEdit k v
186 = MapEdit_Insert Bool v -- ^ Insert the given value here
187 | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here
188 | MapEdit_Move Bool k -- ^ Move the value here from the given key
189 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
191mapEditMoved :: MapEdit k v -> Bool
192mapEditMoved = \case
193 MapEdit_Insert moved _ -> moved
194 MapEdit_Delete moved -> moved
195 MapEdit_Move moved _ -> moved
197mapEditSetMoved :: Bool -> MapEdit k v -> MapEdit k v
198mapEditSetMoved moved = \case
199 MapEdit_Insert _ v -> MapEdit_Insert moved v
200 MapEdit_Delete _ -> MapEdit_Delete moved
201 MapEdit_Move _ k -> MapEdit_Move moved k
203-- | Patch a DMap with additions, deletions, and moves.
204-- Invariants:
205-- * The same source key may not be moved to two destination keys.
206-- * Any key that is the source of a Move must also be edited
207-- (otherwise, the Move would duplicate it)
208data PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
210unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)
211unPatchMapWithMove (PatchMapWithMove p) = p
213-- | Warning: when using this function, you must ensure that the invariants of
214-- 'PatchMapWithMove' are preserved; they will not be checked.
215unsafePatchMapWithMove :: Map k (MapEdit k v) -> PatchMapWithMove k v
216unsafePatchMapWithMove = PatchMapWithMove
218instance Ord k => Patch (PatchMapWithMove k v) where
219 type PatchTarget (PatchMapWithMove k v) = Map k v
220 apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
221 where insertions = flip Map.mapMaybeWithKey p $ const $ \case
222 MapEdit_Insert _ v -> Just v
223 MapEdit_Move _ k -> Map.lookup k old
224 MapEdit_Delete _ -> Nothing
225 deletions = flip Map.mapMaybeWithKey p $ const $ \case
226 MapEdit_Delete _ -> Just ()
227 _ -> Nothing
229-- | Returns all the new elements that will be added to the 'Map'
230patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
231patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ flip fmap (Map.elems p) $ \case
232 MapEdit_Insert _ v -> Just v
233 MapEdit_Move _ _ -> Nothing
234 MapEdit_Delete _ -> Nothing
236validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
237validPatchMapWithMove (PatchMapWithMove p) =
238 let moveSources = catMaybes $ flip fmap (Map.elems p) $ \case
239 MapEdit_Move _ k -> Just k
240 _ -> Nothing
241 in and
242 [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations
243 all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources
244 , -- All Move source keys must also be patched - since the value's being moved elsewhere, the original must either be Deleted or replaced (with Insert or Move)
245 all (isJust . flip Map.lookup p) moveSources
246 ]
248knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
249knownValidPatchMapWithMove =
250 [ PatchMapWithMove mempty
251 , PatchMapWithMove $ Map.fromList
252 [ (1, MapEdit_Move True 2)
253 , (2, MapEdit_Move True 1)
254 ]
255 ]
257knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
258knownInvalidPatchMapWithMove =
259 [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
260 PatchMapWithMove $ Map.singleton 1 $ MapEdit_Move False 2
261 , -- Invalid because we have multiple moves from 3
262 PatchMapWithMove $ Map.fromList
263 [ (1, MapEdit_Move False 3)
264 , (2, MapEdit_Move False 3)
265 , (3, MapEdit_Delete True)
266 ]
267 ]
269patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
270patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g l $ sortBy (cmp `on` snd) l
271 where l = Map.toList m
272 g (to, _) (from, _) = if to == from
273 then Nothing
274 else Just (to, MapEdit_Move True from)
276patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
277patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
278 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
279 newList = Map.toList newByIndexUnsorted
280 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
281 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
282 let f k v = do
283 remainingValues <- get
284 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
285 then Map.delete v remainingValues
286 else Map.insert v remainingKeys remainingValues
287 case Map.lookup v remainingValues of
288 Nothing -> return $ MapEdit_Insert True v -- There's no existing value we can take
289 Just fromKs ->
290 if k `Set.member` fromKs
291 then do
292 putRemainingKeys $ Set.delete k fromKs
293 return $ MapEdit_Move True k -- There's an existing value, and it's here, so no patch necessary
294 else do
295 Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
296 putRemainingKeys remainingKeys
297 return $ MapEdit_Move True fromK
298 Map.traverseWithKey f newByIndex
299 unusedOldKeys = fold unusedValuesByValue
300 pointlessMove k = \case
301 MapEdit_Move _ k' | k == k' -> True
302 _ -> False
303 keyWasMoved k = k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
304 patch = unsafePatchMapWithMove $ Map.filterWithKey (\k v -> not $ pointlessMove k v) $ Map.mergeWithKey (\k a _ -> Just $ mapEditSetMoved (keyWasMoved k) a) (Map.mapWithKey $ \k -> mapEditSetMoved $ keyWasMoved k) (Map.mapWithKey $ \k _ -> MapEdit_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
306data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
307 -- | Insert the given value here
308 DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a
309 -- | Delete the existing value, if any, from here
310 DMapEdit_Delete :: Bool -> DMapEdit k v a
311 -- | Move the value here from the given key
312 DMapEdit_Move :: Bool -> k a -> DMapEdit k v a
314dmapEditMoved :: DMapEdit k v a -> Bool
315dmapEditMoved = \case
316 DMapEdit_Insert moved _ -> moved
317 DMapEdit_Delete moved -> moved
318 DMapEdit_Move moved _ -> moved
320-- | Like 'PatchMapWithMove', but for 'DMap'.
321newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v))
323unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
324unPatchDMapWithMove (PatchDMapWithMove p) = p
326-- | Warning: when using this function, you must ensure that the invariants of
327-- 'PatchDMapWithMove' are preserved; they will not be checked.
328unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
329unsafePatchDMapWithMove = PatchDMapWithMove
331mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
332mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p
333 where g :: forall a. DMapEdit k v a -> DMapEdit k v' a
334 g = \case
335 DMapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
336 DMapEdit_Delete moved -> DMapEdit_Delete moved
337 DMapEdit_Move moved k -> DMapEdit_Move moved k
339traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
340traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
342traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
343traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey g p
344 where g :: forall a. k a -> DMapEdit k v a -> m (DMapEdit k v' a)
345 g k = \case
346 DMapEdit_Insert moved v -> DMapEdit_Insert moved <$> f k v
347 DMapEdit_Delete moved -> pure $ DMapEdit_Delete moved
348 DMapEdit_Move moved fromKey -> pure $ DMapEdit_Move moved fromKey
350weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
351weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
352 where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'
353 g = \case
354 DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
355 DMapEdit_Delete moved -> MapEdit_Delete moved
356 DMapEdit_Move moved k -> MapEdit_Move moved $ Some.This k
358patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
359patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
360 where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'
361 g = \case
362 DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
363 DMapEdit_Delete moved -> MapEdit_Delete moved
364 DMapEdit_Move moved (Const2 k) -> MapEdit_Move moved k
366const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
367const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
368 where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)
369 g (k, e) = Const2 k :=> case e of
370 MapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
371 MapEdit_Delete moved -> DMapEdit_Delete moved
372 MapEdit_Move moved fromKey -> DMapEdit_Move moved $ Const2 fromKey
374instance GCompare k => Patch (PatchDMapWithMove k v) where
375 type PatchTarget (PatchDMapWithMove k v) = DMap k v
376 apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
377 where insertions = DMap.mapMaybeWithKey insertFunc p
378 insertFunc :: forall a. k a -> DMapEdit k v a -> Maybe (v a)
379 insertFunc _ = \case
380 DMapEdit_Insert _ v -> Just v
381 DMapEdit_Move _ k -> DMap.lookup k old
382 DMapEdit_Delete _ -> Nothing
383 deletions = DMap.mapMaybeWithKey deleteFunc p
384 deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)
385 deleteFunc _ = \case
386 DMapEdit_Delete _ -> Just $ Constant ()
387 _ -> Nothing