@@ -2,150 +2,97 @@
22{-# LANGUAGE DeriveTraversable #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
65{-# LANGUAGE LambdaCase #-}
76{-# LANGUAGE MultiParamTypeClasses #-}
87{-# LANGUAGE PatternGuards #-}
9−{-# LANGUAGE PatternSynonyms #-}
108{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE StandaloneDeriving #-}
129{-# LANGUAGE TemplateHaskell #-}
1310{-# LANGUAGE TypeApplications #-}
1411{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE ViewPatterns #-}
1612
1713-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1814-- another
19−module Data.Patch.MapWithMove
20− ( PatchMapWithMove
21− ( PatchMapWithMove
22− , unPatchMapWithMove
23− , ..
24− )
25− , patchMapWithMove
26− , patchMapWithMoveInsertAll
27− , insertMapKey
28− , moveMapKey
29− , swapMapKey
30− , deleteMapKey
31− , unsafePatchMapWithMove
32− , patchMapWithMoveNewElements
33− , patchMapWithMoveNewElementsMap
34− , patchThatSortsMapWith
35− , patchThatChangesAndSortsMapWith
36− , patchThatChangesMap
15+module Data.Patch.MapWithMove where
3716
38− -- * Node Info
39− , NodeInfo
40− ( NodeInfo
41− , _nodeInfo_to
42− , _nodeInfo_from
43− , ..
44− )
45− , bitraverseNodeInfo
46− , nodeInfoMapFrom
47− , nodeInfoMapMFrom
48− , nodeInfoSetTo
49−
50− -- * From
51− , From
52− ( From_Insert
53− , From_Delete
54− , From_Move
55− , ..
56− )
57− , bitraverseFrom
58−
59− -- * To
60− , To
61− ) where
62−
63−import Data.Coerce
64−import Data.Kind (Type)
6517import Data.Patch.Class
66−import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
67−import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
6818
69−import Control.Lens
19+import Control.Lens hiding (from, to)
20+import Data.Align (align)
21+import Data.Foldable
22+import Data.Function
7023import Data.List
7124import Data.Map (Map)
7225import qualified Data.Map as Map
73−import Data.Proxy
26+import Data.Maybe
7427#if !MIN_VERSION_base(4,11,0)
7528import Data.Semigroup (Semigroup (..))
7629#endif
77−import Data.Traversable (foldMapDefault)
30+import Data.Set (Set)
31+import qualified Data.Set as Set
32+import Data.These (These(..))
7833
7934-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
8035-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
8136-- and vice versa. There should never be any unpaired From/To keys.
82−newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
83− { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
84− unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
37+newtype PatchMapWithMove k v = PatchMapWithMove
38+ { -- | Extract the internal representation of the 'PatchMapWithMove'
39+ unPatchMapWithMove :: Map k (NodeInfo k v)
8540 }
8641 deriving ( Show, Read, Eq, Ord
87−-- Haddock cannot handle documentation here before GHC 8.6
88− ,
89−#if __GLASGOW_HASKELL__ >= 806
90− -- | Compose patches having the same effect as applying the
91− -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
92− -- 'applyAlways' q@
93−#endif
94− Semigroup
95− , Monoid
42+ , Functor, Foldable, Traversable
9643 )
9744
98−pattern Coerce :: Coercible a b => a -> b
99−pattern Coerce x <- (coerce -> x)
100− where Coerce x = coerce x
101−
102−{-# COMPLETE PatchMapWithMove #-}
103−pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
104−-- | Extract the representation of the 'PatchMapWithMove' as a map of
105−-- 'NodeInfo'.
106−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
107−pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
108−
109−_PatchMapWithMove
110− :: Iso
111− (PatchMapWithMove k0 v0)
112− (PatchMapWithMove k1 v1)
113− (Map k0 (NodeInfo k0 v0))
114− (Map k1 (NodeInfo k1 v1))
115−_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
45+-- | Holds the information about each key: where its new value should come from,
46+-- and where its old value should go to
47+data NodeInfo k v = NodeInfo
48+ { _nodeInfo_from :: !(From k v)
49+ -- ^ Where do we get the new value for this key?
50+ , _nodeInfo_to :: !(To k)
51+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
52+ -- replaced), where is it going?
53+ }
54+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
11655
117−instance Functor (PatchMapWithMove k) where
118− fmap f = runIdentity . traverse (Identity . f)
56+-- | Describe how a key's new value should be produced
57+data From k v
58+ = From_Insert v -- ^ Insert the given value here
59+ | From_Delete -- ^ Delete the existing value, if any, from here
60+ | From_Move !k -- ^ Move the value here from the given key
61+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
11962
120−instance Foldable (PatchMapWithMove k) where
121− foldMap = foldMapDefault
63+-- | Describe where a key's old value will go. If this is 'Just', that means
64+-- the key's old value will be moved to the given other key; if it is 'Nothing',
65+-- that means it will be deleted.
66+type To = Maybe
12267
123−instance Traversable (PatchMapWithMove k) where
124− traverse =
125− _PatchMapWithMove .
126− traverse .
127− traverse
68+makeWrapped ''PatchMapWithMove
12869
12970instance FunctorWithIndex k (PatchMapWithMove k)
13071instance FoldableWithIndex k (PatchMapWithMove k)
13172instance TraversableWithIndex k (PatchMapWithMove k) where
13273 itraverse = itraversed . Indexed
133− itraversed =
134− _PatchMapWithMove .>
135− itraversed <.
136− traverse
74+ itraversed = _Wrapped .> itraversed <. traversed
13775
13876-- | Create a 'PatchMapWithMove', validating it
13977patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
140−patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
78+patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
79+ where valid = forwardLinks == backwardLinks
80+ forwardLinks = Map.mapMaybe _nodeInfo_to m
81+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
82+ case _nodeInfo_from v of
83+ From_Move from -> Just (from, to)
84+ _ -> Nothing
14185
14286-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
14387patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
144−patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
88+patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
89+ { _nodeInfo_from = From_Insert v
90+ , _nodeInfo_to = Nothing
91+ }
14592
14693-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
14794insertMapKey :: k -> v -> PatchMapWithMove k v
148−insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
95+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
14996
15097-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
15198--
@@ -153,160 +100,188 @@ insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
153100-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
154101-- @
155102moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
156−moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
103+moveMapKey src dst
104+ | src == dst = mempty
105+ | otherwise =
106+ PatchMapWithMove $ Map.fromList
107+ [ (dst, NodeInfo (From_Move src) Nothing)
108+ , (src, NodeInfo From_Delete (Just dst))
109+ ]
157110
158111-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
159112--
160113-- @
161114-- let aMay = Map.lookup a map
162115-- bMay = Map.lookup b map
163−-- in maybe id (Map.insert a) (bMay <> aMay)
164−-- . maybe id (Map.insert b) (aMay <> bMay)
116+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
117+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
165118-- . Map.delete a . Map.delete b $ map
166119-- @
167120swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
168−swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
121+swapMapKey src dst
122+ | src == dst = mempty
123+ | otherwise =
124+ PatchMapWithMove $ Map.fromList
125+ [ (dst, NodeInfo (From_Move src) (Just src))
126+ , (src, NodeInfo (From_Move dst) (Just dst))
127+ ]
169128
170129-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
171130deleteMapKey :: k -> PatchMapWithMove k v
172−deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
131+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
173132
174133-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
175134--
176135-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
177136unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
178−unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
137+unsafePatchMapWithMove = PatchMapWithMove
179138
180139-- | Apply the insertions, deletions, and moves to a given 'Map'
181140instance Ord k => Patch (PatchMapWithMove k v) where
182141 type PatchTarget (PatchMapWithMove k v) = Map k v
183− apply (PatchMapWithMove' p) = apply p
142+ 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?
143+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
144+ From_Insert v -> Just v
145+ From_Move k -> Map.lookup k old
146+ From_Delete -> Nothing
147+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
148+ From_Delete -> Just ()
149+ _ -> Nothing
184150
185151-- | Returns all the new elements that will be added to the 'Map'.
186152patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
187−patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
153+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
188154
189155-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
190156patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
191−patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
157+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
158+ where f ni = case _nodeInfo_from ni of
159+ From_Insert v -> Just v
160+ From_Move _ -> Nothing
161+ From_Delete -> Nothing
192162
193163-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
194164-- its values using the given ordering function. The set keys of the 'Map' is
195165-- not changed.
196166patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
197−patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
167+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
168+ where unsorted = Map.toList m
169+ sorted = sortBy (cmp `on` snd) unsorted
170+ f (to, _) (from, _) = if to == from then Nothing else
171+ Just (from, to)
172+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
173+ g (to, _) (from, _) = if to == from then Nothing else
174+ let Just movingTo = Map.lookup to reverseMapping
175+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)
198176
199177-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
200178-- will produce a 'Map' with the same values as the second 'Map' but with the
201179-- values sorted with the given ordering function.
202−patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
180+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
203181patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
204182 where newList = Map.toList newByIndexUnsorted
205183 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
206184
207185-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
208186-- will produce the second 'Map'.
209−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
210−patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
211− PM.patchThatChangesMap oldByIndex newByIndex
212−
213−--
214−-- NodeInfo
215−--
216−
217−-- | Holds the information about each key: where its new value should come from,
218−-- and where its old value should go to
219−newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
220−
221−deriving instance (Show k, Show p) => Show (NodeInfo k p)
222−deriving instance (Read k, Read p) => Read (NodeInfo k p)
223−deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
224−deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
225−
226−{-# COMPLETE NodeInfo #-}
227−pattern NodeInfo :: To k -> From k v -> NodeInfo k v
228−_nodeInfo_to :: NodeInfo k v -> To k
229−_nodeInfo_from :: NodeInfo k v -> From k v
230−pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
231− PM.NodeInfo
232− { PM._nodeInfo_to = _nodeInfo_to
233− , PM._nodeInfo_from = Coerce _nodeInfo_from
234− }
235−
236−_NodeInfo
237− :: Iso
238− (NodeInfo k0 v0)
239− (NodeInfo k1 v1)
240− (PM.NodeInfo k0 (Proxy v0))
241− (PM.NodeInfo k1 (Proxy v1))
242−_NodeInfo = iso unNodeInfo' NodeInfo'
243−
244−instance Functor (NodeInfo k) where
245− fmap f = runIdentity . traverse (Identity . f)
246−
247−instance Foldable (NodeInfo k) where
248− foldMap = foldMapDefault
249−
250−instance Traversable (NodeInfo k) where
251− traverse = bitraverseNodeInfo pure
252−
253−bitraverseNodeInfo
254− :: Applicative f
255− => (k0 -> f k1)
256− -> (v0 -> f v1)
257− -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258−bitraverseNodeInfo fk fv = fmap NodeInfo'
259− . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260− . coerce
187+patchThatChangesMap :: forall k v. (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
188+patchThatChangesMap oldByIndex newByIndex = patch
189+ where invert :: Map k v -> Map v (Set k)
190+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
191+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
192+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
193+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
194+ unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
195+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
196+ -- Generate patch info for a single value
197+ -- Keys that are found in both the old and new sets will not be patched
198+ -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
199+ -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
200+ patchSingleValue :: v -> Set k -> Set k -> (Map k (From k v), Map k (To k))
201+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
202+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
203+ That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
204+ These oldK newK -> (Map.singleton newK $ From_Move oldK, Map.singleton oldK $ Just newK)
205+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
206+ patchSingleValueThese :: v -> These (Set k) (Set k) -> (Map k (From k v), Map k (To k))
207+ patchSingleValueThese v = \case
208+ This oldKeys -> patchSingleValue v oldKeys mempty
209+ That newKeys -> patchSingleValue v mempty newKeys
210+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
211+ -- Generate froms and tos for all values, then merge them together
212+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
213+ patch = unsafePatchMapWithMove $ align froms tos <&> \case
214+ This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
215+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
216+ These from to -> NodeInfo from to
261217
262218-- | Change the 'From' value of a 'NodeInfo'
263219nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
264−nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
220+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
265221
266222-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
267223-- 'Applicative', 'Monad', etc.) action to get the new value
268−nodeInfoMapMFrom
269− :: Functor f
270− => (From k v -> f (From k v))
271− -> NodeInfo k v -> f (NodeInfo k v)
272−nodeInfoMapMFrom f = fmap NodeInfo'
273− . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274− . coerce
224+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
225+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
275226
276227-- | Set the 'To' field of a 'NodeInfo'
277228nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
278−nodeInfoSetTo = coerce . PM.nodeInfoSetTo
279−
280−--
281−-- From
282−--
283−
284−-- | Describe how a key's new value should be produced
285−newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
286−
287−{-# COMPLETE From_Insert, From_Delete, From_Move #-}
288−
289−-- | Insert the given value here
290−pattern From_Insert :: v -> From k v
291−pattern From_Insert v = From' (PM.From_Insert v)
292−
293−-- | Delete the existing value, if any, from here
294−pattern From_Delete :: From k v
295−pattern From_Delete = From' PM.From_Delete
296−
297−-- | Move the value here from the given key
298−pattern From_Move :: k -> From k v
299−pattern From_Move k = From' (PM.From_Move k Proxy)
300−
301−bitraverseFrom
302− :: Applicative f
303− => (k0 -> f k1)
304− -> (v0 -> f v1)
305− -> From k0 v0 -> f (From k1 v1)
306−bitraverseFrom fk fv = fmap From'
307− . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
308− . coerce
309−
310−makeWrapped ''PatchMapWithMove
311−makeWrapped ''NodeInfo
312−makeWrapped ''From
229+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
230+
231+-- |Helper data structure used for composing patches using the monoid instance.
232+data Fixup k v
233+ = Fixup_Delete
234+ | Fixup_Update (These (From k v) (To k))
235+
236+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
237+instance Ord k => Semigroup (PatchMapWithMove k v) where
238+ PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
239+ where
240+ connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
241+ h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
242+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
243+ (Just toAfter, From_Move fromBefore)
244+ | fromBefore == toAfter
245+ -> [(toAfter, Fixup_Delete)]
246+ | otherwise
247+ -> [ (toAfter, Fixup_Update (This editBefore))
248+ , (fromBefore, Fixup_Update (That mToAfter))
249+ ]
250+ (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
251+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
252+ (Nothing, _) -> []
253+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
254+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)
255+ | This x <- a, That y <- b
256+ = Fixup_Update $ These x y
257+ | That y <- a, This x <- b
258+ = Fixup_Update $ These x y
259+ mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
260+ fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
261+ combineNodeInfos _ nia nib = NodeInfo
262+ { _nodeInfo_from = _nodeInfo_from nia
263+ , _nodeInfo_to = _nodeInfo_to nib
264+ }
265+ applyFixup _ ni = \case
266+ Fixup_Delete -> Nothing
267+ Fixup_Update u -> Just $ NodeInfo
268+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
269+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
270+ }
271+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
272+ getHere :: These a b -> Maybe a
273+ getHere = \case
274+ This a -> Just a
275+ These a _ -> Just a
276+ That _ -> Nothing
277+ getThere :: These a b -> Maybe b
278+ getThere = \case
279+ This _ -> Nothing
280+ These _ b -> Just b
281+ That b -> Just b
282+
283+--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
284+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
285+instance Ord k => Monoid (PatchMapWithMove k v) where
286+ mempty = PatchMapWithMove mempty
287+ mappend = (<>)