Add {drop,preserve}Matched merge strategies (#1240)

dropMatched is added for Map, IntMap and Set. preserveMatched is added
only for Set.

Note that unlike dropMissing and preserveMissing, dropMatched
and preserveMatched are simply for convenience and do not offer a
performance advantage over mapMaybeMatched/filterMatched.

Author: meooow25

containers-tests/tests/intmap-properties.hs

@@ -1461,6 +1461,7 @@ prop_merge miss1 miss2 match m1 m2 =
       MapMissing f -> mapMissing (applyFun2 f)
       MapMaybeMissing f -> mapMaybeMissing (applyFun2 f)
     whenMatched spec = case spec of
+      DropMatched -> dropMatched
       ZipWithMatched f -> zipWithMatched (applyFun3 f)
       ZipWithMaybeMatched f -> zipWithMaybeMatched (applyFun3 f)
 
@@ -1504,6 +1505,7 @@ prop_mergeA miss1 miss2 match m1 m2 =
       MapMissing f -> traverseMissing (\k x -> ([k], applyFun2 f k x))
       MapMaybeMissing f -> traverseMaybeMissing (\k x -> ([k], applyFun2 f k x))
     whenMatched spec = case spec of
+      DropMatched -> dropMatched
       ZipWithMatched f -> zipWithAMatched (\k x y -> ([k], applyFun3 f k x y))
       ZipWithMaybeMatched f -> zipWithMaybeAMatched (\k x y -> ([k], applyFun3 f k x y))
 
@@ -1526,14 +1528,16 @@ instance (Arbitrary a, CoArbitrary a, Function a)
     ]
 
 data WhenMatchedSpec a
-  = ZipWithMatched (Fun (Int, a, a) a)
+  = DropMatched
+  | ZipWithMatched (Fun (Int, a, a) a)
   | ZipWithMaybeMatched (Fun (Int, a, a) (Maybe a))
   deriving Show
 
 instance (Arbitrary a, CoArbitrary a, Function a)
   => Arbitrary (WhenMatchedSpec a) where
   arbitrary = oneof
-    [ ZipWithMatched <$> arbitrary
+    [ pure DropMatched
+    , ZipWithMatched <$> arbitrary
     , ZipWithMaybeMatched <$> arbitrary
     ]
 

containers-tests/tests/map-properties.hs

@@ -1318,6 +1318,7 @@ prop_merge miss1 miss2 match m1 m2 =
       MapMissing f -> mapMissing (applyFun2 f)
       MapMaybeMissing f -> mapMaybeMissing (applyFun2 f)
     whenMatched spec = case spec of
+      DropMatched -> dropMatched
       ZipWithMatched f -> zipWithMatched (applyFun3 f)
       ZipWithMaybeMatched f -> zipWithMaybeMatched (applyFun3 f)
 
@@ -1361,6 +1362,7 @@ prop_mergeA miss1 miss2 match m1 m2 =
       MapMissing f -> traverseMissing (\k x -> ([k], applyFun2 f k x))
       MapMaybeMissing f -> traverseMaybeMissing (\k x -> ([k], applyFun2 f k x))
     whenMatched spec = case spec of
+      DropMatched -> dropMatched
       ZipWithMatched f -> zipWithAMatched (\k x y -> ([k], applyFun3 f k x y))
       ZipWithMaybeMatched f -> zipWithMaybeAMatched (\k x y -> ([k], applyFun3 f k x y))
 
@@ -1383,14 +1385,16 @@ instance (Arbitrary a, CoArbitrary a, Function a, CoArbitrary k, Function k)
     ]
 
 data WhenMatchedSpec k a
-  = ZipWithMatched (Fun (k, a, a) a)
+  = DropMatched
+  | ZipWithMatched (Fun (k, a, a) a)
   | ZipWithMaybeMatched (Fun (k, a, a) (Maybe a))
   deriving Show
 
 instance (Arbitrary a, CoArbitrary a, Function a, CoArbitrary k, Function k)
   => Arbitrary (WhenMatchedSpec k a) where
   arbitrary = oneof
-    [ ZipWithMatched <$> arbitrary
+    [ pure DropMatched
+    , ZipWithMatched <$> arbitrary
     , ZipWithMaybeMatched <$> arbitrary
     ]
 
@@ -1429,6 +1433,7 @@ prop_mergeMapSet miss1 miss2 match m1 s2 =
       GenerateMissingMapSet f -> MergeSet.generateMissingSet (applyFun f)
       GenerateMaybeMissingMapSet f -> MergeSet.generateMaybeMissingSet (applyFun f)
     whenMatched spec = case spec of
+      DropMatchedMapSet -> MergeSet.dropMatched
       FilterMatchedMapSet f -> MergeSet.filterMatched (applyFun2 f)
       MapMatchedMapSet f -> MergeSet.mapMatched (applyFun2 f)
       MapMaybeMatchedMapSet f -> MergeSet.mapMaybeMatched (applyFun2 f)
@@ -1477,6 +1482,7 @@ prop_mergeAMapSet miss1 miss2 match m1 s2 =
       GenerateMissingMapSet f -> MergeSet.generateAMissingSet (\k -> ([k], applyFun f k))
       GenerateMaybeMissingMapSet f -> MergeSet.generateMaybeAMissingSet (\k -> ([k], applyFun f k))
     whenMatched spec = case spec of
+      DropMatchedMapSet -> MergeSet.dropMatched
       FilterMatchedMapSet f -> MergeSet.filterAMatched (\k x -> ([k], applyFun2 f k x))
       MapMatchedMapSet f -> MergeSet.traverseMatched (\k x -> ([k], applyFun2 f k x))
       MapMaybeMatchedMapSet f -> MergeSet.traverseMaybeMatched (\k x -> ([k], applyFun2 f k x))
@@ -1500,19 +1506,22 @@ instance (Arbitrary a, CoArbitrary a, Function a, CoArbitrary k, Function k)
     GenerateMaybeMissingMapSet f -> GenerateMaybeMissingMapSet <$> shrink f
 
 data WhenMatchedMapSetSpec k a
-  = FilterMatchedMapSet (Fun (k, a) Bool)
+  = DropMatchedMapSet
+  | FilterMatchedMapSet (Fun (k, a) Bool)
   | MapMatchedMapSet (Fun (k, a) a)
   | MapMaybeMatchedMapSet (Fun (k, a) (Maybe a))
   deriving Show
 
 instance (Arbitrary a, CoArbitrary a, Function a, CoArbitrary k, Function k)
   => Arbitrary (WhenMatchedMapSetSpec k a) where
   arbitrary = oneof
-    [ FilterMatchedMapSet <$> arbitrary
+    [ pure DropMatchedMapSet
+    , FilterMatchedMapSet <$> arbitrary
     , MapMatchedMapSet <$> arbitrary
     , MapMaybeMatchedMapSet <$> arbitrary
     ]
   shrink spec = case spec of
+    DropMatchedMapSet -> []
     FilterMatchedMapSet f -> FilterMatchedMapSet <$> shrink f
     MapMatchedMapSet f -> MapMatchedMapSet <$> shrink f
     MapMaybeMatchedMapSet f -> MapMaybeMatchedMapSet <$> shrink f

containers-tests/tests/set-properties.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 import qualified Data.IntSet as IntSet
 import Data.Coerce (coerce)
 import Data.List (nub, sort, sortBy)
@@ -809,7 +808,10 @@ prop_merge miss1 miss2 match s1 s2 =
       PreserveMissing -> preserveMissing
       FilterMissing f -> filterMissing (applyFun f)
 
-    toSimpleWhenMatched (FilterMatched f) = filterMatched (applyFun f)
+    toSimpleWhenMatched spec = case spec of
+      DropMatched -> dropMatched
+      PreserveMatched -> preserveMatched
+      FilterMatched f -> filterMatched (applyFun f)
 
 prop_mergeA
   :: WhenMissingSpec Int
@@ -841,16 +843,18 @@ prop_mergeA miss1 miss2 match s1 s2 =
       PreserveMissing -> preserveMissing
       FilterMissing f -> filterAMissing (\x -> ([x], applyFun f x))
 
-    toWhenMatched (FilterMatched f) = filterAMatched (\x -> ([x], applyFun f x))
+    toWhenMatched spec = case spec of
+      DropMatched -> dropMatched
+      PreserveMatched -> preserveMatched
+      FilterMatched f -> filterAMatched (\x -> ([x], applyFun f x))
 
 data WhenMissingSpec a
   = DropMissing
   | PreserveMissing
   | FilterMissing (Fun a Bool)
   deriving Show
 
-instance (Arbitrary a, CoArbitrary a, Function a)
-  => Arbitrary (WhenMissingSpec a) where
+instance (CoArbitrary a, Function a) => Arbitrary (WhenMissingSpec a) where
   arbitrary = oneof
     [ pure DropMissing
     , pure PreserveMissing
@@ -861,5 +865,19 @@ instance (Arbitrary a, CoArbitrary a, Function a)
     PreserveMissing -> []
     FilterMissing f -> FilterMissing <$> shrink f
 
-newtype WhenMatchedSpec a = FilterMatched (Fun a Bool)
-  deriving (Show, Arbitrary)
+data WhenMatchedSpec a
+  = DropMatched
+  | PreserveMatched
+  | FilterMatched (Fun a Bool)
+  deriving Show
+
+instance (CoArbitrary a, Function a) => Arbitrary (WhenMatchedSpec a) where
+  arbitrary = oneof
+    [ pure DropMatched
+    , pure PreserveMatched
+    , FilterMatched <$> arbitrary
+    ]
+  shrink spec = case spec of
+    DropMatched -> []
+    PreserveMatched -> []
+    FilterMatched f -> FilterMatched <$> shrink f

containers/src/Data/IntMap/Internal.hs

@@ -158,6 +158,7 @@ module Data.IntMap.Internal (
     , runWhenMissing
     , merge
     -- *** @WhenMatched@ tactics
+    , dropMatched
     , zipWithMaybeMatched
     , zipWithMatched
     -- *** @WhenMissing@ tactics
@@ -1831,6 +1832,12 @@ mapWhenMatched f (WhenMatched g) =
 -- @since 0.5.9
 type SimpleWhenMatched = WhenMatched Identity
 
+-- | When a key is found in both maps, drop the key and values.
+--
+-- @since FIXME
+dropMatched :: Applicative f => WhenMatched f x y z
+dropMatched = WhenMatched (\_ _ _ -> pure Nothing)
+{-# INLINE dropMatched #-}
 
 -- | When a key is found in both maps, apply a function to the key
 -- and values and use the result in the merged map.

containers/src/Data/IntMap/Merge/Lazy.hs

@@ -40,6 +40,7 @@ module Data.IntMap.Merge.Lazy (
     , merge
 
     -- *** @WhenMatched@ tactics
+    , dropMatched
     , zipWithMaybeMatched
     , zipWithMatched
 

containers/src/Data/IntMap/Merge/Strict.hs

@@ -41,6 +41,7 @@ module Data.IntMap.Merge.Strict (
     , merge
 
     -- *** @WhenMatched@ tactics
+    , dropMatched
     , zipWithMaybeMatched
     , zipWithMatched
 
@@ -94,6 +95,7 @@ import Data.IntMap.Internal
   , WhenMatched (..)
   , mergeA
   , filterAMissing
+  , dropMatched
   , runWhenMatched
   , runWhenMissing
   )

containers/src/Data/Map/Internal.hs

@@ -195,6 +195,7 @@ module Data.Map.Internal (
     , runWhenMissing
     , merge
     -- *** @WhenMatched@ tactics
+    , dropMatched
     , zipWithMaybeMatched
     , zipWithMatched
     -- *** @WhenMissing@ tactics
@@ -2277,6 +2278,13 @@ mapWhenMatched f (WhenMatched g) = WhenMatched $ \k x y -> fmap (fmap f) (g k x
 -- @since 0.5.9
 type SimpleWhenMatched = WhenMatched Identity
 
+-- | When a key is found in both maps, drop the key and values.
+--
+-- @since FIXME
+dropMatched :: Applicative f => WhenMatched f k x y z
+dropMatched = WhenMatched (\_ _ _ -> pure Nothing)
+{-# INLINE dropMatched #-}
+
 -- | When a key is found in both maps, apply a function to the
 -- key and values and use the result in the merged map.
 --

containers/src/Data/Map/Merge/Lazy.hs

@@ -40,6 +40,7 @@ module Data.Map.Merge.Lazy (
     , merge
 
     -- *** @WhenMatched@ tactics
+    , dropMatched
     , zipWithMaybeMatched
     , zipWithMatched
 

containers/src/Data/Map/Merge/Set/Internal.hs

@@ -23,6 +23,7 @@
 module Data.Map.Merge.Set.Internal
   ( WhenMatched(..)
   , SimpleWhenMatched
+  , dropMatched
   , filterMatched
   , filterAMatched
 
@@ -70,6 +71,13 @@ runWhenMatched = matchedKey
 -- @since FIXME
 type SimpleWhenMatched = WhenMatched Identity
 
+-- | When a key is found in both the map and the set, drop the key and value.
+--
+-- @since FIXME
+dropMatched :: Applicative f => WhenMatched f k a b
+dropMatched = WhenMatched (\_ _ -> pure Nothing)
+{-# INLINE dropMatched #-}
+
 -- | When a key is found in both the map and the set, apply a function to the
 -- key and the value in the map and keep the value in the merged map if the
 -- result is @True@.

containers/src/Data/Map/Merge/Set/Lazy.hs

@@ -23,6 +23,7 @@ module Data.Map.Merge.Set.Lazy
   , Internal.merge
 
   -- *** @WhenMatched@ tactics
+  , Internal.dropMatched
   , Internal.filterMatched
   , mapMatched
   , mapMaybeMatched