git.iko.soy/patch
on develop help sign in
WIP Generalize DMap patching
f78dd16John Ericson
patch.cabal+1
compare with develop
unifiedsplit
@@ -54,6 +54,7 @@ library
54
54
55 if flag(split-these)
55 if flag(split-these)
56 build-depends: these >= 1 && <1.1
56 build-depends: these >= 1 && <1.1
57+ , these-lens >= 1 && <1.1
57 , semialign >=1 && <1.2
58 , semialign >=1 && <1.2
58 , monoidal-containers >= 0.6 && < 0.7
59 , monoidal-containers >= 0.6 && < 0.7
59 else
60 else
src/Data/Patch/Class.hs+63−13
@@ -1,8 +1,8 @@
1{-# LANGUAGE DefaultSignatures #-}
1{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE QuantifiedConstraints #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
8-- | The interface for types which represent changes made to other types
8-- | The interface for types which represent changes made to other types
@@ -79,19 +79,69 @@ composePatchFunctions g f a =
79 let fp = f a
79 let fp = f a
80 in g (applyAlways fp a) <> fp
80 in g (applyAlways fp a) <> fp
81
81
82−class (forall x y
82+
83− . ( PatchHet (p x y)
83+class PatchHet2Base (p :: k -> k -> *) where
84− , PatchSource1 p x ~ PatchSource (p x y)
85− , PatchTarget1 p y ~ PatchTarget (p x y)
86− )
87− ) => PatchHet2 (p :: k -> k -> *) where
88 type PatchSource1 p :: k -> *
84 type PatchSource1 p :: k -> *
89 type PatchTarget1 p :: k -> *
85 type PatchTarget1 p :: k -> *
90
86
91−class ( PatchHet2 p
87+class ( PatchHet2Base p
88+ , PatchHet (p from to)
89+ , PatchSource1 p from ~ PatchSource (p from to)
90+ , PatchTarget1 p to ~ PatchTarget (p from to)
91+ ) => PatchHet2Locally (p :: k -> k -> *) from to where
92+instance ( PatchHet2Base p
93+ , PatchHet (p from to)
94+ , PatchSource1 p from ~ PatchSource (p from to)
95+ , PatchTarget1 p to ~ PatchTarget (p from to)
96+ ) => PatchHet2Locally (p :: k -> k -> *) from to where
97+
98+applyHet2Locally
99+ :: PatchHet2Locally p from to
100+ => p from to
101+ -> PatchSource1 p from
102+ -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
103+applyHet2Locally = applyHet
104+
105+applyAlwaysHet2Locally
106+ :: PatchHet2Locally p from to
107+ => p from to
108+ -> PatchSource1 p from
109+ -> PatchTarget1 p to
110+applyAlwaysHet2Locally = applyAlwaysHet
111+
112+-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and
113+-- PatchHet2Locally, or at least get rid of this.
114+class PatchHet2Base p => PatchHet2 (p :: k -> k -> *) where
115+ applyHet2
116+ :: p from to
117+ -> PatchSource1 p from
118+ -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
119+
120+applyAlwaysHet2
121+ :: PatchHet2 p
122+ => p from to
123+ -> PatchSource1 p from
124+ -> PatchTarget1 p to
125+applyAlwaysHet2 p t = case applyHet2 p t of
126+ Left Refl -> t
127+ Right t' -> t'
128+
129+-- | Connect the classes without quanitified constraints
130+newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
131+
132+instance PatchHet2 p => PatchHet (ProjectLocal p from to) where
133+ type PatchSource (ProjectLocal p from to) = PatchSource1 p from
134+ type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to
135+ applyHet (ProjectLocal p) src = applyHet2 p src
136+
137+instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
138+ type PatchSource1 (ProjectLocal p) = PatchSource1 p
139+ type PatchTarget1 (ProjectLocal p) = PatchTarget1 p
140+
141+class ( PatchHet2Base p
92 , PatchSource1 p ~ PatchTarget1 p
142 , PatchSource1 p ~ PatchTarget1 p
93 ) => Patch2 p
143 ) => Patch2 p
94−instance ( PatchHet2 p
144+instance ( PatchHet2Base p
95 , PatchSource1 p ~ PatchTarget1 p
145 , PatchSource1 p ~ PatchTarget1 p
96 ) => Patch2 p
146 ) => Patch2 p
97
147
@@ -106,12 +156,12 @@ data Proxy2 t a b = Proxy2
106 )
156 )
107
157
108-- | 'Replace2' can be used as a 'Patch' that always fully replaces the value
158-- | 'Replace2' can be used as a 'Patch' that always fully replaces the value
109−instance PatchHet (Replace2 (t :: k -> *) (a :: k) (b :: k)) where
159+instance PatchHet (Replace2 (t :: k -> *) (from :: k) (to :: k)) where
110− type PatchSource (Replace2 t a b) = t a
160+ type PatchSource (Replace2 t from to) = t from
111− type PatchTarget (Replace2 t a b) = t b
161+ type PatchTarget (Replace2 t from to) = t to
112 applyHet (Replace2 val) _ = Right val
162 applyHet (Replace2 val) _ = Right val
113
163
114−-- | 'Proxy2' can be used as a 'Patch' that always fully replaces the value
164+-- | 'Proxy2' can be used as a 'Patch' that always does nothing
115instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where
165instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where
116 type PatchSource (Proxy2 t a a) = t a
166 type PatchSource (Proxy2 t a a) = t a
117 type PatchTarget (Proxy2 t a a) = t a
167 type PatchTarget (Proxy2 t a a) = t a
src/Data/Patch/DMapWithMove.hs+217−77
@@ -3,6 +3,7 @@
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE InstanceSigs #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE PatternGuards #-}
@@ -19,10 +20,7 @@
19-- move values between keys.
20-- move values between keys.
20module Data.Patch.DMapWithMove where
21module Data.Patch.DMapWithMove where
21
22
22−import Data.Patch.Class
23+import qualified Control.Category as Cat
23−import Data.Patch.MapWithMove (PatchMapWithMove (..))
24−import qualified Data.Patch.MapWithMove as MapWithMove
25−
26import Data.Constraint.Extras
24import Data.Constraint.Extras
27import Data.Constraint.Compose
25import Data.Constraint.Compose
28import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
26import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
@@ -36,12 +34,16 @@ import qualified Data.Map as Map
36import Data.Maybe
34import Data.Maybe
37import Data.Monoid.DecidablyEmpty
35import Data.Monoid.DecidablyEmpty
38import Data.Semigroup (Semigroup (..), (<>))
36import Data.Semigroup (Semigroup (..), (<>))
37+import Data.Semigroupoid as Cat
39import Data.Some (Some(Some))
38import Data.Some (Some(Some))
40import Data.Proxy
39import Data.Proxy
41import Data.These
40import Data.These
42import Data.Type.Equality ((:~:) (..))
41import Data.Type.Equality ((:~:) (..))
43import Data.Kind (Constraint)
42import Data.Kind (Constraint)
44
43
44+import Data.Patch.Class
45+import Data.Patch.MapWithMove (PatchMapWithMove (..))
46+import qualified Data.Patch.MapWithMove as MapWithMove
45
47
46-- | Composition for constraints.
48-- | Composition for constraints.
47class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
49class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
@@ -53,13 +55,17 @@ type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
53type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
55type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
54 (ArgDict (DupC c g) f, ConstraintsForZip f c g)
56 (ArgDict (DupC c g) f, ConstraintsForZip f c g)
55
57
58+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
56−-- | 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
57−-- destinations.
60+-- and destinations.
58--
61--
59-- Invariants:
62-- Invariants:
60--
63--
61−-- * A key should not move to itself.
64+-- * A key should not move to itself.
65+--
62−-- * 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'
68+-- destination)@)
63newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
69newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
64
70
65deriving instance ( GShow k
71deriving instance ( GShow k
@@ -79,13 +85,16 @@ deriving instance ( GCompare k
79 , Has' Ord k (PatchTarget1 p)
85 , Has' Ord k (PatchTarget1 p)
80 ) => Ord (PatchDMapWithMove k p)
86 ) => Ord (PatchDMapWithMove k p)
81
87
88+-- | Structure which represents what changes apply to a particular key.
82−-- |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
83−-- 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.
84data NodeInfo k p a = NodeInfo
92data NodeInfo k p a = NodeInfo
85 { _nodeInfo_from :: !(From k p a)
93 { _nodeInfo_from :: !(From k p a)
86− -- ^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.
87− , _nodeInfo_to :: !(Some (To k))
95+ , _nodeInfo_to :: !(To k p a)
88− -- ^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'.
89 }
98 }
90
99
91deriving instance ( Show (k a)
100deriving instance ( Show (k a)
@@ -105,16 +114,92 @@ deriving instance ( Ord (k a)
105 , Ord (PatchTarget1 p a)
114 , Ord (PatchTarget1 p a)
106 ) => Ord (NodeInfo k p a)
115 ) => Ord (NodeInfo k p a)
107
116
108−-- |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
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
109−-- key (@From_Delete@), or moving a key (@From_Move@).
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.
110data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
193data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
111− -- |Insert a new or update an existing key with the given value @PatchTarget1 p a@
194+ -- | Insert a new or update an existing key with the given value @PatchTarget1
195+ -- p a@
112− From_Insert :: PatchTarget1 p a -> From k p a
196+ From_Insert :: PatchTarget1 p to -> From k p to
113− -- |Delete the existing key
197+ -- | Delete the existing key
114− From_Delete :: From k p a
198+ From_Delete :: From k p to
199+ -- | Move the value from the given key @k a@ to this key. The source key
115− -- |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
116− -- usually but not necessarily with @From_Delete@.
201+ -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
117− From_Move :: !(k a0) -> p a0 a1 -> From k p a1
202+ From_Move :: !(DSum k (Flip p to)) -> From k p to
118
203
119deriving instance ( Show (k a)
204deriving instance ( Show (k a)
120 , Show (p a a)
205 , Show (p a a)
@@ -125,30 +210,67 @@ deriving instance ( Read (k a)
125 , Read (PatchTarget1 p a)
210 , Read (PatchTarget1 p a)
126 ) => Read (From k p a)
211 ) => Read (From k p a)
127
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 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
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+
128instance ( GEq k
243instance ( GEq k
129 , HasZip Eq k p
244 , HasZip Eq k p
130 , Eq (PatchTarget1 p a)
245 , Eq (PatchTarget1 p a)
131− ) => Eq (From k p a) where
246+ ) => Eq (To k p a) where
132− From_Insert p0 == From_Insert p1 = p0 == p1
247+ To_NonMove == To_NonMove = True
133− From_Delete == From_Delete = True
134− From_Move k0 p0 == From_Move k1 p1 = case geq k0 k1 of
248+ To_Move k0 p0 == To_Move k1 p1 = case geq k0 k1 of
135 Nothing -> False
249 Nothing -> False
136 Just Refl -> has @(DupC Eq p) k0 $ p0 == p1
250 Just Refl -> has @(DupC Eq p) k0 $ p0 == p1
137
251
138instance ( GCompare k
252instance ( GCompare k
139 , HasZip Ord k p
253 , HasZip Ord k p
140 , Ord (PatchTarget1 p a)
254 , Ord (PatchTarget1 p a)
141− ) => Ord (From k p a) where
255+ ) => Ord (To k p a) where
142− From_Insert p0 `compare` From_Insert p1 = p0 `compare` p1
256+ To_NonMove `compare` To_NonMove = EQ
143− From_Delete `compare` From_Delete = EQ
144− From_Move k0 p0 `compare` From_Move k1 p1 = case gcompare k0 k1 of
257+ To_Move k0 p0 `compare` To_Move k1 p1 = case gcompare k0 k1 of
145 DMap.GGT -> GT
258 DMap.GGT -> GT
146 DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1
259 DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1
147 DMap.GLT -> LT
260 DMap.GLT -> LT
148
261
149−-- |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
262+--oToFrom
150−-- operation.
263+-- :: ( PatchSource1 p ~ PatchTarget1 p
151−type To = ComposeMaybe
264+-- , PatchHet2 p
265+-- )
266+-- => To k p between
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
152
274
153-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
275-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
154validPatchDMapWithMove
276validPatchDMapWithMove
@@ -168,25 +290,25 @@ validationErrorsForPatchDMapWithMove m =
168 noSelfMoves <> movesBalanced
290 noSelfMoves <> movesBalanced
169 where
291 where
170 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
292 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
171− selfMove (dst :=> NodeInfo (From_Move src _) _)
293+ selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
172 | 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"
173− selfMove (src :=> NodeInfo _ (Some (ComposeMaybe (Just dst))))
295+ selfMove (src :=> NodeInfo _ (To_Move dst _))
174 | 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"
175 selfMove _ = Nothing
297 selfMove _ = Nothing
176 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
298 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
177− unbalancedMove (dst :=> NodeInfo (From_Move src _) _) =
299+ unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
178 case DMap.lookup src m of
300 case DMap.lookup src m of
179 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"
180− Just (NodeInfo _ (Some (ComposeMaybe (Just dst')))) ->
302+ Just (NodeInfo _ (To_Move dst' _)) ->
181 if isNothing (dst' `geq` dst)
303 if isNothing (dst' `geq` dst)
182 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"
183 else Nothing
305 else Nothing
184 _ ->
306 _ ->
185 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"
186− unbalancedMove (src :=> NodeInfo _ (Some (ComposeMaybe (Just dst)))) =
308+ unbalancedMove (src :=> NodeInfo _ (To_Move dst _)) =
187 case DMap.lookup dst m of
309 case DMap.lookup dst m of
188 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"
189− Just (NodeInfo (From_Move src' _) _) ->
311+ Just (NodeInfo (From_Move (src' :=> _)) _) ->
190 if isNothing (src' `geq` src)
312 if isNothing (src' `geq` src)
191 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"
192 else Nothing
314 else Nothing
@@ -198,36 +320,38 @@ validationErrorsForPatchDMapWithMove m =
198-- |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
199data Pair1 f g a = Pair1 (f a) (g a)
321data Pair1 f g a = Pair1 (f a) (g a)
200
322
201−data PairHalf a f b = PairHalf a (f b)
202−
203-- |Helper data structure used for composing patches using the monoid instance.
323-- |Helper data structure used for composing patches using the monoid instance.
204−data Fixup k v a
324+data Fixup k p a
205 = Fixup_Delete
325 = Fixup_Delete
206− | Fixup_Update (These (From k v a) (To k a))
326+ | Fixup_Update (These (From k p a) (To k p a))
207
327
208−-- |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@
209instance ( GCompare k
330instance ( GCompare k
331+ , Cat.Semigroupoid p
210 -- , DecidablyEmpty p
332 -- , DecidablyEmpty p
211 , PatchHet2 p
333 , PatchHet2 p
212 ) => Semigroup (PatchDMapWithMove k p) where
334 ) => Semigroup (PatchDMapWithMove k p) where
213 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
335 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
214 where
336 where
337+ connections :: [DSum k (Pair1 (To k p) (From k p))]
215 connections = DMap.toList $ DMap.intersectionWithKey
338 connections = DMap.toList $ DMap.intersectionWithKey
216− (\_ a b -> PairHalf (_nodeInfo_to a) (_nodeInfo_from b))
339+ (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
217 ma
340 ma
218 mb
341 mb
219− h :: DSum k (PairHalf (Some (ComposeMaybe k)) (From k v)) -> [DSum k (Fixup k v)]
342+ h :: DSum k (Pair1 k (From k v)) -> [DSum k (Fixup k v)]
220− h (between :=> PairHalf (Some (ComposeMaybe mToAfter)) editBefore) = case (mToAfter, editBefore) of
343+ h (between :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
221− (Just toAfter, From_Move fromBefore p)
344+ (To_Move toAfter p1, From_Move (fromBefore :=> p0)) -> case toAfter `geq` fromBefore of
222− | case fromBefore `geq` toAfter of
223− Nothing -> False
224− Just Refl -> isNull p
345+ Just Refl | isNull p0 ->
225− -> [toAfter :=> Fixup_Delete]
346+ [ toAfter :=> Fixup_Delete ]
226− | otherwise
347+ _ ->
227− -> [ toAfter :=> Fixup_Update (This editBefore)
348+ [ toAfter :=> Fixup_Update (This editBefore)
228− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
349+ , fromBefore :=> Fixup_Update (That editAfter)
229− ]
350+ ]
351+ (To_NonMove, From_Move (fromBefore :=> _)) ->
230− (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))]
231 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
355 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
232 (Nothing, _) -> []
356 (Nothing, _) -> []
233 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
357 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -246,11 +370,11 @@ instance ( GCompare k
246 Fixup_Delete -> Nothing
370 Fixup_Delete -> Nothing
247 Fixup_Update u -> Just $ NodeInfo
371 Fixup_Update u -> Just $ NodeInfo
248 { _nodeInfo_from = case _nodeInfo_from ni of
372 { _nodeInfo_from = case _nodeInfo_from ni of
249− f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
373+ f@(From_Move (_ :=> p')) -> case _here u of -- The `from` fixup comes from the "old" patch
250 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
374 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
251 Just (From_Insert v) -> From_Insert $ applyAlways p' v
375 Just (From_Insert v) -> From_Insert $ applyAlways p' v
252 Just From_Delete -> From_Delete
376 Just From_Delete -> From_Delete
253− Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
377+ Just (From_Move (oldKey :=> p)) -> From_Move $ oldKey :=> (p' <> p)
254 _ -> error "DPatchMapWithMove: fixup for non-move From"
378 _ -> error "DPatchMapWithMove: fixup for non-move From"
255 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
379 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
256 }
380 }
@@ -306,7 +430,7 @@ insertDMapKey k v =
306moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
430moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
307moveDMapKey src dst = case src `geq` dst of
431moveDMapKey src dst = case src `geq` dst of
308 Nothing -> PatchDMapWithMove $ DMap.fromList
432 Nothing -> PatchDMapWithMove $ DMap.fromList
309− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
433+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe Nothing)
310 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
434 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
311 ]
435 ]
312 Just _ -> mempty
436 Just _ -> mempty
@@ -323,8 +447,8 @@ moveDMapKey src dst = case src `geq` dst of
323swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
447swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
324swapDMapKey src dst = case src `geq` dst of
448swapDMapKey src dst = case src `geq` dst of
325 Nothing -> PatchDMapWithMove $ DMap.fromList
449 Nothing -> PatchDMapWithMove $ DMap.fromList
326− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
450+ [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
327− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
451+ , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (ComposeMaybe $ Just dst)
328 ]
452 ]
329 Just _ -> mempty
453 Just _ -> mempty
330
454
@@ -378,17 +502,20 @@ patchDMapWithMove dm =
378mapPatchDMapWithMove
502mapPatchDMapWithMove
379 :: forall k p p'
503 :: forall k p p'
380 . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
504 . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
505+ -> (forall from to. p from to -> p' from to)
381 -> PatchDMapWithMove k p
506 -> PatchDMapWithMove k p
382 -> PatchDMapWithMove k p'
507 -> PatchDMapWithMove k p'
383−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
508+mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
384 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
509 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
385 where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
510 where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
386 g = \case
511 g = \case
387 From_Insert v -> From_Insert $ f v
512 From_Insert v -> From_Insert $ f v
388 From_Delete -> From_Delete
513 From_Delete -> From_Delete
389− From_Move k -> From_Move k
514+ From_Move k p -> From_Move k $ g p
390
515
516+-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
391−-- |Traverse an effectful function @forall a. PatchTarget1 p 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')@.
392traversePatchDMapWithMove
519traversePatchDMapWithMove
393 :: forall m k p p'
520 :: forall m k p p'
394 . Applicative m
521 . Applicative m
@@ -397,7 +524,9 @@ traversePatchDMapWithMove
397 -> m (PatchDMapWithMove k p')
524 -> m (PatchDMapWithMove k p')
398traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
525traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
399
526
527+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
400−-- |Map an effectful function @forall a. k a -> PatchTarget1 p 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')@.
401traversePatchDMapWithMoveWithKey
530traversePatchDMapWithMoveWithKey
402 :: forall m k p p'
531 :: forall m k p p'
403 . Applicative m
532 . Applicative m
@@ -412,14 +541,16 @@ traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
412 From_Delete -> pure From_Delete
541 From_Delete -> pure From_Delete
413 From_Move fromKey -> pure $ From_Move fromKey
542 From_Move fromKey -> pure $ From_Move fromKey
414
543
415−-- |Map a function which transforms @'From' k PatchTarget1 p a@ into a @'From' k PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p 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@.
416nodeInfoMapFrom
546nodeInfoMapFrom
417 :: (From k p a -> From k p' a)
547 :: (From k p a -> From k p' a)
418 -> NodeInfo k p a
548 -> NodeInfo k p a
419 -> NodeInfo k p' a
549 -> NodeInfo k p' a
420nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
550nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
421
551
422−-- |Map an effectful function which transforms @'From' k PatchTarget1 p a@ into a @f ('From' k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p 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@.
423nodeInfoMapFromM
554nodeInfoMapFromM
424 :: Functor f
555 :: Functor f
425 => (From k p a -> f (From k p' a))
556 => (From k p a -> f (From k p' a))
@@ -427,8 +558,9 @@ nodeInfoMapFromM
427 -> f (NodeInfo k p' a)
558 -> f (NodeInfo k p' a)
428nodeInfoMapFromM 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
429
560
430−-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @PatchTarget1 p 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
431−-- values.
563+-- @PatchTarget1 p a -> v'@ to values.
432weakenPatchDMapWithMoveWith
564weakenPatchDMapWithMoveWith
433 :: forall k p v'
565 :: forall k p v'
434 . (forall a. PatchTarget1 p a -> v')
566 . (forall a. PatchTarget1 p a -> v')
@@ -444,8 +576,10 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
444 , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
576 , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
445 }
577 }
446
578
579+-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
447−-- |"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
448−-- 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.
449patchDMapWithMoveToPatchMapWithMoveWith
583patchDMapWithMoveToPatchMapWithMoveWith
450 :: forall k p v' a. (PatchTarget1 p a -> v')
584 :: forall k p v' a. (PatchTarget1 p a -> v')
451 -> PatchDMapWithMove (Const2 k a) p
585 -> PatchDMapWithMove (Const2 k a) p
@@ -460,9 +594,11 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
460 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
594 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
461 }
595 }
462
596
463−-- |"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
599+-- dependently typed one but which always has a constant key type represented by
464−-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p' a@.
600+-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
465−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
601+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
466const2PatchDMapWithMoveWith
602const2PatchDMapWithMoveWith
467 :: forall k v p' a
603 :: forall k v p' a
468 . (v -> PatchTarget1 p' a)
604 . (v -> PatchTarget1 p' a)
@@ -483,7 +619,10 @@ instance GCompare k => PatchHet (PatchDMapWithMove k p) where
483 type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
619 type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
484 type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
620 type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
485instance GCompare k => Patch (PatchDMapWithMove k p) where
621instance GCompare k => Patch (PatchDMapWithMove k p) where
486− 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?
487 where insertions = DMap.mapMaybeWithKey insertFunc p
626 where insertions = DMap.mapMaybeWithKey insertFunc p
488 insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
627 insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
489 insertFunc _ ni = case _nodeInfo_from ni of
628 insertFunc _ ni = case _nodeInfo_from ni of
@@ -496,7 +635,8 @@ instance GCompare k => Patch (PatchDMapWithMove k p) where
496 From_Delete -> Just $ Constant ()
635 From_Delete -> Just $ Constant ()
497 _ -> Nothing
636 _ -> Nothing
498
637
499−-- | 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'.
500getDeletionsAndMoves :: 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))
501getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
641getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
502 where f _ v ni = Pair v $ _nodeInfo_to ni
642 where f _ v ni = Pair v $ _nodeInfo_to ni
src/Data/Patch/DMapWithReset.hs+3−1
@@ -93,10 +93,12 @@ mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKe
93{-# INLINE mergeWithKey #-}
93{-# INLINE mergeWithKey #-}
94
94
95-- | Apply the insertions or deletions to a given 'DMap'.
95-- | Apply the insertions or deletions to a given 'DMap'.
96−instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
96+instance (GCompare k, Has (Patches1Locally p) k) => PatchHet (PatchDMapWithReset k p) where
97
97
98+ type PatchSource (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
98 type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
99 type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
99
100
101+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
100 apply = go
102 apply = go
101 where
103 where
102 go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
104 go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))