diff --git a/containers-tests/tests/set-properties.hs b/containers-tests/tests/set-properties.hs index 32c1aebb1..d574f4c85 100644 --- a/containers-tests/tests/set-properties.hs +++ b/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 = diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 82fd1541e..e8ba1231c 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/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) diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 5ff13fe05..dd4435e5e 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/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 diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index 6852092e1..d3ce36ed1 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/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) diff --git a/containers/src/Data/Map/Merge/Lazy.hs b/containers/src/Data/Map/Merge/Lazy.hs index 5ac059ab9..da5bfcfaf 100644 --- a/containers/src/Data/Map/Merge/Lazy.hs +++ b/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 diff --git a/containers/src/Data/Set.hs b/containers/src/Data/Set.hs index 8831c0a7b..913372525 100644 --- a/containers/src/Data/Set.hs +++ b/containers/src/Data/Set.hs @@ -135,6 +135,7 @@ module Data.Set ( -- * Filter , S.filter + , filterA , takeWhileAntitone , dropWhileAntitone , spanAntitone diff --git a/containers/src/Data/Set/Internal.hs b/containers/src/Data/Set/Internal.hs index 780caf5b7..dacfab0cb 100644 --- a/containers/src/Data/Set/Internal.hs +++ b/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)