@@ -48,10 +48,10 @@ module Data.Patch.MapWithPatchingMove
49import Data.Patch.Class
49import Data.Patch.Class
51−import Control.Arrow
51+import Control.Lens hiding (from, to)
52import Control.Lens.TH (makeWrapped)
52import Control.Lens.TH (makeWrapped)
53−import Control.Monad.Trans.State
53+import Data.Align (align)
54−import Data.Foldable
54+import Data.Foldable (toList)
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
64import qualified Data.Set as Set
65import qualified Data.Set as Set
65import Data.These (These (..))
66import 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@,
@@ -229,39 +229,40 @@ 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.
232patchThatChangesMap
233patchThatChangesMap
233− :: (Ord k, Ord (PatchTarget p), Monoid p)
235+ . (Ord k, Ord (PatchTarget p), Monoid p)
234 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
235patchThatChangesMap oldByIndex newByIndex = patch
237patchThatChangesMap oldByIndex newByIndex = patch
236− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
238+ where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
237− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
239+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
238− let f k v = do
240+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
239− remainingValues <- get
241+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
240− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
242+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
241− then Map.delete v remainingValues
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))
242− else Map.insert v remainingKeys remainingValues
244+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
243− case Map.lookup v remainingValues of
245+ -- Generate patch info for a single value
244− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
246+ -- Keys that are found in both the old and new sets will not be patched
245− Just fromKs ->
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
246− if k `Set.member` 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
247− then do
249+ patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
248− putRemainingKeys $ Set.delete k fromKs
250+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
249− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
251+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
250− else do
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
251− (fromK, remainingKeys) <- return $
253+ These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
252− fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
254+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
253− Set.minView fromKs -- There's an existing value, but it's not here; move it here
255+ patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
254− putRemainingKeys remainingKeys
256+ patchSingleValueThese v = \case
255− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
257+ This oldKeys -> patchSingleValue v oldKeys mempty
256− Map.traverseWithKey f newByIndex
258+ That newKeys -> patchSingleValue v mempty newKeys
257− unusedOldKeys = fold unusedValuesByValue
259+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
258− pointlessMove k = \case
260+ -- Generate froms and tos for all values, then merge them together
259− From_Move k' _ | k == k' -> True
261+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
260− _ -> False
262+ patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
261− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
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.
262− then Just undefined
264+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
263− else Nothing
265+ These from to -> NodeInfo from to
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
267-- NodeInfo
268-- NodeInfo