git.iko.soy/patch
on 584334f help sign in
patch/src/Data/Patch/DMapWithMove.hs
617 lines 27 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE InstanceSigs #-}
7{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE PatternGuards #-}
10{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE Rank2Types #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE UndecidableSuperClasses #-}
18-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
19-- move values between keys.
20module Data.Patch.DMapWithMove where
22import qualified Control.Category as Cat
23--import qualified Control.Category.DecidablyEmpty as Cat
24import Data.Constraint.Extras (Has')
25import Data.Dependent.Map (DMap)
26import Data.Dependent.Sum (DSum (..))
27import qualified Data.Dependent.Map as DMap
28import Data.Functor.Constant (Constant (..))
29import Data.Functor.Misc
30 ( Const2 (..), Proxy3 (..)
31 , weakenDMapWith
32 , dmapToMapWith
33 )
34import Data.Functor.Product (Product (..))
35import Data.GADT.Compare (GEq (..), GCompare (..))
36import Data.GADT.Show (GRead, GShow, gshow)
37import qualified Data.Map as Map
38import Data.Maybe
39import Data.Semigroup (Semigroup (..), (<>))
40import Data.Semigroupoid as Cat
41import Data.Some (Some(Some))
42import Data.Proxy (Proxy (..))
43import Data.These (These (..))
45import Data.Patch.Class
46 ( Patch (..), PatchHet (..)
47 , PatchHet2 (..), PatchSource1, PatchTarget1
48 , applyAlwaysHet2
49 )
50import Data.Patch.MapWithMove (PatchMapWithMove (..))
51import qualified Data.Patch.MapWithMove as MapWithMove
53-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
54-- which describes how it will be changed by the patch and connects move sources
55-- and destinations.
56--
57-- Invariants:
58--
59-- * A key should not move to itself.
60--
61-- * A move should always be represented with both the destination key (as a
62-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'
63-- destination)@)
64newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
66--deriving instance ( GShow k
67-- , HasZip Show k p
68-- , Has' Show k (PatchTarget1 p)
69-- ) => Show (PatchDMapWithMove k p)
70--deriving instance ( GRead k
71-- , HasZip Read k p
72-- , Has' Read k (PatchTarget1 p)
73-- ) => Read (PatchDMapWithMove k p)
74--deriving instance ( GEq k
75-- , HasZip Eq k p
76-- , Has' Eq k (PatchTarget1 p)
77-- ) => Eq (PatchDMapWithMove k p)
78--deriving instance ( GCompare k
79-- , HasZip Ord k p
80-- , Has' Ord k (PatchTarget1 p)
81-- ) => Ord (PatchDMapWithMove k p)
83-- | Structure which represents what changes apply to a particular key.
84-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
85-- other key the current key is moving from, while @_nodeInfo_to@ specifies what
86-- key the current key is moving to if involved in a move.
87data NodeInfo k p a = NodeInfo
88 { _nodeInfo_from :: !(From k p a)
89 -- ^ Change applying to the current key, be it an insert, move, or delete.
90 , _nodeInfo_to :: !(To k p a)
91 -- ^ Where this key is moving to, if involved in a move. Should only be
92 -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
93 }
95--deriving instance ( Show (k a)
96-- , Show (p a a)
97-- , Show (PatchTarget1 p a)
98-- ) => Show (NodeInfo k p a)
99--deriving instance ( Read (k a)
100-- , Read (p a a)
101-- , Read (PatchTarget1 p a)
102-- ) => Read (NodeInfo k p a)
103--deriving instance ( Eq (k a)
104-- , Eq (p a a)
105-- , Eq (PatchTarget1 p a)
106-- ) => Eq (NodeInfo k p a)
107--deriving instance ( Ord (k a)
108-- , Ord (p a a)
109-- , Ord (PatchTarget1 p a)
110-- ) => Ord (NodeInfo k p a)
112-- | Structure describing a particular change to a key, be it inserting a new
113-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
114-- a key (@From_Delete@), or moving a key (@From_Move@).
115--
116-- This type isn't used directly as the from field patch, but is instead wrapped
117-- in an existential. However, it is nice to be able to reason about this in
118-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
119data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
120 -- | Insert a new or update an existing key with the given value @PatchTarget1
121 -- p a@
122 From_Insert :: PatchTarget1 p to -> From k p to
123 -- | Delete the existing key
124 From_Delete :: From k p to
125 -- | Move the value from the given key @k a@ to this key. The source key
126 -- should also have an entry in the patch giving the current key as
127 -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
128 From_Move :: !(DSum k (Flip p to)) -> From k p to
130deriving instance ( Show (k a), GShow k
131 , Has' Show k (Flip p a)
132 , Show (PatchTarget1 p a)
133 ) => Show (From k p a)
134deriving instance ( Read (k a), GRead k
135 , Has' Read k (Flip p a)
136 , Read (PatchTarget1 p a)
137 ) => Read (From k p a)
138deriving instance ( GEq k
139 , Has' Eq k (Flip p a)
140 , Eq (PatchTarget1 p a)
141 ) => Eq (From k p a)
142deriving instance ( GCompare k
143 , Has' Eq k (Flip p a) -- superclass bug
144 , Has' Ord k (Flip p a)
145 , Ord (PatchTarget1 p a)
146 ) => Ord (From k p a)
148newtype Flip p to from = Flip (p from to)
150instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
151 id = Flip Cat.id
152 Flip y . Flip x = Flip $ x Cat.. y
154-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
155-- is, we store just the information necessary to compose a @To@ and @From@ like
156-- @oLocal@ composes two @From@s.
157data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
158 -- | Delete or leave in place
159 To_NonMove :: To k p from
160 -- | Move the value from the given key @k a@ to this key. The target key
161 -- should also have an entry in the patch giving the current key in
162 -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
163 To_Move :: !(DSum k (p from)) -> To k p from
165deriving instance ( Show (k a), GShow k
166 , Has' Show k (p a)
167 , Show (PatchTarget1 p a)
168 ) => Show (To k p a)
169deriving instance ( Read (k a), GRead k
170 , Has' Read k (p a)
171 , Read (PatchTarget1 p a)
172 ) => Read (To k p a)
173deriving instance ( GEq k
174 , Has' Eq k (p a)
175 , Eq (PatchTarget1 p a)
176 ) => Eq (To k p a)
177deriving instance ( GCompare k
178 , Has' Eq k (p a) -- superclass bug
179 , Has' Ord k (p a)
180 , Ord (PatchTarget1 p a)
181 ) => Ord (To k p a)
183-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
184validPatchDMapWithMove
185 :: forall k v
186 . (GCompare k, GShow k)
187 => DMap k (NodeInfo k v)
188 -> Bool
189validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
191-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
192validationErrorsForPatchDMapWithMove
193 :: forall k v
194 . (GCompare k, GShow k)
195 => DMap k (NodeInfo k v)
196 -> [String]
197validationErrorsForPatchDMapWithMove m =
198 noSelfMoves <> movesBalanced
199 where
200 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
201 selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
202 | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
203 selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
204 | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
205 selfMove _ = Nothing
206 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
207 unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
208 case DMap.lookup src m of
209 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
210 Just (NodeInfo _ (To_Move (dst' :=> _))) ->
211 if isNothing (dst' `geq` dst)
212 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
213 else Nothing
214 _ ->
215 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
216 unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
217 case DMap.lookup dst m of
218 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
219 Just (NodeInfo (From_Move (src' :=> _)) _) ->
220 if isNothing (src' `geq` src)
221 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
222 else Nothing
224 _ ->
225 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
226 unbalancedMove _ = Nothing
228-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
229data Pair1 f g a = Pair1 (f a) (g a)
231-- |Helper data structure used for composing patches using the monoid instance.
232data Fixup k p a
233 = Fixup_Delete
234 | Fixup_Update (These (From k p a) (To k p a))
236-- | Compose patches having the same effect as applying the patches in turn:
237-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
238instance ( GCompare k
239 , Cat.Semigroupoid p
240 -- , Cat.DecidablyEmpty p
241 , PatchHet2 p
242 , PatchSource1 p ~ PatchTarget1 p
243 ) => Semigroup (PatchDMapWithMove k p) where
244 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
245 where
246 connections :: [DSum k (Pair1 (To k p) (From k p))]
247 connections = DMap.toList $ DMap.intersectionWithKey
248 (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
249 ma
250 mb
251 h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
252 h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
253 (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
254 --case toAfter `geq` fromBefore of
255 -- Just Refl | Just Refl <- Cat.isId p0 ->
256 -- [ toAfter :=> Fixup_Delete ]
257 -- _ ->
258 [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
259 , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
260 ]
261 (To_NonMove, From_Move (fromBefore :=> _)) ->
262 -- The item is destroyed in the second patch, so indicate that it is
263 -- destroyed in the source map
264 [fromBefore :=> Fixup_Update (That To_NonMove)]
265 (To_Move (toAfter :=> p), From_Insert val) ->
266 [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
267 (To_Move (toAfter :=> _), From_Delete) ->
268 [toAfter :=> Fixup_Update (This From_Delete)]
269 (To_NonMove, _) ->
270 []
271 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
272 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
273 | This x <- a, That y <- b
274 = Fixup_Update $ These x y
275 | That y <- a, This x <- b
276 = Fixup_Update $ These x y
277 mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"
278 fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
279 combineNodeInfos _ nia nib = NodeInfo
280 { _nodeInfo_from = _nodeInfo_from nia
281 , _nodeInfo_to = _nodeInfo_to nib
282 }
283 applyFixup _ ni = \case
284 Fixup_Delete -> Nothing
285 Fixup_Update u -> Just $ NodeInfo
286 { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
287 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
288 }
289 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
290 getHere :: These a b -> Maybe a
291 getHere = \case
292 This a -> Just a
293 These a _ -> Just a
294 That _ -> Nothing
295 getThere :: These a b -> Maybe b
296 getThere = \case
297 This _ -> Nothing
298 These _ b -> Just b
299 That b -> Just b
301-- | Compose patches having the same effect as applying the patches in turn:
302-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
303instance ( GCompare k
304 , Cat.Semigroupoid p
305 -- , DecidablyEmpty p
306 , PatchHet2 p
307 , PatchSource1 p ~ PatchTarget1 p
308 ) => Monoid (PatchDMapWithMove k p) where
309 mempty = PatchDMapWithMove mempty
310 mappend = (<>)
312{-
313mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
314PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
315 where
316 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
317 removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
318 removeRedundantDst _ a = Just a
319 f :: forall a. k a -> From k v a -> Maybe (From k v a)
320 f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
321 From_Move fromKey -> getDstAction fromKey dstBefore
322 nonMove -> nonMove
323 dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
324 getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
325 removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
326 removeRedundantSrc _ a = Just a
327 g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
328 g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
329 ComposeMaybe Nothing -> ComposeMaybe Nothing
330 ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
331 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
332-}
334-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or
335-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
336-- 'DMap.insert'.
337insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
338insertDMapKey k v =
339 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
341-- | Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value
342-- from the first key @k a@ to the second key @k a@, equivalent to:
343--
344-- @
345-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
346-- @
347moveDMapKey
348 :: GCompare k
349 => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
350moveDMapKey src dst = case src `geq` dst of
351 Nothing -> PatchDMapWithMove $ DMap.fromList
352 [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
353 , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
354 ]
355 Just _ -> PatchDMapWithMove DMap.empty
357-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
358-- in the mapping, equivalent to:
359--
360-- @
361-- let aMay = DMap.lookup a dmap
362-- bMay = DMap.lookup b dmap
363-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
364-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
365-- . DMap.delete a . DMap.delete b $ dmap
366-- @
367swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
368swapDMapKey src dst = case src `geq` dst of
369 Nothing -> PatchDMapWithMove $ DMap.fromList
370 [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
371 , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
372 ]
373 Just _ -> PatchDMapWithMove DMap.empty
375-- | Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in
376-- the mapping, equivalent to 'DMap.delete'.
377deleteDMapKey :: k a -> PatchDMapWithMove k v
378deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
380{-
381k1, k2 :: Const2 Int () ()
382k1 = Const2 1
383k2 = Const2 2
384p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
385p1 = moveDMapKey k1 k2
386p2 = moveDMapKey k2 k1
387p12 = p1 <> p2
388p21 = p2 <> p1
389p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
390p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
392testPatchDMapWithMove = do
393 print p1
394 print p2
395 print $ p12 == deleteDMapKey k1
396 print $ p21 == deleteDMapKey k2
397 print $ p12Slow == deleteDMapKey k1
398 print $ p21Slow == deleteDMapKey k2
400dst (PatchDMapWithMove x _) = x
401src (PatchDMapWithMove _ x) = x
402-}
404-- | Extract the 'DMap' representing the patch changes from the
405-- 'PatchDMapWithMove'.
406unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
407unPatchDMapWithMove (PatchDMapWithMove p) = p
409-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',
410-- without checking any invariants.
411--
412-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
413unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
414unsafePatchDMapWithMove = PatchDMapWithMove
416-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while
417-- checking invariants. If the invariants are satisfied, @Right p@ is returned
418-- otherwise @Left errors@.
419patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
420patchDMapWithMove dm =
421 case validationErrorsForPatchDMapWithMove dm of
422 [] -> Right $ unsafePatchDMapWithMove dm
423 errs -> Left errs
425-- | Map a natural transform @v -> v'@ over the given patch, transforming
426-- @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
427mapPatchDMapWithMove
428 :: forall k p p'
429 . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
430 -> (forall from to. p from to -> p' from to)
431 -> PatchDMapWithMove k p
432 -> PatchDMapWithMove k p'
433mapPatchDMapWithMove f g (PatchDMapWithMove m) =
434 PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
435 { _nodeInfo_from = h $ _nodeInfo_from ni
436 , _nodeInfo_to = j $ _nodeInfo_to ni
437 }) m
438 where h :: forall a. From k p a -> From k p' a
439 h = \case
440 From_Insert v -> From_Insert $ f v
441 From_Delete -> From_Delete
442 From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
443 j :: forall a. To k p a -> To k p' a
444 j = \case
445 To_NonMove -> To_NonMove
446 To_Move (k :=> p) -> To_Move $ k :=> g p
448-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
449-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
450-- ('PatchDMapWithMove' k v')@.
451traversePatchDMapWithMove
452 :: forall m k p p'
453 . Applicative m
454 => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
455 -> (forall from to. p from to -> m (p' from to))
456 -> PatchDMapWithMove k p
457 -> m (PatchDMapWithMove k p')
458traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
459 (\_ -> f)
460 (\_ _ -> g)
462-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
463-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
464-- ('PatchDMapWithMove' k v')@.
465traversePatchDMapWithMoveWithKey
466 :: forall m k p p'
467 . Applicative m
468 => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
469 -> (forall from to. k from -> k to -> p from to -> m (p' from to))
470 -> PatchDMapWithMove k p
471 -> m (PatchDMapWithMove k p')
472traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
473 PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
474 <$> h k (_nodeInfo_from ni)
475 <*> j k (_nodeInfo_to ni)) m
476 where h :: forall a. k a -> From k p a -> m (From k p' a)
477 h k = \case
478 From_Insert v -> From_Insert <$> f k v
479 From_Delete -> pure From_Delete
480 From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
481 j :: forall a. k a -> To k p a -> m (To k p' a)
482 j k = \case
483 To_NonMove -> pure To_NonMove
484 To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
486-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
487-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
488nodeInfoMapFrom
489 :: (From k p a -> From k p' a)
490 -> (To k p a -> To k p' a)
491 -> NodeInfo k p a
492 -> NodeInfo k p' a
493nodeInfoMapFrom f g ni = NodeInfo
494 { _nodeInfo_from = f $ _nodeInfo_from ni
495 , _nodeInfo_to = g $ _nodeInfo_to ni
496 }
498-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
499-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
500nodeInfoMapFromM
501 :: Applicative f
502 => (From k p a -> f (From k p' a))
503 -> (To k p a -> f (To k p' a))
504 -> NodeInfo k p a
505 -> f (NodeInfo k p' a)
506nodeInfoMapFromM f g ni = NodeInfo
507 <$> f (_nodeInfo_from ni)
508 <*> g (_nodeInfo_to ni)
510-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
511-- from @k a@ to @'Some' k@ and applying a given weakening function
512-- @PatchTarget1 p a -> v'@ to values.
513weakenPatchDMapWithMoveWith
514 :: forall k p p'
515 . (forall a. PatchTarget1 p a -> PatchTarget p')
516 -> (forall from to. p from to -> p')
517 -> PatchDMapWithMove k p
518 -> PatchMapWithMove (Some k) p'
519weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
520 PatchMapWithMove $ weakenDMapWith h m
521 where h :: forall a. NodeInfo k p a -> MapWithMove.NodeInfo (Some k) p'
522 h ni = MapWithMove.NodeInfo
523 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
524 From_Insert v -> MapWithMove.From_Insert $ f v
525 From_Delete -> MapWithMove.From_Delete
526 From_Move (k :=> Flip p) -> MapWithMove.From_Move (Some k) $ g p
527 , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
528 To_NonMove -> MapWithMove.To_NonMove
529 To_Move (k :=> p) -> MapWithMove.To_Move (Some k) $ g p
530 }
532-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
533-- v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
534-- dependency in the typing and all points are already @a@, hence the function
535-- to map each value to @v'@ is not higher rank.
536patchDMapWithMoveToPatchMapWithMoveWith
537 :: forall k p p' a
538 . (PatchTarget1 p a -> PatchTarget p')
539 -> (p a a -> p')
540 -> PatchDMapWithMove (Const2 k a) p
541 -> PatchMapWithMove k p'
542patchDMapWithMoveToPatchMapWithMoveWith f g (PatchDMapWithMove m) =
543 PatchMapWithMove $ dmapToMapWith h m
544 where h :: NodeInfo (Const2 k a) p a -> MapWithMove.NodeInfo k p'
545 h ni = MapWithMove.NodeInfo
546 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
547 From_Insert v -> MapWithMove.From_Insert $ f v
548 From_Delete -> MapWithMove.From_Delete
549 From_Move (Const2 k :=> Flip p) -> MapWithMove.From_Move k $ g p
550 , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
551 To_NonMove -> MapWithMove.To_NonMove
552 To_Move (Const2 k :=> p) -> MapWithMove.To_Move k $ g p
553 }
555-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
556-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
557-- dependently typed one but which always has a constant key type represented by
558-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
559-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
560const2PatchDMapWithMoveWith
561 :: forall k v v' a
562 . (v -> v' a)
563 -> PatchMapWithMove k (Proxy v)
564 -> PatchDMapWithMove (Const2 k a) (Proxy3 v')
565const2PatchDMapWithMoveWith f (PatchMapWithMove p) =
566 PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
567 where g :: (k, MapWithMove.NodeInfo k (Proxy v))
568 -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
569 g (k, ni) = Const2 k :=> NodeInfo
570 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
571 MapWithMove.From_Insert v -> From_Insert $ f v
572 MapWithMove.From_Delete -> From_Delete
573 MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
574 , _nodeInfo_to = case MapWithMove._nodeInfo_to ni of
575 MapWithMove.To_NonMove -> To_NonMove
576 MapWithMove.To_Move toKey Proxy -> To_Move $ Const2 toKey :=> Proxy3
577 }
579-- | Apply the insertions, deletions, and moves to a given 'DMap'.
580instance ( GCompare k
581 , PatchHet2 p
582 , PatchSource1 p ~ PatchTarget1 p
583 ) => PatchHet (PatchDMapWithMove k p) where
584 type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
585 type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
587instance ( GCompare k
588 , PatchHet2 p
589 , PatchSource1 p ~ PatchTarget1 p
590 ) => Patch (PatchDMapWithMove k p) where
591 apply (PatchDMapWithMove m) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
592 -- TODO: return Nothing sometimes --Note: the strict application here is
593 -- critical to ensuring that incremental merges don't hold onto all their
594 -- prerequisite events forever; can we make this more robust?
595 where insertions = DMap.mapMaybeWithKey insertFunc m
596 insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
597 insertFunc _ ni = case _nodeInfo_from ni of
598 From_Insert v -> Just v
599 From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
600 From_Delete -> Nothing
601 deletions = DMap.mapMaybeWithKey deleteFunc m
602 deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
603 deleteFunc _ ni = case _nodeInfo_from ni of
604 From_Delete -> Just $ Constant ()
605 _ -> Nothing
607-- | Get the values that will be replaced, deleted, or moved if the given patch
608-- is applied to the given 'DMap'.
609getDeletionsAndMoves
610 :: ( GCompare k
611 , PatchSource1 p ~ PatchTarget1 p
612 )
613 => PatchDMapWithMove k p
614 -> DMap k (PatchSource1 p)
615 -> DMap k (Product (PatchTarget1 p) (To k p))
616getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
617 where f _ v ni = Pair v $ _nodeInfo_to ni