@@ -32,6 +32,7 @@ import Data.Functor.Misc
3232 , weakenDMapWith
3333 , dmapToMapWith
3434 )
35+import Data.Functor.Const (Const (..))
3536import Data.Functor.Product (Product (..))
3637import Data.GADT.Compare (GEq (..), GCompare (..))
3738import Data.GADT.Show (GRead, GShow, gshow)
@@ -100,7 +101,7 @@ instance ( GCompare k
100101data NodeInfo k p a = NodeInfo
101102 { _nodeInfo_from :: !(From k p a)
102103 -- ^ 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)
104105 -- ^ Where this key is moving to, if involved in a move. Should only be
105106 -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
106107 }
@@ -167,31 +168,18 @@ instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
167168-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
168169-- is, we store just the information necessary to compose a @To@ and @From@ like
169170-- @oLocal@ composes two @From@s.
170−data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
171+data To (k :: a -> *) where
171172 -- | Delete or leave in place
172− To_NonMove :: To k p from
173+ To_NonMove :: To k
173174 -- | Move the value from the given key @k a@ to this key. The target key
174175 -- should also have an entry in the patch giving the current key in
175176 -- @_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
177178
178−deriving instance ( Show (k a), GShow k
179− , Has' Show k (p a)
180− , Show (PatchTarget1 p a)
181− ) => Show (To k p a)
182−deriving instance ( Read (k a), GRead k
183− , Has' Read k (p a)
184− , Read (PatchTarget1 p a)
185− ) => Read (To k p a)
186−deriving instance ( GEq k
187− , Has' Eq k (p a)
188− , Eq (PatchTarget1 p a)
189− ) => Eq (To k p a)
190−deriving instance ( GCompare k
191− , Has' Eq k (p a) -- superclass bug
192− , Has' Ord k (p a)
193− , Ord (PatchTarget1 p a)
194− ) => Ord (To k p a)
179+deriving instance GShow k => Show (To k)
180+deriving instance GRead k => Read (To k)
181+deriving instance GEq k => Eq (To k)
182+deriving instance GCompare k => Ord (To k)
195183
196184-- |Test whether a 'PatchDMapWithPatchingMove' satisfies its invariants.
197185validPatchDMapWithPatchingMove
@@ -238,13 +226,13 @@ validationErrorsForPatchDMapWithPatchingMove m =
238226 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
239227 unbalancedMove _ = Nothing
240228
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)
243229
244−-- |Helper data structure used for composing patches using the monoid instance.
230+data ToFrom k p a = ToFrom (To k) (From k p a)
231+
232+-- | Helper data structure used for composing patches using the monoid instance.
245233data Fixup k p a
246234 = 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))
248236
249237-- | Compose patches having the same effect as applying the patches in turn:
250238-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
@@ -258,13 +246,13 @@ instance forall k p
258246 => Semigroup (PatchDMapWithPatchingMove k p) where
259247 PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
260248 where
261− connections :: [DSum k (Pair1 (To k p) (From k p))]
249+ connections :: [DSum k (ToFrom k p)]
262250 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))
264252 ma
265253 mb
266− h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
267− h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
254+ h :: DSum k (ToFrom k p) -> [DSum k (Fixup k p)]
255+ h ((between :: k between) :=> ToFrom editAfter editBefore) = case (editAfter, editBefore) of
268256 (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
269257 --case toAfter `geq` fromBefore of
270258 -- Just Refl | Just Refl <- Cat.isId p0 ->
@@ -460,17 +448,13 @@ mapPatchDMapWithPatchingMove
460448mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
461449 PatchDMapWithPatchingMove $ DMap.map (\ni -> NodeInfo
462450 { _nodeInfo_from = h $ _nodeInfo_from ni
463− , _nodeInfo_to = j $ _nodeInfo_to ni
451+ , _nodeInfo_to = _nodeInfo_to ni
464452 }) m
465453 where h :: forall a. From k p a -> From k p' a
466454 h = \case
467455 From_Insert v -> From_Insert $ f v
468456 From_Delete -> From_Delete
469457 From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
470− j :: forall a. To k p a -> To k p' a
471− j = \case
472− To_NonMove -> To_NonMove
473− To_Move (Some k) -> To_Move $ Some k
474458
475459-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
476460-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
@@ -499,22 +483,18 @@ traversePatchDMapWithPatchingMoveWithKey
499483traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
500484 PatchDMapWithPatchingMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
501485 <$> h k (_nodeInfo_from ni)
502− <*> j k (_nodeInfo_to ni)) m
486+ <*> pure (_nodeInfo_to ni)) m
503487 where h :: forall a. k a -> From k p a -> m (From k p' a)
504488 h k = \case
505489 From_Insert v -> From_Insert <$> f k v
506490 From_Delete -> pure From_Delete
507491 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)
509− j _ = \case
510− To_NonMove -> pure To_NonMove
511− To_Move (Some toKey) -> pure $ To_Move $ Some toKey
512492
513493-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
514494-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
515495nodeInfoMapFrom
516496 :: (From k p a -> From k p' a)
517− -> (To k p a -> To k p' a)
497+ -> (To k -> To k)
518498 -> NodeInfo k p a
519499 -> NodeInfo k p' a
520500nodeInfoMapFrom f g ni = NodeInfo
@@ -527,7 +507,7 @@ nodeInfoMapFrom f g ni = NodeInfo
527507nodeInfoMapFromM
528508 :: Applicative f
529509 => (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))
531511 -> NodeInfo k p a
532512 -> f (NodeInfo k p' a)
533513nodeInfoMapFromM f g ni = NodeInfo
@@ -639,6 +619,6 @@ getDeletionsAndMoves
639619 )
640620 => PatchDMapWithPatchingMove k p
641621 -> DMap k (PatchSource1 p)
642− -> DMap k (Product (PatchTarget1 p) (To k p))
622+ -> DMap k (Product (PatchTarget1 p) (Const (To k)))
643623getDeletionsAndMoves (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