@@ -1,101 +1,305 @@
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 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
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)
243+deriving instance ( GEq k
245+ , Eq (PatchTarget1 p a)
248+deriving instance ( GCompare k
250+ , Ord (PatchTarget1 p a)
254+-- :: ( PatchSource1 p ~ PatchTarget1 p
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
72-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
266-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
73−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
267+validPatchDMapWithMove
269+ . (GCompare k, GShow k)
270+ => DMap k (NodeInfo k v)
74validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
272validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
76-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
274-- |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
277+ . (GCompare k, GShow k)
278+ => DMap k (NodeInfo k v)
78validationErrorsForPatchDMapWithMove m =
280validationErrorsForPatchDMapWithMove m =
79 noSelfMoves <> movesBalanced
281 noSelfMoves <> movesBalanced
81 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
283 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
284+ 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"
285+ | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
286+ 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"
287+ | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
84 selfMove _ = Nothing
288 selfMove _ = Nothing
85 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
289 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
86− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
290+ unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
87 case DMap.lookup src m of
291 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"
292 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' :=> _))) ->
90 if isNothing (dst' `geq` dst)
294 if isNothing (dst' `geq` dst)
91 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
295 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
92 else Nothing
296 else Nothing
94 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
298 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 :=> _))) =
96 case DMap.lookup dst m of
300 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"
301 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' :=> _)) _) ->
99 if isNothing (src' `geq` src)
303 if isNothing (src' `geq` src)
100 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
304 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
101 else Nothing
305 else Nothing
@@ -104,35 +308,49 @@ validationErrorsForPatchDMapWithMove m =
104 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
308 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
105 unbalancedMove _ = Nothing
309 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
311-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
112data Pair1 f g a = Pair1 (f a) (g a)
312data Pair1 f g a = Pair1 (f a) (g a)
114-- |Helper data structure used for composing patches using the monoid instance.
314-- |Helper data structure used for composing patches using the monoid instance.
115−data Fixup k v a
315+data Fixup k p a
116 = Fixup_Delete
316 = Fixup_Delete
117− | Fixup_Update (These (From k v a) (To k a))
317+ | 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@
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
325+ , PatchSource1 p ~ PatchTarget1 p
120−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
326+ ) => Semigroup (PatchDMapWithMove k p) where
121 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
327 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
329+ connections :: [DSum k (Pair1 (To k p) (From k p))]
330+ connections = DMap.toList $ DMap.intersectionWithKey
123− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
331+ (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
124− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
334+ h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
125− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
335+ h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
126− (Just toAfter, From_Move fromBefore)
336+ (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
127− | isJust $ fromBefore `geq` toAfter
337+ case toAfter `geq` fromBefore of
338+ Just Refl | isNull p0 ->
128− -> [toAfter :=> Fixup_Delete]
339+ [ toAfter :=> Fixup_Delete ]
129− | otherwise
340+ _ ->
130− -> [ toAfter :=> Fixup_Update (This editBefore)
341+ [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
131− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
342+ , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
344+ (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
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) ->
134− (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
351+ [toAfter :=> Fixup_Update (This From_Delete)]
135− (Nothing, _) -> []
352+ (To_NonMove, _) ->
136 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
354 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
137 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
355 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
138 | This x <- a, That y <- b
356 | This x <- a, That y <- b
@@ -163,13 +381,19 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
163 These _ b -> Just b
381 These _ b -> Just b
164 That b -> Just b
382 That b -> Just b
166−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
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
390+ , PatchSource1 p ~ PatchTarget1 p
167−instance GCompare k => Monoid (PatchDMapWithMove k v) where
391+ ) => Monoid (PatchDMapWithMove k p) where
168 mempty = PatchDMapWithMove mempty
392 mempty = PatchDMapWithMove mempty
169 mappend = (<>)
393 mappend = (<>)
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
173PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
397PatchDMapWithMove 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
399 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
190 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
414 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'.
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'.
194−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
418+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
195insertDMapKey k v =
419insertDMapKey k v =
196− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
420+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
198-- |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:
422-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
201-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
425-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
203−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
427+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy2 v)
204moveDMapKey src dst = case src `geq` dst of
428moveDMapKey src dst = case src `geq` dst of
205 Nothing -> PatchDMapWithMove $ DMap.fromList
429 Nothing -> PatchDMapWithMove $ DMap.fromList
206− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
430+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) To_NonMove
207− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
431+ , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy2)
209 Just _ -> mempty
433 Just _ -> mempty
@@ -220,8 +444,8 @@ moveDMapKey src dst = case src `geq` dst of
220swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
444swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
221swapDMapKey src dst = case src `geq` dst of
445swapDMapKey src dst = case src `geq` dst of
222 Nothing -> PatchDMapWithMove $ DMap.fromList
446 Nothing -> PatchDMapWithMove $ DMap.fromList
223− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
447+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
224− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
448+ , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (To_Move $ dst :=> Proxy2)
226 Just _ -> mempty
450 Just _ -> mempty
@@ -272,41 +496,75 @@ patchDMapWithMove dm =
272 errs -> Left errs
496 errs -> Left errs
274-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
498-- |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'
499+mapPatchDMapWithMove
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'
276−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
505+mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
277 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
506 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
279 g = \case
508 g = \case
280 From_Insert v -> From_Insert $ f v
509 From_Insert v -> From_Insert $ f v
281 From_Delete -> From_Delete
510 From_Delete -> From_Delete
282− From_Move k -> From_Move k
511+ From_Move k p -> From_Move k $ g p
513+-- | 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')@.
514+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
515+-- ('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')
516+traversePatchDMapWithMove
519+ => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
520+ -> PatchDMapWithMove k p
521+ -> m (PatchDMapWithMove k p')
286traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
522traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
524+-- | 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')@.
525+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
526+-- ('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')
527+traversePatchDMapWithMoveWithKey
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) =
290−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
534+ PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
291− where g :: forall a. k a -> From k v a -> m (From k v' a)
535+ where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)
292 g k = \case
536 g k = \case
293 From_Insert v -> From_Insert <$> f k v
537 From_Insert v -> From_Insert <$> f k v
294 From_Delete -> pure From_Delete
538 From_Delete -> pure From_Delete
295 From_Move fromKey -> pure $ From_Move fromKey
539 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@.
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@.
298−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
543+nodeInfoMapFrom
544+ :: (From k p a -> From k p' a)
299nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
547nodeInfoMapFrom 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@.
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@.
302−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
551+nodeInfoMapFromM
553+ => (From k p a -> f (From k p' a))
555+ -> f (NodeInfo k p' a)
303nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
556nodeInfoMapFromM 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
558+-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
559+-- from @k a@ to @'Some' k@ and applying a given weakening function
306−-- values.
560+-- @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')
561+weakenPatchDMapWithMoveWith
563+ . (forall a. PatchTarget1 p a -> v')
564+ -> PatchDMapWithMove k p
565+ -> PatchMapWithMove (Some k) (Proxy v')
308weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
566weakenPatchDMapWithMoveWith 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')
310 g ni = MapWithMove.NodeInfo
568 g ni = MapWithMove.NodeInfo
311 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
569 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
312 From_Insert v -> MapWithMove.From_Insert $ f v
570 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -315,11 +573,16 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
315 , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
573 , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
576+-- | "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
577+-- 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.
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.
320−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k (Proxy v')
580+patchDMapWithMoveToPatchMapWithMoveWith
581+ :: forall k p v' a. (PatchTarget1 p a -> v')
582+ -> PatchDMapWithMove (Const2 k a) p
583+ -> PatchMapWithMove k (Proxy v')
321patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
584patchDMapWithMoveToPatchMapWithMoveWith 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')
323 g ni = MapWithMove.NodeInfo
586 g ni = MapWithMove.NodeInfo
324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
587 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
325 From_Insert v -> MapWithMove.From_Insert $ f v
588 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -328,10 +591,16 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
328 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
591 , 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
594+-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
595+-- ('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@.
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'
333−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
598+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
334−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k (Proxy v) -> PatchDMapWithMove (Const2 k a) v'
599+const2PatchDMapWithMoveWith
601+ . (v -> PatchTarget1 p' a)
602+ -> PatchMapWithMove k (Proxy v)
603+ -> PatchDMapWithMove (Const2 k a) p'
335const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
604const2PatchDMapWithMoveWith 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')
605 where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
337 g (k, ni) = Const2 k :=> NodeInfo
606 g (k, ni) = Const2 k :=> NodeInfo
@@ -343,22 +612,28 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
345-- | Apply the insertions, deletions, and moves to a given 'DMap'.
614-- | Apply the insertions, deletions, and moves to a given 'DMap'.
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)
346−instance GCompare k => Patch (PatchDMapWithMove k v) where
618+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?
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?
349 where insertions = DMap.mapMaybeWithKey insertFunc p
623 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)
351 insertFunc _ ni = case _nodeInfo_from ni of
625 insertFunc _ ni = case _nodeInfo_from ni of
352 From_Insert v -> Just v
626 From_Insert v -> Just v
353 From_Move k -> DMap.lookup k old
627 From_Move k -> DMap.lookup k old
354 From_Delete -> Nothing
628 From_Delete -> Nothing
355 deletions = DMap.mapMaybeWithKey deleteFunc p
629 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)
357 deleteFunc _ ni = case _nodeInfo_from ni of
631 deleteFunc _ ni = case _nodeInfo_from ni of
358 From_Delete -> Just $ Constant ()
632 From_Delete -> Just $ Constant ()
359 _ -> Nothing
633 _ -> Nothing
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'.
362getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
637getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
363getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
638getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
364 where f _ v ni = Pair v $ _nodeInfo_to ni
639 where f _ v ni = Pair v $ _nodeInfo_to ni