git.iko.soy/patch
on c97c126 help sign in
patch/src/Data/Patch/MapWithPatchingMove.hs
328 lines 16 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
12-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
13-- another
14module Data.Patch.MapWithPatchingMove where
16import Data.Patch.Class
18import Control.Arrow
19import Control.Monad.Trans.State
20import Data.Foldable
21import Data.Function
22import Data.List
23import Data.Map (Map)
24import qualified Data.Map as Map
25import Data.Maybe
26--import Data.Proxy
27#if !MIN_VERSION_base(4,10,0)
28import Data.Semigroup (Semigroup (..))
29#endif
30import Data.Monoid.DecidablyEmpty
31import qualified Data.Set as Set
32import Data.These (These (..))
33import Data.Tuple
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 }
42deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
43deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
44deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
45deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
47-- | Holds the information about each key: where its new value should come from,
48-- and where its old value should go to
49data NodeInfo k p = NodeInfo
50 { _nodeInfo_from :: !(From k p)
51 -- ^ Where do we get the new value for this key?
52 , _nodeInfo_to :: !(To k)
53 -- ^ If the old value is being kept (i.e. moved rather than deleted or
54 -- replaced), where is it going?
55 }
56deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
57deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
58deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
59deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
61-- | Describe how a key's new value should be produced
62data From k p
63 = From_Insert (PatchTarget p) -- ^ Insert the given value here
64 | From_Delete -- ^ Delete the existing value, if any, from here
65 | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
67deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
68deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
69deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
70deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
72-- | Describe where a key's old value will go. If this is 'Just', that means
73-- the key's old value will be moved to the given other key; if it is 'Nothing',
74-- that means it will be deleted.
75type To = Maybe
77-- | Create a 'PatchMapWithPatchingMove', validating it
78patchMapWithPatchingMove
79 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
80patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
81 where valid = forwardLinks == backwardLinks
82 forwardLinks = Map.mapMaybe _nodeInfo_to m
83 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
84 case _nodeInfo_from p of
85 From_Move from _ -> Just (from, to)
86 _ -> Nothing
88-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
89patchMapWithPatchingMoveInsertAll
90 :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
91patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
92 { _nodeInfo_from = From_Insert v
93 , _nodeInfo_to = Nothing
94 }
96-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
97insertMapKey
98 :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
99insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
101-- |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:
102--
103-- @
104-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
105-- @
106moveMapKey
107 :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithPatchingMove k p
108moveMapKey src dst
109 | src == dst = mempty
110 | otherwise =
111 PatchMapWithPatchingMove $ Map.fromList
112 [ (dst, NodeInfo (From_Move src mempty) Nothing)
113 , (src, NodeInfo From_Delete (Just dst))
114 ]
116-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
117--
118-- @
119-- let aMay = Map.lookup a map
120-- bMay = Map.lookup b map
121-- in maybe id (Map.insert a) (bMay `mplus` aMay)
122-- . maybe id (Map.insert b) (aMay `mplus` bMay)
123-- . Map.delete a . Map.delete b $ map
124-- @
125swapMapKey
126 :: (DecidablyEmpty p, Patch p)
127 => Ord k => k -> k -> PatchMapWithPatchingMove k p
128swapMapKey src dst
129 | src == dst = mempty
130 | otherwise =
131 PatchMapWithPatchingMove $ Map.fromList
132 [ (dst, NodeInfo (From_Move src mempty) (Just src))
133 , (src, NodeInfo (From_Move dst mempty) (Just dst))
134 ]
136-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
137-- the mapping, equivalent to 'Map.delete'.
138deleteMapKey
139 :: k -> PatchMapWithPatchingMove k v
140deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
142-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
143--
144-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
145unsafePatchMapWithPatchingMove
146 :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
147unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
149-- | Apply the insertions, deletions, and moves to a given 'Map'
150instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
151 type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
152 -- TODO: return Nothing sometimes
153 -- Note: the strict application here is critical to ensuring that incremental
154 -- merges don't hold onto all their prerequisite events forever; can we make
155 -- this more robust?
156 apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
157 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
158 From_Insert v -> Just v
159 From_Move k p -> applyAlways p <$> Map.lookup k old
160 From_Delete -> Nothing
161 deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
162 From_Delete -> Just ()
163 _ -> Nothing
165-- | Returns all the new elements that will be added to the 'Map'
166patchMapWithPatchingMoveNewElements
167 :: PatchMapWithPatchingMove k p -> [PatchTarget p]
168patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
170-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
171patchMapWithPatchingMoveNewElementsMap
172 :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
173patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
174 where f ni = case _nodeInfo_from ni of
175 From_Insert v -> Just v
176 From_Move _ _ -> Nothing
177 From_Delete -> Nothing
179-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
180-- its values using the given ordering function. The set keys of the 'Map' is
181-- not changed.
182patchThatSortsMapWith
183 :: (Ord k, Monoid p)
184 => (PatchTarget p -> PatchTarget p -> Ordering)
185 -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
186patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
187 where unsorted = Map.toList m
188 sorted = sortBy (cmp `on` snd) unsorted
189 f (to, _) (from, _) = if to == from then Nothing else
190 Just (from, to)
191 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
192 g (to, _) (from, _) = if to == from then Nothing else
193 let Just movingTo = Map.lookup from reverseMapping
194 in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
196-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
197-- will produce a 'Map' with the same values as the second 'Map' but with the
198-- values sorted with the given ordering function.
199patchThatChangesAndSortsMapWith
200 :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
201 => (PatchTarget p -> PatchTarget p -> Ordering)
202 -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
204 where newList = Map.toList newByIndexUnsorted
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
207-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
208-- will produce the second 'Map'.
209patchThatChangesMap
210 :: (Ord k, Ord (PatchTarget p), Monoid p)
211 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
212patchThatChangesMap oldByIndex newByIndex = patch
213 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
214 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
215 let f k v = do
216 remainingValues <- get
217 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
218 then Map.delete v remainingValues
219 else Map.insert v remainingKeys remainingValues
220 case Map.lookup v remainingValues of
221 Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
222 Just fromKs ->
223 if k `Set.member` fromKs
224 then do
225 putRemainingKeys $ Set.delete k fromKs
226 return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
227 else do
228 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
229 putRemainingKeys remainingKeys
230 return $ NodeInfo (From_Move fromK mempty) $ Just undefined
231 Map.traverseWithKey f newByIndex
232 unusedOldKeys = fold unusedValuesByValue
233 pointlessMove k = \case
234 From_Move k' _ | k == k' -> True
235 _ -> False
236 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
237 then Just undefined
238 else Nothing
239 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
241-- | Change the 'From' value of a 'NodeInfo'
242nodeInfoMapFrom
243 :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
244nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
246-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
247-- 'Applicative', 'Monad', etc.) action to get the new value
248nodeInfoMapMFrom
249 :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
250nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
252-- | Set the 'To' field of a 'NodeInfo'
253nodeInfoSetTo
254 :: To k -> NodeInfo k v -> NodeInfo k v
255nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
257-- |Helper data structure used for composing patches using the monoid instance.
258data Fixup k v
259 = Fixup_Delete
260 | Fixup_Update (These (From k v) (To k))
262-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
263instance ( Ord k
264 , Monoid p
265 , DecidablyEmpty p
266 , Patch p
267 ) => Semigroup (PatchMapWithPatchingMove k p) where
268 PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
269 where
270 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
271 h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
272 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
273 (Just toAfter, From_Move fromBefore p)
274 | fromBefore == toAfter && isEmpty p
275 -> [(toAfter, Fixup_Delete)]
276 | otherwise
277 -> [ (toAfter, Fixup_Update (This editBefore))
278 , (fromBefore, Fixup_Update (That mToAfter))
279 ]
280 (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
281 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
282 (Nothing, _) -> []
283 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
284 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
285 | This x <- a, That y <- b
286 = Fixup_Update $ These x y
287 | That y <- a, This x <- b
288 = Fixup_Update $ These x y
289 mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
290 fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
291 combineNodeInfos _ nia nib = NodeInfo
292 { _nodeInfo_from = _nodeInfo_from nia
293 , _nodeInfo_to = _nodeInfo_to nib
294 }
295 applyFixup _ ni = \case
296 Fixup_Delete -> Nothing
297 Fixup_Update u -> Just $ NodeInfo
298 { _nodeInfo_from = case _nodeInfo_from ni of
299 f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
300 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
301 Just (From_Insert v) -> From_Insert $ applyAlways p' v
302 Just From_Delete -> From_Delete
303 Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
304 _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
305 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
306 }
307 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
308 getHere :: These a b -> Maybe a
309 getHere = \case
310 This a -> Just a
311 These a _ -> Just a
312 That _ -> Nothing
313 getThere :: These a b -> Maybe b
314 getThere = \case
315 This _ -> Nothing
316 These _ b -> Just b
317 That b -> Just b
319--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
320-- | Compose patches having the same effect as applying the patches in turn:
321-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
322instance ( Ord k
323 , Monoid p
324 , DecidablyEmpty p
325 , Patch p
326 ) => Monoid (PatchMapWithPatchingMove k p) where
327 mempty = PatchMapWithPatchingMove mempty
328 mappend = (<>)