Add whenMissing, which takes user-supplied fns

containers-tests/tests/set-properties.hs

@@ -104,6 +104,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
@@ -646,8 +647,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

@@ -185,6 +185,7 @@ module Data.IntMap.Internal (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , whenMissing
 
     -- ** Deprecated general combining function
     , mergeWithKey
@@ -1650,6 +1651,44 @@ instance 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@.
 --
@@ -2182,6 +2221,38 @@ 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 two maps.
+-- unionIntersection :: IntMap a -> IntMap a -> (IntMap a, IntMap a)
+-- unionIntersection m1 m2 =
+--   case mergeA preserveAndDropMissing preserveAndDropMissing preserveLeftMatched 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)
+--     preserveLeftMatched = '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 'dropMissing' 'dropMatched' m1 m2))
+--   where
+--     isEmpty = 'whenMissing' (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))
+-- @
+--
 -- @since 0.5.9
 mergeA
   :: (Applicative f)

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

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

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

@@ -73,6 +73,7 @@ module Data.IntMap.Merge.Strict (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , Internal.whenMissing
 
     -- ** Covariant maps for tactics
     , mapWhenMissing
@@ -99,6 +100,7 @@ import Data.IntMap.Internal
   , runWhenMatched
   , runWhenMissing
   )
+import qualified Data.IntMap.Internal as Internal
 import Data.IntMap.Strict.Internal
 import Prelude hiding (filter, map, foldl, foldr)
 

containers/src/Data/Map/Internal.hs

@@ -225,6 +225,7 @@ module Data.Map.Internal (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , whenMissing
 
     -- ** Deprecated general combining function
 
@@ -2125,6 +2126,43 @@ instance 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
@@ -2618,6 +2656,38 @@ 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 two maps.
+-- unionIntersection :: Ord k => Map k a -> Map k a -> (Map k a, Map k a)
+-- unionIntersection m1 m2 =
+--   case mergeA preserveAndDropMissing preserveAndDropMissing preserveLeftMatched 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)
+--     preserveLeftMatched = '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 'dropMissing' 'dropMatched' m1 m2))
+--   where
+--     isEmpty = 'whenMissing' (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))
+-- @
+--
 -- @since 0.5.9
 mergeA
   :: (Applicative f, Ord k)

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

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

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

@@ -236,6 +236,37 @@ merge miss1 miss2 match = \t1 t2 -> runIdentity (mergeA miss1 miss2 match t1 t2)
 -- 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)
+--
+-- -- | Partition the map according to whether the keys appear in the set.
+-- partitionKeys :: Ord k => Map k a -> Set k -> (Map k a, Map k a)
+-- partitionKeys m s =
+--   case mergeA dropAndPreserveMissing dropMissingSet preserveAndDropMatched m s of
+--     Pair m1 m2 -> (m1, m2)
+--   where
+--     dropAndPreserveMissing = whenMissing (\\_k x -> Pair Nothing (Just x)) (\\m -> Pair empty m)
+--     preserveAndDropMatched = traverseMaybeMatched (\\_k x -> Pair (Just x) Nothing)
+-- @
+--
+-- @
+-- import Data.Functor.Const (Const(..))
+-- import Data.Monoid (All(..))
+--
+-- -- | Whether the keys of the map are a subset of the keys of the set.
+-- keysAreSubsetOf :: Ord k => Map k a -> Set k -> Bool
+-- keysAreSubsetOf m s =
+--   getAll (getConst (mergeA isEmpty dropMissing 'dropMatched' m1 m2))
+--   where
+--     isEmpty = whenMissing (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))
+-- @
+--
 -- @since FIXME
 mergeA
   :: (Applicative f, Ord k)

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

@@ -57,6 +57,7 @@ module Data.Map.Merge.Set.Lazy
   , M.filterAMissing
   , M.traverseMissing
   , M.traverseMaybeMissing
+  , M.whenMissing
 
   -- *** @WhenMissingSet@ tactics
   , generateAMissingSet

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

@@ -60,6 +60,7 @@ module Data.Map.Merge.Set.Strict
   , MS.filterAMissing
   , MS.traverseMissing
   , MS.traverseMaybeMissing
+  , M.whenMissing
 
   -- *** @WhenMissingSet@ tactics
   , generateAMissingSet
@@ -71,6 +72,7 @@ module Data.Map.Merge.Set.Strict
   ) where
 
 import qualified Data.Map.Strict.Internal as MS
+import qualified Data.Map.Internal as M
 import qualified Data.Map.Merge.Set.Internal as Internal
 import Data.Map.Merge.Set.Internal (WhenMatched(..), WhenMissingSet(..))
 

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

@@ -78,6 +78,7 @@ module Data.Map.Merge.Strict (
     , traverseMaybeMissing
     , traverseMissing
     , filterAMissing
+    , Internal.whenMissing
 
     -- ** Covariant maps for tactics
     , mapWhenMissing
@@ -89,4 +90,5 @@ module Data.Map.Merge.Strict (
     , runWhenMissing
     ) where
 
+import qualified Data.Map.Internal as Internal
 import Data.Map.Strict.Internal

containers/src/Data/Set.hs

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