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