@@ -1,181 +1,18 @@
11-- | This module defines the 'Patch' class, which is used by Reflex to manage
22-- changes to 'Reflex.Class.Incremental' values.
3−{-# LANGUAGE CPP #-}
4−{-# LANGUAGE DeriveFoldable #-}
5−{-# LANGUAGE DeriveFunctor #-}
6−{-# LANGUAGE DeriveTraversable #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE FlexibleInstances #-}
9−{-# LANGUAGE GADTs #-}
10−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11−{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE MultiParamTypeClasses #-}
13−{-# LANGUAGE PolyKinds #-}
14−{-# LANGUAGE Rank2Types #-}
15−{-# LANGUAGE ScopedTypeVariables #-}
16−{-# LANGUAGE StandaloneDeriving #-}
173{-# LANGUAGE TypeFamilies #-}
18−{-# LANGUAGE UndecidableInstances #-}
194module Reflex.Patch
20−{- ( Patch (..)
21− , PatchDMap (..)
22− , mapPatchDMap
23− , traversePatchDMap
24− , traversePatchDMapWithKey
25− , weakenPatchDMapWith
26− , patchDMapToPatchMapWith
27− , const2PatchDMapWith
28− , ComposeMaybe (..)
29− , PatchMap (..)
30− , patchMapNewElements
31− , Group (..)
32− , Additive
33− , AdditivePatch (..)
34− , PatchMapWithMove
35− , unPatchMapWithMove
36− , unsafePatchMapWithMove
37− , patchMapWithMoveNewElements
38− , MapEdit (..)
39− , mapEditMoved
40− , mapEditSetMoved
41− , PatchDMapWithMove
42−-- , unPatchDMapWithMove
43− , unsafePatchDMapWithMove
44− , patchThatSortsMapWith
45− , patchThatChangesAndSortsMapWith
46− , mapPatchDMapWithMove
47− , traversePatchDMapWithMove
48− , traversePatchDMapWithMoveWithKey
49− , weakenPatchDMapWithMoveWith
50− , patchDMapWithMoveToPatchMapWithMoveWith
51− , const2PatchDMapWithMoveWith
52− , DMapEdit (..)
53− , dmapEditMoved
54− -- * Test functions
55− , validPatchMapWithMove
56− , knownValidPatchMapWithMove
57− , knownInvalidPatchMapWithMove
58− ) -} where
5+ ( module Reflex.Patch
6+ , module X
7+ ) where
598
60−import Control.Arrow
61−import Control.Monad.Identity
62−import Control.Monad.State
63−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
64−import qualified Data.Dependent.Map as DMap
65−import Data.Dependent.Sum (ShowTag (..), ReadTag (..), EqTag (..), OrdTag (..))
66−import Data.Foldable
67−import Data.Function
68−import Data.Functor.Constant
69−import Data.Functor.Misc
70−import Data.GADT.Compare (GEq (..))
71−import Data.GADT.Show (GShow (..))
72−import Data.List
73−import Data.Map (Map)
74−import qualified Data.Map as Map
75−import Data.Maybe
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
80−import Data.Tuple
81−import Data.Typeable (Proxy (..))
9+import Reflex.Patch.Class as X
10+import Reflex.Patch.DMap as X
11+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)
12+import Reflex.Patch.Map as X
13+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)
8214
83−-- | A 'Patch' type represents a kind of change made to a datastructure.
84−class Patch p where
85− type PatchTarget p :: *
86− -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
87− -- 'Nothing'.
88− apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
89−
90−applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
91−applyAlways p t = fromMaybe t $ apply p t
92−
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)
97−
98−instance EqTag f g => EqTag f (ComposeMaybe g) where
99− eqTagToEq f p r = eqTagToEq f (Proxy :: Proxy g) r
100−
101−deriving instance Functor f => Functor (ComposeMaybe f)
102−
103−instance Patch (Identity a) where
104− type PatchTarget (Identity a) = a
105− apply (Identity a) _ = Just a
106−
107−-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
108−-- deleted.
109−newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))
110−
111−deriving instance GCompare k => Semigroup (PatchDMap k v)
112−
113−deriving instance GCompare k => Monoid (PatchDMap k v)
114−
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 ()
122− Just _ -> Nothing
123−
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
126−
127−traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
128−traversePatchDMap f = traversePatchDMapWithKey $ const f
129−
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
132−
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
135−
136−patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
137−patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
138−
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)
143−
144−-- | A set of changes to a 'Map'. Any element may be inserted/updated or
145−-- deleted.
146−newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
147−
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
154− Nothing -> Just ()
155− Just _ -> Nothing
156−
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
162−#else
163− times1p n x = case compare n 0 of
164− LT -> error "stimesIdempotentMonoid: negative multiplier"
165− EQ -> mempty
166− GT -> x
167−#endif
168−
169−instance Ord k => Monoid (PatchMap k v) where
170− mempty = PatchMap mempty
171− mappend = (<>)
172−
173−instance Functor (PatchMap k) where
174− fmap f = PatchMap . fmap (fmap f) . unPatchMap
175−
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
15+import Data.Semigroup (Semigroup (..), (<>))
17916
18017---- Patches based on commutative groups
18118
@@ -194,353 +31,3 @@ newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
19431instance Additive p => Patch (AdditivePatch p) where
19532 type PatchTarget (AdditivePatch p) = p
19633 apply (AdditivePatch p) q = Just $ p <> q
197−
198−data MapEdit k v
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)
203−
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
209−
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
215−
216−-- | Patch a DMap with additions, deletions, and moves.
217−-- Invariants:
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)
222−
223−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)
224−unPatchMapWithMove (PatchMapWithMove p) = p
225−
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
230−
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 ()
240− _ -> Nothing
241−
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
248−
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
253− _ -> Nothing
254− in and
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
259− ]
260−
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)
267− ]
268− ]
269−
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))
279− ]
280− ]
281−
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
287− Just (from, to)
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)
292−
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
299− let f k v = 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
306− Just fromKs ->
307− if k `Set.member` fromKs
308− then do
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
311− else do
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
319− _ -> False
320− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
321− then Just undefined
322− else Nothing
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
324−
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)
333−
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
336−
337−instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where
338− showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)
339−
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)
342−
343−{-
344−dmapEditMoved :: DMapEdit k v a -> Bool
345−dmapEditMoved = isJust . dmapEditMovedTo
346−
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
352−-}
353−
354−-- | Like 'PatchMapWithMove', but for 'DMap'.
355−data PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v)) (DMap k (ComposeMaybe k))
356− deriving (Show)
357−
358−validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool
359−validPatchDMapWithMove (PatchDMapWithMove dst src) = src == srcFromDst
360− where
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
365−
366−instance (Eq k, Eq v) => EqTag (Const2 k v) Identity where
367− eqTagToEq (Const2 _) _ = id
368−
369−instance (Eq k, Eq v) => EqTag (Const2 k v) (Const2 k v) where
370− eqTagToEq (Const2 _) _ = id
371−
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])
375− Just _ -> mempty
376−
377−deleteDMapKey :: k a -> PatchDMapWithMove k v
378−deleteDMapKey k = PatchDMapWithMove (DMap.singleton k DMapEdit_Delete) $ DMap.singleton k $ ComposeMaybe Nothing
379−
380−{-
381−k1, k2 :: Const2 Int () ()
382−k1 = Const2 1
383−k2 = Const2 2
384−p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
385−p1 = moveDMapKey k1 k2
386−p2 = moveDMapKey k2 k1
387−p12 = p1 <> p2
388−p21 = p2 <> p1
389−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
390−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
391−
392−testPatchDMapWithMove = do
393− print p1
394− print p2
395− print $ p12 == deleteDMapKey k1
396− print $ p21 == deleteDMapKey k2
397− print $ p12Slow == deleteDMapKey k1
398− print $ p21Slow == deleteDMapKey k2
399−
400−dst (PatchDMapWithMove x _) = x
401−src (PatchDMapWithMove _ x) = x
402−-}
403−
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
406−
407−data Pair1 f g a = Pair1 (f a) (g a)
408−
409−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
410− (<>) = mappend
411−
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
415− where
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
437−
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
440− where
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
447− nonMove -> nonMove
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
457−
458−{-
459−unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
460−unPatchDMapWithMove (PatchDMapWithMove p) = p
461−
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
466−-}
467−
468−{-
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
475− dst <- moved
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
485−-}
486−
487−{-
488−
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
492− g = \case
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
496−
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
499−
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)
503− g k = \case
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
507−
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'
511− g = \case
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
515−
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'
519− g = \case
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
523−
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
531−
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 ()
545− _ -> Nothing
546−-}