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