@@ -48,10 +48,10 @@ module Data.Patch.MapWithPatchingMove
4848
4949import Data.Patch.Class
5050
51−import Control.Lens hiding (from, to)
51+import Control.Arrow
5252import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
54−import Data.Foldable (toList)
53+import Control.Monad.Trans.State
54+import Data.Foldable
5555import Data.Function
5656import Data.List
5757import Data.Map (Map)
@@ -61,9 +61,9 @@ import Data.Maybe
6161import Data.Semigroup (Semigroup (..))
6262#endif
6363import Data.Monoid.DecidablyEmpty
64−import Data.Set (Set)
6564import qualified Data.Set as Set
6665import Data.These (These (..))
66+import Data.Tuple
6767
6868-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
6969-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -136,8 +136,8 @@ moveMapKey src dst
136136-- @
137137-- let aMay = Map.lookup a map
138138-- bMay = Map.lookup b map
139−-- in maybe id (Map.insert a) (bMay <> aMay)
140−-- . maybe id (Map.insert b) (aMay <> bMay)
139+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
140+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
141141-- . Map.delete a . Map.delete b $ map
142142-- @
143143swapMapKey
@@ -229,40 +229,39 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
229229
230230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231231-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233232patchThatChangesMap
234− :: forall k p
235− . (Ord k, Ord (PatchTarget p), Monoid p)
233+ :: (Ord k, Ord (PatchTarget p), Monoid p)
236234 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237235patchThatChangesMap oldByIndex newByIndex = patch
238− where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
239− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
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))
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
245− -- Generate patch info for a single value
246− -- Keys that are found in both the old and new sets will not be patched
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
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
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
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
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
256− patchSingleValueThese v = \case
257− This oldKeys -> patchSingleValue v oldKeys mempty
258− That newKeys -> patchSingleValue v mempty newKeys
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
260− -- Generate froms and tos for all values, then merge them together
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
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.
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
265− These from to -> NodeInfo from to
236+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
237+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
238+ let f k v = do
239+ remainingValues <- get
240+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
241+ then Map.delete v remainingValues
242+ else Map.insert v remainingKeys remainingValues
243+ case Map.lookup v remainingValues of
244+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
245+ Just fromKs ->
246+ if k `Set.member` fromKs
247+ then do
248+ putRemainingKeys $ Set.delete k fromKs
249+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
250+ else do
251+ (fromK, remainingKeys) <- return $
252+ fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
253+ Set.minView fromKs -- There's an existing value, but it's not here; move it here
254+ putRemainingKeys remainingKeys
255+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
256+ Map.traverseWithKey f newByIndex
257+ unusedOldKeys = fold unusedValuesByValue
258+ pointlessMove k = \case
259+ From_Move k' _ | k == k' -> True
260+ _ -> False
261+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
262+ then Just undefined
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
266265
267266--
268267-- NodeInfo
@@ -282,8 +281,6 @@ deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
282281deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
283282deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
284283
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.
287284bitraverseNodeInfo
288285 :: Applicative f
289286 => (k0 -> f k1)
@@ -325,8 +322,6 @@ deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
325322deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
326323deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
327324
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.
330325bitraverseFrom
331326 :: Applicative f
332327 => (k0 -> f k1)