git.iko.soy/patch
on 80d2a39 help sign in
patch/src/Data/Patch/MapWithPatchingMove.hs
359 lines 16 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
14-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
15-- another
16module Data.Patch.MapWithPatchingMove where
18import Data.Patch.Class
20import Control.Lens.TH (makeWrapped)
21import Data.Function
22import Data.Functor
23import Data.List
24import Data.Map (Map)
25import qualified Data.Map as Map
26import Data.Maybe
27#if !MIN_VERSION_base(4,11,0)
28import Data.Semigroup (Semigroup (..))
29#endif
30import Data.Monoid.DecidablyEmpty
31import Data.Patch.MapWithMove (PatchMapWithMove (..))
32import qualified Data.Patch.MapWithMove as MapWithMove
33import Data.These (These (..))
35-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
36-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
37-- and vice versa. There should never be any unpaired From/To keys.
38newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
39 { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'
40 unPatchMapWithPatchingMove :: Map k (NodeInfo k p)
41 }
43deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
44deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
45deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
46deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
48deriving instance ( Ord k
49#if !MIN_VERSION_base(4,11,0)
50 , Semigroup p
51#endif
52 , DecidablyEmpty p
53 , Patch p
54 ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
56-- | Holds the information about each key: where its new value should come from,
57-- and where its old value should go to
58data NodeInfo k p = NodeInfo
59 { _nodeInfo_from :: !(From k p)
60 -- ^ Where do we get the new value for this key?
61 , _nodeInfo_to :: !(To k)
62 -- ^ If the old value is being kept (i.e. moved rather than deleted or
63 -- replaced), where is it going?
64 }
65deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
66deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
67deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
68deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
70bitraverseNodeInfo
71 :: Applicative f
72 => (k0 -> f k1)
73 -> (p0 -> f p1)
74 -> (PatchTarget p0 -> f (PatchTarget p1))
75 -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
76bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
77 <$> bitraverseFrom fk fp fpt from
78 <*> traverse fk to
80-- | Describe how a key's new value should be produced
81data From k p
82 = From_Insert (PatchTarget p) -- ^ Insert the given value here
83 | From_Delete -- ^ Delete the existing value, if any, from here
84 | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
86bitraverseFrom
87 :: Applicative f
88 => (k0 -> f k1)
89 -> (p0 -> f p1)
90 -> (PatchTarget p0 -> f (PatchTarget p1))
91 -> From k0 p0 -> f (From k1 p1)
92bitraverseFrom fk fp fpt = \case
93 From_Insert pt -> From_Insert <$> fpt pt
94 From_Delete -> pure From_Delete
95 From_Move k p -> From_Move <$> fk k <*> fp p
97deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
98deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
99deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
100deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
102-- | Describe where a key's old value will go. If this is 'Just', that means
103-- the key's old value will be moved to the given other key; if it is 'Nothing',
104-- that means it will be deleted.
105type To = Maybe
107-- | Create a 'PatchMapWithPatchingMove', validating it
108patchMapWithPatchingMove
109 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
110patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
111 where valid = forwardLinks == backwardLinks
112 forwardLinks = Map.mapMaybe _nodeInfo_to m
113 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
114 case _nodeInfo_from p of
115 From_Move from _ -> Just (from, to)
116 _ -> Nothing
118-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
119patchMapWithPatchingMoveInsertAll
120 :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
121patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
122 { _nodeInfo_from = From_Insert v
123 , _nodeInfo_to = Nothing
124 }
126-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
127insertMapKey
128 :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
129insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
131-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
132--
133-- @
134-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
135-- @
136moveMapKey
137 :: ( DecidablyEmpty p
138#if !MIN_VERSION_base(4,11,0)
139 , Semigroup p
140#endif
141 , Patch p
142 )
143 => Ord k => k -> k -> PatchMapWithPatchingMove k p
144moveMapKey src dst
145 | src == dst = mempty
146 | otherwise =
147 PatchMapWithPatchingMove $ Map.fromList
148 [ (dst, NodeInfo (From_Move src mempty) Nothing)
149 , (src, NodeInfo From_Delete (Just dst))
150 ]
152-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
153--
154-- @
155-- let aMay = Map.lookup a map
156-- bMay = Map.lookup b map
157-- in maybe id (Map.insert a) (bMay `mplus` aMay)
158-- . maybe id (Map.insert b) (aMay `mplus` bMay)
159-- . Map.delete a . Map.delete b $ map
160-- @
161swapMapKey
162 :: ( DecidablyEmpty p
163#if !MIN_VERSION_base(4,11,0)
164 , Semigroup p
165#endif
166 , Patch p
167 )
168 => Ord k => k -> k -> PatchMapWithPatchingMove k p
169swapMapKey src dst
170 | src == dst = mempty
171 | otherwise =
172 PatchMapWithPatchingMove $ Map.fromList
173 [ (dst, NodeInfo (From_Move src mempty) (Just src))
174 , (src, NodeInfo (From_Move dst mempty) (Just dst))
175 ]
177-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
178-- the mapping, equivalent to 'Map.delete'.
179deleteMapKey
180 :: k -> PatchMapWithPatchingMove k v
181deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
183-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
184--
185-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
186unsafePatchMapWithPatchingMove
187 :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
188unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
190-- | Apply the insertions, deletions, and moves to a given 'Map'
191instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
192 type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
193 -- TODO: return Nothing sometimes
194 -- Note: the strict application here is critical to ensuring that incremental
195 -- merges don't hold onto all their prerequisite events forever; can we make
196 -- this more robust?
197 apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
198 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
199 From_Insert v -> Just v
200 From_Move k p -> applyAlways p <$> Map.lookup k old
201 From_Delete -> Nothing
202 deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
203 From_Delete -> Just ()
204 _ -> Nothing
206-- | Returns all the new elements that will be added to the 'Map'
207patchMapWithPatchingMoveNewElements
208 :: PatchMapWithPatchingMove k p -> [PatchTarget p]
209patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
211-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
212patchMapWithPatchingMoveNewElementsMap
213 :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
214patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
215 where f ni = case _nodeInfo_from ni of
216 From_Insert v -> Just v
217 From_Move _ _ -> Nothing
218 From_Delete -> Nothing
220-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
221-- its values using the given ordering function. The set keys of the 'Map' is
222-- not changed.
223patchThatSortsMapWith
224 :: (Ord k, Monoid p)
225 => (PatchTarget p -> PatchTarget p -> Ordering)
226 -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
227patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
228 where unsorted = Map.toList m
229 sorted = sortBy (cmp `on` snd) unsorted
230 f (to, _) (from, _) = if to == from then Nothing else
231 Just (from, to)
232 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
233 g (to, _) (from, _) = if to == from then Nothing else
234 let Just movingTo = Map.lookup from reverseMapping
235 in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
237-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
238-- will produce a 'Map' with the same values as the second 'Map' but with the
239-- values sorted with the given ordering function.
240patchThatChangesAndSortsMapWith
241 :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
242 => (PatchTarget p -> PatchTarget p -> Ordering)
243 -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
244patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
245 where newList = Map.toList newByIndexUnsorted
246 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
248-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
249-- will produce the second 'Map'.
250-- Note: this will never produce a patch on a value.
251patchThatChangesMap
252 :: (Ord k, Ord (PatchTarget p), Monoid p)
253 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
254patchThatChangesMap oldByIndex newByIndex = fromMapWithMove $ MapWithMove.patchThatChangesMap oldByIndex newByIndex
256fromMapWithMove :: Monoid p => PatchMapWithMove k (PatchTarget p) -> PatchMapWithPatchingMove k p
257fromMapWithMove p = PatchMapWithPatchingMove $ unPatchMapWithMove p <&> \n -> NodeInfo
258 { _nodeInfo_from = case MapWithMove._nodeInfo_from n of
259 MapWithMove.From_Insert v -> From_Insert v
260 MapWithMove.From_Delete -> From_Delete
261 MapWithMove.From_Move k -> From_Move k mempty
262 , _nodeInfo_to = MapWithMove._nodeInfo_to n
263 }
265-- | Change the 'From' value of a 'NodeInfo'
266nodeInfoMapFrom
267 :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
268nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
270-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
271-- 'Applicative', 'Monad', etc.) action to get the new value
272nodeInfoMapMFrom
273 :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
274nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
276-- | Set the 'To' field of a 'NodeInfo'
277nodeInfoSetTo
278 :: To k -> NodeInfo k v -> NodeInfo k v
279nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
281-- | Helper data structure used for composing patches using the monoid instance.
282data Fixup k v
283 = Fixup_Delete
284 | Fixup_Update (These (From k v) (To k))
286-- | Compose patches having the same effect as applying the patches in turn:
287-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
288instance ( Ord k
289#if !MIN_VERSION_base(4,11,0)
290 , Semigroup p
291#endif
292 , DecidablyEmpty p
293 , Patch p
294 ) => Semigroup (PatchMapWithPatchingMove k p) where
295 PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
296 where
297 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
298 h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
299 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
300 (Just toAfter, From_Move fromBefore p)
301 | fromBefore == toAfter && isEmpty p
302 -> [(toAfter, Fixup_Delete)]
303 | otherwise
304 -> [ (toAfter, Fixup_Update (This editBefore))
305 , (fromBefore, Fixup_Update (That mToAfter))
306 ]
307 (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
308 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
309 (Nothing, _) -> []
310 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
311 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
312 | This x <- a, That y <- b
313 = Fixup_Update $ These x y
314 | That y <- a, This x <- b
315 = Fixup_Update $ These x y
316 mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
317 fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
318 combineNodeInfos _ nia nib = NodeInfo
319 { _nodeInfo_from = _nodeInfo_from nia
320 , _nodeInfo_to = _nodeInfo_to nib
321 }
322 applyFixup _ ni = \case
323 Fixup_Delete -> Nothing
324 Fixup_Update u -> Just $ NodeInfo
325 { _nodeInfo_from = case _nodeInfo_from ni of
326 f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
327 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
328 Just (From_Insert v) -> From_Insert $ applyAlways p' v
329 Just From_Delete -> From_Delete
330 Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
331 _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
332 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
333 }
334 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
335 getHere :: These a b -> Maybe a
336 getHere = \case
337 This a -> Just a
338 These a _ -> Just a
339 That _ -> Nothing
340 getThere :: These a b -> Maybe b
341 getThere = \case
342 This _ -> Nothing
343 These _ b -> Just b
344 That b -> Just b
346--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
347-- | Compose patches having the same effect as applying the patches in turn:
348-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
349instance ( Ord k
350#if !MIN_VERSION_base(4,11,0)
351 , Semigroup p
352#endif
353 , DecidablyEmpty p
354 , Patch p
355 ) => Monoid (PatchMapWithPatchingMove k p) where
356 mempty = PatchMapWithPatchingMove mempty
357 mappend = (<>)
359makeWrapped ''PatchMapWithPatchingMove