@@ -1,101 +1,314 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE InstanceSigs #-}
5{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE Rank2Types #-}
11{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE StandaloneDeriving #-}
14+{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE UndecidableInstances #-}
17+{-# LANGUAGE UndecidableSuperClasses #-}
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
19-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
15-- move values between keys.
20-- move values between keys.
16module Data.Patch.DMapWithMove where
21module Data.Patch.DMapWithMove where
18−import Data.Patch.Class
23+import qualified Control.Category as Cat
19−import Data.Patch.MapWithMove (PatchMapWithMove (..))
20−import qualified Data.Patch.MapWithMove as MapWithMove
22import Data.Constraint.Extras
24import Data.Constraint.Extras
25+import Data.Constraint.Compose
23import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
26import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24import qualified Data.Dependent.Map as DMap
27import qualified Data.Dependent.Map as DMap
25import Data.Functor.Constant
28import Data.Functor.Constant
26import Data.Functor.Misc
29import Data.Functor.Misc
27import Data.Functor.Product
30import Data.Functor.Product
28−import Data.GADT.Compare (GEq (..))
31+import Data.GADT.Compare (GEq (..), GCompare)
29−import Data.GADT.Show (GShow, gshow)
32+import Data.GADT.Show (GRead, GShow, gshow)
30import qualified Data.Map as Map
33import qualified Data.Map as Map
31import Data.Maybe
34import Data.Maybe
35+import Data.Monoid.DecidablyEmpty
32import Data.Semigroup (Semigroup (..), (<>))
36import Data.Semigroup (Semigroup (..), (<>))
37+import Data.Semigroupoid as Cat
33import Data.Some (Some(Some))
38import Data.Some (Some(Some))
34import Data.Proxy
39import Data.Proxy
35import Data.These
40import Data.These
41+import Data.Type.Equality ((:~:) (..))
42+import Data.Kind (Constraint)
44+import Data.Patch.Class
45+import Data.Patch.MapWithMove (PatchMapWithMove (..))
46+import qualified Data.Patch.MapWithMove as MapWithMove
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
52+type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
53+ ConstraintsFor f (DupC c g)
55+type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
56+ (ArgDict (DupC c g) f, ConstraintsForZip f c g)
58+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
37−-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
59+-- which describes how it will be changed by the patch and connects move sources
38−-- destinations.
60+-- and destinations.
40-- Invariants:
62-- Invariants:
42−-- * A key should not move to itself.
64+-- * A key should not move to itself.
43−-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
66+-- * A move should always be represented with both the destination key (as a
67+-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'
44newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
69newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
71+deriving instance ( GShow k
73+ , Has' Show k (PatchTarget1 p)
74+ ) => Show (PatchDMapWithMove k p)
75+deriving instance ( GRead k
77+ , Has' Read k (PatchTarget1 p)
78+ ) => Read (PatchDMapWithMove k p)
79+deriving instance ( GEq k
81+ , Has' Eq k (PatchTarget1 p)
82+ ) => Eq (PatchDMapWithMove k p)
83+deriving instance ( GCompare k
85+ , Has' Ord k (PatchTarget1 p)
86+ ) => Ord (PatchDMapWithMove k p)
88+-- | Structure which represents what changes apply to a particular key.
46−-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
89+-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
47−-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
90+-- other key the current key is moving from, while @_nodeInfo_to@ specifies what
91+-- key the current key is moving to if involved in a move.
48−data NodeInfo k v a = NodeInfo
92+data NodeInfo k p a = NodeInfo
49− { _nodeInfo_from :: !(From k v a)
93+ { _nodeInfo_from :: !(From k p a)
50− -- ^Change applying to the current key, be it an insert, move, or delete.
94+ -- ^ Change applying to the current key, be it an insert, move, or delete.
51− , _nodeInfo_to :: !(To k a)
95+ , _nodeInfo_to :: !(To k p a)
52− -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
96+ -- ^ Where this key is moving to, if involved in a move. Should only be
97+ -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
55−
100+deriving instance ( Show (k a)
102+ , Show (PatchTarget1 p a)
103+ ) => Show (NodeInfo k p a)
104+deriving instance ( Read (k a)
106+ , Read (PatchTarget1 p a)
107+ ) => Read (NodeInfo k p a)
108+deriving instance ( Eq (k a)
110+ , Eq (PatchTarget1 p a)
111+ ) => Eq (NodeInfo k p a)
112+deriving instance ( Ord (k a)
114+ , Ord (PatchTarget1 p a)
115+ ) => Ord (NodeInfo k p a)
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@).
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
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
135+deriving instance ( Show (k to)
137+ , Show (PatchTarget1 p to)
138+ ) => Show (By k p from to)
139+deriving instance ( Read (k to)
141+ , Read (PatchTarget1 p to)
142+ ) => Read (By k p from to)
143+deriving instance ( Eq (k to)
145+ , Eq (PatchTarget1 p to)
146+ ) => Eq (By k p from to)
147+deriving instance ( Ord (k to)
149+ , Ord (PatchTarget1 p to)
150+ ) => Ord (By k p from to)
153+ :: PatchTarget1 p0 ~ PatchTarget1 p1
154+ => ((p0 from to) -> (p1 from to))
158+ By_Insert v -> By_Insert v
159+ By_Delete -> By_Delete
160+ By_Move k p -> By_Move k $ f p
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
167+ ) => Cat.Semigroupoid (By k p) where
168+ o p0 p1 = mapByPatch unProjectLocal $
169+ oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
172+ :: ( PatchSource1 p ~ PatchTarget1 p
173+ , PatchHet2Locally p between after
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
184+newtype Flip p to from = Flip (p from to)
56−-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
186+-- | Structure describing a particular change to a key, be it inserting a new
187+-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
57−-- key (@From_Delete@), or moving a key (@From_Move@).
188+-- a key (@From_Delete@), or moving a key (@From_Move@).
190+-- This type isn't used directly as the from field patch, but is instead wrapped
191+-- in an existential. However, it is nice to be able to reason about this in
192+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
58−data From (k :: a -> *) (v :: a -> *) :: a -> * where
193+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
59− -- |Insert a new or update an existing key with the given value @v a@
194+ -- | Insert a new or update an existing key with the given value @PatchTarget1
60− From_Insert :: v a -> From k v a
196+ From_Insert :: PatchTarget1 p to -> From k p to
61− -- |Delete the existing key
197+ -- | Delete the existing key
62− From_Delete :: From k v a
198+ From_Delete :: From k p to
199+ -- | Move the value from the given key @k a@ to this key. The source key
63− -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
200+ -- should also have an entry in the patch giving the current key as
64− -- usually but not necessarily with @From_Delete@.
201+ -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
202+ From_Move :: !(DSum k (Flip p to)) -> From k p to
204+deriving instance ( Show (k a)
206+ , Show (PatchTarget1 p a)
65− From_Move :: !(k a) -> From k v a
207+ ) => Show (From k p a)
66− deriving (Show, Read, Eq, Ord)
208+deriving instance ( Read (k a)
68−-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
210+ , Read (PatchTarget1 p a)
69−-- operation.
211+ ) => Read (From k p a)
70−type To = ComposeMaybe
212+
213+deriving instance ( GEq k
215+ , Eq (PatchTarget1 p a)
216+ ) => Eq (From k p a)
218+deriving instance ( GCompare k
220+ , Ord (PatchTarget1 p a)
221+ ) => Ord (From k p a)
223+-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
224+-- is, we store just the information necessary to compose a @To@ and @From@ like
225+-- @oLocal@ composes two @From@s.
226+data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
227+ -- | Delete or leave in place
228+ To_NonMove :: To k p a0
229+ -- | Move the value from the given key @k a@ to this key. The target key
230+ -- should also have an entry in the patch giving the current key in
231+ -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
232+ To_Move :: !(k a1) -> p a0 a1 -> To k p a0
234+deriving instance ( Show (k a)
236+ , Show (PatchTarget1 p a)
237+ ) => Show (To k p a)
238+deriving instance ( Read (k a)
240+ , Read (PatchTarget1 p a)
241+ ) => Read (To k p a)
245+ , Eq (PatchTarget1 p a)
246+ ) => Eq (To k p a) where
247+ To_NonMove == To_NonMove = True
248+ To_Move k0 p0 == To_Move k1 p1 = case geq k0 k1 of
250+ Just Refl -> has @(DupC Eq p) k0 $ p0 == p1
252+instance ( GCompare k
254+ , Ord (PatchTarget1 p a)
255+ ) => Ord (To k p a) where
256+ To_NonMove `compare` To_NonMove = EQ
257+ To_Move k0 p0 `compare` To_Move k1 p1 = case gcompare k0 k1 of
259+ DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1
263+-- :: ( PatchSource1 p ~ PatchTarget1 p
267+-- -> From k p between
268+-- -> DSum k (From k p)
269+--From_Insert new `oToFrom` _ = From_Insert new
270+--From_Delete `oToFrom` _ = From_Delete
271+--From_Move _ x `oToFrom` From_Insert y = From_Insert $ applyAlwaysHet2 x y
272+--From_Move _ x `oToFrom` From_Move src y = From_Move src $ x `o` y
273+--From_Move _ _ `oToFrom` From_Delete = From_Delete
72-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
275-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
73−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
276+validPatchDMapWithMove
278+ . (GCompare k, GShow k)
279+ => DMap k (NodeInfo k v)
74validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
281validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
76-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
283-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
77−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
284+validationErrorsForPatchDMapWithMove
286+ . (GCompare k, GShow k)
287+ => DMap k (NodeInfo k v)
78validationErrorsForPatchDMapWithMove m =
289validationErrorsForPatchDMapWithMove m =
79 noSelfMoves <> movesBalanced
290 noSelfMoves <> movesBalanced
81 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
292 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
293+ selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
82− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
294+ | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
295+ selfMove (src :=> NodeInfo _ (To_Move dst _))
83− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
296+ | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
84 selfMove _ = Nothing
297 selfMove _ = Nothing
85 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
298 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
86− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
299+ unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
87 case DMap.lookup src m of
300 case DMap.lookup src m of
88 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
301 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
89− Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
302+ Just (NodeInfo _ (To_Move dst' _)) ->
90 if isNothing (dst' `geq` dst)
303 if isNothing (dst' `geq` dst)
91 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
304 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
92 else Nothing
305 else Nothing
94 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
307 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
95− unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
308+ unbalancedMove (src :=> NodeInfo _ (To_Move dst _)) =
96 case DMap.lookup dst m of
309 case DMap.lookup dst m of
97 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
310 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
98− Just (NodeInfo (From_Move src') _) ->
311+ Just (NodeInfo (From_Move (src' :=> _)) _) ->
99 if isNothing (src' `geq` src)
312 if isNothing (src' `geq` src)
100 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
313 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
101 else Nothing
314 else Nothing
@@ -104,33 +317,41 @@ validationErrorsForPatchDMapWithMove m =
104 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
317 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
105 unbalancedMove _ = Nothing
318 unbalancedMove _ = Nothing
107−-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
108−instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
109− PatchDMapWithMove a == PatchDMapWithMove b = a == b
111-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
320-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
112data Pair1 f g a = Pair1 (f a) (g a)
321data Pair1 f g a = Pair1 (f a) (g a)
114-- |Helper data structure used for composing patches using the monoid instance.
323-- |Helper data structure used for composing patches using the monoid instance.
115−data Fixup k v a
324+data Fixup k p a
116 = Fixup_Delete
325 = Fixup_Delete
117− | Fixup_Update (These (From k v a) (To k a))
326+ | Fixup_Update (These (From k p a) (To k p a))
119−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
328+-- | Compose patches having the same effect as applying the patches in turn:
329+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
330+instance ( GCompare k
331+ , Cat.Semigroupoid p
332+ -- , DecidablyEmpty p
120−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
334+ ) => Semigroup (PatchDMapWithMove k p) where
121 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
335 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
337+ connections :: [DSum k (Pair1 (To k p) (From k p))]
338+ connections = DMap.toList $ DMap.intersectionWithKey
123− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
339+ (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
124− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
342+ h :: DSum k (Pair1 k (From k v)) -> [DSum k (Fixup k v)]
125− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
343+ h (between :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
126− (Just toAfter, From_Move fromBefore)
344+ (To_Move toAfter p1, From_Move (fromBefore :=> p0)) -> case toAfter `geq` fromBefore of
127− | isJust $ fromBefore `geq` toAfter
345+ Just Refl | isNull p0 ->
128− -> [toAfter :=> Fixup_Delete]
346+ [ toAfter :=> Fixup_Delete ]
129− | otherwise
347+ _ ->
130− -> [ toAfter :=> Fixup_Update (This editBefore)
348+ [ toAfter :=> Fixup_Update (This editBefore)
131− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
349+ , fromBefore :=> Fixup_Update (That editAfter)
351+ (To_NonMove, From_Move (fromBefore :=> _)) ->
133− (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
352+ -- The item is destroyed in the second patch, so indicate that it is
353+ -- destroyed in the source map
354+ [fromBefore :=> Fixup_Update (That (ComposeMaybe editAfter))]
134 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
355 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
135 (Nothing, _) -> []
356 (Nothing, _) -> []
136 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
357 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -148,7 +369,13 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
148 applyFixup _ ni = \case
369 applyFixup _ ni = \case
149 Fixup_Delete -> Nothing
370 Fixup_Delete -> Nothing
150 Fixup_Update u -> Just $ NodeInfo
371 Fixup_Update u -> Just $ NodeInfo
151− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
372+ { _nodeInfo_from = case _nodeInfo_from ni of
373+ f@(From_Move (_ :=> p')) -> case _here u of -- The `from` fixup comes from the "old" patch
374+ Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
375+ Just (From_Insert v) -> From_Insert $ applyAlways p' v
376+ Just From_Delete -> From_Delete
377+ Just (From_Move (oldKey :=> p)) -> From_Move $ oldKey :=> (p' <> p)
378+ _ -> error "DPatchMapWithMove: fixup for non-move From"
152 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
379 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
154 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
381 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -169,7 +396,7 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where
169 mappend = (<>)
396 mappend = (<>)
172−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
399+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
173PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
400PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
175 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
402 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
@@ -190,8 +417,8 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
190 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
417 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
193−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
420+-- |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'.
194−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
421+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
195insertDMapKey k v =
422insertDMapKey k v =
196 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
423 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
@@ -203,7 +430,7 @@ insertDMapKey k v =
203moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
430moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
204moveDMapKey src dst = case src `geq` dst of
431moveDMapKey src dst = case src `geq` dst of
205 Nothing -> PatchDMapWithMove $ DMap.fromList
432 Nothing -> PatchDMapWithMove $ DMap.fromList
206− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
433+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe Nothing)
207 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
434 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
209 Just _ -> mempty
436 Just _ -> mempty
@@ -220,8 +447,8 @@ moveDMapKey src dst = case src `geq` dst of
220swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
447swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
221swapDMapKey src dst = case src `geq` dst of
448swapDMapKey src dst = case src `geq` dst of
222 Nothing -> PatchDMapWithMove $ DMap.fromList
449 Nothing -> PatchDMapWithMove $ DMap.fromList
223− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
450+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
224− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
451+ , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (ComposeMaybe $ Just dst)
226 Just _ -> mempty
453 Just _ -> mempty
@@ -272,41 +499,75 @@ patchDMapWithMove dm =
272 errs -> Left errs
499 errs -> Left errs
274-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
501-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
275−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
502+mapPatchDMapWithMove
504+ . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
505+ -> (forall from to. p from to -> p' from to)
506+ -> PatchDMapWithMove k p
507+ -> PatchDMapWithMove k p'
276−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
508+mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
277 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
509 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
278− where g :: forall a. From k v a -> From k v' a
510+ where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
279 g = \case
511 g = \case
280 From_Insert v -> From_Insert $ f v
512 From_Insert v -> From_Insert $ f v
281 From_Delete -> From_Delete
513 From_Delete -> From_Delete
282− From_Move k -> From_Move k
514+ From_Move k p -> From_Move k $ g p
516+-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
284−-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
517+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
518+-- ('PatchDMapWithMove' k v')@.
285−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
519+traversePatchDMapWithMove
522+ => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
523+ -> PatchDMapWithMove k p
524+ -> m (PatchDMapWithMove k p')
286traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
525traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
527+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
288−-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
528+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
529+-- ('PatchDMapWithMove' k v')@.
289−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
530+traversePatchDMapWithMoveWithKey
533+ => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
534+ -> PatchDMapWithMove k p
535+ -> m (PatchDMapWithMove k p')
536+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
290−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
537+ PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
291− where g :: forall a. k a -> From k v a -> m (From k v' a)
538+ where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)
292 g k = \case
539 g k = \case
293 From_Insert v -> From_Insert <$> f k v
540 From_Insert v -> From_Insert <$> f k v
294 From_Delete -> pure From_Delete
541 From_Delete -> pure From_Delete
295 From_Move fromKey -> pure $ From_Move fromKey
542 From_Move fromKey -> pure $ From_Move fromKey
297−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
544+-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
545+-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
298−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
546+nodeInfoMapFrom
547+ :: (From k p a -> From k p' a)
299nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
550nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
301−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
552+-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
553+-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
302−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
554+nodeInfoMapFromM
556+ => (From k p a -> f (From k p' a))
558+ -> f (NodeInfo k p' a)
303nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
559nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
305−-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
561+-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
562+-- from @k a@ to @'Some' k@ and applying a given weakening function
306−-- values.
563+-- @PatchTarget1 p a -> v'@ to values.
307−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) (Proxy v')
564+weakenPatchDMapWithMoveWith
566+ . (forall a. PatchTarget1 p a -> v')
567+ -> PatchDMapWithMove k p
568+ -> PatchMapWithMove (Some k) (Proxy v')
308weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
569weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
309− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) (Proxy v')
570+ where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
310 g ni = MapWithMove.NodeInfo
571 g ni = MapWithMove.NodeInfo
311 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
572 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
312 From_Insert v -> MapWithMove.From_Insert $ f v
573 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -315,11 +576,16 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
315 , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
576 , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
579+-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
318−-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
580+-- v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
319−-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
581+-- dependency in the typing and all points are already @a@, hence the function
582+-- to map each value to @v'@ is not higher rank.
320−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k (Proxy v')
583+patchDMapWithMoveToPatchMapWithMoveWith
584+ :: forall k p v' a. (PatchTarget1 p a -> v')
585+ -> PatchDMapWithMove (Const2 k a) p
586+ -> PatchMapWithMove k (Proxy v')
321patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
587patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
322− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k (Proxy v')
588+ where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
323 g ni = MapWithMove.NodeInfo
589 g ni = MapWithMove.NodeInfo
324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
590 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
325 From_Insert v -> MapWithMove.From_Insert $ f v
591 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -328,10 +594,16 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
328 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
594 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
331−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
597+-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
598+-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
332−-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
599+-- dependently typed one but which always has a constant key type represented by
600+-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
333−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
601+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
334−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k (Proxy v) -> PatchDMapWithMove (Const2 k a) v'
602+const2PatchDMapWithMoveWith
604+ . (v -> PatchTarget1 p' a)
605+ -> PatchMapWithMove k (Proxy v)
606+ -> PatchDMapWithMove (Const2 k a) p'
335const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
607const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
336 where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
608 where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
337 g (k, ni) = Const2 k :=> NodeInfo
609 g (k, ni) = Const2 k :=> NodeInfo
@@ -343,22 +615,28 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
345-- | Apply the insertions, deletions, and moves to a given 'DMap'.
617-- | Apply the insertions, deletions, and moves to a given 'DMap'.
618+instance GCompare k => PatchHet (PatchDMapWithMove k p) where
619+ type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
620+ type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
346−instance GCompare k => Patch (PatchDMapWithMove k v) where
621+instance GCompare k => Patch (PatchDMapWithMove k p) where
347− type PatchTarget (PatchDMapWithMove k v) = DMap k v
348− apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
622+ apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
623+ -- TODO: return Nothing sometimes --Note: the strict application here is
624+ -- critical to ensuring that incremental merges don't hold onto all their
625+ -- prerequisite events forever; can we make this more robust?
349 where insertions = DMap.mapMaybeWithKey insertFunc p
626 where insertions = DMap.mapMaybeWithKey insertFunc p
350− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
627+ insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
351 insertFunc _ ni = case _nodeInfo_from ni of
628 insertFunc _ ni = case _nodeInfo_from ni of
352 From_Insert v -> Just v
629 From_Insert v -> Just v
353 From_Move k -> DMap.lookup k old
630 From_Move k -> DMap.lookup k old
354 From_Delete -> Nothing
631 From_Delete -> Nothing
355 deletions = DMap.mapMaybeWithKey deleteFunc p
632 deletions = DMap.mapMaybeWithKey deleteFunc p
356− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
633+ deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
357 deleteFunc _ ni = case _nodeInfo_from ni of
634 deleteFunc _ ni = case _nodeInfo_from ni of
358 From_Delete -> Just $ Constant ()
635 From_Delete -> Just $ Constant ()
359 _ -> Nothing
636 _ -> Nothing
361−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
638+-- | Get the values that will be replaced, deleted, or moved if the given patch
639+-- is applied to the given 'DMap'.
362getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
640getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
363getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
641getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
364 where f _ v ni = Pair v $ _nodeInfo_to ni
642 where f _ v ni = Pair v $ _nodeInfo_to ni