@@ -1,108 +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
23−import Data.Dependent.Map (DMap)
26+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24−import Data.Dependent.Sum (DSum (..))
25import qualified Data.Dependent.Map as DMap
27import qualified Data.Dependent.Map as DMap
26import Data.Functor.Constant
28import Data.Functor.Constant
27import Data.Functor.Misc
29import Data.Functor.Misc
28import Data.Functor.Product
30import Data.Functor.Product
29−import Data.GADT.Compare (GEq (..), GCompare (..))
31+import Data.GADT.Compare (GEq (..), GCompare)
30−import Data.GADT.Show (GShow, gshow)
32+import Data.GADT.Show (GRead, GShow, gshow)
31import qualified Data.Map as Map
33import qualified Data.Map as Map
32import Data.Maybe
34import Data.Maybe
33import Data.Monoid.DecidablyEmpty
35import Data.Monoid.DecidablyEmpty
34−#if !MIN_VERSION_base(4,11,0)
35−import Data.Semigroup (Semigroup (..))
36+import Data.Semigroup (Semigroup (..), (<>))
36−#endif
37+import Data.Semigroupoid as Cat
37−import Data.Some (Some, mkSome)
38+import Data.Some (Some(Some))
38import 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'
40−-- | 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
41−-- destinations.
60+-- and destinations.
43-- Invariants:
62-- Invariants:
45−-- * A key should not move to itself.
64+-- * A key should not move to itself.
46−-- * 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'
47newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
69newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
49−-- It won't let me derive for some reason
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)
50−instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
83+deriving instance ( GCompare k
51− isEmpty (PatchDMapWithMove m) = DMap.null m
84+ , HasZip Ord k p
52−
85+ , Has' Ord k (PatchTarget1 p)
86+ ) => Ord (PatchDMapWithMove k p)
88+-- | Structure which represents what changes apply to a particular key.
53−-- |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
54−-- 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.
55−data NodeInfo k v a = NodeInfo
92+data NodeInfo k p a = NodeInfo
56− { _nodeInfo_from :: !(From k v a)
93+ { _nodeInfo_from :: !(From k p a)
57− -- ^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.
58− , _nodeInfo_to :: !(To k a)
95+ , _nodeInfo_to :: !(To k p a)
59− -- ^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'.
62−
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)
63−-- |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
64−-- 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.
65−data From (k :: a -> *) (v :: a -> *) :: a -> * where
193+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
66− -- |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
67− From_Insert :: v a -> From k v a
196+ From_Insert :: PatchTarget1 p to -> From k p to
68− -- |Delete the existing key
197+ -- | Delete the existing key
69− 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
70− -- |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
71− -- 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)
72− From_Move :: !(k a) -> From k v a
207+ ) => Show (From k p a)
73− deriving (Show, Read, Eq, Ord)
208+deriving instance ( Read (k a)
75−-- |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)
76−-- operation.
211+ ) => Read (From k p a)
77−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
79-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
275-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
80−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)
81validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
281validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
83-- |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.
84−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)
85validationErrorsForPatchDMapWithMove m =
289validationErrorsForPatchDMapWithMove m =
86 noSelfMoves <> movesBalanced
290 noSelfMoves <> movesBalanced
88 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
292 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
293+ selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
89− 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 _))
90− 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"
91 selfMove _ = Nothing
297 selfMove _ = Nothing
92 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
298 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
93− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
299+ unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
94 case DMap.lookup src m of
300 case DMap.lookup src m of
95 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"
96− Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
302+ Just (NodeInfo _ (To_Move dst' _)) ->
97 if isNothing (dst' `geq` dst)
303 if isNothing (dst' `geq` dst)
98 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"
99 else Nothing
305 else Nothing
101 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"
102− unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
308+ unbalancedMove (src :=> NodeInfo _ (To_Move dst _)) =
103 case DMap.lookup dst m of
309 case DMap.lookup dst m of
104 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"
105− Just (NodeInfo (From_Move src') _) ->
311+ Just (NodeInfo (From_Move (src' :=> _)) _) ->
106 if isNothing (src' `geq` src)
312 if isNothing (src' `geq` src)
107 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"
108 else Nothing
314 else Nothing
@@ -111,33 +317,41 @@ validationErrorsForPatchDMapWithMove m =
111 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"
112 unbalancedMove _ = Nothing
318 unbalancedMove _ = Nothing
114−-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
115−instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
116− PatchDMapWithMove a == PatchDMapWithMove b = a == b
118-- |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
119data Pair1 f g a = Pair1 (f a) (g a)
321data Pair1 f g a = Pair1 (f a) (g a)
121-- |Helper data structure used for composing patches using the monoid instance.
323-- |Helper data structure used for composing patches using the monoid instance.
122−data Fixup k v a
324+data Fixup k p a
123 = Fixup_Delete
325 = Fixup_Delete
124− | Fixup_Update (These (From k v a) (To k a))
326+ | Fixup_Update (These (From k p a) (To k p a))
126−-- |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
127−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
334+ ) => Semigroup (PatchDMapWithMove k p) where
128 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
130− 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))
131− 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)]
132− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
343+ h (between :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
133− (Just toAfter, From_Move fromBefore)
344+ (To_Move toAfter p1, From_Move (fromBefore :=> p0)) -> case toAfter `geq` fromBefore of
134− | isJust $ fromBefore `geq` toAfter
345+ Just Refl | isNull p0 ->
135− -> [toAfter :=> Fixup_Delete]
346+ [ toAfter :=> Fixup_Delete ]
136− | otherwise
347+ _ ->
137− -> [ toAfter :=> Fixup_Update (This editBefore)
348+ [ toAfter :=> Fixup_Update (This editBefore)
138− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
349+ , fromBefore :=> Fixup_Update (That editAfter)
351+ (To_NonMove, From_Move (fromBefore :=> _)) ->
140− (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))]
141 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
355 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
142 (Nothing, _) -> []
356 (Nothing, _) -> []
143 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
357 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -155,7 +369,13 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
155 applyFixup _ ni = \case
369 applyFixup _ ni = \case
156 Fixup_Delete -> Nothing
370 Fixup_Delete -> Nothing
157 Fixup_Update u -> Just $ NodeInfo
371 Fixup_Update u -> Just $ NodeInfo
158− { _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"
159 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
379 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
161 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
381 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -176,7 +396,7 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where
176 mappend = (<>)
396 mappend = (<>)
179−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
180PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
400PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
182 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
@@ -197,8 +417,8 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
197 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
417 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
200−-- |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'.
201−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
421+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
202insertDMapKey k v =
422insertDMapKey k v =
203 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
423 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
@@ -210,7 +430,7 @@ insertDMapKey k v =
210moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
430moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
211moveDMapKey src dst = case src `geq` dst of
431moveDMapKey src dst = case src `geq` dst of
212 Nothing -> PatchDMapWithMove $ DMap.fromList
432 Nothing -> PatchDMapWithMove $ DMap.fromList
213− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
433+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe Nothing)
214 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
434 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
216 Just _ -> mempty
436 Just _ -> mempty
@@ -220,15 +440,15 @@ moveDMapKey src dst = case src `geq` dst of
221-- let aMay = DMap.lookup a dmap
441-- let aMay = DMap.lookup a dmap
222-- bMay = DMap.lookup b dmap
442-- bMay = DMap.lookup b dmap
223−-- in maybe id (DMap.insert a) (bMay <> aMay)
443+-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
224−-- . maybe id (DMap.insert b) (aMay <> bMay)
444+-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
225-- . DMap.delete a . DMap.delete b $ dmap
445-- . DMap.delete a . DMap.delete b $ dmap
227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
447swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
228swapDMapKey src dst = case src `geq` dst of
448swapDMapKey src dst = case src `geq` dst of
229 Nothing -> PatchDMapWithMove $ DMap.fromList
449 Nothing -> PatchDMapWithMove $ DMap.fromList
230− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
450+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
231− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
451+ , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (ComposeMaybe $ Just dst)
233 Just _ -> mempty
453 Just _ -> mempty
@@ -279,93 +499,144 @@ patchDMapWithMove dm =
279 errs -> Left errs
499 errs -> Left errs
281-- |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'@.
282−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'
283−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
508+mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
284 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
509 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
285− 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
286 g = \case
511 g = \case
287 From_Insert v -> From_Insert $ f v
512 From_Insert v -> From_Insert $ f v
288 From_Delete -> From_Delete
513 From_Delete -> From_Delete
289− 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)@
291−-- |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')@.
292−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')
293traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
525traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
527+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
295−-- |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')@.
296−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) =
297−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
537+ PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
298− 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)
299 g k = \case
539 g k = \case
300 From_Insert v -> From_Insert <$> f k v
540 From_Insert v -> From_Insert <$> f k v
301 From_Delete -> pure From_Delete
541 From_Delete -> pure From_Delete
302 From_Move fromKey -> pure $ From_Move fromKey
542 From_Move fromKey -> pure $ From_Move fromKey
304−-- |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@.
305−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)
306nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
550nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
308−-- |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@.
309−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)
310nodeInfoMapFromM 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
312−-- |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
313−-- values.
563+-- @PatchTarget1 p a -> v'@ to values.
314−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
564+weakenPatchDMapWithMoveWith
566+ . (forall a. PatchTarget1 p a -> v')
567+ -> PatchDMapWithMove k p
568+ -> PatchMapWithMove (Some k) (Proxy v')
315weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
569weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
316− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
570+ where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
317 g ni = MapWithMove.NodeInfo
571 g ni = MapWithMove.NodeInfo
318 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
572 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
319 From_Insert v -> MapWithMove.From_Insert $ f v
573 From_Insert v -> MapWithMove.From_Insert $ f v
320 From_Delete -> MapWithMove.From_Delete
574 From_Delete -> MapWithMove.From_Delete
321− From_Move k -> MapWithMove.From_Move $ mkSome k
575+ From_Move k -> MapWithMove.From_Move (Some k) Proxy
322− , MapWithMove._nodeInfo_to = mkSome <$> 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
325−-- |"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
326−-- 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.
327−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
583+patchDMapWithMoveToPatchMapWithMoveWith
584+ :: forall k p v' a. (PatchTarget1 p a -> v')
585+ -> PatchDMapWithMove (Const2 k a) p
586+ -> PatchMapWithMove k (Proxy v')
328patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
587patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
329− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
588+ where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
330 g ni = MapWithMove.NodeInfo
589 g ni = MapWithMove.NodeInfo
331 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
590 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
332 From_Insert v -> MapWithMove.From_Insert $ f v
591 From_Insert v -> MapWithMove.From_Insert $ f v
333 From_Delete -> MapWithMove.From_Delete
592 From_Delete -> MapWithMove.From_Delete
334− From_Move (Const2 k) -> MapWithMove.From_Move k
593+ From_Move (Const2 k) -> MapWithMove.From_Move k Proxy
335 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
594 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
338−-- |"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
339−-- 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'
340−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
601+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
341−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
602+const2PatchDMapWithMoveWith
604+ . (v -> PatchTarget1 p' a)
605+ -> PatchMapWithMove k (Proxy v)
606+ -> PatchDMapWithMove (Const2 k a) p'
342const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
607const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
343− where g :: (k, MapWithMove.NodeInfo k 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')
344 g (k, ni) = Const2 k :=> NodeInfo
609 g (k, ni) = Const2 k :=> NodeInfo
345 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
610 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
346 MapWithMove.From_Insert v -> From_Insert $ f v
611 MapWithMove.From_Insert v -> From_Insert $ f v
347 MapWithMove.From_Delete -> From_Delete
612 MapWithMove.From_Delete -> From_Delete
348− MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
613+ MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey
349 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
614 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
352-- | 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)
353−instance GCompare k => Patch (PatchDMapWithMove k v) where
621+instance GCompare k => Patch (PatchDMapWithMove k p) where
354− type PatchTarget (PatchDMapWithMove k v) = DMap k v
355− 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?
356 where insertions = DMap.mapMaybeWithKey insertFunc p
626 where insertions = DMap.mapMaybeWithKey insertFunc p
357− 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)
358 insertFunc _ ni = case _nodeInfo_from ni of
628 insertFunc _ ni = case _nodeInfo_from ni of
359 From_Insert v -> Just v
629 From_Insert v -> Just v
360 From_Move k -> DMap.lookup k old
630 From_Move k -> DMap.lookup k old
361 From_Delete -> Nothing
631 From_Delete -> Nothing
362 deletions = DMap.mapMaybeWithKey deleteFunc p
632 deletions = DMap.mapMaybeWithKey deleteFunc p
363− 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)
364 deleteFunc _ ni = case _nodeInfo_from ni of
634 deleteFunc _ ni = case _nodeInfo_from ni of
365 From_Delete -> Just $ Constant ()
635 From_Delete -> Just $ Constant ()
366 _ -> Nothing
636 _ -> Nothing
368−-- | 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'.
369getDeletionsAndMoves :: 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))
370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
641getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
371 where f _ v ni = Pair v $ _nodeInfo_to ni
642 where f _ v ni = Pair v $ _nodeInfo_to ni