@@ -1,305 +1,108 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE FlexibleContexts #-}
43{-# LANGUAGE FlexibleInstances #-}
54{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE InstanceSigs #-}
75{-# LANGUAGE LambdaCase #-}
86{-# LANGUAGE MultiParamTypeClasses #-}
97{-# LANGUAGE PatternGuards #-}
108{-# LANGUAGE PolyKinds #-}
119{-# LANGUAGE Rank2Types #-}
1210{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE TypeApplications #-}
1511{-# LANGUAGE TypeFamilies #-}
1612{-# LANGUAGE UndecidableInstances #-}
17−{-# LANGUAGE UndecidableSuperClasses #-}
1813
1914-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
2015-- move values between keys.
2116module Data.Patch.DMapWithMove where
2217
23−import qualified Control.Category as Cat
18+import Data.Patch.Class
19+import Data.Patch.MapWithMove (PatchMapWithMove (..))
20+import qualified Data.Patch.MapWithMove as MapWithMove
21+
2422import Data.Constraint.Extras
25−import Data.Constraint.Compose
26−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
23+import Data.Dependent.Map (DMap)
24+import Data.Dependent.Sum (DSum (..))
2725import qualified Data.Dependent.Map as DMap
2826import Data.Functor.Constant
2927import Data.Functor.Misc
3028import Data.Functor.Product
31−import Data.GADT.Compare (GEq (..), GCompare)
32−import Data.GADT.Show (GRead, GShow, gshow)
29+import Data.GADT.Compare (GEq (..), GCompare (..))
30+import Data.GADT.Show (GShow, gshow)
3331import qualified Data.Map as Map
3432import Data.Maybe
3533import Data.Monoid.DecidablyEmpty
36−import Data.Semigroup (Semigroup (..), (<>))
37−import Data.Semigroupoid as Cat
38−import Data.Some (Some(Some))
39−import Data.Proxy
34+#if !MIN_VERSION_base(4,11,0)
35+import Data.Semigroup (Semigroup (..))
36+#endif
37+import Data.Some (Some, mkSome)
4038import Data.These
41−import Data.Type.Equality ((:~:) (..))
42−import Data.Kind (Constraint)
43−
44−import Data.Patch.Class
45−import Data.Patch.MapWithMove (PatchMapWithMove (..))
46−import qualified Data.Patch.MapWithMove as MapWithMove
47−
48−-- | Composition for constraints.
49−class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
50−instance p (f a a) => DupC p f a
5139
52−type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
53− ConstraintsFor f (DupC c g)
54−
55−type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
56− (ArgDict (DupC c g) f, ConstraintsForZip f c g)
57−
58−-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
59−-- which describes how it will be changed by the patch and connects move sources
60−-- and destinations.
40+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
41+-- destinations.
6142--
6243-- Invariants:
6344--
64−-- * A key should not move to itself.
65−--
66−-- * A move should always be represented with both the destination key (as a
67−-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'
68−-- destination)@)
45+-- * A key should not move to itself.
46+-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
6947newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
7048
71−deriving instance ( GShow k
72− , HasZip Show k p
73− , Has' Show k (PatchTarget1 p)
74− ) => Show (PatchDMapWithMove k p)
75−deriving instance ( GRead k
76− , HasZip Read k p
77− , Has' Read k (PatchTarget1 p)
78− ) => Read (PatchDMapWithMove k p)
79−deriving instance ( GEq k
80− , HasZip Eq k p
81− , Has' Eq k (PatchTarget1 p)
82− ) => Eq (PatchDMapWithMove k p)
83−deriving instance ( GCompare k
84− , HasZip Ord k p
85− , Has' Ord k (PatchTarget1 p)
86− ) => Ord (PatchDMapWithMove k p)
87−
88−-- | Structure which represents what changes apply to a particular key.
89−-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
90−-- other key the current key is moving from, while @_nodeInfo_to@ specifies what
91−-- key the current key is moving to if involved in a move.
92−data NodeInfo k p a = NodeInfo
93− { _nodeInfo_from :: !(From k p a)
94− -- ^ Change applying to the current key, be it an insert, move, or delete.
95− , _nodeInfo_to :: !(To k p a)
96− -- ^ Where this key is moving to, if involved in a move. Should only be
97− -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
49+-- It won't let me derive for some reason
50+instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
51+ isEmpty (PatchDMapWithMove m) = DMap.null m
52+
53+-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
54+-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
55+data NodeInfo k v a = NodeInfo
56+ { _nodeInfo_from :: !(From k v a)
57+ -- ^Change applying to the current key, be it an insert, move, or delete.
58+ , _nodeInfo_to :: !(To k a)
59+ -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
9860 }
99−
100−deriving instance ( Show (k a)
101− , Show (p a a)
102− , Show (PatchTarget1 p a)
103− ) => Show (NodeInfo k p a)
104−deriving instance ( Read (k a)
105− , Read (p a a)
106− , Read (PatchTarget1 p a)
107− ) => Read (NodeInfo k p a)
108−deriving instance ( Eq (k a)
109− , Eq (p a a)
110− , Eq (PatchTarget1 p a)
111− ) => Eq (NodeInfo k p a)
112−deriving instance ( Ord (k a)
113− , Ord (p a a)
114− , Ord (PatchTarget1 p a)
115− ) => Ord (NodeInfo k p a)
116−
117−-- | Structure describing a particular change to a key, be it inserting a new
118−-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
119−-- a key (@By_Delete@), or moving a key (@By_Move@).
120−--
121−-- This type isn't used directly as the from field patch, but is instead wrapped
122−-- in an existential. However, it is nice to be able to reason about this in
123−-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
124−data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
125− -- | Insert a new or update an existing key with the given value @PatchTarget1
126− -- p a@
127− By_Insert :: PatchTarget1 p to -> By k p from to
128− -- | Delete the existing key
129− By_Delete :: By k p from to
130− -- | Move the value from the given key @k a@ to this key. The source key
131− -- should also have an entry in the patch giving the current key as
132− -- @_nodeInfo_to@, usually but not necessarily with @By_Delete@.
133− By_Move :: !(k from) -> p from to -> By k p from to
134−
135−deriving instance ( Show (k to)
136− , Show (p from to)
137− , Show (PatchTarget1 p to)
138− ) => Show (By k p from to)
139−deriving instance ( Read (k to)
140− , Read (p from to)
141− , Read (PatchTarget1 p to)
142− ) => Read (By k p from to)
143−deriving instance ( Eq (k to)
144− , Eq (p from to)
145− , Eq (PatchTarget1 p to)
146− ) => Eq (By k p from to)
147−deriving instance ( Ord (k to)
148− , Ord (p from to)
149− , Ord (PatchTarget1 p to)
150− ) => Ord (By k p from to)
151−
152−mapByPatch
153− :: PatchTarget1 p0 ~ PatchTarget1 p1
154− => ((p0 from to) -> (p1 from to))
155− -> By k p0 from to
156− -> By k p1 from to
157−mapByPatch f = \case
158− By_Insert v -> By_Insert v
159− By_Delete -> By_Delete
160− By_Move k p -> By_Move k $ f p
161−
162−-- | Compose patches having the same effect as applying the patches in turn:
163−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
164−instance ( PatchSource1 p ~ PatchTarget1 p
165− , Cat.Semigroupoid p
166− , PatchHet2 p
167− ) => Cat.Semigroupoid (By k p) where
168− o p0 p1 = mapByPatch unProjectLocal $
169− oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
170−
171−oLocal
172− :: ( PatchSource1 p ~ PatchTarget1 p
173− , PatchHet2Locally p between after
174− )
175− => By k p between after
176− -> By k p before between
177− -> By k p before after
178−By_Insert new `oLocal` _ = By_Insert new
179−By_Delete `oLocal` _ = By_Delete
180−By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2 x y
181−By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
182−By_Move _ _ `oLocal` By_Delete = By_Delete
183−
184−newtype Flip p to from = Flip (p from to)
185−
186−-- | Structure describing a particular change to a key, be it inserting a new
187−-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
188−-- a key (@From_Delete@), or moving a key (@From_Move@).
189−--
190−-- This type isn't used directly as the from field patch, but is instead wrapped
191−-- in an existential. However, it is nice to be able to reason about this in
192−-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
193−data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
194− -- | Insert a new or update an existing key with the given value @PatchTarget1
195− -- p a@
196− From_Insert :: PatchTarget1 p to -> From k p to
197− -- | Delete the existing key
198− From_Delete :: From k p to
199− -- | Move the value from the given key @k a@ to this key. The source key
200− -- should also have an entry in the patch giving the current key as
201− -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
202− From_Move :: !(DSum k (Flip p to)) -> From k p to
203−
204−deriving instance ( Show (k a)
205− , Show (p a a)
206− , Show (PatchTarget1 p a)
207− ) => Show (From k p a)
208−deriving instance ( Read (k a)
209− , Read (p a a)
210− , Read (PatchTarget1 p a)
211− ) => Read (From k p a)
212−
213−deriving instance ( GEq k
214− , HasZip Eq k p
215− , Eq (PatchTarget1 p a)
216− ) => Eq (From k p a)
217−
218−deriving instance ( GCompare k
219− , HasZip Ord k p
220− , Ord (PatchTarget1 p a)
221− ) => Ord (From k p a)
222−
223−-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
224−-- is, we store just the information necessary to compose a @To@ and @From@ like
225−-- @oLocal@ composes two @From@s.
226−data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
227− -- | Delete or leave in place
228− To_NonMove :: To k p from
229− -- | Move the value from the given key @k a@ to this key. The target key
230− -- should also have an entry in the patch giving the current key in
231− -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
232− To_Move :: !(DSum k (p from)) -> To k p from
233−
234−deriving instance ( Show (k a)
235− , Show (p a a)
236− , Show (PatchTarget1 p a)
237− ) => Show (To k p a)
238−deriving instance ( Read (k a)
239− , Read (p a a)
240− , Read (PatchTarget1 p a)
241− ) => Read (To k p a)
242−
243−deriving instance ( GEq k
244− , HasZip Eq k p
245− , Eq (PatchTarget1 p a)
246− ) => Eq (To k p a)
247−
248−deriving instance ( GCompare k
249− , HasZip Ord k p
250− , Ord (PatchTarget1 p a)
251− ) => Ord (To k p a)
252−
253−--oToFrom
254−-- :: ( PatchSource1 p ~ PatchTarget1 p
255−-- , PatchHet2 p
256−-- )
257−-- => To k p between
258−-- -> From k p between
259−-- -> DSum k (From k p)
260−--From_Insert new `oToFrom` _ = From_Insert new
261−--From_Delete `oToFrom` _ = From_Delete
262−--From_Move _ x `oToFrom` From_Insert y = From_Insert $ applyAlwaysHet2 x y
263−--From_Move _ x `oToFrom` From_Move src y = From_Move src $ x `o` y
264−--From_Move _ _ `oToFrom` From_Delete = From_Delete
61+ deriving (Show)
62+
63+-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
64+-- key (@From_Delete@), or moving a key (@From_Move@).
65+data From (k :: a -> *) (v :: a -> *) :: a -> * where
66+ -- |Insert a new or update an existing key with the given value @v a@
67+ From_Insert :: v a -> From k v a
68+ -- |Delete the existing key
69+ From_Delete :: From k v a
70+ -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
71+ -- usually but not necessarily with @From_Delete@.
72+ From_Move :: !(k a) -> From k v a
73+ deriving (Show, Read, Eq, Ord)
74+
75+-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
76+-- operation.
77+type To = ComposeMaybe
26578
26679-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
267−validPatchDMapWithMove
268− :: forall k v
269− . (GCompare k, GShow k)
270− => DMap k (NodeInfo k v)
271− -> Bool
80+validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
27281validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
27382
27483-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
275−validationErrorsForPatchDMapWithMove
276− :: forall k v
277− . (GCompare k, GShow k)
278− => DMap k (NodeInfo k v)
279− -> [String]
84+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
28085validationErrorsForPatchDMapWithMove m =
28186 noSelfMoves <> movesBalanced
28287 where
28388 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
284− selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
285− | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
286− selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
287− | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
89+ selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
90+ selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
28891 selfMove _ = Nothing
28992 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
290− unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
93+ unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
29194 case DMap.lookup src m of
29295 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
293− Just (NodeInfo _ (To_Move (dst' :=> _))) ->
96+ Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
29497 if isNothing (dst' `geq` dst)
29598 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
29699 else Nothing
297100 _ ->
298101 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
299− unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
102+ unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
300103 case DMap.lookup dst m of
301104 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
302− Just (NodeInfo (From_Move (src' :=> _)) _) ->
105+ Just (NodeInfo (From_Move src') _) ->
303106 if isNothing (src' `geq` src)
304107 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
305108 else Nothing
@@ -308,49 +111,35 @@ validationErrorsForPatchDMapWithMove m =
308111 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
309112 unbalancedMove _ = Nothing
310113
114+-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
115+instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
116+ PatchDMapWithMove a == PatchDMapWithMove b = a == b
117+
311118-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
312119data Pair1 f g a = Pair1 (f a) (g a)
313120
314121-- |Helper data structure used for composing patches using the monoid instance.
315−data Fixup k p a
122+data Fixup k v a
316123 = Fixup_Delete
317− | Fixup_Update (These (From k p a) (To k p a))
318−
319−-- | Compose patches having the same effect as applying the patches in turn:
320−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
321−instance ( GCompare k
322− , Cat.Semigroupoid p
323− -- , DecidablyEmpty p
324− , PatchHet2 p
325− , PatchSource1 p ~ PatchTarget1 p
326− ) => Semigroup (PatchDMapWithMove k p) where
124+ | Fixup_Update (These (From k v a) (To k a))
125+
126+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
127+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
327128 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
328129 where
329− connections :: [DSum k (Pair1 (To k p) (From k p))]
330− connections = DMap.toList $ DMap.intersectionWithKey
331− (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
332− ma
333− mb
334− h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
335− h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
336− (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
337− case toAfter `geq` fromBefore of
338− Just Refl | isNull p0 ->
339− [ toAfter :=> Fixup_Delete ]
340− _ ->
341− [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
342− , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
343− ]
344− (To_NonMove, From_Move (fromBefore :=> _)) ->
345− -- The item is destroyed in the second patch, so indicate that it is
346− -- destroyed in the source map
347− [fromBefore :=> Fixup_Update (That To_NonMove)]
348− (To_Move (toAfter :=> p), From_Insert val) ->
349− [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
350− (To_Move (toAfter :=> p), From_Delete) ->
351− [toAfter :=> Fixup_Update (This From_Delete)]
352− (To_NonMove, _) ->
353− []
130+ connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
131+ h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
132+ h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
133+ (Just toAfter, From_Move fromBefore)
134+ | isJust $ fromBefore `geq` toAfter
135+ -> [toAfter :=> Fixup_Delete]
136+ | otherwise
137+ -> [ toAfter :=> Fixup_Update (This editBefore)
138+ , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
139+ ]
140+ (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
141+ (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
142+ (Nothing, _) -> []
354143 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
355144 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
356145 | This x <- a, That y <- b
@@ -381,19 +170,13 @@ instance ( GCompare k
381170 These _ b -> Just b
382171 That b -> Just b
383172
384−-- | Compose patches having the same effect as applying the patches in turn:
385−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
386−instance ( GCompare k
387− , Cat.Semigroupoid p
388− -- , DecidablyEmpty p
389− , PatchHet2 p
390− , PatchSource1 p ~ PatchTarget1 p
391− ) => Monoid (PatchDMapWithMove k p) where
173+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
174+instance GCompare k => Monoid (PatchDMapWithMove k v) where
392175 mempty = PatchDMapWithMove mempty
393176 mappend = (<>)
394177
395178{-
396−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
179+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
397180PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
398181 where
399182 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
@@ -414,21 +197,21 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
414197 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
415198-}
416199
417−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @PatchTarget1 p a@ to the given key @k a@, like 'DMap.insert'.
418−insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
200+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
201+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
419202insertDMapKey k v =
420− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
203+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
421204
422205-- |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:
423206--
424207-- @
425208-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
426209-- @
427−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy2 v)
210+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
428211moveDMapKey src dst = case src `geq` dst of
429212 Nothing -> PatchDMapWithMove $ DMap.fromList
430− [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) To_NonMove
431− , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy2)
213+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
214+ , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
432215 ]
433216 Just _ -> mempty
434217
@@ -437,15 +220,15 @@ moveDMapKey src dst = case src `geq` dst of
437220-- @
438221-- let aMay = DMap.lookup a dmap
439222-- bMay = DMap.lookup b dmap
440−-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
441−-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
223+-- in maybe id (DMap.insert a) (bMay <> aMay)
224+-- . maybe id (DMap.insert b) (aMay <> bMay)
442225-- . DMap.delete a . DMap.delete b $ dmap
443226-- @
444227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
445228swapDMapKey src dst = case src `geq` dst of
446229 Nothing -> PatchDMapWithMove $ DMap.fromList
447− [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
448− , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (To_Move $ dst :=> Proxy2)
230+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
231+ , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
449232 ]
450233 Just _ -> mempty
451234
@@ -496,144 +279,93 @@ patchDMapWithMove dm =
496279 errs -> Left errs
497280
498281-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
499−mapPatchDMapWithMove
500− :: forall k p p'
501− . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
502− -> (forall from to. p from to -> p' from to)
503− -> PatchDMapWithMove k p
504− -> PatchDMapWithMove k p'
505−mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
282+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
283+mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
506284 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
507− where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
285+ where g :: forall a. From k v a -> From k v' a
508286 g = \case
509287 From_Insert v -> From_Insert $ f v
510288 From_Delete -> From_Delete
511− From_Move k p -> From_Move k $ g p
512−
513−-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
514−-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
515−-- ('PatchDMapWithMove' k v')@.
516−traversePatchDMapWithMove
517− :: forall m k p p'
518− . Applicative m
519− => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
520− -> PatchDMapWithMove k p
521− -> m (PatchDMapWithMove k p')
289+ From_Move k -> From_Move k
290+
291+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
292+traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
522293traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
523294
524−-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
525−-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
526−-- ('PatchDMapWithMove' k v')@.
527−traversePatchDMapWithMoveWithKey
528− :: forall m k p p'
529− . Applicative m
530− => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
531− -> PatchDMapWithMove k p
532− -> m (PatchDMapWithMove k p')
533−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
534− PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
535− where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)
295+-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
296+traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
297+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
298+ where g :: forall a. k a -> From k v a -> m (From k v' a)
536299 g k = \case
537300 From_Insert v -> From_Insert <$> f k v
538301 From_Delete -> pure From_Delete
539302 From_Move fromKey -> pure $ From_Move fromKey
540303
541−-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
542−-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
543−nodeInfoMapFrom
544− :: (From k p a -> From k p' a)
545− -> NodeInfo k p a
546− -> NodeInfo k p' a
304+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
305+nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
547306nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
548307
549−-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
550−-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
551−nodeInfoMapFromM
552− :: Functor f
553− => (From k p a -> f (From k p' a))
554− -> NodeInfo k p a
555− -> f (NodeInfo k p' a)
308+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
309+nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
556310nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
557311
558−-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
559−-- from @k a@ to @'Some' k@ and applying a given weakening function
560−-- @PatchTarget1 p a -> v'@ to values.
561−weakenPatchDMapWithMoveWith
562− :: forall k p v'
563− . (forall a. PatchTarget1 p a -> v')
564− -> PatchDMapWithMove k p
565− -> PatchMapWithMove (Some k) (Proxy v')
312+-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
313+-- values.
314+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
566315weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
567− where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
316+ where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
568317 g ni = MapWithMove.NodeInfo
569318 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
570319 From_Insert v -> MapWithMove.From_Insert $ f v
571320 From_Delete -> MapWithMove.From_Delete
572− From_Move k -> MapWithMove.From_Move (Some k) Proxy
573− , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
321+ From_Move k -> MapWithMove.From_Move $ mkSome k
322+ , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
574323 }
575324
576−-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
577−-- v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
578−-- dependency in the typing and all points are already @a@, hence the function
579−-- to map each value to @v'@ is not higher rank.
580−patchDMapWithMoveToPatchMapWithMoveWith
581− :: forall k p v' a. (PatchTarget1 p a -> v')
582− -> PatchDMapWithMove (Const2 k a) p
583− -> PatchMapWithMove k (Proxy v')
325+-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
326+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
327+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
584328patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
585− where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
329+ where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
586330 g ni = MapWithMove.NodeInfo
587331 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
588332 From_Insert v -> MapWithMove.From_Insert $ f v
589333 From_Delete -> MapWithMove.From_Delete
590− From_Move (Const2 k) -> MapWithMove.From_Move k Proxy
334+ From_Move (Const2 k) -> MapWithMove.From_Move k
591335 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
592336 }
593337
594−-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
595−-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
596−-- dependently typed one but which always has a constant key type represented by
597−-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
598−-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
599−const2PatchDMapWithMoveWith
600− :: forall k v p' a
601− . (v -> PatchTarget1 p' a)
602− -> PatchMapWithMove k (Proxy v)
603− -> PatchDMapWithMove (Const2 k a) p'
338+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
339+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
340+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
341+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
604342const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
605− where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
343+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
606344 g (k, ni) = Const2 k :=> NodeInfo
607345 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
608346 MapWithMove.From_Insert v -> From_Insert $ f v
609347 MapWithMove.From_Delete -> From_Delete
610− MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey
348+ MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
611349 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
612350 }
613351
614352-- | 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)
618−instance GCompare k => Patch (PatchDMapWithMove k p) where
619− apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
620− -- TODO: return Nothing sometimes --Note: the strict application here is
621− -- critical to ensuring that incremental merges don't hold onto all their
622− -- prerequisite events forever; can we make this more robust?
353+instance GCompare k => Patch (PatchDMapWithMove k v) where
354+ type PatchTarget (PatchDMapWithMove k v) = DMap k v
355+ apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
623356 where insertions = DMap.mapMaybeWithKey insertFunc p
624− insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
357+ insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
625358 insertFunc _ ni = case _nodeInfo_from ni of
626359 From_Insert v -> Just v
627360 From_Move k -> DMap.lookup k old
628361 From_Delete -> Nothing
629362 deletions = DMap.mapMaybeWithKey deleteFunc p
630− deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
363+ deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
631364 deleteFunc _ ni = case _nodeInfo_from ni of
632365 From_Delete -> Just $ Constant ()
633366 _ -> Nothing
634367
635−-- | Get the values that will be replaced, deleted, or moved if the given patch
636−-- is applied to the given 'DMap'.
368+-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
637369getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
638370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
639371 where f _ v ni = Pair v $ _nodeInfo_to ni