@@ -42,9 +42,10 @@ import Data.Semigroupoid as Cat
4242#if !MIN_VERSION_base(4,11,0)
4343import Data.Semigroup (Semigroup (..), (<>))
4444#endif
45−import Data.Some (Some, mkSome)
45+import Data.Some (Some (Some), mkSome)
4646import Data.Proxy (Proxy (..))
4747import Data.These (These (..))
48+import Data.Type.Equality ((:~:)(..))
4849
4950import Data.Patch.Class
5051 ( Patch (..), PatchHet (..)
@@ -172,7 +173,7 @@ data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
172173 -- | Move the value from the given key @k a@ to this key. The target key
173174 -- should also have an entry in the patch giving the current key in
174175 -- @_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
176177
177178deriving instance ( Show (k a), GShow k
178179 , Has' Show k (p a)
@@ -212,20 +213,20 @@ validationErrorsForPatchDMapWithPatchingMove m =
212213 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
213214 selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
214215 | 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)))
216217 | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
217218 selfMove _ = Nothing
218219 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
219220 unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
220221 case DMap.lookup src m of
221222 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'))) ->
223224 if isNothing (dst' `geq` dst)
224225 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
225226 else Nothing
226227 _ ->
227228 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))) =
229230 case DMap.lookup dst m of
230231 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
231232 Just (NodeInfo (From_Move (src' :=> _)) _) ->
@@ -243,16 +244,18 @@ data Pair1 f g a = Pair1 (f a) (g a)
243244-- |Helper data structure used for composing patches using the monoid instance.
244245data Fixup k p a
245246 = 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))
247248
248249-- | Compose patches having the same effect as applying the patches in turn:
249250-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
250−instance ( GCompare k
251− , Cat.Semigroupoid p
252− -- , Cat.DecidablyEmpty p
253− , PatchHet2 p
254− , PatchSource1 p ~ PatchTarget1 p
255− ) => Semigroup (PatchDMapWithPatchingMove k p) where
251+instance forall k p
252+ . ( GCompare k
253+ , Cat.Semigroupoid p
254+ -- , Cat.DecidablyEmpty p
255+ , PatchHet2 p
256+ , PatchSource1 p ~ PatchTarget1 p
257+ )
258+ => Semigroup (PatchDMapWithPatchingMove k p) where
256259 PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
257260 where
258261 connections :: [DSum k (Pair1 (To k p) (From k p))]
@@ -261,23 +264,25 @@ instance ( GCompare k
261264 ma
262265 mb
263266 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
265− (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
267+ h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
268+ (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
266269 --case toAfter `geq` fromBefore of
267270 -- Just Refl | Just Refl <- Cat.isId p0 ->
268271 -- [ toAfter :=> Fixup_Delete ]
269272 -- _ ->
270− [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
271− , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
273+ [ toAfter :=> Fixup_Update (This $ between :=> From_Move (fromBefore :=> Flip p))
274+ , fromBefore :=> Fixup_Update (That $ To_Move $ Some toAfter)
272275 ]
273276 (To_NonMove, From_Move (fromBefore :=> _)) ->
274277 -- The item is destroyed in the second patch, so indicate that it is
275278 -- destroyed in the source map
276279 [fromBefore :=> Fixup_Update (That To_NonMove)]
277− (To_Move (toAfter :=> p), From_Insert val) ->
278− [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
279− (To_Move (toAfter :=> _), From_Delete) ->
280− [toAfter :=> Fixup_Update (This From_Delete)]
280+ --(To_Move (Some toAfter), From_Insert val) ->
281+ -- [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
282+ --(To_Move (Some toAfter), From_Delete) ->
283+ -- [toAfter :=> Fixup_Update (This From_Delete)]
284+ (To_Move (Some toAfter), _) ->
285+ [toAfter :=> Fixup_Update (This $ between :=> editBefore)]
281286 (To_NonMove, _) ->
282287 []
283288 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -292,10 +297,20 @@ instance ( GCompare k
292297 { _nodeInfo_from = _nodeInfo_from nia
293298 , _nodeInfo_to = _nodeInfo_to nib
294299 }
300+ applyFixup :: k a -> NodeInfo k p a -> Fixup k p a -> Maybe (NodeInfo k p a)
295301 applyFixup _ ni = \case
296302 Fixup_Delete -> Nothing
297303 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"
299314 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
300315 }
301316 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -362,7 +377,7 @@ moveDMapKey
362377moveDMapKey src dst = case src `geq` dst of
363378 Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
364379 [ 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)
366381 ]
367382 Just _ -> PatchDMapWithPatchingMove DMap.empty
368383
@@ -379,8 +394,8 @@ moveDMapKey src dst = case src `geq` dst of
379394swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
380395swapDMapKey src dst = case src `geq` dst of
381396 Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
382− [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
383− , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
397+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ Some src)
398+ , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ Some dst)
384399 ]
385400 Just _ -> PatchDMapWithPatchingMove DMap.empty
386401
@@ -455,7 +470,7 @@ mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
455470 j :: forall a. To k p a -> To k p' a
456471 j = \case
457472 To_NonMove -> To_NonMove
458− To_Move (k :=> p) -> To_Move $ k :=> g p
473+ To_Move (Some k) -> To_Move $ Some k
459474
460475-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
461476-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
@@ -491,9 +506,9 @@ traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
491506 From_Delete -> pure From_Delete
492507 From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
493508 j :: forall a. k a -> To k p a -> m (To k p' a)
494− j k = \case
509+ j _ = \case
495510 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
497512
498513-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
499514-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
@@ -538,7 +553,7 @@ weakenPatchDMapWithPatchingMoveWith f g (PatchDMapWithPatchingMove m) =
538553 From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
539554 , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
540555 To_NonMove -> Nothing
541− To_Move (k :=> _) -> Just (mkSome k)
556+ To_Move (Some k) -> Just (mkSome k)
542557 }
543558
544559-- | "Weaken" a @'PatchDMapWithPatchingMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' k
@@ -561,7 +576,7 @@ patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith f g (PatchDMapWithPatchi
561576 From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
562577 , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
563578 To_NonMove -> Nothing
564− To_Move (Const2 k :=> _) -> Just k
579+ To_Move (Some (Const2 k)) -> Just k
565580 }
566581
567582-- | "Strengthen" a @'PatchMapWithPatchingMove' k v@ into a @'PatchDMapWithPatchingMove
@@ -585,7 +600,7 @@ const2PatchDMapWithPatchingMoveWith f (PatchMapWithPatchingMove p) =
585600 MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
586601 , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
587602 Nothing -> To_NonMove
588− Just toKey -> To_Move $ Const2 toKey :=> Proxy3
603+ Just toKey -> To_Move $ Some (Const2 toKey)
589604 }
590605
591606-- | Apply the insertions, deletions, and moves to a given 'DMap'.