git.iko.soy/patch
on patch-dmap-reset help sign in
patch/src/Data/Patch/MapWithMove.hs
270 lines 13 kB history raw
1{-# LANGUAGE DeriveFoldable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
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
23import Data.Semigroup (Semigroup (..), (<>))
24import qualified Data.Set as Set
25import Data.These (These(..))
26import Data.Tuple
28-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
29-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
30-- and vice versa. There should never be any unpaired From/To keys.
31newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
33-- | Holds the information about each key: where its new value should come from,
34-- and where its old value should go to
35data NodeInfo k v = NodeInfo
36 { _nodeInfo_from :: !(From k v)
37 -- ^ Where do we get the new value for this key?
38 , _nodeInfo_to :: !(To k)
39 -- ^ If the old value is being kept (i.e. moved rather than deleted or
40 -- replaced), where is it going?
41 }
42 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
44-- | Describe how a key's new value should be produced
45data From k v
46 = From_Insert v -- ^ Insert the given value here
47 | From_Delete -- ^ Delete the existing value, if any, from here
48 | From_Move !k -- ^ Move the value here from the given key
49 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
51-- | Describe where a key's old value will go. If this is 'Just', that means
52-- the key's old value will be moved to the given other key; if it is 'Nothing',
53-- that means it will be deleted.
54type To = Maybe
56-- | Create a 'PatchMapWithMove', validating it
57patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
58patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
59 where valid = forwardLinks == backwardLinks
60 forwardLinks = Map.mapMaybe _nodeInfo_to m
61 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
62 case _nodeInfo_from v of
63 From_Move from -> Just (from, to)
64 _ -> Nothing
66-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
67patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
68patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
69 { _nodeInfo_from = From_Insert v
70 , _nodeInfo_to = Nothing
71 }
73-- | Extract the internal representation of the 'PatchMapWithMove'
74unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
75unPatchMapWithMove (PatchMapWithMove p) = p
77-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
78insertMapKey :: k -> v -> PatchMapWithMove k v
79insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
81-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
82--
83-- @
84-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
85-- @
86moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
87moveMapKey src dst
88 | src == dst = mempty
89 | otherwise =
90 PatchMapWithMove $ Map.fromList
91 [ (dst, NodeInfo (From_Move src) Nothing)
92 , (src, NodeInfo From_Delete (Just dst))
93 ]
95-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
96--
97-- @
98-- let aMay = Map.lookup a map
99-- bMay = Map.lookup b map
100-- in maybe id (Map.insert a) (bMay `mplus` aMay)
101-- . maybe id (Map.insert b) (aMay `mplus` bMay)
102-- . Map.delete a . Map.delete b $ map
103-- @
104swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
105swapMapKey src dst
106 | src == dst = mempty
107 | otherwise =
108 PatchMapWithMove $ Map.fromList
109 [ (dst, NodeInfo (From_Move src) (Just src))
110 , (src, NodeInfo (From_Move dst) (Just dst))
111 ]
113-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
114deleteMapKey :: k -> PatchMapWithMove k v
115deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
117-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
118--
119-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
120unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
121unsafePatchMapWithMove = PatchMapWithMove
123-- | Apply the insertions, deletions, and moves to a given 'Map'
124instance Ord k => Patch (PatchMapWithMove k v) where
125 type PatchTarget (PatchMapWithMove k v) = Map k v
126 apply (PatchMapWithMove p) 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?
127 where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
128 From_Insert v -> Just v
129 From_Move k -> Map.lookup k old
130 From_Delete -> Nothing
131 deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
132 From_Delete -> Just ()
133 _ -> Nothing
135-- | Returns all the new elements that will be added to the 'Map'.
136patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
137patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
139-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
140patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
141patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
142 where f ni = case _nodeInfo_from ni of
143 From_Insert v -> Just v
144 From_Move _ -> Nothing
145 From_Delete -> Nothing
147-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
148-- its values using the given ordering function. The set keys of the 'Map' is
149-- not changed.
150patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
151patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
152 where unsorted = Map.toList m
153 sorted = sortBy (cmp `on` snd) unsorted
154 f (to, _) (from, _) = if to == from then Nothing else
155 Just (from, to)
156 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
157 g (to, _) (from, _) = if to == from then Nothing else
158 let Just movingTo = Map.lookup to reverseMapping
159 in Just (to, NodeInfo (From_Move from) $ Just movingTo)
161-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
162-- will produce a 'Map' with the same values as the second 'Map' but with the
163-- values sorted with the given ordering function.
164patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
165patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
166 where newList = Map.toList newByIndexUnsorted
167 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
169-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
170-- will produce the second 'Map'.
171patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
172patchThatChangesMap oldByIndex newByIndex = patch
173 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
174 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
175 let f k v = do
176 remainingValues <- get
177 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
178 then Map.delete v remainingValues
179 else Map.insert v remainingKeys remainingValues
180 case Map.lookup v remainingValues of
181 Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
182 Just fromKs ->
183 if k `Set.member` fromKs
184 then do
185 putRemainingKeys $ Set.delete k fromKs
186 return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
187 else do
188 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
189 putRemainingKeys remainingKeys
190 return $ NodeInfo (From_Move fromK) $ Just undefined
191 Map.traverseWithKey f newByIndex
192 unusedOldKeys = fold unusedValuesByValue
193 pointlessMove k = \case
194 From_Move k' | k == k' -> True
195 _ -> False
196 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
197 then Just undefined
198 else Nothing
199 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
201-- | Change the 'From' value of a 'NodeInfo'
202nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
203nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
205-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
206-- 'Applicative', 'Monad', etc.) action to get the new value
207nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
208nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
210-- | Set the 'To' field of a 'NodeInfo'
211nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
212nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
214-- |Helper data structure used for composing patches using the monoid instance.
215data Fixup k v
216 = Fixup_Delete
217 | Fixup_Update (These (From k v) (To k))
219-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
220instance Ord k => Semigroup (PatchMapWithMove k v) where
221 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
222 where
223 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
224 h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
225 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
226 (Just toAfter, From_Move fromBefore)
227 | fromBefore == toAfter
228 -> [(toAfter, Fixup_Delete)]
229 | otherwise
230 -> [ (toAfter, Fixup_Update (This editBefore))
231 , (fromBefore, Fixup_Update (That mToAfter))
232 ]
233 (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
234 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
235 (Nothing, _) -> []
236 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
237 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
238 | This x <- a, That y <- b
239 = Fixup_Update $ These x y
240 | That y <- a, This x <- b
241 = Fixup_Update $ These x y
242 mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
243 fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
244 combineNodeInfos _ nia nib = NodeInfo
245 { _nodeInfo_from = _nodeInfo_from nia
246 , _nodeInfo_to = _nodeInfo_to nib
247 }
248 applyFixup _ ni = \case
249 Fixup_Delete -> Nothing
250 Fixup_Update u -> Just $ NodeInfo
251 { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
252 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
253 }
254 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
255 getHere :: These a b -> Maybe a
256 getHere = \case
257 This a -> Just a
258 These a _ -> Just a
259 That _ -> Nothing
260 getThere :: These a b -> Maybe b
261 getThere = \case
262 This _ -> Nothing
263 These _ b -> Just b
264 That b -> Just b
266--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
267-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
268instance Ord k => Monoid (PatchMapWithMove k v) where
269 mempty = PatchMapWithMove mempty
270 mappend = (<>)