@@ -17,11 +17,9 @@ module Data.Patch.MapWithPatchingMove where
1717
1818import Data.Patch.Class
1919
20−import Control.Arrow
2120import Control.Lens.TH (makeWrapped)
22−import Control.Monad.Trans.State
23−import Data.Foldable
2421import Data.Function
22+import Data.Functor
2523import Data.List
2624import Data.Map (Map)
2725import qualified Data.Map as Map
@@ -30,9 +28,9 @@ import Data.Maybe
3028import Data.Semigroup (Semigroup (..))
3129#endif
3230import Data.Monoid.DecidablyEmpty
33−import qualified Data.Set as Set
31+import Data.Patch.MapWithMove (PatchMapWithMove (..))
32+import qualified Data.Patch.MapWithMove as MapWithMove
3433import Data.These (These (..))
35−import Data.Tuple
3634
3735-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
3836-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -249,39 +247,20 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
249247
250248-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
251249-- will produce the second 'Map'.
250+-- Note: this will never produce a patch on a value.
252251patchThatChangesMap
253252 :: (Ord k, Ord (PatchTarget p), Monoid p)
254253 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
255−patchThatChangesMap oldByIndex newByIndex = patch
256− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
257− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
258− let f k v = do
259− remainingValues <- get
260− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
261− then Map.delete v remainingValues
262− else Map.insert v remainingKeys remainingValues
263− case Map.lookup v remainingValues of
264− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
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
254+patchThatChangesMap oldByIndex newByIndex = fromMapWithMove $ MapWithMove.patchThatChangesMap oldByIndex newByIndex
255+
256+fromMapWithMove :: Monoid p => PatchMapWithMove k (PatchTarget p) -> PatchMapWithPatchingMove k p
257+fromMapWithMove p = PatchMapWithPatchingMove $ unPatchMapWithMove p <&> \n -> NodeInfo
258+ { _nodeInfo_from = case MapWithMove._nodeInfo_from n of
259+ MapWithMove.From_Insert v -> From_Insert v
260+ MapWithMove.From_Delete -> From_Delete
261+ MapWithMove.From_Move k -> From_Move k mempty
262+ , _nodeInfo_to = MapWithMove._nodeInfo_to n
263+ }
285264
286265-- | Change the 'From' value of a 'NodeInfo'
287266nodeInfoMapFrom