Add whenMissing, which takes user-supplied fns

containers-tests/tests/set-properties.hs

@@ -101,6 +101,7 @@ main = defaultMain $ testGroup "set-properties"
                    , testProperty "prop_splitRoot" prop_splitRoot
                    , testProperty "prop_partition" prop_partition
                    , testProperty "prop_filter" prop_filter
+                   , testProperty "prop_filterA" prop_filterA
                    , testProperty "prop_mapMaybe" prop_mapMaybe
                    , testProperty "takeWhileAntitone"    prop_takeWhileAntitone
                    , testProperty "dropWhileAntitone"    prop_dropWhileAntitone
@@ -622,8 +623,19 @@ prop_partition :: Set Int -> Int -> Bool
 prop_partition s i = case partition odd s of
     (s1,s2) -> all odd (toList s1) && all even (toList s2) && s == s1 `union` s2
 
-prop_filter :: Set Int -> Int -> Bool
-prop_filter s i = partition odd s == (filter odd s, filter even s)
+prop_filter :: Set Int -> Fun Int Bool -> Property
+prop_filter s f =
+  valid s' .&&. toList s' === List.filter (applyFun f) (toList s)
+  where
+    s' = filter (applyFun f) s
+
+prop_filterA :: Set Int -> Fun Int Bool -> Property
+prop_filterA s f =
+  valid s' .&&.
+  xs === toList s .&&.
+  toList s' === List.filter (applyFun f) (toList s)
+  where
+    (xs, s') = filterA (\x -> ([x], applyFun f x)) s
 
 prop_mapMaybe :: Fun Int (Maybe Int) -> Set Int -> Property
 prop_mapMaybe f s =

containers/src/Data/IntMap/Internal.hs

@@ -187,6 +187,7 @@ module Data.IntMap.Internal (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , whenMissing
 
     -- ** Deprecated general combining function
     , mergeWithKey
@@ -1629,6 +1630,44 @@ instance (Applicative f, Monad f) => Monad (WhenMissing f x) where
         Just r  -> missingKey (f r) k x
   {-# INLINE (>>=) #-}
 
+-- | Create a @WhenMissing@ from two functions.
+--
+-- @whenMissing@ must be called with two functions @f@ and @g@ such that
+-- @g = 'traverseMaybeWithKey' f@. @g@ may be a more efficient way of applying
+-- @f@ to all key-value pairs in an @IntMap@.
+--
+-- __Warning__: It is the caller's responsibility to ensure the above property.
+--
+-- === __Examples__
+--
+-- @
+-- preserveMissing :: Applicative f => WhenMissing f x x
+-- preserveMissing = whenMissing f g
+--   where
+--     f _k x = pure (Just x)
+--     g m = pure m
+--     -- Note that this satisfies g = traverseMaybeWithKey f
+-- @
+--
+-- @
+-- import Data.Functor.Const (Const(..))
+-- import Data.Monoid (All(..))
+--
+-- -- For a usage of this, see examples on mergeA
+-- isEmpty :: WhenMissing (Const All) x y
+-- isEmpty = whenMissing f g
+--   where
+--     f _k _x = Const (All False)
+--     g m = Const (All (null m))
+--     -- Note that this satisfies g = traverseMaybeWithKey f
+-- @
+--
+-- @since FIXME
+whenMissing
+  :: (Key -> x -> f (Maybe y))
+  -> (IntMap x -> f (IntMap y))
+  -> WhenMissing f x y
+whenMissing = flip WhenMissing
 
 -- | Map covariantly over a @'WhenMissing' f x@.
 --
@@ -2155,6 +2194,41 @@ merge g1 g2 f = \m1 m2 ->
 -- site. To prevent excessive inlining, you should generally only use
 -- 'mergeA' to define custom combining functions.
 --
+-- === __Examples__
+--
+-- @
+-- data Pair a = Pair !a !a deriving Functor
+--
+-- instance Applicative Pair where
+--    pure x = Pair x x
+--    liftA2 f (Pair x1 y1) (Pair x2 y2) = Pair (f x1 x2) (f y1 y2)
+--
+-- -- | Calculate the left-biased union and intersection of the two maps.
+-- unionIntersection :: IntMap a -> IntMap a -> (IntMap a, IntMap a)
+-- unionIntersection m1 m2 =
+--   case mergeA preserveAndDropMissing preserveAndDropMissing preserveAndPreserveMatched m1 m2 of
+--     Pair mu mi -> (mu, mi)
+--   where
+--     -- use Pair to build the union and intersection together
+--     preserveAndDropMissing = 'whenMissing' (\\_k x -> Pair (Just x) Nothing) (\\m -> Pair m empty)
+--     preserveAndPreserveMatched = 'zipWithMaybeAMatched' (\\_k x1 _x2 -> Pair (Just x1) (Just x1))
+-- @
+--
+-- @
+-- import Data.Functor.Const (Const(..))
+-- import Data.Monoid (All(..))
+--
+-- -- | Whether the keys of the first map are a subset of the keys of the second map.
+-- keysAreSubsetOf :: IntMap a -> IntMap b -> Bool
+-- keysAreSubsetOf m1 m2 =
+--   getAll (getConst (mergeA isEmpty alwaysTrueMissing alwaysTrueMatched m1 m2))
+--   where
+--     -- the result is True if there are no keys occurring only in the first map
+--     isEmpty = 'whenMissing' (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))
+--     alwaysTrueMissing = 'whenMissing' (\\_k _x -> Const (All True)) (\\_m -> Const (All True))
+--     alwaysTrueMatched = 'zipWithAMatched' (\\_k _x1 _x2 -> Const (All True))
+-- @
+--
 -- @since 0.5.9
 mergeA
   :: (Applicative f)

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

@@ -73,6 +73,7 @@ module Data.IntMap.Merge.Lazy (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , whenMissing
 
     -- *** Covariant maps for tactics
     , mapWhenMissing

containers/src/Data/Map/Internal.hs

@@ -230,6 +230,7 @@ module Data.Map.Internal (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , whenMissing
 
     -- ** Deprecated general combining function
 
@@ -2193,6 +2194,43 @@ instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where
            Just r -> missingKey (f r) k x
   {-# INLINE (>>=) #-}
 
+-- | Create a @WhenMissing@ from two functions.
+--
+-- @whenMissing@ must be called with two functions @f@ and @g@ such that
+-- @g = 'traverseMaybeWithKey' f@. @g@ may be a more efficient way of applying
+-- @f@ to all key-value pairs in a @Map@.
+--
+-- __Warning__: It is the caller's responsibility to ensure the above property.
+--
+-- === __Examples__
+--
+-- @
+-- preserveMissing :: Applicative f => WhenMissing f k x x
+-- preserveMissing = whenMissing f g
+--   where
+--     f _k x = pure (Just x)
+--     g m = pure m
+--     -- Note that this satisfies g = traverseMaybeWithKey f
+-- @
+--
+-- @
+-- import Data.Functor.Const (Const(..))
+-- import Data.Monoid (All(..))
+--
+-- -- For a usage of this, see examples on mergeA
+-- isEmpty :: WhenMissing (Const All) k x y
+-- isEmpty = whenMissing f g
+--   where
+--     f _k _x = Const (All False)
+--     g m = Const (All (null m))
+--     -- Note that this satisfies g = traverseMaybeWithKey f
+-- @
+--
+-- @since FIXME
+whenMissing
+  :: (k -> x -> f (Maybe y)) -> (Map k x -> f (Map k y)) -> WhenMissing f k x y
+whenMissing = flip WhenMissing
+
 -- | Map covariantly over a @'WhenMissing' f k x@.
 --
 -- @since 0.5.9
@@ -2679,6 +2717,41 @@ merge g1 g2 f = \m1 m2 -> runIdentity $
 -- site. To prevent excessive inlining, you should generally only use
 -- 'mergeA' to define custom combining functions.
 --
+-- === __Examples__
+--
+-- @
+-- data Pair a = Pair !a !a deriving Functor
+--
+-- instance Applicative Pair where
+--    pure x = Pair x x
+--    liftA2 f (Pair x1 y1) (Pair x2 y2) = Pair (f x1 x2) (f y1 y2)
+--
+-- -- | Calculate the left-biased union and intersection of the two maps.
+-- unionIntersection :: Ord k => Map k a -> Map k a -> (Map k a, Map k a)
+-- unionIntersection m1 m2 =
+--   case mergeA preserveAndDropMissing preserveAndDropMissing preserveAndPreserveMatched m1 m2 of
+--     Pair mu mi -> (mu, mi)
+--   where
+--     -- use Pair to build the union and intersection together
+--     preserveAndDropMissing = 'whenMissing' (\\_k x -> Pair (Just x) Nothing) (\\m -> Pair m empty)
+--     preserveAndPreserveMatched = 'zipWithMaybeAMatched' (\\_k x1 _x2 -> Pair (Just x1) (Just x1))
+-- @
+--
+-- @
+-- import Data.Functor.Const (Const(..))
+-- import Data.Monoid (All(..))
+--
+-- -- | Whether the keys of the first map are a subset of the keys of the second map.
+-- keysAreSubsetOf :: Ord k => Map k a -> Map k b -> Bool
+-- keysAreSubsetOf m1 m2 =
+--   getAll (getConst (mergeA isEmpty alwaysTrueMissing alwaysTrueMatched m1 m2))
+--   where
+--     -- the result is True if there are no keys occurring only in the first map
+--     isEmpty = 'whenMissing' (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))
+--     alwaysTrueMissing = 'whenMissing' (\\_k _x -> Const (All True)) (\\_m -> Const (All True))
+--     alwaysTrueMatched = 'zipWithAMatched' (\\_k _x1 _x2 -> Const (All True))
+-- @
+--
 -- @since 0.5.9
 mergeA
   :: (Applicative f, Ord k)

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

@@ -73,6 +73,7 @@ module Data.Map.Merge.Lazy (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , whenMissing
 
     -- *** Covariant maps for tactics
     , mapWhenMissing

containers/src/Data/Set.hs

@@ -135,6 +135,7 @@ module Data.Set (
 
             -- * Filter
             , S.filter
+            , filterA
             , takeWhileAntitone
             , dropWhileAntitone
             , spanAntitone

containers/src/Data/Set/Internal.hs

@@ -157,6 +157,7 @@ module Data.Set.Internal (
 
             -- * Filter
             , filter
+            , filterA
             , takeWhileAntitone
             , dropWhileAntitone
             , spanAntitone
@@ -227,6 +228,7 @@ module Data.Set.Internal (
             , preserveMissing
             , filterMissing
             , filterAMissing
+            , whenMissing
             , runWhenMissing
             , WhenMatched(..)
             , SimpleWhenMatched
@@ -958,7 +960,7 @@ symmetricDifference (Bin _ x l1 r1) t2
 {--------------------------------------------------------------------
   Filter and partition
 --------------------------------------------------------------------}
--- | \(O(n)\). Filter all elements that satisfy the predicate.
+-- | \(O(n)\). Keep all elements that satisfy the predicate.
 filter :: (a -> Bool) -> Set a -> Set a
 filter _ Tip = Tip
 filter p t@(Bin _ x l r)
@@ -970,6 +972,9 @@ filter p t@(Bin _ x l r)
       !l' = filter p l
       !r' = filter p r
 
+-- | \(O(n)\). Keep all elements that satisfy the Applicative predicate.
+--
+-- @since FIXME
 filterA :: Applicative f => (a -> f Bool) -> Set a -> f (Set a)
 filterA p = go
   where
@@ -2263,6 +2268,42 @@ filterMatched f = WhenMatched (pure . f)
 filterAMatched :: (a -> f Bool) -> WhenMatched f a
 filterAMatched = WhenMatched
 
+-- | Create a @WhenMissing@ from two functions.
+--
+-- @whenMissing@ must be called with two functions @f@ and @g@ such that
+-- @g = 'filterA' f@. @g@ may be a more efficient way of applying @f@ to all
+-- elements in a @Set@.
+--
+-- __Warning__: It is the caller's responsibility to ensure the above property.
+--
+-- === __Examples__
+--
+-- @
+-- preserveMissing :: Applicative f => WhenMissing f a
+-- preserveMissing = whenMissing f g
+--   where
+--     f _x = pure True
+--     g s = pure s
+--     -- Note that this satisfies g = filterA f
+-- @
+--
+-- @
+-- import Data.Functor.Const (Const(..))
+-- import Data.Monoid (All(..))
+--
+-- -- For a usage of this, see examples on mergeA
+-- isEmpty :: WhenMissing (Const All) a
+-- isEmpty = whenMissing f g
+--   where
+--     f _x = Const (All False)
+--     g s = Const (All (null s))
+--     -- Note that this satisfies g = filterA f
+-- @
+--
+-- @since FIXME
+whenMissing :: (a -> f Bool) -> (Set a -> f (Set a)) -> WhenMissing f a
+whenMissing = flip WhenMissing
+
 -- | Drop all the elements that are missing from the other set.
 --
 -- @
@@ -2420,6 +2461,41 @@ merge g1 g2 f = \s1 s2 -> runIdentity (mergeA g1 g2 f s1 s2)
 -- site. To prevent excessive inlining, you should generally only use
 -- 'mergeA' to define custom combining functions.
 --
+-- === __Examples__
+--
+-- @
+-- data Pair a = Pair !a !a deriving Functor
+--
+-- instance Applicative Pair where
+--    pure x = Pair x x
+--    liftA2 f (Pair x1 y1) (Pair x2 y2) = Pair (f x1 x2) (f y1 y2)
+--
+-- -- | Calculate the left-biased union and intersection of the two sets.
+-- unionIntersection :: Ord a => Set a -> Set a -> (Set a, Set a)
+-- unionIntersection m1 m2 =
+--   case mergeA preserveAndDropMissing preserveAndDropMissing preserveAndPreserveMatched m1 m2 of
+--     Pair mu mi -> (mu, mi)
+--   where
+--     -- use Pair to build the union and intersection together
+--     preserveAndDropMissing = 'whenMissing' (\\_x -> Pair True False) (\\s -> Pair s empty)
+--     preserveAndPreserveMatched = 'filterAMatched' (\\_x -> Pair True True)
+-- @
+--
+-- @
+-- import Data.Functor.Const (Const(..))
+-- import Data.Monoid (All(..))
+--
+-- -- | Whether the first set is a subset of the second set.
+-- isSubsetOf :: Ord a => Set a -> Set a -> Bool
+-- isSubsetOf m1 m2 =
+--   getAll (getConst (mergeA isEmpty alwaysTrueMissing alwaysTrueMatched m1 m2))
+--   where
+--     -- the result is True if there are no elements occurring only in the first set
+--     isEmpty = 'whenMissing' (\\_x -> Const (All False)) (\\s -> Const (All (null s)))
+--     alwaysTrueMissing = 'whenMissing' (\\_x -> Const (All True)) (\\_s -> Const (All True))
+--     alwaysTrueMatched = 'filterAMatched' (\\_x -> Const (All True))
+-- @
+--
 -- @since FIXME
 mergeA
   :: (Applicative f, Ord a)