diff --git a/ChangeLog.md b/ChangeLog.md index 7d15268..dbe42a7 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for patch +## Unreleased + +* Improve asympotics of merging + ## 0.0.5.1 - 2021-12-28 * New dep of `data-orphans` for old GHC to get instances honestly instead of diff --git a/src/Data/Patch/IntMap.hs b/src/Data/Patch/IntMap.hs index c8246eb..4449082 100644 --- a/src/Data/Patch/IntMap.hs +++ b/src/Data/Patch/IntMap.hs @@ -14,9 +14,11 @@ Patches of this sort allow for insert/update or delete of associations. -} module Data.Patch.IntMap where +import Control.Applicative import Control.Lens -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap +import Data.IntMap.Lazy (IntMap) +import qualified Data.IntMap.Lazy as IntMap +import Data.IntMap.Merge.Lazy import Data.Maybe import Data.Monoid.DecidablyEmpty #if !MIN_VERSION_base(4,11,0) @@ -43,10 +45,14 @@ makeWrapped ''PatchIntMap -- | Apply the insertions or deletions to a given 'IntMap'. instance Patch (PatchIntMap a) where type PatchTarget (PatchIntMap a) = IntMap a - apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $ - let removes = IntMap.filter isNothing p - adds = IntMap.mapMaybe id p - in IntMap.union adds $ v `IntMap.difference` removes + apply (PatchIntMap p) old + | IntMap.null p + = Nothing + | otherwise + = Just $! merge + (mapMaybeMissing $ \_k mv -> mv) + preserveMissing + (zipWithMaybeMatched (\_k mv v -> mv <|> Just v)) p old instance FunctorWithIndex Int PatchIntMap instance FoldableWithIndex Int PatchIntMap diff --git a/src/Data/Patch/Map.hs b/src/Data/Patch/Map.hs index 32e4a7a..8b5050d 100644 --- a/src/Data/Patch/Map.hs +++ b/src/Data/Patch/Map.hs @@ -18,12 +18,14 @@ module Data.Patch.Map where import Data.Patch.Class +import Control.Applicative import Control.Lens import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Monoid.DecidablyEmpty import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) +import Data.Map.Merge.Lazy -- | A set of changes to a 'Map'. Any element may be inserted/updated or -- deleted. Insertions are represented as values wrapped in 'Just', while @@ -52,12 +54,36 @@ instance Ord k => Semigroup (PatchMap k v) where instance Ord k => Patch (PatchMap k v) where type PatchTarget (PatchMap k v) = Map k v {-# INLINABLE apply #-} - apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? - where insertions = Map.mapMaybeWithKey (const id) p - deletions = Map.mapMaybeWithKey (const nothingToJust) p - nothingToJust = \case - Nothing -> Just () - Just _ -> Nothing + apply (PatchMap p) old + = changedToMaybe $ + mergeA + (traverseMaybeMissing $ \_k mv -> + case mv of + Nothing -> Unchanged Nothing + Just _ -> Changed mv) + preserveMissing + -- We could try to detect an update here that does nothing, but that + -- will be quite unreliable for a map of Events or similar; it may + -- not be worth the trouble. + (zipWithMaybeAMatched (\_k mv v -> Changed $! mv <|> Just v)) p old + +changedToMaybe :: Changed a -> Maybe a +changedToMaybe (Unchanged _) = Nothing +changedToMaybe (Changed a) = Just a + +data Changed a + = Unchanged a + | Changed a + deriving (Functor) + +instance Applicative Changed where + pure = Unchanged +#if MIN_VERSION_base(4,10,0) + liftA2 f (Changed x) (Changed y) = Changed (f x y) + liftA2 f (Unchanged x) (Changed y) = Changed (f x y) + liftA2 f (Changed x) (Unchanged y) = Changed (f x y) + liftA2 f (Unchanged x) (Unchanged y) = Unchanged (f x y) +#endif instance FunctorWithIndex k (PatchMap k) instance FoldableWithIndex k (PatchMap k)