@@ -48,10 +48,10 @@ module Data.Patch.MapWithPatchingMove
49import Data.Patch.Class
49import Data.Patch.Class
51−import Control.Lens hiding (from, to)
51+import Control.Arrow
52import Control.Lens.TH (makeWrapped)
52import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
53+import Control.Monad.Trans.State
54−import Data.Foldable (toList)
54+import Data.Foldable
55import Data.Function
55import Data.Function
56import Data.List
56import Data.List
57import Data.Map (Map)
57import Data.Map (Map)
@@ -61,9 +61,9 @@ import Data.Maybe
61import Data.Semigroup (Semigroup (..))
61import Data.Semigroup (Semigroup (..))
63import Data.Monoid.DecidablyEmpty
63import Data.Monoid.DecidablyEmpty
65import qualified Data.Set as Set
64import qualified Data.Set as Set
66import Data.These (These (..))
65import Data.These (These (..))
68-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
68-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
69-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
69-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -136,8 +136,8 @@ moveMapKey src dst
137-- let aMay = Map.lookup a map
137-- let aMay = Map.lookup a map
138-- bMay = Map.lookup b map
138-- bMay = Map.lookup b map
139−-- in maybe id (Map.insert a) (bMay <> aMay)
139+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
140−-- . maybe id (Map.insert b) (aMay <> bMay)
140+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
141-- . Map.delete a . Map.delete b $ map
141-- . Map.delete a . Map.delete b $ map
143swapMapKey
143swapMapKey
@@ -229,40 +229,39 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231-- will produce the second 'Map'.
231-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233patchThatChangesMap
232patchThatChangesMap
235− . (Ord k, Ord (PatchTarget p), Monoid p)
233+ :: (Ord k, Ord (PatchTarget p), Monoid p)
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
234 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237patchThatChangesMap oldByIndex newByIndex = patch
235patchThatChangesMap oldByIndex newByIndex = patch
238− where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
236+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
239− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
237+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
238+ let f k v = do
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
239+ remainingValues <- get
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
240+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
243− unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
241+ then Map.delete v remainingValues
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
242+ else Map.insert v remainingKeys remainingValues
245− -- Generate patch info for a single value
243+ case Map.lookup v remainingValues of
246− -- Keys that are found in both the old and new sets will not be patched
244+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
247− -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
245+ Just fromKs ->
248− -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
246+ if k `Set.member` fromKs
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
247+ then do
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
248+ putRemainingKeys $ Set.delete k fromKs
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
249+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
252− That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
250+ else do
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
251+ (fromK, remainingKeys) <- return $
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
252+ fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
253+ Set.minView fromKs -- There's an existing value, but it's not here; move it here
256− patchSingleValueThese v = \case
254+ putRemainingKeys remainingKeys
257− This oldKeys -> patchSingleValue v oldKeys mempty
255+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
258− That newKeys -> patchSingleValue v mempty newKeys
256+ Map.traverseWithKey f newByIndex
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
257+ unusedOldKeys = fold unusedValuesByValue
260− -- Generate froms and tos for all values, then merge them together
258+ pointlessMove k = \case
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
259+ From_Move k' _ | k == k' -> True
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
260+ _ -> False
263− This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
261+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
262+ then Just undefined
265− These from to -> NodeInfo from to
263+ else Nothing
264+ 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
268-- NodeInfo
267-- NodeInfo
@@ -282,8 +281,6 @@ deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
282deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
281deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
283deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
282deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
285−-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of
286−-- the type families here, this doesn't it any bi- or tri-traversal class.
287bitraverseNodeInfo
284bitraverseNodeInfo
288 :: Applicative f
285 :: Applicative f
289 => (k0 -> f k1)
286 => (k0 -> f k1)
@@ -325,8 +322,6 @@ deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
325deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
322deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
326deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
323deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
328−-- | Traverse the 'From' over the key, patch, and patch target. Because of
329−-- the type families here, this doesn't it any bi- or tri-traversal class.
330bitraverseFrom
325bitraverseFrom
331 :: Applicative f
326 :: Applicative f
332 => (k0 -> f k1)
327 => (k0 -> f k1)