From f78211aa3aa3b873956a2aafaf648b072a09d174 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Tue, 16 Jul 2019 15:29:37 -0400 Subject: [PATCH 1/5] Patch maps better * Use the `merge` API from `containers` to perform each merge in one go. * Use lazy merge operations for both; this is more consistent. --- src/Reflex/Patch/IntMap.hs | 18 ++++++++++++------ src/Reflex/Patch/Map.hs | 22 ++++++++++++++++------ 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/src/Reflex/Patch/IntMap.hs b/src/Reflex/Patch/IntMap.hs index 3f9a7fb2..fe615aae 100644 --- a/src/Reflex/Patch/IntMap.hs +++ b/src/Reflex/Patch/IntMap.hs @@ -8,11 +8,13 @@ -- insert/update or delete of associations. module Reflex.Patch.IntMap where -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.Maybe import Data.Semigroup import Reflex.Patch.Class +import Data.IntMap.Merge.Lazy +import Control.Applicative -- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping. -- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update @@ -22,10 +24,14 @@ newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldab -- | 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 -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. -- If the same key is modified by both patches, the one on the left will take diff --git a/src/Reflex/Patch/Map.hs b/src/Reflex/Patch/Map.hs index 4d22a058..1692d4c0 100644 --- a/src/Reflex/Patch/Map.hs +++ b/src/Reflex/Patch/Map.hs @@ -11,6 +11,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Semigroup +import Data.Map.Merge.Lazy +import Control.Applicative -- | A set of changes to a 'Map'. Any element may be inserted/updated or -- deleted. Insertions are represented as values wrapped in 'Just', while @@ -22,12 +24,20 @@ newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) } 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 + | Map.null p = Nothing + | otherwise + -- TODO: Can we return Nothing sometimes? This requires checking whether + -- the old and new values are the same. If those are Events or similar, + -- we're not likely to do so reliably. For other purposes, we can try + -- pointer equality, but that will only be semi-reliable if both values + -- have been forced. + = Just $! --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? + merge + (mapMaybeMissing $ \_k mv -> mv) + preserveMissing + (zipWithMaybeMatched (\_k mv v -> mv <|> Just v)) p old + -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. -- If the same key is modified by both patches, the one on the left will take From 42517f7746cb2a9184a5ce597053bfd8004ee0cf Mon Sep 17 00:00:00 2001 From: David Feuer Date: Tue, 16 Jul 2019 15:49:38 -0400 Subject: [PATCH 2/5] Add useless-deletion detection for Map If we decide to include this, we can use it for `IntMap` too. --- src/Reflex/Patch/Map.hs | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/src/Reflex/Patch/Map.hs b/src/Reflex/Patch/Map.hs index 1692d4c0..9b36568f 100644 --- a/src/Reflex/Patch/Map.hs +++ b/src/Reflex/Patch/Map.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveTraversable #-} -- | 'Patch'es on 'Map' that consist only of insertions (including overwrites) -- and deletions module Reflex.Patch.Map where @@ -25,19 +26,33 @@ instance Ord k => Patch (PatchMap k v) where type PatchTarget (PatchMap k v) = Map k v {-# INLINABLE apply #-} apply (PatchMap p) old - | Map.null p = Nothing - | otherwise - -- TODO: Can we return Nothing sometimes? This requires checking whether - -- the old and new values are the same. If those are Events or similar, - -- we're not likely to do so reliably. For other purposes, we can try - -- pointer equality, but that will only be semi-reliable if both values - -- have been forced. - = Just $! --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? - merge - (mapMaybeMissing $ \_k mv -> mv) + = changedToMaybe $ + mergeA + (traverseMaybeMissing $ \_k mv -> + case mv of + Nothing -> Unchanged Nothing + Just _ -> Changed mv) preserveMissing - (zipWithMaybeMatched (\_k mv v -> mv <|> Just v)) p old + -- 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 + 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) -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. -- If the same key is modified by both patches, the one on the left will take From 7c369fa2bed595b4cd16afe4a0466b217a6a5514 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 8 Jan 2020 18:38:53 -0500 Subject: [PATCH 3/5] Add change log entry --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index a863cded..3c4be33a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for patch +## Unreleased + +* Improve asympotics of merging + ## 0.0.0.1 * Remove unneeded dependencies From 001f1f9f9766aa36e442991bc746828ce8f21321 Mon Sep 17 00:00:00 2001 From: Owen Shepherd Date: Thu, 9 Jan 2020 14:02:48 +0000 Subject: [PATCH 4/5] rm lambdacase extension use --- src/Data/Patch/Map.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Patch/Map.hs b/src/Data/Patch/Map.hs index 2261744f..2dff98f3 100644 --- a/src/Data/Patch/Map.hs +++ b/src/Data/Patch/Map.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveTraversable #-} -- | 'Patch'es on 'Map' that consist only of insertions (including overwrites) From 7ba3e6c486a21f49b7786dbeee3c96c26d3f9455 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Sun, 23 May 2021 12:38:47 -0400 Subject: [PATCH 5/5] `liftA2` wasn't a method before --- src/Data/Patch/Map.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Patch/Map.hs b/src/Data/Patch/Map.hs index 87b181a4..62761a1c 100644 --- a/src/Data/Patch/Map.hs +++ b/src/Data/Patch/Map.hs @@ -74,10 +74,12 @@ data Changed a 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)