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