@@ -16,9 +16,8 @@ module Data.Patch.MapWithMove where
1616
1717import Data.Patch.Class
1818
19−import Control.Arrow
2019import Control.Lens hiding (from, to)
21−import Control.Monad.Trans.State
20+import Data.Align
2221import Data.Foldable
2322import Data.Function
2423import Data.List
@@ -28,9 +27,9 @@ import Data.Maybe
2827#if !MIN_VERSION_base(4,11,0)
2928import Data.Semigroup (Semigroup (..))
3029#endif
30+import Data.Set (Set)
3131import qualified Data.Set as Set
3232import Data.These (These(..))
33−import Data.Tuple
3433
3534-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
3635-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -185,37 +184,36 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
185184
186185-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
187186-- will produce the second 'Map'.
188−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
187+patchThatChangesMap :: forall k v. (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
189188patchThatChangesMap 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
189+ where invert :: Map k v -> Map v (Set k)
190+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
191+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
192+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
193+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
194+ 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))
195+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
196+ -- Generate patch info for a single value
197+ -- Keys that are found in both the old and new sets will not be patched
198+ -- 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
199+ -- 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
200+ patchSingleValue :: v -> Set k -> Set k -> (Map k (From k v), Map k (To k))
201+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
202+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
203+ 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
204+ These oldK newK -> (Map.singleton newK $ From_Move oldK, Map.singleton oldK $ Just newK)
205+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
206+ patchSingleValueThese :: v -> These (Set k) (Set k) -> (Map k (From k v), Map k (To k))
207+ patchSingleValueThese v = \case
208+ This oldKeys -> patchSingleValue v oldKeys mempty
209+ That newKeys -> patchSingleValue v mempty newKeys
210+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
211+ -- Generate froms and tos for all values, then merge them together
212+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
213+ patch = unsafePatchMapWithMove $ align froms tos <&> \case
214+ 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.
215+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
216+ These from to -> NodeInfo from to
219217
220218-- | Change the 'From' value of a 'NodeInfo'
221219nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v