git.iko.soy/patch
on develop help sign in
WIP: Patch in PatchDMapWithMove's From_Move
aa7311bJohn Ericson
src/Data/Patch/Class.hs+45−3
compare with develop
unifiedsplit
@@ -1,4 +1,8 @@
1{-# LANGUAGE DefaultSignatures #-}
1{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE DeriveTraversable #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE QuantifiedConstraints #-}
2{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
4-- | The interface for types which represent changes made to other types
8-- | The interface for types which represent changes made to other types
@@ -56,11 +60,11 @@ instance PatchHet (Identity a) where
56instance Patch (Identity a) where
60instance Patch (Identity a) where
57 apply (Identity a) _ = Just a
61 apply (Identity a) _ = Just a
58
62
59−-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
63+-- | 'Proxy' can be used as a 'Patch' that always fully replaces the value
60−instance PatchHet (Proxy a) where
64+instance PatchHet (Proxy (a :: *)) where
61 type PatchSource (Proxy a) = a
65 type PatchSource (Proxy a) = a
62 type PatchTarget (Proxy a) = a
66 type PatchTarget (Proxy a) = a
63−instance Patch (Proxy a) where
67+instance Patch (Proxy (a :: *)) where
64 apply ~Proxy _ = Nothing
68 apply ~Proxy _ = Nothing
65
69
66-- | Like '(.)', but composes functions that return patches rather than
70-- | Like '(.)', but composes functions that return patches rather than
@@ -74,3 +78,41 @@ composePatchFunctions
74composePatchFunctions g f a =
78composePatchFunctions g f a =
75 let fp = f a
79 let fp = f a
76 in g (applyAlways fp a) <> fp
80 in g (applyAlways fp a) <> fp
81+
82+class (forall x y
83+ . ( PatchHet (p x y)
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 -> *
89+ type PatchTarget1 p :: k -> *
90+
91+class ( PatchHet2 p
92+ , PatchSource1 p ~ PatchTarget1 p
93+ ) => Patch2 p
94+instance ( PatchHet2 p
95+ , PatchSource1 p ~ PatchTarget1 p
96+ ) => Patch2 p
97+
98+newtype Replace2 (t :: k -> *) (a :: k) (b :: k) = Replace2 (t b)
99+ deriving ( Show, Read, Eq, Ord
100+ , Functor, Foldable, Traversable
101+ )
102+
103+data Proxy2 t a b = Proxy2
104+ deriving ( Show, Read, Eq, Ord
105+ , Functor, Foldable, Traversable
106+ )
107+
108+-- | 'Replace2' can be used as a 'Patch' that always fully replaces the value
109+instance PatchHet (Replace2 (t :: k -> *) (a :: k) (b :: k)) where
110+ type PatchSource (Replace2 t a b) = t a
111+ type PatchTarget (Replace2 t a b) = t b
112+ applyHet (Replace2 val) _ = Right val
113+
114+-- | 'Proxy2' can be used as a 'Patch' that always fully replaces the value
115+instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where
116+ type PatchSource (Proxy2 t a a) = t a
117+ type PatchTarget (Proxy2 t a a) = t a
118+ applyHet ~Proxy2 _ = Left Refl
src/Data/Patch/DMapWithMove.hs+185−54
@@ -1,4 +1,5 @@
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 #-}
@@ -8,8 +9,11 @@
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE StandaloneDeriving #-}
13+{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableSuperClasses #-}
13
17
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
18-- |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.
19-- move values between keys.
@@ -20,19 +24,34 @@ import Data.Patch.MapWithMove (PatchMapWithMove (..))
20import qualified Data.Patch.MapWithMove as MapWithMove
24import qualified Data.Patch.MapWithMove as MapWithMove
21
25
22import Data.Constraint.Extras
26import Data.Constraint.Extras
27+import Data.Constraint.Compose
23import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
28import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24import qualified Data.Dependent.Map as DMap
29import qualified Data.Dependent.Map as DMap
25import Data.Functor.Constant
30import Data.Functor.Constant
26import Data.Functor.Misc
31import Data.Functor.Misc
27import Data.Functor.Product
32import Data.Functor.Product
28−import Data.GADT.Compare (GEq (..))
33+import Data.GADT.Compare (GEq (..), GCompare)
29−import Data.GADT.Show (GShow, gshow)
34+import Data.GADT.Show (GRead, GShow, gshow)
30import qualified Data.Map as Map
35import qualified Data.Map as Map
31import Data.Maybe
36import Data.Maybe
37+import Data.Monoid.DecidablyEmpty
32import Data.Semigroup (Semigroup (..), (<>))
38import Data.Semigroup (Semigroup (..), (<>))
33import Data.Some (Some(Some))
39import Data.Some (Some(Some))
34import Data.Proxy
40import Data.Proxy
35import Data.These
41import Data.These
42+import Data.Type.Equality ((:~:) (..))
43+import Data.Kind (Constraint)
44+
45+
46+-- | Composition for constraints.
47+class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
48+instance p (f a a) => DupC p f a
49+
50+type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
51+ ConstraintsFor f (DupC c g)
52+
53+type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
54+ (ArgDict (DupC c g) f, ConstraintsForZip f c g)
36
55
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
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
38-- destinations.
57-- destinations.
@@ -43,47 +62,119 @@ import Data.These
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)@)
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)@)
44newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
63newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
45
64
65+deriving instance ( GShow k
66+ , HasZip Show k p
67+ , Has' Show k (PatchTarget1 p)
68+ ) => Show (PatchDMapWithMove k p)
69+deriving instance ( GRead k
70+ , HasZip Read k p
71+ , Has' Read k (PatchTarget1 p)
72+ ) => Read (PatchDMapWithMove k p)
73+deriving instance ( GEq k
74+ , HasZip Eq k p
75+ , Has' Eq k (PatchTarget1 p)
76+ ) => Eq (PatchDMapWithMove k p)
77+deriving instance ( GCompare k
78+ , HasZip Ord k p
79+ , Has' Ord k (PatchTarget1 p)
80+ ) => Ord (PatchDMapWithMove k p)
81+
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
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
47-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
83-- 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
84+data NodeInfo k p a = NodeInfo
49− { _nodeInfo_from :: !(From k v a)
85+ { _nodeInfo_from :: !(From k p a)
50 -- ^Change applying to the current key, be it an insert, move, or delete.
86 -- ^Change applying to the current key, be it an insert, move, or delete.
51 , _nodeInfo_to :: !(To k a)
87 , _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'.
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'.
53 }
89 }
90+
54− deriving (Show)
91+deriving instance ( Show (k a)
92+ , Show (p a a)
93+ , Show (PatchTarget1 p a)
94+ ) => Show (NodeInfo k p a)
95+deriving instance ( Read (k a)
96+ , Read (p a a)
97+ , Read (PatchTarget1 p a)
98+ ) => Read (NodeInfo k p a)
99+deriving instance ( Eq (k a)
100+ , Eq (p a a)
101+ , Eq (PatchTarget1 p a)
102+ ) => Eq (NodeInfo k p a)
103+deriving instance ( Ord (k a)
104+ , Ord (p a a)
105+ , Ord (PatchTarget1 p a)
106+ ) => Ord (NodeInfo k p a)
55
107
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
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
57-- key (@From_Delete@), or moving a key (@From_Move@).
109-- key (@From_Delete@), or moving a key (@From_Move@).
58−data From (k :: a -> *) (v :: a -> *) :: a -> * where
110+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
59− -- |Insert a new or update an existing key with the given value @v a@
111+ -- |Insert a new or update an existing key with the given value @PatchTarget1 p a@
60− From_Insert :: v a -> From k v a
112+ From_Insert :: PatchTarget1 p a -> From k p a
61 -- |Delete the existing key
113 -- |Delete the existing key
62− From_Delete :: From k v a
114+ From_Delete :: From k p 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@,
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@,
64 -- usually but not necessarily with @From_Delete@.
116 -- usually but not necessarily with @From_Delete@.
65− From_Move :: !(k a) -> From k v a
117+ From_Move :: !(k a0) -> p a0 a1 -> From k p a1
66− deriving (Show, Read, Eq, Ord)
118+
119+deriving instance ( Show (k a)
120+ , Show (p a a)
121+ , Show (PatchTarget1 p a)
122+ ) => Show (From k p a)
123+deriving instance ( Read (k a)
124+ , Read (p a a)
125+ , Read (PatchTarget1 p a)
126+ ) => Read (From k p a)
127+
128+instance ( GEq k
129+ , HasZip Eq k p
130+ , Eq (PatchTarget1 p a)
131+ ) => Eq (From k p a) where
132+ From_Insert p0 == From_Insert p1 = p0 == p1
133+ From_Delete == From_Delete = True
134+ From_Move k0 p0 == From_Move k1 p1 = case geq k0 k1 of
135+ Nothing -> False
136+ Just Refl -> has @(DupC Eq p) k0 $ p0 == p1
137+
138+instance ( GCompare k
139+ , HasZip Ord k p
140+ , Ord (PatchTarget1 p a)
141+ ) => Ord (From k p a) where
142+ From_Insert p0 `compare` From_Insert p1 = p0 `compare` p1
143+ From_Delete `compare` From_Delete = EQ
144+ From_Move k0 p0 `compare` From_Move k1 p1 = case gcompare k0 k1 of
145+ DMap.GGT -> GT
146+ DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1
147+ DMap.GLT -> LT
67
148
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
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
69-- operation.
150-- operation.
70type To = ComposeMaybe
151type To = ComposeMaybe
71
152
72-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
153-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
73−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
154+validPatchDMapWithMove
155+ :: forall k v
156+ . (GCompare k, GShow k)
157+ => DMap k (NodeInfo k v)
158+ -> Bool
74validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
159validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
75
160
76-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
161-- |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]
162+validationErrorsForPatchDMapWithMove
163+ :: forall k v
164+ . (GCompare k, GShow k)
165+ => DMap k (NodeInfo k v)
166+ -> [String]
78validationErrorsForPatchDMapWithMove m =
167validationErrorsForPatchDMapWithMove m =
79 noSelfMoves <> movesBalanced
168 noSelfMoves <> movesBalanced
80 where
169 where
81 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
170 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
171+ 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"
172+ | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
173+ selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst)))
83− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
174+ | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
84 selfMove _ = Nothing
175 selfMove _ = Nothing
85 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
176 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
86− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
177+ unbalancedMove (dst :=> NodeInfo (From_Move src _) _) =
87 case DMap.lookup src m of
178 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"
179 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'))) ->
180 Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
@@ -95,7 +186,7 @@ validationErrorsForPatchDMapWithMove m =
95 unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
186 unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
96 case DMap.lookup dst m of
187 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"
188 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') _) ->
189+ Just (NodeInfo (From_Move src' _) _) ->
99 if isNothing (src' `geq` src)
190 if isNothing (src' `geq` src)
100 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
191 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
101 else Nothing
192 else Nothing
@@ -104,10 +195,6 @@ validationErrorsForPatchDMapWithMove m =
104 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
195 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
105 unbalancedMove _ = Nothing
196 unbalancedMove _ = Nothing
106
197
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−
111-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
198-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
112data Pair1 f g a = Pair1 (f a) (g a)
199data Pair1 f g a = Pair1 (f a) (g a)
113
200
@@ -117,20 +204,25 @@ data Fixup k v a
117 | Fixup_Update (These (From k v a) (To k a))
204 | Fixup_Update (These (From k v a) (To k a))
118
205
119-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
206-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
207+instance ( GCompare k
208+ -- , DecidablyEmpty p
209+ , PatchHet2 p
120−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
210+ ) => Semigroup (PatchDMapWithMove k p) where
121 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
211 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
122 where
212 where
123 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
213 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)]
214 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
125 h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
215 h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
126− (Just toAfter, From_Move fromBefore)
216+ (Just toAfter, From_Move fromBefore p)
127− | isJust $ fromBefore `geq` toAfter
217+ | case fromBefore `geq` toAfter of
218+ Nothing -> False
219+ Just Refl -> isNull p
128 -> [toAfter :=> Fixup_Delete]
220 -> [toAfter :=> Fixup_Delete]
129 | otherwise
221 | otherwise
130 -> [ toAfter :=> Fixup_Update (This editBefore)
222 -> [ toAfter :=> Fixup_Update (This editBefore)
131 , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
223 , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
132 ]
224 ]
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
225+ (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)]
226 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
135 (Nothing, _) -> []
227 (Nothing, _) -> []
136 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
228 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -148,7 +240,13 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
148 applyFixup _ ni = \case
240 applyFixup _ ni = \case
149 Fixup_Delete -> Nothing
241 Fixup_Delete -> Nothing
150 Fixup_Update u -> Just $ NodeInfo
242 Fixup_Update u -> Just $ NodeInfo
151− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
243+ { _nodeInfo_from = case _nodeInfo_from ni of
244+ f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
245+ Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
246+ Just (From_Insert v) -> From_Insert $ applyAlways p' v
247+ Just From_Delete -> From_Delete
248+ Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
249+ _ -> error "DPatchMapWithMove: fixup for non-move From"
152 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
250 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
153 }
251 }
154 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
252 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -169,7 +267,7 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where
169 mappend = (<>)
267 mappend = (<>)
170
268
171{-
269{-
172−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
270+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
271PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
174 where
272 where
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
273 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
@@ -190,8 +288,8 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
190 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
288 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
191-}
289-}
192
290
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'.
291+-- |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
292+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
195insertDMapKey k v =
293insertDMapKey k v =
196 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
294 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
197
295
@@ -272,41 +370,67 @@ patchDMapWithMove dm =
272 errs -> Left errs
370 errs -> Left errs
273
371
274-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
372-- |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'
373+mapPatchDMapWithMove
374+ :: forall k p p'
375+ . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
376+ -> PatchDMapWithMove k p
377+ -> PatchDMapWithMove k p'
276mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
378mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
277 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
379 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
278− where g :: forall a. From k v a -> From k v' a
380+ where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
279 g = \case
381 g = \case
280 From_Insert v -> From_Insert $ f v
382 From_Insert v -> From_Insert $ f v
281 From_Delete -> From_Delete
383 From_Delete -> From_Delete
282 From_Move k -> From_Move k
384 From_Move k -> From_Move k
283
385
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')@.
386+-- |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')@.
285−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
387+traversePatchDMapWithMove
388+ :: forall m k p p'
389+ . Applicative m
390+ => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
391+ -> PatchDMapWithMove k p
392+ -> m (PatchDMapWithMove k p')
286traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
393traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
287
394
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')@.
395+-- |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')@.
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')
396+traversePatchDMapWithMoveWithKey
397+ :: forall m k p p'
398+ . Applicative m
399+ => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
400+ -> PatchDMapWithMove k p
401+ -> m (PatchDMapWithMove k p')
402+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
290−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
403+ PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
291− where g :: forall a. k a -> From k v a -> m (From k v' a)
404+ where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)
292 g k = \case
405 g k = \case
293 From_Insert v -> From_Insert <$> f k v
406 From_Insert v -> From_Insert <$> f k v
294 From_Delete -> pure From_Delete
407 From_Delete -> pure From_Delete
295 From_Move fromKey -> pure $ From_Move fromKey
408 From_Move fromKey -> pure $ From_Move fromKey
296
409
297−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
410+-- |Map a function which transforms @'From' k PatchTarget1 p a@ into a @'From' k 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
411+nodeInfoMapFrom
412+ :: (From k p a -> From k p' a)
413+ -> NodeInfo k p a
414+ -> NodeInfo k p' a
299nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
415nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
300
416
301−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
417+-- |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@.
302−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
418+nodeInfoMapFromM
419+ :: Functor f
420+ => (From k p a -> f (From k p' a))
421+ -> NodeInfo k p a
422+ -> f (NodeInfo k p' a)
303nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
423nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
304
424
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
425+-- |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
306-- values.
426-- values.
307−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) (Proxy v')
427+weakenPatchDMapWithMoveWith
428+ :: forall k p v'
429+ . (forall a. PatchTarget1 p a -> v')
430+ -> PatchDMapWithMove k p
431+ -> PatchMapWithMove (Some k) (Proxy v')
308weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
432weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
309− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) (Proxy v')
433+ where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
310 g ni = MapWithMove.NodeInfo
434 g ni = MapWithMove.NodeInfo
311 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
435 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
312 From_Insert v -> MapWithMove.From_Insert $ f v
436 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -317,9 +441,12 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
317
441
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
442-- |"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.
443-- 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')
444+patchDMapWithMoveToPatchMapWithMoveWith
445+ :: forall k p v' a. (PatchTarget1 p a -> v')
446+ -> PatchDMapWithMove (Const2 k a) p
447+ -> PatchMapWithMove k (Proxy v')
321patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
448patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
322− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k (Proxy v')
449+ where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
323 g ni = MapWithMove.NodeInfo
450 g ni = MapWithMove.NodeInfo
324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
451 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
325 From_Insert v -> MapWithMove.From_Insert $ f v
452 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -329,9 +456,13 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
329 }
456 }
330
457
331-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
458-- |"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@.
459+-- 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@.
333-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
460-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
334−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k (Proxy v) -> PatchDMapWithMove (Const2 k a) v'
461+const2PatchDMapWithMoveWith
462+ :: forall k v p' a
463+ . (v -> PatchTarget1 p' a)
464+ -> PatchMapWithMove k (Proxy v)
465+ -> PatchDMapWithMove (Const2 k a) p'
335const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
466const2PatchDMapWithMoveWith 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')
467 where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
337 g (k, ni) = Const2 k :=> NodeInfo
468 g (k, ni) = Const2 k :=> NodeInfo
@@ -343,19 +474,19 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
343 }
474 }
344
475
345-- | Apply the insertions, deletions, and moves to a given 'DMap'.
476-- | Apply the insertions, deletions, and moves to a given 'DMap'.
346−instance GCompare k => PatchHet (PatchDMapWithMove k v) where
477+instance GCompare k => PatchHet (PatchDMapWithMove k p) where
347− type PatchSource (PatchDMapWithMove k v) = DMap k v
478+ type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
348− type PatchTarget (PatchDMapWithMove k v) = DMap k v
479+ type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
349−instance GCompare k => Patch (PatchDMapWithMove k v) where
480+instance GCompare k => Patch (PatchDMapWithMove k p) where
350 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?
481 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?
351 where insertions = DMap.mapMaybeWithKey insertFunc p
482 where insertions = DMap.mapMaybeWithKey insertFunc p
352− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
483+ insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
353 insertFunc _ ni = case _nodeInfo_from ni of
484 insertFunc _ ni = case _nodeInfo_from ni of
354 From_Insert v -> Just v
485 From_Insert v -> Just v
355 From_Move k -> DMap.lookup k old
486 From_Move k -> DMap.lookup k old
356 From_Delete -> Nothing
487 From_Delete -> Nothing
357 deletions = DMap.mapMaybeWithKey deleteFunc p
488 deletions = DMap.mapMaybeWithKey deleteFunc p
358− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
489+ deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
359 deleteFunc _ ni = case _nodeInfo_from ni of
490 deleteFunc _ ni = case _nodeInfo_from ni of
360 From_Delete -> Just $ Constant ()
491 From_Delete -> Just $ Constant ()
361 _ -> Nothing
492 _ -> Nothing
src/Data/Patch/MapWithMove.hs−1
@@ -258,7 +258,6 @@ data Fixup k v
258
258
259-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
259-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
260instance ( Ord k
260instance ( Ord k
261− , Monoid p
262 , DecidablyEmpty p
261 , DecidablyEmpty p
263 , Patch p
262 , Patch p
264 ) => Semigroup (PatchMapWithMove k p) where
263 ) => Semigroup (PatchMapWithMove k p) where