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