@@ -1,181 +1,18 @@
1-- | This module defines the 'Patch' class, which is used by Reflex to manage
1-- | This module defines the 'Patch' class, which is used by Reflex to manage
2-- changes to 'Reflex.Class.Incremental' values.
2-- changes to 'Reflex.Class.Incremental' values.
4−{-# LANGUAGE DeriveFoldable #-}
5−{-# LANGUAGE DeriveFunctor #-}
6−{-# LANGUAGE DeriveTraversable #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE FlexibleInstances #-}
10−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11−{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE MultiParamTypeClasses #-}
13−{-# LANGUAGE PolyKinds #-}
14−{-# LANGUAGE Rank2Types #-}
15−{-# LANGUAGE ScopedTypeVariables #-}
16−{-# LANGUAGE StandaloneDeriving #-}
17{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
18−{-# LANGUAGE UndecidableInstances #-}
19module Reflex.Patch
4module Reflex.Patch
20−{- ( Patch (..)
5+ ( module Reflex.Patch
21− , PatchDMap (..)
6+ , module X
24− , traversePatchDMapWithKey
25− , weakenPatchDMapWith
26− , patchDMapToPatchMapWith
27− , const2PatchDMapWith
30− , patchMapNewElements
36− , unsafePatchMapWithMove
37− , patchMapWithMoveNewElements
42−-- , unPatchDMapWithMove
43− , unsafePatchDMapWithMove
44− , patchThatSortsMapWith
45− , patchThatChangesAndSortsMapWith
46− , mapPatchDMapWithMove
47− , traversePatchDMapWithMove
48− , traversePatchDMapWithMoveWithKey
49− , weakenPatchDMapWithMoveWith
50− , patchDMapWithMoveToPatchMapWithMoveWith
51− , const2PatchDMapWithMoveWith
55− , validPatchMapWithMove
56− , knownValidPatchMapWithMove
57− , knownInvalidPatchMapWithMove
60−import Control.Arrow
9+import Reflex.Patch.Class as X
61−import Control.Monad.Identity
10+import Reflex.Patch.DMap as X
62−import Control.Monad.State
11+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)
63−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
12+import Reflex.Patch.Map as X
64−import qualified Data.Dependent.Map as DMap
13+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)
65−import Data.Dependent.Sum (ShowTag (..), ReadTag (..), EqTag (..), OrdTag (..))
68−import Data.Functor.Constant
69−import Data.Functor.Misc
70−import Data.GADT.Compare (GEq (..))
71−import Data.GADT.Show (GShow (..))
74−import qualified Data.Map as Map
76−import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))
77−import qualified Data.Set as Set
78−import Data.Some (Some)
79−import qualified Data.Some as Some
81−import Data.Typeable (Proxy (..))
83−-- | A 'Patch' type represents a kind of change made to a datastructure.
15+import Data.Semigroup (Semigroup (..), (<>))
85− type PatchTarget p :: *
86− -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
88− apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
90−applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
91−applyAlways p t = fromMaybe t $ apply p t
93−-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
94−-- make the 'f' parameter have a nominal type role. We need f to be
95−-- representational so that we can use safe 'coerce'.
96−newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq)
98−instance EqTag f g => EqTag f (ComposeMaybe g) where
99− eqTagToEq f p r = eqTagToEq f (Proxy :: Proxy g) r
101−deriving instance Functor f => Functor (ComposeMaybe f)
103−instance Patch (Identity a) where
104− type PatchTarget (Identity a) = a
105− apply (Identity a) _ = Just a
107−-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
109−newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))
111−deriving instance GCompare k => Semigroup (PatchDMap k v)
113−deriving instance GCompare k => Monoid (PatchDMap k v)
115−instance GCompare k => Patch (PatchDMap k v) where
116− type PatchTarget (PatchDMap k v) = DMap k v
117− 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?
118− where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
119− deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
120− nothingToJust = \case
121− Nothing -> Just $ Constant ()
124−mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
125−mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
127−traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
128−traversePatchDMap f = traversePatchDMapWithKey $ const f
130−traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
131−traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
133−weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
134−weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
136−patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
137−patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
139−const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
140−const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
141− where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)
142− g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
144−-- | A set of changes to a 'Map'. Any element may be inserted/updated or
146−newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
148−instance Ord k => Patch (PatchMap k v) where
149− type PatchTarget (PatchMap k v) = Map k v
150− 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?
151− where insertions = Map.mapMaybeWithKey (const id) p
152− deletions = Map.mapMaybeWithKey (const nothingToJust) p
153− nothingToJust = \case
157−instance Ord k => Semigroup (PatchMap k v) where
158− PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
159− -- PatchMap is idempotent, so stimes n is id for every n
160−#if MIN_VERSION_semigroups(0,17,0)
161− stimes = stimesIdempotentMonoid
163− times1p n x = case compare n 0 of
164− LT -> error "stimesIdempotentMonoid: negative multiplier"
169−instance Ord k => Monoid (PatchMap k v) where
170− mempty = PatchMap mempty
173−instance Functor (PatchMap k) where
174− fmap f = PatchMap . fmap (fmap f) . unPatchMap
176−-- | Returns all the new elements that will be added to the 'Map'
177−patchMapNewElements :: PatchMap k v -> [v]
178−patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
180---- Patches based on commutative groups
17---- Patches based on commutative groups
@@ -194,353 +31,3 @@ newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
194instance Additive p => Patch (AdditivePatch p) where
31instance Additive p => Patch (AdditivePatch p) where
195 type PatchTarget (AdditivePatch p) = p
32 type PatchTarget (AdditivePatch p) = p
196 apply (AdditivePatch p) q = Just $ p <> q
33 apply (AdditivePatch p) q = Just $ p <> q
199− = MapEdit_Insert (Maybe k) v -- ^ Insert the given value here
200− | MapEdit_Delete (Maybe k) -- ^ Delete the existing value, if any, from here
201− | MapEdit_Move (Maybe k) k -- ^ Move the value here from the given key
202− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
204−mapEditMoved :: MapEdit k v -> Bool
205−mapEditMoved = isJust . \case
206− MapEdit_Insert moved _ -> moved
207− MapEdit_Delete moved -> moved
208− MapEdit_Move moved _ -> moved
210−mapEditSetMoved :: Maybe k -> MapEdit k v -> MapEdit k v
211−mapEditSetMoved moved = \case
212− MapEdit_Insert _ v -> MapEdit_Insert moved v
213− MapEdit_Delete _ -> MapEdit_Delete moved
214− MapEdit_Move _ k -> MapEdit_Move moved k
216−-- | Patch a DMap with additions, deletions, and moves.
218−-- * The same source key may not be moved to two destination keys.
219−-- * Any key that is the source of a Move must also be edited
220−-- (otherwise, the Move would duplicate it)
221−data PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
223−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)
224−unPatchMapWithMove (PatchMapWithMove p) = p
226−-- | Warning: when using this function, you must ensure that the invariants of
227−-- 'PatchMapWithMove' are preserved; they will not be checked.
228−unsafePatchMapWithMove :: Map k (MapEdit k v) -> PatchMapWithMove k v
229−unsafePatchMapWithMove = PatchMapWithMove
231−instance Ord k => Patch (PatchMapWithMove k v) where
232− type PatchTarget (PatchMapWithMove k v) = Map k v
233− 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?
234− where insertions = flip Map.mapMaybeWithKey p $ const $ \case
235− MapEdit_Insert _ v -> Just v
236− MapEdit_Move _ k -> Map.lookup k old
237− MapEdit_Delete _ -> Nothing
238− deletions = flip Map.mapMaybeWithKey p $ const $ \case
239− MapEdit_Delete _ -> Just ()
242−-- | Returns all the new elements that will be added to the 'Map'
243−patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
244−patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ flip fmap (Map.elems p) $ \case
245− MapEdit_Insert _ v -> Just v
246− MapEdit_Move _ _ -> Nothing
247− MapEdit_Delete _ -> Nothing
249−validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
250−validPatchMapWithMove (PatchMapWithMove p) =
251− let moveSources = catMaybes $ flip fmap (Map.elems p) $ \case
252− MapEdit_Move _ k -> Just k
255− [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations
256− all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources
257− , -- 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)
258− all (isJust . flip Map.lookup p) moveSources
261−knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
262−knownValidPatchMapWithMove =
263− [ PatchMapWithMove mempty
264− , PatchMapWithMove $ Map.fromList
265− [ (1, MapEdit_Move (Just 1) 2)
266− , (2, MapEdit_Move (Just 2) 1)
270−knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
271−knownInvalidPatchMapWithMove =
272− [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
273− PatchMapWithMove $ Map.singleton 1 $ MapEdit_Move Nothing 2
274− , -- Invalid because we have multiple moves from 3
275− PatchMapWithMove $ Map.fromList
276− [ (1, MapEdit_Move Nothing 3)
277− , (2, MapEdit_Move Nothing 3)
278− , (3, MapEdit_Delete (Just 1))
282−patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
283−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
284− where unsorted = Map.toList m
285− sorted = sortBy (cmp `on` snd) unsorted
286− f (to, _) (from, _) = if to == from then Nothing else
288− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
289− g (to, _) (from, _) = if to == from then Nothing else
290− let Just movingTo = Map.lookup from reverseMapping
291− in Just (to, MapEdit_Move (Just movingTo) from)
293−patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
294−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
295− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
296− newList = Map.toList newByIndexUnsorted
297− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
298− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
300− remainingValues <- get
301− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
302− then Map.delete v remainingValues
303− else Map.insert v remainingKeys remainingValues
304− case Map.lookup v remainingValues of
305− Nothing -> return $ MapEdit_Insert (Just undefined) v -- There's no existing value we can take
307− if k `Set.member` fromKs
309− putRemainingKeys $ Set.delete k fromKs
310− return $ MapEdit_Move (Just undefined) k -- There's an existing value, and it's here, so no patch necessary
312− Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
313− putRemainingKeys remainingKeys
314− return $ MapEdit_Move (Just undefined) fromK
315− Map.traverseWithKey f newByIndex
316− unusedOldKeys = fold unusedValuesByValue
317− pointlessMove k = \case
318− MapEdit_Move _ k' | k == k' -> True
320− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
323− 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
325−data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
326− -- | Insert the given value here
327− DMapEdit_Insert :: v a -> DMapEdit k v a
328− -- | Delete the existing value, if any, from here
329− DMapEdit_Delete :: DMapEdit k v a
330− -- | Move the value here from the given key
331− DMapEdit_Move :: k a -> DMapEdit k v a
332− deriving (Show, Read, Eq, Ord)
334−instance {-# INCOHERENT #-} (GShow k, ShowTag k v) => ShowTag k (DMapEdit k v) where
335− showTagToShow k _ r = gshowToShow k $ showTagToShow k (Proxy :: Proxy v) r
337−instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where
338− showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)
340−instance (GEq k, EqTag k v) => EqTag k (DMapEdit k v) where
341− eqTagToEq k p r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)
344−dmapEditMoved :: DMapEdit k v a -> Bool
345−dmapEditMoved = isJust . dmapEditMovedTo
347−dmapEditMovedTo :: DMapEdit k v a -> Maybe (k a)
348−dmapEditMovedTo = \case
349− DMapEdit_Insert moved _ -> moved
350− DMapEdit_Delete moved -> moved
351− DMapEdit_Move moved _ -> moved
354−-- | Like 'PatchMapWithMove', but for 'DMap'.
355−data PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v)) (DMap k (ComposeMaybe k))
358−validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool
359−validPatchDMapWithMove (PatchDMapWithMove dst src) = src == srcFromDst
361− srcFromDst :: DMap k (ComposeMaybe k)
362− srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of
363− DMapEdit_Move from -> from :=> ComposeMaybe (Just to)
364− _ -> to :=> ComposeMaybe Nothing
366−instance (Eq k, Eq v) => EqTag (Const2 k v) Identity where
367− eqTagToEq (Const2 _) _ = id
369−instance (Eq k, Eq v) => EqTag (Const2 k v) (Const2 k v) where
370− eqTagToEq (Const2 _) _ = id
372−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
373−moveDMapKey src dst = case src `geq` dst of
374− Nothing -> PatchDMapWithMove (DMap.fromList [dst :=> DMapEdit_Move src, src :=> DMapEdit_Delete]) (DMap.fromList [src :=> ComposeMaybe (Just dst), dst :=> ComposeMaybe Nothing])
377−deleteDMapKey :: k a -> PatchDMapWithMove k v
378−deleteDMapKey k = PatchDMapWithMove (DMap.singleton k DMapEdit_Delete) $ DMap.singleton k $ ComposeMaybe Nothing
381−k1, k2 :: Const2 Int () ()
384−p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
385−p1 = moveDMapKey k1 k2
386−p2 = moveDMapKey k2 k1
389−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
390−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
392−testPatchDMapWithMove = do
395− print $ p12 == deleteDMapKey k1
396− print $ p21 == deleteDMapKey k2
397− print $ p12Slow == deleteDMapKey k1
398− print $ p21Slow == deleteDMapKey k2
400−dst (PatchDMapWithMove x _) = x
401−src (PatchDMapWithMove _ x) = x
404−instance (EqTag k k, EqTag k v, EqTag k (ComposeMaybe k)) => Eq (PatchDMapWithMove k v) where
405− PatchDMapWithMove dstA srcA == PatchDMapWithMove dstB srcB = dstA == dstB && srcA == srcB
407−data Pair1 f g a = Pair1 (f a) (g a)
409−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
412−instance GCompare k => Monoid (PatchDMapWithMove k v) where
413− mempty = PatchDMapWithMove mempty mempty
414− PatchDMapWithMove dstAfter srcAfter `mappend` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
416− connections = DMap.toList $ DMap.intersectionWithKey (const Pair1) srcAfter dstBefore
417− f :: DSum k (Pair1 (ComposeMaybe k) (DMapEdit k v)) -> Maybe (DSum k (ComposeMaybe (DMapEdit k v)))
418− f (k :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case mToAfter of
419− Nothing -> Nothing -- Since the result of this connection was simply discarded, we don't need to change dst
420− Just toAfter -> Just $ (toAfter :=>) $ ComposeMaybe $ case editBefore of
421− DMapEdit_Move fromBefore -> if isJust $ fromBefore `geq` toAfter
422− then Nothing -- The two moves have canceled out, so eliminate the destination entry
423− else Just editBefore
424− nonMove -> Just editBefore
425− dstPatch = PatchDMap $ DMap.fromList $ catMaybes $ f <$> connections
426− dst = applyAlways dstPatch $ DMap.union dstAfter dstBefore
427− g :: DSum k (Pair1 (ComposeMaybe k) (DMapEdit k v)) -> Maybe (DSum k (ComposeMaybe (ComposeMaybe k)))
428− g (k :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case editBefore of
429− DMapEdit_Move fromBefore -> Just $ (fromBefore :=>) $ ComposeMaybe $ case mToAfter of
430− Nothing -> Just $ ComposeMaybe Nothing -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
431− Just toAfter -> if isJust $ toAfter `geq` fromBefore
432− then Nothing -- The two moves have canceled out, so eliminate the source entry
433− else Just $ ComposeMaybe mToAfter
434− _ -> Nothing --TODO: Is this right?
435− srcPatch = PatchDMap $ DMap.fromList $ catMaybes $ g <$> connections
436− src = applyAlways srcPatch $ DMap.union srcBefore srcAfter
438−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
439−PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
441− getDstAction k m = fromMaybe (DMapEdit_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
442− removeRedundantDst toKey (DMapEdit_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
443− removeRedundantDst _ a = Just a
444− f :: forall a. k a -> DMapEdit k v a -> Maybe (DMapEdit k v a)
445− f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
446− DMapEdit_Move fromKey -> getDstAction fromKey dstBefore
448− dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
449− getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
450− removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
451− removeRedundantSrc _ a = Just a
452− g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
453− g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
454− ComposeMaybe Nothing -> ComposeMaybe Nothing
455− ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
456− src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
459−unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
460−unPatchDMapWithMove (PatchDMapWithMove p) = p
462−-- | Warning: when using this function, you must ensure that the invariants of
463−-- 'PatchDMapWithMove' are preserved; they will not be checked.
464−unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
465−unsafePatchDMapWithMove = PatchDMapWithMove
469−instance GCompare k => Monoid (PatchDMapWithMove k v) where
470− mempty = PatchDMapWithMove mempty
471− PatchDMapWithMove a `mappend` PatchDMapWithMove b = PatchDMapWithMove $ DMap.unionWithKey f a b
472− where f :: forall a. k a -> DMapEdit k v a -> DMapEdit k v a -> DMapEdit k v a
473− f _ ea eb = case (ea, eb) of
474− (DMapEdit_Delete _, DMapEdit_Delete moved) -> DMapEdit_Delete $ do
476− case DMap.lookup dst a of
477− Nothing -> return dst
478− Just dstChange -> dmapEditMovedTo dstChange
479− (DMapEdit_Move _ from, DMapEdit_Delete moved) -> DMapEdit_Move moved from
480− (DMapEdit_Insert _ v, DMapEdit_Delete moved) -> DMapEdit_Insert moved v
481− (DMapEdit_Delete _, DMapEdit_Insert moved v) -> DMapEdit_Delete moved
482− (DMapEdit_Move _ from, DMapEdit_Insert moved v) -> DMapEdit_Move moved from
483− (DMapEdit_Insert _ newV, DMapEdit_Insert moved oldV) -> DMapEdit_Insert moved newV
484− (DMapEdit_Delete _, DMapEdit_Move moved k) -> DMapEdit_Delete moved
489−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
490−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p
491− where g :: forall a. DMapEdit k v a -> DMapEdit k v' a
493− DMapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
494− DMapEdit_Delete moved -> DMapEdit_Delete moved
495− DMapEdit_Move moved k -> DMapEdit_Move moved k
497−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
498−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
500−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
501−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey g p
502− where g :: forall a. k a -> DMapEdit k v a -> m (DMapEdit k v' a)
504− DMapEdit_Insert moved v -> DMapEdit_Insert moved <$> f k v
505− DMapEdit_Delete moved -> pure $ DMapEdit_Delete moved
506− DMapEdit_Move moved fromKey -> pure $ DMapEdit_Move moved fromKey
508−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
509−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
510− where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'
512− DMapEdit_Insert moved v -> MapEdit_Insert (Some.This <$> moved) $ f v
513− DMapEdit_Delete moved -> MapEdit_Delete $ Some.This <$> moved
514− DMapEdit_Move moved k -> MapEdit_Move (Some.This <$> moved) $ Some.This k
516−patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
517−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
518− where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'
520− DMapEdit_Insert moved v -> MapEdit_Insert (unConst2 <$> moved) $ f v
521− DMapEdit_Delete moved -> MapEdit_Delete $ unConst2 <$> moved
522− DMapEdit_Move moved (Const2 k) -> MapEdit_Move (unConst2 <$> moved) k
524−const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
525−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
526− where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)
527− g (k, e) = Const2 k :=> case e of
528− MapEdit_Insert moved v -> DMapEdit_Insert (Const2 <$> moved) $ f v
529− MapEdit_Delete moved -> DMapEdit_Delete $ Const2 <$> moved
530− MapEdit_Move moved fromKey -> DMapEdit_Move (Const2 <$> moved) $ Const2 fromKey
532−instance GCompare k => Patch (PatchDMapWithMove k v) where
533− type PatchTarget (PatchDMapWithMove k v) = DMap k v
534− 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?
535− where insertions = DMap.mapMaybeWithKey insertFunc p
536− insertFunc :: forall a. k a -> DMapEdit k v a -> Maybe (v a)
537− insertFunc _ = \case
538− DMapEdit_Insert _ v -> Just v
539− DMapEdit_Move _ k -> DMap.lookup k old
540− DMapEdit_Delete _ -> Nothing
541− deletions = DMap.mapMaybeWithKey deleteFunc p
542− deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)
543− deleteFunc _ = \case
544− DMapEdit_Delete _ -> Just $ Constant ()