@@ -1,101 +1,305 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
45{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE InstanceSigs #-}
57{-# LANGUAGE LambdaCase #-}
68{-# LANGUAGE MultiParamTypeClasses #-}
79{-# LANGUAGE PatternGuards #-}
810{-# LANGUAGE PolyKinds #-}
911{-# LANGUAGE Rank2Types #-}
1012{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE StandaloneDeriving #-}
14+{-# LANGUAGE TypeApplications #-}
1115{-# LANGUAGE TypeFamilies #-}
1216{-# LANGUAGE UndecidableInstances #-}
17+{-# LANGUAGE UndecidableSuperClasses #-}
1318
1419-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
1520-- move values between keys.
1621module Data.Patch.DMapWithMove where
1722
18−import Data.Patch.Class
19−import Data.Patch.MapWithMove (PatchMapWithMove (..))
20−import qualified Data.Patch.MapWithMove as MapWithMove
21−
23+import qualified Control.Category as Cat
2224import Data.Constraint.Extras
25+import Data.Constraint.Compose
2326import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
2427import qualified Data.Dependent.Map as DMap
2528import Data.Functor.Constant
2629import Data.Functor.Misc
2730import Data.Functor.Product
28−import Data.GADT.Compare (GEq (..))
29−import Data.GADT.Show (GShow, gshow)
31+import Data.GADT.Compare (GEq (..), GCompare)
32+import Data.GADT.Show (GRead, GShow, gshow)
3033import qualified Data.Map as Map
3134import Data.Maybe
35+import Data.Monoid.DecidablyEmpty
3236import Data.Semigroup (Semigroup (..), (<>))
37+import Data.Semigroupoid as Cat
3338import Data.Some (Some(Some))
3439import Data.Proxy
3540import Data.These
41+import Data.Type.Equality ((:~:) (..))
42+import Data.Kind (Constraint)
43+
44+import Data.Patch.Class
45+import Data.Patch.MapWithMove (PatchMapWithMove (..))
46+import qualified Data.Patch.MapWithMove as MapWithMove
47+
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
3651
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
38−-- destinations.
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+
58+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
59+-- which describes how it will be changed by the patch and connects move sources
60+-- and destinations.
3961--
4062-- Invariants:
4163--
42−-- * 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)@)
64+-- * A key should not move to itself.
65+--
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'
68+-- destination)@)
4469newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
4570
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
47−-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
48−data NodeInfo k v a = NodeInfo
49− { _nodeInfo_from :: !(From k v a)
50− -- ^Change applying to the current key, be it an insert, move, or delete.
51− , _nodeInfo_to :: !(To k 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'.
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)
87+
88+-- | Structure which represents what changes apply to a particular key.
89+-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
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.
92+data NodeInfo k p a = NodeInfo
93+ { _nodeInfo_from :: !(From k p a)
94+ -- ^ Change applying to the current key, be it an insert, move, or delete.
95+ , _nodeInfo_to :: !(To k p a)
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'.
5398 }
54− deriving (Show)
55−
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
57−-- key (@From_Delete@), or moving a key (@From_Move@).
58−data From (k :: a -> *) (v :: a -> *) :: a -> * where
59− -- |Insert a new or update an existing key with the given value @v a@
60− From_Insert :: v a -> From k v a
61− -- |Delete the existing key
62− From_Delete :: From k v a
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@,
64− -- usually but not necessarily with @From_Delete@.
65− From_Move :: !(k a) -> From k v a
66− deriving (Show, Read, Eq, Ord)
67−
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
69−-- operation.
70−type To = ComposeMaybe
99+
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)
185+
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
188+-- a key (@From_Delete@), or moving a key (@From_Move@).
189+--
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.
193+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
194+ -- | Insert a new or update an existing key with the given value @PatchTarget1
195+ -- p a@
196+ From_Insert :: PatchTarget1 p to -> From k p to
197+ -- | Delete the existing key
198+ From_Delete :: From k p to
199+ -- | Move the value from the given key @k a@ to this key. The source key
200+ -- should also have an entry in the patch giving the current key as
201+ -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
202+ From_Move :: !(DSum k (Flip p to)) -> From k p to
203+
204+deriving instance ( Show (k a)
205+ , Show (p a a)
206+ , Show (PatchTarget1 p a)
207+ ) => Show (From k p a)
208+deriving instance ( Read (k a)
209+ , Read (p a a)
210+ , Read (PatchTarget1 p a)
211+ ) => Read (From k p a)
212+
213+deriving instance ( GEq k
214+ , HasZip Eq k p
215+ , Eq (PatchTarget1 p a)
216+ ) => Eq (From k p a)
217+
218+deriving instance ( GCompare k
219+ , HasZip Ord k p
220+ , Ord (PatchTarget1 p a)
221+ ) => Ord (From k p a)
222+
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 from
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 :: !(DSum k (p from)) -> To k p from
233+
234+deriving instance ( Show (k a)
235+ , Show (p a a)
236+ , Show (PatchTarget1 p a)
237+ ) => Show (To k p a)
238+deriving instance ( Read (k a)
239+ , Read (p a a)
240+ , Read (PatchTarget1 p a)
241+ ) => Read (To k p a)
242+
243+deriving instance ( GEq k
244+ , HasZip Eq k p
245+ , Eq (PatchTarget1 p a)
246+ ) => Eq (To k p a)
247+
248+deriving instance ( GCompare k
249+ , HasZip Ord k p
250+ , Ord (PatchTarget1 p a)
251+ ) => Ord (To k p a)
252+
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
71265
72266-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
73−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
267+validPatchDMapWithMove
268+ :: forall k v
269+ . (GCompare k, GShow k)
270+ => DMap k (NodeInfo k v)
271+ -> Bool
74272validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
75273
76274-- |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]
275+validationErrorsForPatchDMapWithMove
276+ :: forall k v
277+ . (GCompare k, GShow k)
278+ => DMap k (NodeInfo k v)
279+ -> [String]
78280validationErrorsForPatchDMapWithMove m =
79281 noSelfMoves <> movesBalanced
80282 where
81283 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
82− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
83− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
284+ selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
285+ | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
286+ selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
287+ | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
84288 selfMove _ = Nothing
85289 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
86− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
290+ unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
87291 case DMap.lookup src m of
88292 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'))) ->
293+ Just (NodeInfo _ (To_Move (dst' :=> _))) ->
90294 if isNothing (dst' `geq` dst)
91295 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
92296 else Nothing
93297 _ ->
94298 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))) =
299+ unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
96300 case DMap.lookup dst m of
97301 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') _) ->
302+ Just (NodeInfo (From_Move (src' :=> _)) _) ->
99303 if isNothing (src' `geq` src)
100304 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
101305 else Nothing
@@ -104,35 +308,49 @@ validationErrorsForPatchDMapWithMove m =
104308 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
105309 unbalancedMove _ = Nothing
106310
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
110−
111311-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
112312data Pair1 f g a = Pair1 (f a) (g a)
113313
114314-- |Helper data structure used for composing patches using the monoid instance.
115−data Fixup k v a
315+data Fixup k p a
116316 = Fixup_Delete
117− | Fixup_Update (These (From k v a) (To k a))
118−
119−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
120−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
317+ | Fixup_Update (These (From k p a) (To k p a))
318+
319+-- | Compose patches having the same effect as applying the patches in turn:
320+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
321+instance ( GCompare k
322+ , Cat.Semigroupoid p
323+ -- , DecidablyEmpty p
324+ , PatchHet2 p
325+ , PatchSource1 p ~ PatchTarget1 p
326+ ) => Semigroup (PatchDMapWithMove k p) where
121327 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
122328 where
123− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
124− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
125− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
126− (Just toAfter, From_Move fromBefore)
127− | isJust $ fromBefore `geq` toAfter
128− -> [toAfter :=> Fixup_Delete]
129− | otherwise
130− -> [ toAfter :=> Fixup_Update (This editBefore)
131− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
132− ]
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
134− (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
135− (Nothing, _) -> []
329+ connections :: [DSum k (Pair1 (To k p) (From k p))]
330+ connections = DMap.toList $ DMap.intersectionWithKey
331+ (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
332+ ma
333+ mb
334+ 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
336+ (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+ _ ->
341+ [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
342+ , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
343+ ]
344+ (To_NonMove, From_Move (fromBefore :=> _)) ->
345+ -- The item is destroyed in the second patch, so indicate that it is
346+ -- destroyed in the source map
347+ [fromBefore :=> Fixup_Update (That To_NonMove)]
348+ (To_Move (toAfter :=> p), From_Insert val) ->
349+ [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
350+ (To_Move (toAfter :=> p), From_Delete) ->
351+ [toAfter :=> Fixup_Update (This From_Delete)]
352+ (To_NonMove, _) ->
353+ []
136354 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
137355 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
138356 | This x <- a, That y <- b
@@ -163,13 +381,19 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
163381 These _ b -> Just b
164382 That b -> Just b
165383
166−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
167−instance GCompare k => Monoid (PatchDMapWithMove k v) where
384+-- | Compose patches having the same effect as applying the patches in turn:
385+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
386+instance ( GCompare k
387+ , Cat.Semigroupoid p
388+ -- , DecidablyEmpty p
389+ , PatchHet2 p
390+ , PatchSource1 p ~ PatchTarget1 p
391+ ) => Monoid (PatchDMapWithMove k p) where
168392 mempty = PatchDMapWithMove mempty
169393 mappend = (<>)
170394
171395{-
172−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
396+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
173397PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
174398 where
175399 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,21 +414,21 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
190414 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
191415-}
192416
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'.
194−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
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'.
418+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
195419insertDMapKey k v =
196− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
420+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
197421
198422-- |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:
199423--
200424-- @
201425-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
202426-- @
203−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
427+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy2 v)
204428moveDMapKey src dst = case src `geq` dst of
205429 Nothing -> PatchDMapWithMove $ DMap.fromList
206− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
207− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
430+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) To_NonMove
431+ , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy2)
208432 ]
209433 Just _ -> mempty
210434
@@ -220,8 +444,8 @@ moveDMapKey src dst = case src `geq` dst of
220444swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
221445swapDMapKey src dst = case src `geq` dst of
222446 Nothing -> PatchDMapWithMove $ DMap.fromList
223− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
224− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
447+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
448+ , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (To_Move $ dst :=> Proxy2)
225449 ]
226450 Just _ -> mempty
227451
@@ -272,41 +496,75 @@ patchDMapWithMove dm =
272496 errs -> Left errs
273497
274498-- |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'
276−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
499+mapPatchDMapWithMove
500+ :: forall k p p'
501+ . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
502+ -> (forall from to. p from to -> p' from to)
503+ -> PatchDMapWithMove k p
504+ -> PatchDMapWithMove k p'
505+mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
277506 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
278− where g :: forall a. From k v a -> From k v' a
507+ where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
279508 g = \case
280509 From_Insert v -> From_Insert $ f v
281510 From_Delete -> From_Delete
282− From_Move k -> From_Move k
283−
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')@.
285−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
511+ From_Move k p -> From_Move k $ g p
512+
513+-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
514+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
515+-- ('PatchDMapWithMove' k v')@.
516+traversePatchDMapWithMove
517+ :: forall m k p p'
518+ . Applicative m
519+ => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
520+ -> PatchDMapWithMove k p
521+ -> m (PatchDMapWithMove k p')
286522traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
287523
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')@.
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')
290−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
291− where g :: forall a. k a -> From k v a -> m (From k v' a)
524+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
525+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
526+-- ('PatchDMapWithMove' k v')@.
527+traversePatchDMapWithMoveWithKey
528+ :: forall m k p p'
529+ . Applicative m
530+ => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
531+ -> PatchDMapWithMove k p
532+ -> 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)
292536 g k = \case
293537 From_Insert v -> From_Insert <$> f k v
294538 From_Delete -> pure From_Delete
295539 From_Move fromKey -> pure $ From_Move fromKey
296540
297−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
298−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
541+-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
542+-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
543+nodeInfoMapFrom
544+ :: (From k p a -> From k p' a)
545+ -> NodeInfo k p a
546+ -> NodeInfo k p' a
299547nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
300548
301−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
302−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
549+-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
550+-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
551+nodeInfoMapFromM
552+ :: Functor f
553+ => (From k p a -> f (From k p' a))
554+ -> NodeInfo k p a
555+ -> f (NodeInfo k p' a)
303556nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
304557
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
306−-- values.
307−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) (Proxy v')
558+-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
559+-- from @k a@ to @'Some' k@ and applying a given weakening function
560+-- @PatchTarget1 p a -> v'@ to values.
561+weakenPatchDMapWithMoveWith
562+ :: forall k p v'
563+ . (forall a. PatchTarget1 p a -> v')
564+ -> PatchDMapWithMove k p
565+ -> PatchMapWithMove (Some k) (Proxy v')
308566weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
309− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) (Proxy v')
567+ where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
310568 g ni = MapWithMove.NodeInfo
311569 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
312570 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -315,11 +573,16 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
315573 , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
316574 }
317575
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
319−-- dependency in the typing and all points are already @a@, hence the function 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')
576+-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
577+-- v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
578+-- dependency in the typing and all points are already @a@, hence the function
579+-- to map each value to @v'@ is not higher rank.
580+patchDMapWithMoveToPatchMapWithMoveWith
581+ :: forall k p v' a. (PatchTarget1 p a -> v')
582+ -> PatchDMapWithMove (Const2 k a) p
583+ -> PatchMapWithMove k (Proxy v')
321584patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
322− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k (Proxy v')
585+ where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
323586 g ni = MapWithMove.NodeInfo
324587 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
325588 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -328,10 +591,16 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
328591 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
329592 }
330593
331−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
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@.
333−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
334−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k (Proxy v) -> PatchDMapWithMove (Const2 k a) v'
594+-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
595+-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
596+-- dependently typed one but which always has a constant key type represented by
597+-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
598+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
599+const2PatchDMapWithMoveWith
600+ :: forall k v p' a
601+ . (v -> PatchTarget1 p' a)
602+ -> PatchMapWithMove k (Proxy v)
603+ -> PatchDMapWithMove (Const2 k a) p'
335604const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
336605 where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
337606 g (k, ni) = Const2 k :=> NodeInfo
@@ -343,22 +612,28 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
343612 }
344613
345614-- | Apply the insertions, deletions, and moves to a given 'DMap'.
346−instance GCompare k => Patch (PatchDMapWithMove k v) 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?
615+instance GCompare k => PatchHet (PatchDMapWithMove k p) where
616+ type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
617+ 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)
620+ -- TODO: return Nothing sometimes --Note: the strict application here is
621+ -- critical to ensuring that incremental merges don't hold onto all their
622+ -- prerequisite events forever; can we make this more robust?
349623 where insertions = DMap.mapMaybeWithKey insertFunc p
350− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
624+ insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
351625 insertFunc _ ni = case _nodeInfo_from ni of
352626 From_Insert v -> Just v
353627 From_Move k -> DMap.lookup k old
354628 From_Delete -> Nothing
355629 deletions = DMap.mapMaybeWithKey deleteFunc p
356− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
630+ deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
357631 deleteFunc _ ni = case _nodeInfo_from ni of
358632 From_Delete -> Just $ Constant ()
359633 _ -> Nothing
360634
361−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
635+-- | Get the values that will be replaced, deleted, or moved if the given patch
636+-- is applied to the given 'DMap'.
362637getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
363638getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
364639 where f _ v ni = Pair v $ _nodeInfo_to ni