git.iko.soy/patch
on develop help sign in
Replace patchThatChangesMap for PatchMapWithPatchingMove
80d2a39Ryan Trinkle
src/Data/Patch/MapWithPatchingMove.hs+14−35
compare with develop
unifiedsplit
@@ -17,11 +17,9 @@ module Data.Patch.MapWithPatchingMove where
17
17
18import Data.Patch.Class
18import Data.Patch.Class
19
19
20−import Control.Arrow
21import Control.Lens.TH (makeWrapped)
20import Control.Lens.TH (makeWrapped)
22−import Control.Monad.Trans.State
23−import Data.Foldable
24import Data.Function
21import Data.Function
22+import Data.Functor
25import Data.List
23import Data.List
26import Data.Map (Map)
24import Data.Map (Map)
27import qualified Data.Map as Map
25import qualified Data.Map as Map
@@ -30,9 +28,9 @@ import Data.Maybe
30import Data.Semigroup (Semigroup (..))
28import Data.Semigroup (Semigroup (..))
31#endif
29#endif
32import Data.Monoid.DecidablyEmpty
30import Data.Monoid.DecidablyEmpty
31+import Data.Patch.MapWithMove (PatchMapWithMove (..))
33−import qualified Data.Set as Set
32+import qualified Data.Patch.MapWithMove as MapWithMove
34import Data.These (These (..))
33import Data.These (These (..))
35−import Data.Tuple
36
34
37-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
35-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
38-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
36-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -249,39 +247,20 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
249
247
250-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
248-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
251-- will produce the second 'Map'.
249-- will produce the second 'Map'.
250+-- Note: this will never produce a patch on a value.
252patchThatChangesMap
251patchThatChangesMap
253 :: (Ord k, Ord (PatchTarget p), Monoid p)
252 :: (Ord k, Ord (PatchTarget p), Monoid p)
254 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
253 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
255−patchThatChangesMap oldByIndex newByIndex = patch
254+patchThatChangesMap oldByIndex newByIndex = fromMapWithMove $ MapWithMove.patchThatChangesMap oldByIndex newByIndex
256− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
255+
257− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
256+fromMapWithMove :: Monoid p => PatchMapWithMove k (PatchTarget p) -> PatchMapWithPatchingMove k p
258− let f k v = do
257+fromMapWithMove p = PatchMapWithPatchingMove $ unPatchMapWithMove p <&> \n -> NodeInfo
259− remainingValues <- get
258+ { _nodeInfo_from = case MapWithMove._nodeInfo_from n of
260− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
259+ MapWithMove.From_Insert v -> From_Insert v
261− then Map.delete v remainingValues
260+ MapWithMove.From_Delete -> From_Delete
262− else Map.insert v remainingKeys remainingValues
261+ MapWithMove.From_Move k -> From_Move k mempty
263− case Map.lookup v remainingValues of
262+ , _nodeInfo_to = MapWithMove._nodeInfo_to n
264− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
263+ }
265− Just fromKs ->
266− if k `Set.member` fromKs
267− then do
268− putRemainingKeys $ Set.delete k fromKs
269− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
270− else do
271− (fromK, remainingKeys) <- return $
272− fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
273− Set.minView fromKs -- There's an existing value, but it's not here; move it here
274− putRemainingKeys remainingKeys
275− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
276− Map.traverseWithKey f newByIndex
277− unusedOldKeys = fold unusedValuesByValue
278− pointlessMove k = \case
279− From_Move k' _ | k == k' -> True
280− _ -> False
281− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
282− then Just undefined
283− else Nothing
284− 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
285
264
286-- | Change the 'From' value of a 'NodeInfo'
265-- | Change the 'From' value of a 'NodeInfo'
287nodeInfoMapFrom
266nodeInfoMapFrom