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