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