@@ -21,40 +21,36 @@
2121module Data.Patch.DMapWithMove where
2222
2323import qualified Control.Category as Cat
24−import Data.Constraint.Extras
25−import Data.Constraint.Compose
26−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24+--import qualified Control.Category.DecidablyEmpty as Cat
25+import Data.Constraint.Extras (Has')
26+import Data.Dependent.Map (DMap)
27+import Data.Dependent.Sum (DSum (..))
2728import qualified Data.Dependent.Map as DMap
28−import Data.Functor.Constant
29+import Data.Functor.Constant (Constant (..))
2930import Data.Functor.Misc
30−import Data.Functor.Product
31−import Data.GADT.Compare (GEq (..), GCompare)
31+ ( Const2 (..), Proxy3 (..)
32+ , weakenDMapWith
33+ , dmapToMapWith
34+ )
35+import Data.Functor.Product (Product (..))
36+import Data.GADT.Compare (GEq (..), GCompare (..))
3237import Data.GADT.Show (GRead, GShow, gshow)
3338import qualified Data.Map as Map
3439import Data.Maybe
35−import Data.Monoid.DecidablyEmpty
3640import Data.Semigroup (Semigroup (..), (<>))
3741import Data.Semigroupoid as Cat
3842import Data.Some (Some(Some))
39−import Data.Proxy
40−import Data.These
41−import Data.Type.Equality ((:~:) (..))
42−import Data.Kind (Constraint)
43+import Data.Proxy (Proxy (..))
44+import Data.These (These (..))
4345
4446import Data.Patch.Class
47+ ( Patch (..), PatchHet (..)
48+ , PatchHet2 (..), PatchSource1, PatchTarget1
49+ , applyAlwaysHet2
50+ )
4551import Data.Patch.MapWithMove (PatchMapWithMove (..))
4652import qualified Data.Patch.MapWithMove as MapWithMove
4753
48−-- | Composition for constraints.
49−class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
50−instance p (f a a) => DupC p f a
51−
52−type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
53− ConstraintsFor f (DupC c g)
54−
55−type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
56− (ArgDict (DupC c g) f, ConstraintsForZip f c g)
57−
5854-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
5955-- which describes how it will be changed by the patch and connects move sources
6056-- and destinations.
@@ -68,22 +64,22 @@ type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
6864-- destination)@)
6965newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
7066
71−deriving instance ( GShow k
72− , HasZip Show k p
73− , Has' Show k (PatchTarget1 p)
74− ) => Show (PatchDMapWithMove k p)
75−deriving instance ( GRead k
76− , HasZip Read k p
77− , Has' Read k (PatchTarget1 p)
78− ) => Read (PatchDMapWithMove k p)
79−deriving instance ( GEq k
80− , HasZip Eq k p
81− , Has' Eq k (PatchTarget1 p)
82− ) => Eq (PatchDMapWithMove k p)
83−deriving instance ( GCompare k
84− , HasZip Ord k p
85− , Has' Ord k (PatchTarget1 p)
86− ) => Ord (PatchDMapWithMove k p)
67+--deriving instance ( GShow k
68+-- , HasZip Show k p
69+-- , Has' Show k (PatchTarget1 p)
70+-- ) => Show (PatchDMapWithMove k p)
71+--deriving instance ( GRead k
72+-- , HasZip Read k p
73+-- , Has' Read k (PatchTarget1 p)
74+-- ) => Read (PatchDMapWithMove k p)
75+--deriving instance ( GEq k
76+-- , HasZip Eq k p
77+-- , Has' Eq k (PatchTarget1 p)
78+-- ) => Eq (PatchDMapWithMove k p)
79+--deriving instance ( GCompare k
80+-- , HasZip Ord k p
81+-- , Has' Ord k (PatchTarget1 p)
82+-- ) => Ord (PatchDMapWithMove k p)
8783
8884-- | Structure which represents what changes apply to a particular key.
8985-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
@@ -97,91 +93,22 @@ data NodeInfo k p a = NodeInfo
9793 -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
9894 }
9995
100−deriving instance ( Show (k a)
101− , Show (p a a)
102− , Show (PatchTarget1 p a)
103− ) => Show (NodeInfo k p a)
104−deriving instance ( Read (k a)
105− , Read (p a a)
106− , Read (PatchTarget1 p a)
107− ) => Read (NodeInfo k p a)
108−deriving instance ( Eq (k a)
109− , Eq (p a a)
110− , Eq (PatchTarget1 p a)
111− ) => Eq (NodeInfo k p a)
112−deriving instance ( Ord (k a)
113− , Ord (p a a)
114− , Ord (PatchTarget1 p a)
115− ) => Ord (NodeInfo k p a)
116−
117−-- | Structure describing a particular change to a key, be it inserting a new
118−-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
119−-- a key (@By_Delete@), or moving a key (@By_Move@).
120−--
121−-- This type isn't used directly as the from field patch, but is instead wrapped
122−-- in an existential. However, it is nice to be able to reason about this in
123−-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
124−data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
125− -- | Insert a new or update an existing key with the given value @PatchTarget1
126− -- p a@
127− By_Insert :: PatchTarget1 p to -> By k p from to
128− -- | Delete the existing key
129− By_Delete :: By k p from to
130− -- | Move the value from the given key @k a@ to this key. The source key
131− -- should also have an entry in the patch giving the current key as
132− -- @_nodeInfo_to@, usually but not necessarily with @By_Delete@.
133− By_Move :: !(k from) -> p from to -> By k p from to
134−
135−deriving instance ( Show (k to)
136− , Show (p from to)
137− , Show (PatchTarget1 p to)
138− ) => Show (By k p from to)
139−deriving instance ( Read (k to)
140− , Read (p from to)
141− , Read (PatchTarget1 p to)
142− ) => Read (By k p from to)
143−deriving instance ( Eq (k to)
144− , Eq (p from to)
145− , Eq (PatchTarget1 p to)
146− ) => Eq (By k p from to)
147−deriving instance ( Ord (k to)
148− , Ord (p from to)
149− , Ord (PatchTarget1 p to)
150− ) => Ord (By k p from to)
151−
152−mapByPatch
153− :: PatchTarget1 p0 ~ PatchTarget1 p1
154− => ((p0 from to) -> (p1 from to))
155− -> By k p0 from to
156− -> By k p1 from to
157−mapByPatch f = \case
158− By_Insert v -> By_Insert v
159− By_Delete -> By_Delete
160− By_Move k p -> By_Move k $ f p
161−
162−-- | Compose patches having the same effect as applying the patches in turn:
163−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
164−instance ( PatchSource1 p ~ PatchTarget1 p
165− , Cat.Semigroupoid p
166− , PatchHet2 p
167− ) => Cat.Semigroupoid (By k p) where
168− o p0 p1 = mapByPatch unProjectLocal $
169− oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
170−
171−oLocal
172− :: ( PatchSource1 p ~ PatchTarget1 p
173− , PatchHet2Locally p between after
174− )
175− => By k p between after
176− -> By k p before between
177− -> By k p before after
178−By_Insert new `oLocal` _ = By_Insert new
179−By_Delete `oLocal` _ = By_Delete
180−By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2 x y
181−By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
182−By_Move _ _ `oLocal` By_Delete = By_Delete
183−
184−newtype Flip p to from = Flip (p from to)
96+--deriving instance ( Show (k a)
97+-- , Show (p a a)
98+-- , Show (PatchTarget1 p a)
99+-- ) => Show (NodeInfo k p a)
100+--deriving instance ( Read (k a)
101+-- , Read (p a a)
102+-- , Read (PatchTarget1 p a)
103+-- ) => Read (NodeInfo k p a)
104+--deriving instance ( Eq (k a)
105+-- , Eq (p a a)
106+-- , Eq (PatchTarget1 p a)
107+-- ) => Eq (NodeInfo k p a)
108+--deriving instance ( Ord (k a)
109+-- , Ord (p a a)
110+-- , Ord (PatchTarget1 p a)
111+-- ) => Ord (NodeInfo k p a)
185112
186113-- | Structure describing a particular change to a key, be it inserting a new
187114-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
@@ -201,25 +128,30 @@ data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
201128 -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
202129 From_Move :: !(DSum k (Flip p to)) -> From k p to
203130
204−deriving instance ( Show (k a)
205− , Show (p a a)
131+deriving instance ( Show (k a), GShow k
132+ , Has' Show k (Flip p a)
206133 , Show (PatchTarget1 p a)
207134 ) => Show (From k p a)
208−deriving instance ( Read (k a)
209− , Read (p a a)
135+deriving instance ( Read (k a), GRead k
136+ , Has' Read k (Flip p a)
210137 , Read (PatchTarget1 p a)
211138 ) => Read (From k p a)
212−
213139deriving instance ( GEq k
214− , HasZip Eq k p
140+ , Has' Eq k (Flip p a)
215141 , Eq (PatchTarget1 p a)
216142 ) => Eq (From k p a)
217−
218143deriving instance ( GCompare k
219− , HasZip Ord k p
144+ , Has' Eq k (Flip p a) -- superclass bug
145+ , Has' Ord k (Flip p a)
220146 , Ord (PatchTarget1 p a)
221147 ) => Ord (From k p a)
222148
149+newtype Flip p to from = Flip (p from to)
150+
151+instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
152+ id = Flip Cat.id
153+ Flip y . Flip x = Flip $ x Cat.. y
154+
223155-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
224156-- is, we store just the information necessary to compose a @To@ and @From@ like
225157-- @oLocal@ composes two @From@s.
@@ -231,38 +163,24 @@ data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
231163 -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
232164 To_Move :: !(DSum k (p from)) -> To k p from
233165
234−deriving instance ( Show (k a)
235− , Show (p a a)
166+deriving instance ( Show (k a), GShow k
167+ , Has' Show k (p a)
236168 , Show (PatchTarget1 p a)
237169 ) => Show (To k p a)
238−deriving instance ( Read (k a)
239− , Read (p a a)
170+deriving instance ( Read (k a), GRead k
171+ , Has' Read k (p a)
240172 , Read (PatchTarget1 p a)
241173 ) => Read (To k p a)
242−
243174deriving instance ( GEq k
244− , HasZip Eq k p
175+ , Has' Eq k (p a)
245176 , Eq (PatchTarget1 p a)
246177 ) => Eq (To k p a)
247−
248178deriving instance ( GCompare k
249− , HasZip Ord k p
179+ , Has' Eq k (p a) -- superclass bug
180+ , Has' Ord k (p a)
250181 , Ord (PatchTarget1 p a)
251182 ) => Ord (To k p a)
252183
253−--oToFrom
254−-- :: ( PatchSource1 p ~ PatchTarget1 p
255−-- , PatchHet2 p
256−-- )
257−-- => To k p between
258−-- -> From k p between
259−-- -> DSum k (From k p)
260−--From_Insert new `oToFrom` _ = From_Insert new
261−--From_Delete `oToFrom` _ = From_Delete
262−--From_Move _ x `oToFrom` From_Insert y = From_Insert $ applyAlwaysHet2 x y
263−--From_Move _ x `oToFrom` From_Move src y = From_Move src $ x `o` y
264−--From_Move _ _ `oToFrom` From_Delete = From_Delete
265−
266184-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
267185validPatchDMapWithMove
268186 :: forall k v
@@ -320,7 +238,7 @@ data Fixup k p a
320238-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
321239instance ( GCompare k
322240 , Cat.Semigroupoid p
323− -- , DecidablyEmpty p
241+ -- , Cat.DecidablyEmpty p
324242 , PatchHet2 p
325243 , PatchSource1 p ~ PatchTarget1 p
326244 ) => Semigroup (PatchDMapWithMove k p) where
@@ -332,12 +250,12 @@ instance ( GCompare k
332250 ma
333251 mb
334252 h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
335− h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
253+ h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
336254 (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
337− case toAfter `geq` fromBefore of
338− Just Refl | isNull p0 ->
339− [ toAfter :=> Fixup_Delete ]
340− _ ->
255+ --case toAfter `geq` fromBefore of
256+ -- Just Refl | Just Refl <- Cat.isId p0 ->
257+ -- [ toAfter :=> Fixup_Delete ]
258+ -- _ ->
341259 [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
342260 , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
343261 ]
@@ -347,7 +265,7 @@ instance ( GCompare k
347265 [fromBefore :=> Fixup_Update (That To_NonMove)]
348266 (To_Move (toAfter :=> p), From_Insert val) ->
349267 [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
350− (To_Move (toAfter :=> p), From_Delete) ->
268+ (To_Move (toAfter :=> _), From_Delete) ->
351269 [toAfter :=> Fixup_Update (This From_Delete)]
352270 (To_NonMove, _) ->
353271 []
@@ -414,25 +332,31 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
414332 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
415333-}
416334
417−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @PatchTarget1 p a@ to the given key @k a@, like 'DMap.insert'.
335+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or
336+-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
337+-- 'DMap.insert'.
418338insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
419339insertDMapKey k v =
420340 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
421341
422−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
342+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value
343+-- from the first key @k a@ to the second key @k a@, equivalent to:
423344--
424345-- @
425346-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
426347-- @
427−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy2 v)
348+moveDMapKey
349+ :: GCompare k
350+ => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
428351moveDMapKey src dst = case src `geq` dst of
429352 Nothing -> PatchDMapWithMove $ DMap.fromList
430− [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) To_NonMove
431− , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy2)
353+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
354+ , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
432355 ]
433− Just _ -> mempty
356+ Just _ -> PatchDMapWithMove DMap.empty
434357
435−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
358+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
359+-- in the mapping, equivalent to:
436360--
437361-- @
438362-- let aMay = DMap.lookup a dmap
@@ -441,17 +365,18 @@ moveDMapKey src dst = case src `geq` dst of
441365-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
442366-- . DMap.delete a . DMap.delete b $ dmap
443367-- @
444−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
368+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
445369swapDMapKey src dst = case src `geq` dst of
446370 Nothing -> PatchDMapWithMove $ DMap.fromList
447− [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
448− , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (To_Move $ dst :=> Proxy2)
371+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
372+ , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
449373 ]
450− Just _ -> mempty
374+ Just _ -> PatchDMapWithMove DMap.empty
451375
452−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
376+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in
377+-- the mapping, equivalent to 'DMap.delete'.
453378deleteDMapKey :: k a -> PatchDMapWithMove k v
454−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
379+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
455380
456381{-
457382k1, k2 :: Const2 Int () ()
@@ -477,17 +402,20 @@ dst (PatchDMapWithMove x _) = x
477402src (PatchDMapWithMove _ x) = x
478403-}
479404
480−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
405+-- | Extract the 'DMap' representing the patch changes from the
406+-- 'PatchDMapWithMove'.
481407unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
482408unPatchDMapWithMove (PatchDMapWithMove p) = p
483409
484−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
410+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',
411+-- without checking any invariants.
485412--
486413-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
487414unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
488415unsafePatchDMapWithMove = PatchDMapWithMove
489416
490−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
417+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while
418+-- checking invariants. If the invariants are satisfied, @Right p@ is returned
491419-- otherwise @Left errors@.
492420patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
493421patchDMapWithMove dm =
@@ -495,20 +423,28 @@ patchDMapWithMove dm =
495423 [] -> Right $ unsafePatchDMapWithMove dm
496424 errs -> Left errs
497425
498−-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
426+-- | Map a natural transform @v -> v'@ over the given patch, transforming
427+-- @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
499428mapPatchDMapWithMove
500429 :: forall k p p'
501430 . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
502431 -> (forall from to. p from to -> p' from to)
503432 -> PatchDMapWithMove k p
504433 -> PatchDMapWithMove k p'
505−mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
506− DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
507− where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
508− g = \case
434+mapPatchDMapWithMove f g (PatchDMapWithMove m) =
435+ PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
436+ { _nodeInfo_from = h $ _nodeInfo_from ni
437+ , _nodeInfo_to = j $ _nodeInfo_to ni
438+ }) m
439+ where h :: forall a. From k p a -> From k p' a
440+ h = \case
509441 From_Insert v -> From_Insert $ f v
510442 From_Delete -> From_Delete
511− From_Move k p -> From_Move k $ g p
443+ From_Move (k :=> (Flip p)) -> From_Move $ k :=> Flip (g p)
444+ j :: forall a. To k p a -> To k p' a
445+ j = \case
446+ To_NonMove -> To_NonMove
447+ To_Move (k :=> p) -> To_Move $ k :=> g p
512448
513449-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
514450-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
@@ -517,9 +453,12 @@ traversePatchDMapWithMove
517453 :: forall m k p p'
518454 . Applicative m
519455 => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
456+ -> (forall from to. p from to -> m (p' from to))
520457 -> PatchDMapWithMove k p
521458 -> m (PatchDMapWithMove k p')
522−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
459+traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
460+ (\_ -> f)
461+ (\_ _ -> g)
523462
524463-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
525464-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
@@ -528,49 +467,67 @@ traversePatchDMapWithMoveWithKey
528467 :: forall m k p p'
529468 . Applicative m
530469 => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
470+ -> (forall from to. k from -> k to -> p from to -> m (p' from to))
531471 -> PatchDMapWithMove k p
532472 -> m (PatchDMapWithMove k p')
533−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
534− PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
535− where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)
536− g k = \case
473+traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
474+ fmap PatchDMapWithMove $ DMap.traverseWithKey (\k ni -> NodeInfo
475+ <$> (h k $ _nodeInfo_from ni)
476+ <*> (j k $ _nodeInfo_to ni)) m
477+ where h :: forall a. k a -> From k p a -> m (From k p' a)
478+ h k = \case
537479 From_Insert v -> From_Insert <$> f k v
538480 From_Delete -> pure From_Delete
539− From_Move fromKey -> pure $ From_Move fromKey
481+ From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
482+ j :: forall a. k a -> To k p a -> m (To k p' a)
483+ j k = \case
484+ To_NonMove -> pure To_NonMove
485+ To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
540486
541487-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
542488-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
543489nodeInfoMapFrom
544490 :: (From k p a -> From k p' a)
491+ -> (To k p a -> To k p' a)
545492 -> NodeInfo k p a
546493 -> NodeInfo k p' a
547−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
494+nodeInfoMapFrom f g ni = NodeInfo
495+ { _nodeInfo_from = f $ _nodeInfo_from ni
496+ , _nodeInfo_to = g $ _nodeInfo_to ni
497+ }
548498
549499-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
550500-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
551501nodeInfoMapFromM
552− :: Functor f
502+ :: Applicative f
553503 => (From k p a -> f (From k p' a))
504+ -> (To k p a -> f (To k p' a))
554505 -> NodeInfo k p a
555506 -> f (NodeInfo k p' a)
556−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
507+nodeInfoMapFromM f g ni = NodeInfo
508+ <$> (f $ _nodeInfo_from ni)
509+ <*> (g $ _nodeInfo_to ni)
557510
558511-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
559512-- from @k a@ to @'Some' k@ and applying a given weakening function
560513-- @PatchTarget1 p a -> v'@ to values.
561514weakenPatchDMapWithMoveWith
562− :: forall k p v'
563− . (forall a. PatchTarget1 p a -> v')
515+ :: forall k p p'
516+ . (forall a. PatchTarget1 p a -> PatchTarget p')
517+ -> (forall from to. p from to -> p')
564518 -> PatchDMapWithMove k p
565− -> PatchMapWithMove (Some k) (Proxy v')
566−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
567− where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
568− g ni = MapWithMove.NodeInfo
519+ -> PatchMapWithMove (Some k) p'
520+weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
521+ PatchMapWithMove $ weakenDMapWith h m
522+ where h :: forall a. NodeInfo k p a -> MapWithMove.NodeInfo (Some k) p'
523+ h ni = MapWithMove.NodeInfo
569524 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
570525 From_Insert v -> MapWithMove.From_Insert $ f v
571526 From_Delete -> MapWithMove.From_Delete
572− From_Move k -> MapWithMove.From_Move (Some k) Proxy
573− , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
527+ From_Move (k :=> Flip p) -> MapWithMove.From_Move (Some k) $ g p
528+ , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
529+ To_NonMove -> MapWithMove.To_NonMove
530+ To_Move (k :=> p) -> MapWithMove.To_Move (Some k) $ g p
574531 }
575532
576533-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
@@ -578,17 +535,22 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
578535-- dependency in the typing and all points are already @a@, hence the function
579536-- to map each value to @v'@ is not higher rank.
580537patchDMapWithMoveToPatchMapWithMoveWith
581− :: forall k p v' a. (PatchTarget1 p a -> v')
538+ :: forall k p p' a
539+ . (PatchTarget1 p a -> PatchTarget p')
540+ -> (p a a -> p')
582541 -> PatchDMapWithMove (Const2 k a) p
583− -> PatchMapWithMove k (Proxy v')
584−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
585− where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
586− g ni = MapWithMove.NodeInfo
542+ -> PatchMapWithMove k p'
543+patchDMapWithMoveToPatchMapWithMoveWith f g (PatchDMapWithMove m) =
544+ PatchMapWithMove $ dmapToMapWith h m
545+ where h :: NodeInfo (Const2 k a) p a -> MapWithMove.NodeInfo k p'
546+ h ni = MapWithMove.NodeInfo
587547 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
588548 From_Insert v -> MapWithMove.From_Insert $ f v
589549 From_Delete -> MapWithMove.From_Delete
590− From_Move (Const2 k) -> MapWithMove.From_Move k Proxy
591− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
550+ From_Move (Const2 k :=> Flip p) -> MapWithMove.From_Move k $ g p
551+ , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
552+ To_NonMove -> MapWithMove.To_NonMove
553+ To_Move (Const2 k :=> p) -> MapWithMove.To_Move k $ g p
592554 }
593555
594556-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
@@ -597,36 +559,47 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
597559-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
598560-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
599561const2PatchDMapWithMoveWith
600− :: forall k v p' a
601− . (v -> PatchTarget1 p' a)
562+ :: forall k v v' a
563+ . (v -> v' a)
602564 -> PatchMapWithMove k (Proxy v)
603− -> PatchDMapWithMove (Const2 k a) p'
604−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
605− where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
565+ -> PatchDMapWithMove (Const2 k a) (Proxy3 v')
566+const2PatchDMapWithMoveWith f (PatchMapWithMove p) =
567+ PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
568+ where g :: (k, MapWithMove.NodeInfo k (Proxy v))
569+ -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
606570 g (k, ni) = Const2 k :=> NodeInfo
607571 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
608572 MapWithMove.From_Insert v -> From_Insert $ f v
609573 MapWithMove.From_Delete -> From_Delete
610− MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey
611− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
574+ MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
575+ , _nodeInfo_to = case MapWithMove._nodeInfo_to ni of
576+ MapWithMove.To_NonMove -> To_NonMove
577+ MapWithMove.To_Move toKey Proxy -> To_Move $ Const2 toKey :=> Proxy3
612578 }
613579
614580-- | Apply the insertions, deletions, and moves to a given 'DMap'.
615−instance GCompare k => PatchHet (PatchDMapWithMove k p) where
581+instance ( GCompare k
582+ , PatchHet2 p
583+ , PatchSource1 p ~ PatchTarget1 p
584+ ) => PatchHet (PatchDMapWithMove k p) where
616585 type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
617586 type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
618−instance GCompare k => Patch (PatchDMapWithMove k p) where
619− apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
587+
588+instance ( GCompare k
589+ , PatchHet2 p
590+ , PatchSource1 p ~ PatchTarget1 p
591+ ) => Patch (PatchDMapWithMove k p) where
592+ apply (PatchDMapWithMove m) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
620593 -- TODO: return Nothing sometimes --Note: the strict application here is
621594 -- critical to ensuring that incremental merges don't hold onto all their
622595 -- prerequisite events forever; can we make this more robust?
623− where insertions = DMap.mapMaybeWithKey insertFunc p
596+ where insertions = DMap.mapMaybeWithKey insertFunc m
624597 insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
625598 insertFunc _ ni = case _nodeInfo_from ni of
626599 From_Insert v -> Just v
627− From_Move k -> DMap.lookup k old
600+ From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
628601 From_Delete -> Nothing
629− deletions = DMap.mapMaybeWithKey deleteFunc p
602+ deletions = DMap.mapMaybeWithKey deleteFunc m
630603 deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
631604 deleteFunc _ ni = case _nodeInfo_from ni of
632605 From_Delete -> Just $ Constant ()
@@ -634,6 +607,12 @@ instance GCompare k => Patch (PatchDMapWithMove k p) where
634607
635608-- | Get the values that will be replaced, deleted, or moved if the given patch
636609-- is applied to the given 'DMap'.
637−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
610+getDeletionsAndMoves
611+ :: ( GCompare k
612+ , PatchSource1 p ~ PatchTarget1 p
613+ )
614+ => PatchDMapWithMove k p
615+ -> DMap k (PatchSource1 p)
616+ -> DMap k (Product (PatchTarget1 p) (To k p))
638617getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
639618 where f _ v ni = Pair v $ _nodeInfo_to ni