@@ -32,6 +32,7 @@ import Data.Functor.Misc
32 , weakenDMapWith
32 , weakenDMapWith
33 , dmapToMapWith
33 , dmapToMapWith
35+import Data.Functor.Const (Const (..))
35import Data.Functor.Product (Product (..))
36import Data.Functor.Product (Product (..))
36import Data.GADT.Compare (GEq (..), GCompare (..))
37import Data.GADT.Compare (GEq (..), GCompare (..))
37import Data.GADT.Show (GRead, GShow, gshow)
38import Data.GADT.Show (GRead, GShow, gshow)
@@ -100,7 +101,7 @@ instance ( GCompare k
100data NodeInfo k p a = NodeInfo
101data NodeInfo k p a = NodeInfo
101 { _nodeInfo_from :: !(From k p a)
102 { _nodeInfo_from :: !(From k p a)
102 -- ^ Change applying to the current key, be it an insert, move, or delete.
103 -- ^ Change applying to the current key, be it an insert, move, or delete.
103− , _nodeInfo_to :: !(To k p a)
104+ , _nodeInfo_to :: !(To k)
104 -- ^ Where this key is moving to, if involved in a move. Should only be
105 -- ^ Where this key is moving to, if involved in a move. Should only be
105 -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
106 -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
@@ -167,31 +168,18 @@ instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
167-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
168-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
168-- is, we store just the information necessary to compose a @To@ and @From@ like
169-- is, we store just the information necessary to compose a @To@ and @From@ like
169-- @oLocal@ composes two @From@s.
170-- @oLocal@ composes two @From@s.
170−data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
171+data To (k :: a -> *) where
171 -- | Delete or leave in place
172 -- | Delete or leave in place
172− To_NonMove :: To k p from
173+ To_NonMove :: To k
173 -- | Move the value from the given key @k a@ to this key. The target key
174 -- | Move the value from the given key @k a@ to this key. The target key
174 -- should also have an entry in the patch giving the current key in
175 -- should also have an entry in the patch giving the current key in
175 -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
176 -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
176− To_Move :: !(Some k) -> To k p from
177+ To_Move :: !(Some k) -> To k
178−deriving instance ( Show (k a), GShow k
179+deriving instance GShow k => Show (To k)
180− , Show (PatchTarget1 p a)
181− ) => Show (To k p a)
182−deriving instance ( Read (k a), GRead k
180+deriving instance GRead k => Read (To k)
184− , Read (PatchTarget1 p a)
185− ) => Read (To k p a)
186−deriving instance ( GEq k
181+deriving instance GEq k => Eq (To k)
188− , Eq (PatchTarget1 p a)
190−deriving instance ( GCompare k
182+deriving instance GCompare k => Ord (To k)
191− , Has' Eq k (p a) -- superclass bug
193− , Ord (PatchTarget1 p a)
196-- |Test whether a 'PatchDMapWithPatchingMove' satisfies its invariants.
184-- |Test whether a 'PatchDMapWithPatchingMove' satisfies its invariants.
197validPatchDMapWithPatchingMove
185validPatchDMapWithPatchingMove
@@ -238,13 +226,13 @@ validationErrorsForPatchDMapWithPatchingMove m =
238 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
226 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
239 unbalancedMove _ = Nothing
227 unbalancedMove _ = Nothing
241−-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
242−data Pair1 f g a = Pair1 (f a) (g a)
230+data ToFrom k p a = ToFrom (To k) (From k p a)
244−-- |Helper data structure used for composing patches using the monoid instance.
232+-- | Helper data structure used for composing patches using the monoid instance.
245data Fixup k p a
233data Fixup k p a
246 = Fixup_Delete
234 = Fixup_Delete
247− | Fixup_Update (These (DSum k (From k p)) (To k p a))
235+ | Fixup_Update (These (DSum k (From k p)) (To k))
249-- | Compose patches having the same effect as applying the patches in turn:
237-- | Compose patches having the same effect as applying the patches in turn:
250-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
238-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
@@ -258,13 +246,13 @@ instance forall k p
258 => Semigroup (PatchDMapWithPatchingMove k p) where
246 => Semigroup (PatchDMapWithPatchingMove k p) where
259 PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
247 PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
261− connections :: [DSum k (Pair1 (To k p) (From k p))]
249+ connections :: [DSum k (ToFrom k p)]
262 connections = DMap.toList $ DMap.intersectionWithKey
250 connections = DMap.toList $ DMap.intersectionWithKey
263− (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
251+ (\_ a b -> ToFrom (_nodeInfo_to a) (_nodeInfo_from b))
266− h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
254+ h :: DSum k (ToFrom k p) -> [DSum k (Fixup k p)]
267− h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
255+ h ((between :: k between) :=> ToFrom editAfter editBefore) = case (editAfter, editBefore) of
268 (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
256 (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
269 --case toAfter `geq` fromBefore of
257 --case toAfter `geq` fromBefore of
270 -- Just Refl | Just Refl <- Cat.isId p0 ->
258 -- Just Refl | Just Refl <- Cat.isId p0 ->
@@ -460,17 +448,13 @@ mapPatchDMapWithPatchingMove
460mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
448mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
461 PatchDMapWithPatchingMove $ DMap.map (\ni -> NodeInfo
449 PatchDMapWithPatchingMove $ DMap.map (\ni -> NodeInfo
462 { _nodeInfo_from = h $ _nodeInfo_from ni
450 { _nodeInfo_from = h $ _nodeInfo_from ni
463− , _nodeInfo_to = j $ _nodeInfo_to ni
451+ , _nodeInfo_to = _nodeInfo_to ni
465 where h :: forall a. From k p a -> From k p' a
453 where h :: forall a. From k p a -> From k p' a
466 h = \case
454 h = \case
467 From_Insert v -> From_Insert $ f v
455 From_Insert v -> From_Insert $ f v
468 From_Delete -> From_Delete
456 From_Delete -> From_Delete
469 From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
457 From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
470− j :: forall a. To k p a -> To k p' a
472− To_NonMove -> To_NonMove
473− To_Move (Some k) -> To_Move $ Some k
475-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
459-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
476-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
460-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
@@ -499,22 +483,18 @@ traversePatchDMapWithPatchingMoveWithKey
499traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
483traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
500 PatchDMapWithPatchingMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
484 PatchDMapWithPatchingMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
501 <$> h k (_nodeInfo_from ni)
485 <$> h k (_nodeInfo_from ni)
502− <*> j k (_nodeInfo_to ni)) m
486+ <*> pure (_nodeInfo_to ni)) m
503 where h :: forall a. k a -> From k p a -> m (From k p' a)
487 where h :: forall a. k a -> From k p a -> m (From k p' a)
504 h k = \case
488 h k = \case
505 From_Insert v -> From_Insert <$> f k v
489 From_Insert v -> From_Insert <$> f k v
506 From_Delete -> pure From_Delete
490 From_Delete -> pure From_Delete
507 From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
491 From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
508− j :: forall a. k a -> To k p a -> m (To k p' a)
510− To_NonMove -> pure To_NonMove
511− To_Move (Some toKey) -> pure $ To_Move $ Some toKey
513-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
493-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
514-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
494-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
515nodeInfoMapFrom
495nodeInfoMapFrom
516 :: (From k p a -> From k p' a)
496 :: (From k p a -> From k p' a)
517− -> (To k p a -> To k p' a)
497+ -> (To k -> To k)
518 -> NodeInfo k p a
498 -> NodeInfo k p a
519 -> NodeInfo k p' a
499 -> NodeInfo k p' a
520nodeInfoMapFrom f g ni = NodeInfo
500nodeInfoMapFrom f g ni = NodeInfo
@@ -527,7 +507,7 @@ nodeInfoMapFrom f g ni = NodeInfo
527nodeInfoMapFromM
507nodeInfoMapFromM
528 :: Applicative f
508 :: Applicative f
529 => (From k p a -> f (From k p' a))
509 => (From k p a -> f (From k p' a))
530− -> (To k p a -> f (To k p' a))
510+ -> (To k -> f (To k))
531 -> NodeInfo k p a
511 -> NodeInfo k p a
532 -> f (NodeInfo k p' a)
512 -> f (NodeInfo k p' a)
533nodeInfoMapFromM f g ni = NodeInfo
513nodeInfoMapFromM f g ni = NodeInfo
@@ -639,6 +619,6 @@ getDeletionsAndMoves
640 => PatchDMapWithPatchingMove k p
620 => PatchDMapWithPatchingMove k p
641 -> DMap k (PatchSource1 p)
621 -> DMap k (PatchSource1 p)
642− -> DMap k (Product (PatchTarget1 p) (To k p))
622+ -> DMap k (Product (PatchTarget1 p) (Const (To k)))
643getDeletionsAndMoves (PatchDMapWithPatchingMove p) m = DMap.intersectionWithKey f m p
623getDeletionsAndMoves (PatchDMapWithPatchingMove p) m = DMap.intersectionWithKey f m p
644− where f _ v ni = Pair v $ _nodeInfo_to ni
624+ where f _ v ni = Pair v $ Const $ _nodeInfo_to ni