@@ -42,9 +42,10 @@ import Data.Semigroupoid as Cat
42#if !MIN_VERSION_base(4,11,0)
42#if !MIN_VERSION_base(4,11,0)
43import Data.Semigroup (Semigroup (..), (<>))
43import Data.Semigroup (Semigroup (..), (<>))
45−import Data.Some (Some, mkSome)
45+import Data.Some (Some (Some), mkSome)
46import Data.Proxy (Proxy (..))
46import Data.Proxy (Proxy (..))
47import Data.These (These (..))
47import Data.These (These (..))
48+import Data.Type.Equality ((:~:)(..))
49import Data.Patch.Class
50import Data.Patch.Class
50 ( Patch (..), PatchHet (..)
51 ( Patch (..), PatchHet (..)
@@ -172,7 +173,7 @@ data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
172 -- | Move the value from the given key @k a@ to this key. The target key
173 -- | Move the value from the given key @k a@ to this key. The target key
173 -- should also have an entry in the patch giving the current key in
174 -- should also have an entry in the patch giving the current key in
174 -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
175 -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
175− To_Move :: !(DSum k (p from)) -> To k p from
176+ To_Move :: !(Some k) -> To k p from
177deriving instance ( Show (k a), GShow k
178deriving instance ( Show (k a), GShow k
178 , Has' Show k (p a)
179 , Has' Show k (p a)
@@ -212,20 +213,20 @@ validationErrorsForPatchDMapWithPatchingMove m =
212 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
213 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
213 selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
214 selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
214 | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
215 | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
215− selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
216+ selfMove (src :=> NodeInfo _ (To_Move (Some dst)))
216 | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
217 | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
217 selfMove _ = Nothing
218 selfMove _ = Nothing
218 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
219 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
219 unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
220 unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
220 case DMap.lookup src m of
221 case DMap.lookup src m of
221 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
222 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
222− Just (NodeInfo _ (To_Move (dst' :=> _))) ->
223+ Just (NodeInfo _ (To_Move (Some dst'))) ->
223 if isNothing (dst' `geq` dst)
224 if isNothing (dst' `geq` dst)
224 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
225 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
225 else Nothing
226 else Nothing
227 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
228 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
228− unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
229+ unbalancedMove (src :=> NodeInfo _ (To_Move (Some dst))) =
229 case DMap.lookup dst m of
230 case DMap.lookup dst m of
230 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
231 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
231 Just (NodeInfo (From_Move (src' :=> _)) _) ->
232 Just (NodeInfo (From_Move (src' :=> _)) _) ->
@@ -243,16 +244,18 @@ data Pair1 f g a = Pair1 (f a) (g a)
243-- |Helper data structure used for composing patches using the monoid instance.
244-- |Helper data structure used for composing patches using the monoid instance.
244data Fixup k p a
245data Fixup k p a
245 = Fixup_Delete
246 = Fixup_Delete
246− | Fixup_Update (These (From k p a) (To k p a))
247+ | Fixup_Update (These (DSum k (From k p)) (To k p a))
248-- | Compose patches having the same effect as applying the patches in turn:
249-- | Compose patches having the same effect as applying the patches in turn:
249-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
250-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
250−instance ( GCompare k
252+ . ( GCompare k
251− , Cat.Semigroupoid p
253+ , Cat.Semigroupoid p
252− -- , Cat.DecidablyEmpty p
254+ -- , Cat.DecidablyEmpty p
253− , PatchHet2 p
255+ , PatchHet2 p
254− , PatchSource1 p ~ PatchTarget1 p
256+ , PatchSource1 p ~ PatchTarget1 p
255− ) => Semigroup (PatchDMapWithPatchingMove k p) where
258+ => Semigroup (PatchDMapWithPatchingMove k p) where
256 PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
259 PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
258 connections :: [DSum k (Pair1 (To k p) (From k p))]
261 connections :: [DSum k (Pair1 (To k p) (From k p))]
@@ -261,23 +264,25 @@ instance ( GCompare k
263 h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
266 h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
264− h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
267+ h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
265− (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
268+ (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
266 --case toAfter `geq` fromBefore of
269 --case toAfter `geq` fromBefore of
267 -- Just Refl | Just Refl <- Cat.isId p0 ->
270 -- Just Refl | Just Refl <- Cat.isId p0 ->
268 -- [ toAfter :=> Fixup_Delete ]
271 -- [ toAfter :=> Fixup_Delete ]
270− [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
273+ [ toAfter :=> Fixup_Update (This $ between :=> From_Move (fromBefore :=> Flip p))
271− , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
274+ , fromBefore :=> Fixup_Update (That $ To_Move $ Some toAfter)
273 (To_NonMove, From_Move (fromBefore :=> _)) ->
276 (To_NonMove, From_Move (fromBefore :=> _)) ->
274 -- The item is destroyed in the second patch, so indicate that it is
277 -- The item is destroyed in the second patch, so indicate that it is
275 -- destroyed in the source map
278 -- destroyed in the source map
276 [fromBefore :=> Fixup_Update (That To_NonMove)]
279 [fromBefore :=> Fixup_Update (That To_NonMove)]
277− (To_Move (toAfter :=> p), From_Insert val) ->
280+ --(To_Move (Some toAfter), From_Insert val) ->
278− [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
281+ -- [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
279− (To_Move (toAfter :=> _), From_Delete) ->
282+ --(To_Move (Some toAfter), From_Delete) ->
283+ -- [toAfter :=> Fixup_Update (This From_Delete)]
284+ (To_Move (Some toAfter), _) ->
280− [toAfter :=> Fixup_Update (This From_Delete)]
285+ [toAfter :=> Fixup_Update (This $ between :=> editBefore)]
281 (To_NonMove, _) ->
286 (To_NonMove, _) ->
283 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
288 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -292,10 +297,20 @@ instance ( GCompare k
292 { _nodeInfo_from = _nodeInfo_from nia
297 { _nodeInfo_from = _nodeInfo_from nia
293 , _nodeInfo_to = _nodeInfo_to nib
298 , _nodeInfo_to = _nodeInfo_to nib
300+ applyFixup :: k a -> NodeInfo k p a -> Fixup k p a -> Maybe (NodeInfo k p a)
295 applyFixup _ ni = \case
301 applyFixup _ ni = \case
296 Fixup_Delete -> Nothing
302 Fixup_Delete -> Nothing
297 Fixup_Update u -> Just $ NodeInfo
303 Fixup_Update u -> Just $ NodeInfo
298− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
304+ { _nodeInfo_from = case _nodeInfo_from ni of
305+ f@(From_Move ((between0 :: k between0) :=> Flip (p' :: p between0 a))) -> case getHere u of -- The `from` fixup comes from the "old" patch
306+ Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
307+ Just ((between1 :: k between1) :=> frm) -> case geq between0 between1 of
308+ Nothing -> error "fixup joined-on key did not match"
309+ Just Refl -> case frm of
310+ From_Insert v -> From_Insert $ applyAlwaysHet2 p' v
311+ From_Delete -> From_Delete
312+ From_Move (oldKey :=> Flip (p :: p oldKey between1)) -> From_Move $ oldKey :=> Flip (p' `o` p :: p oldKey a)
313+ _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
299 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
314 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
301 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
316 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -362,7 +377,7 @@ moveDMapKey
362moveDMapKey src dst = case src `geq` dst of
377moveDMapKey src dst = case src `geq` dst of
363 Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
378 Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
364 [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
379 [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
365− , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
380+ , src :=> NodeInfo From_Delete (To_Move $ Some dst)
367 Just _ -> PatchDMapWithPatchingMove DMap.empty
382 Just _ -> PatchDMapWithPatchingMove DMap.empty
@@ -379,8 +394,8 @@ moveDMapKey src dst = case src `geq` dst of
379swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
394swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
380swapDMapKey src dst = case src `geq` dst of
395swapDMapKey src dst = case src `geq` dst of
381 Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
396 Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
382− [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
397+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ Some src)
383− , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
398+ , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ Some dst)
385 Just _ -> PatchDMapWithPatchingMove DMap.empty
400 Just _ -> PatchDMapWithPatchingMove DMap.empty
@@ -455,7 +470,7 @@ mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
455 j :: forall a. To k p a -> To k p' a
470 j :: forall a. To k p a -> To k p' a
456 j = \case
471 j = \case
457 To_NonMove -> To_NonMove
472 To_NonMove -> To_NonMove
458− To_Move (k :=> p) -> To_Move $ k :=> g p
473+ To_Move (Some k) -> To_Move $ Some k
460-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
475-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
461-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
476-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
@@ -491,9 +506,9 @@ traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
491 From_Delete -> pure From_Delete
506 From_Delete -> pure From_Delete
492 From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
507 From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
493 j :: forall a. k a -> To k p a -> m (To k p' a)
508 j :: forall a. k a -> To k p a -> m (To k p' a)
494− j k = \case
509+ j _ = \case
495 To_NonMove -> pure To_NonMove
510 To_NonMove -> pure To_NonMove
496− To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
511+ To_Move (Some toKey) -> pure $ To_Move $ Some toKey
498-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
513-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
499-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
514-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
@@ -538,7 +553,7 @@ weakenPatchDMapWithPatchingMoveWith f g (PatchDMapWithPatchingMove m) =
538 From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
553 From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
539 , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
554 , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
540 To_NonMove -> Nothing
555 To_NonMove -> Nothing
541− To_Move (k :=> _) -> Just (mkSome k)
556+ To_Move (Some k) -> Just (mkSome k)
544-- | "Weaken" a @'PatchDMapWithPatchingMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' k
559-- | "Weaken" a @'PatchDMapWithPatchingMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' k
@@ -561,7 +576,7 @@ patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith f g (PatchDMapWithPatchi
561 From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
576 From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
562 , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
577 , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
563 To_NonMove -> Nothing
578 To_NonMove -> Nothing
564− To_Move (Const2 k :=> _) -> Just k
579+ To_Move (Some (Const2 k)) -> Just k
567-- | "Strengthen" a @'PatchMapWithPatchingMove' k v@ into a @'PatchDMapWithPatchingMove
582-- | "Strengthen" a @'PatchMapWithPatchingMove' k v@ into a @'PatchDMapWithPatchingMove
@@ -585,7 +600,7 @@ const2PatchDMapWithPatchingMoveWith f (PatchMapWithPatchingMove p) =
585 MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
600 MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
586 , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
601 , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
587 Nothing -> To_NonMove
602 Nothing -> To_NonMove
588− Just toKey -> To_Move $ Const2 toKey :=> Proxy3
603+ Just toKey -> To_Move $ Some (Const2 toKey)
591-- | Apply the insertions, deletions, and moves to a given 'DMap'.
606-- | Apply the insertions, deletions, and moves to a given 'DMap'.