@@ -1,620 +0,0 @@
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 #-}
17−
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.
20−module Data.Patch.DMapWithPatchingMove where
21−
22−import qualified Control.Category as Cat
23−--import qualified Control.Category.DecidablyEmpty as Cat
24−
25−import Data.Constraint.Extras (Has')
26−import Data.Dependent.Map (DMap)
27−import Data.Dependent.Sum (DSum (..))
28−import qualified Data.Dependent.Map as DMap
29−import Data.Functor.Constant (Constant (..))
30−import Data.Functor.Misc
31− ( Const2 (..), Proxy3 (..)
32− , weakenDMapWith
33− , dmapToMapWith
34− )
35−import Data.Functor.Const (Const (..))
36−import Data.Functor.Product (Product (..))
37−import Data.GADT.Compare (GEq (..), GCompare (..))
38−import Data.GADT.Show (GRead, GShow, gshow)
39−import qualified Data.Map as Map
40−import Data.Maybe
41−import Data.Monoid.DecidablyEmpty
42−import Data.Semigroupoid as Cat
43−#if !MIN_VERSION_base(4,11,0)
44−import Data.Semigroup (Semigroup (..), (<>))
45−#endif
46−import Data.Some (Some (Some), mkSome)
47−import Data.Proxy (Proxy (..))
48−import Data.These (These (..))
49−import Data.Type.Equality ((:~:)(..))
50−
51−import Data.Patch.Class
52− ( Patch (..), PatchHet (..)
53− , PatchHet2 (..), PatchSource1, PatchTarget1
54− , applyAlwaysHet2
55− )
56−import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove (..))
57−import qualified Data.Patch.MapWithPatchingMove as MapWithPatchingMove
58−
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)@)
70−newtype PatchDMapWithPatchingMove k v = PatchDMapWithPatchingMove (DMap k (NodeInfo k v))
71−
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)
88−
89−-- It won't let me derive for some reason
90−instance ( 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
96−
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.
101−data 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− }
108−
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)
125−
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.
133−data 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
143−
144−deriving instance ( Show (k a), GShow k
145− , Has' Show k (Flip p a)
146− , Show (PatchTarget1 p a)
147− ) => Show (From k p a)
148−deriving instance ( Read (k a), GRead k
149− , Has' Read k (Flip p a)
150− , Read (PatchTarget1 p a)
151− ) => Read (From k p a)
152−deriving instance ( GEq k
153− , Has' Eq k (Flip p a)
154− , Eq (PatchTarget1 p a)
155− ) => Eq (From k p a)
156−deriving 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)
161−
162−newtype Flip p to from = Flip (p from to)
163−
164−instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
165− id = Flip Cat.id
166− Flip y . Flip x = Flip $ x Cat.. y
167−
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.
171−data 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
178−
179−deriving instance GShow k => Show (To k)
180−deriving instance GRead k => Read (To k)
181−deriving instance GEq k => Eq (To k)
182−deriving instance GCompare k => Ord (To k)
183−
184−-- |Test whether a 'PatchDMapWithPatchingMove' satisfies its invariants.
185−validPatchDMapWithPatchingMove
186− :: forall k v
187− . (GCompare k, GShow k)
188− => DMap k (NodeInfo k v)
189− -> Bool
190−validPatchDMapWithPatchingMove = not . null . validationErrorsForPatchDMapWithPatchingMove
191−
192−-- |Enumerate what reasons a 'PatchDMapWithPatchingMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
193−validationErrorsForPatchDMapWithPatchingMove
194− :: forall k v
195− . (GCompare k, GShow k)
196− => DMap k (NodeInfo k v)
197− -> [String]
198−validationErrorsForPatchDMapWithPatchingMove 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
224−
225− _ ->
226− Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
227− unbalancedMove _ = Nothing
228−
229−
230−data ToFrom k p a = ToFrom (To k) (From k p a)
231−
232−-- | Helper data structure used for composing patches using the monoid instance.
233−data Fixup k p
234− = Fixup_Delete
235− | Fixup_Update (These (DSum k (From k p)) (To k))
236−
237−-- | Compose patches having the same effect as applying the patches in turn:
238−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
239−instance 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
311−
312−-- | Compose patches having the same effect as applying the patches in turn:
313−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
314−instance ( 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 = (<>)
322−
323−{-
324−mappendPatchDMapWithPatchingMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithPatchingMove k v -> PatchDMapWithPatchingMove k v -> PatchDMapWithPatchingMove k v
325−PatchDMapWithPatchingMove 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−-}
344−
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'.
348−insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithPatchingMove k p
349−insertDMapKey k v =
350− PatchDMapWithPatchingMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
351−
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−-- @
358−moveDMapKey
359− :: GCompare k
360− => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
361−moveDMapKey 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
367−
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−-- @
378−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
379−swapDMapKey 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
385−
386−-- | Make a @'PatchDMapWithPatchingMove' k v@ which has the effect of deleting a key in
387−-- the mapping, equivalent to 'DMap.delete'.
388−deleteDMapKey :: k a -> PatchDMapWithPatchingMove k v
389−deleteDMapKey k = PatchDMapWithPatchingMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
390−
391−{-
392−k1, k2 :: Const2 Int () ()
393−k1 = Const2 1
394−k2 = Const2 2
395−p1, p2 :: PatchDMapWithPatchingMove (Const2 Int ()) Identity
396−p1 = moveDMapKey k1 k2
397−p2 = moveDMapKey k2 k1
398−p12 = p1 <> p2
399−p21 = p2 <> p1
400−p12Slow = p1 `mappendPatchDMapWithPatchingMoveSlow` p2
401−p21Slow = p2 `mappendPatchDMapWithPatchingMoveSlow` p1
402−
403−testPatchDMapWithPatchingMove = 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
410−
411−dst (PatchDMapWithPatchingMove x _) = x
412−src (PatchDMapWithPatchingMove _ x) = x
413−-}
414−
415−-- | Extract the 'DMap' representing the patch changes from the
416−-- 'PatchDMapWithPatchingMove'.
417−unPatchDMapWithPatchingMove :: PatchDMapWithPatchingMove k v -> DMap k (NodeInfo k v)
418−unPatchDMapWithPatchingMove (PatchDMapWithPatchingMove p) = p
419−
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.
424−unsafePatchDMapWithPatchingMove :: DMap k (NodeInfo k v) -> PatchDMapWithPatchingMove k v
425−unsafePatchDMapWithPatchingMove = PatchDMapWithPatchingMove
426−
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@.
430−patchDMapWithPatchingMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithPatchingMove k v)
431−patchDMapWithPatchingMove dm =
432− case validationErrorsForPatchDMapWithPatchingMove dm of
433− [] -> Right $ unsafePatchDMapWithPatchingMove dm
434− errs -> Left errs
435−
436−-- | Map a natural transform @v -> v'@ over the given patch, transforming
437−-- @'PatchDMapWithPatchingMove' k v@ into @'PatchDMapWithPatchingMove' k v'@.
438−mapPatchDMapWithPatchingMove
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'
444−mapPatchDMapWithPatchingMove 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)
454−
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')@.
458−traversePatchDMapWithPatchingMove
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')
465−traversePatchDMapWithPatchingMove f g = traversePatchDMapWithPatchingMoveWithKey
466− (\_ -> f)
467− (\_ _ -> g)
468−
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')@.
472−traversePatchDMapWithPatchingMoveWithKey
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')
479−traversePatchDMapWithPatchingMoveWithKey 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
488−
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@.
491−nodeInfoMapFrom
492− :: (From k p a -> From k p' a)
493− -> (To k -> To k)
494− -> NodeInfo k p a
495− -> NodeInfo k p' a
496−nodeInfoMapFrom f g ni = NodeInfo
497− { _nodeInfo_from = f $ _nodeInfo_from ni
498− , _nodeInfo_to = g $ _nodeInfo_to ni
499− }
500−
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@.
503−nodeInfoMapFromM
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)
509−nodeInfoMapFromM f g ni = NodeInfo
510− <$> f (_nodeInfo_from ni)
511− <*> g (_nodeInfo_to ni)
512−
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.
516−weakenPatchDMapWithPatchingMoveWith
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'
522−weakenPatchDMapWithPatchingMoveWith 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− }
534−
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.
539−patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith
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'
545−patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith 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− }
557−
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'
563−const2PatchDMapWithPatchingMoveWith
564− :: forall k v v' a
565− . (v -> v' a)
566− -> PatchMapWithPatchingMove k (Proxy v)
567− -> PatchDMapWithPatchingMove (Const2 k a) (Proxy3 v')
568−const2PatchDMapWithPatchingMoveWith 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− }
581−
582−-- | Apply the insertions, deletions, and moves to a given 'DMap'.
583−instance ( 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)
589−
590−instance ( 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
609−
610−-- | Get the values that will be replaced, deleted, or moved if the given patch
611−-- is applied to the given 'DMap'.
612−getDeletionsAndMoves
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)))
619−getDeletionsAndMoves (PatchDMapWithPatchingMove p) m = DMap.intersectionWithKey f m p
620− where f _ v ni = Pair v $ Const $ _nodeInfo_to ni