witherable 0.4.1 → 0.4.2
raw patch · 5 files changed
+118/−52 lines, 5 filesdep ~basedep ~base-orphansdep ~containers
Dependency ranges changed: base, base-orphans, containers, hashable, transformers, vector
Files
- CHANGELOG.md +6/−0
- src/Data/Witherable.hs +1/−1
- src/Witherable.hs +37/−41
- tests/tests.hs +71/−7
- witherable.cabal +3/−3
CHANGELOG.md view
@@ -1,3 +1,9 @@+0.4.2+-------++* Supported GHC 9.2+* Improved the instances for `vector`+ 0.4.1 ------- * Added `ordNubBy`, `hashNubBy`, `ordNubByOf`, and `hashNubByOf`.
src/Data/Witherable.hs view
@@ -96,7 +96,7 @@ -- | Reconstitute a 'Filter' from its monomorphic form. cloneFilter :: FilterLike (Peat a b) s t a b -> Filter s t a b-cloneFilter l f = (`runPeat` f) . l (\a -> Peat $ \g -> g a)+cloneFilter l f = (\a -> a `runPeat` f) . l (\a -> Peat $ \g -> g a) {-# INLINABLE cloneFilter #-} -- | 'witherOf' is actually 'id', but left for consistency.
src/Witherable.hs view
@@ -54,7 +54,9 @@ import Data.Monoid import Data.Orphans () import Data.Proxy+#if !MIN_VERSION_base(4,16,0) import Data.Semigroup (Option (..))+#endif import Data.Traversable.WithIndex import Data.Void import Prelude hiding (filter)@@ -68,11 +70,6 @@ import qualified Data.Set as Set import qualified Data.Traversable as T import qualified Data.Vector as V-import qualified Data.Vector.Generic as VG-import qualified Data.Vector.Fusion.Bundle as V.B-import qualified Data.Vector.Fusion.Bundle.Size as V.BS-import qualified Data.Vector.Fusion.Bundle.Monadic as V.MB-import qualified Data.Vector.Fusion.Stream.Monadic as V.MS import qualified GHC.Generics as Generics import qualified Prelude @@ -109,27 +106,50 @@ -- -- A definition of 'wither' must satisfy the following laws: ----- [/conservation/]--- @'wither' ('fmap' 'Just' . f) ≡ 'traverse' f@+-- [/identity/]+-- @'wither' ('Data.Functor.Identity' . Just) ≡ 'Data.Functor.Identity'@ -- -- [/composition/] -- @'Compose' . 'fmap' ('wither' f) . 'wither' g ≡ 'wither' ('Compose' . 'fmap' ('wither' f) . g)@ -- -- Parametricity implies the naturality law: ----- Whenever @t@ is an //applicative transformation// in the sense described in the--- 'Traversable' documentation,---+-- [/naturality/] -- @t . 'wither' f ≡ 'wither' (t . f)@ ----- See the @Properties.md@ file in the git distribution for some special properties of--- empty containers.+-- Where @t@ is an //applicative transformation// in the sense described in the+-- 'Traversable' documentation.+-- +-- In the relation to superclasses, these should satisfy too:+--+-- [/conservation/]+-- @'wither' ('fmap' Just . f) = 'T.traverse' f@+--+-- [/pure filter/]+-- @'wither' ('Data.Functor.Identity' . f) = 'Data.Functor.Identity' . 'mapMaybe' f@+-- +-- See the @Properties.md@ and @Laws.md@ files in the git distribution for more+-- in-depth explanation about properties of @Witherable@ containers.+--+-- The laws and restrictions are enough to+-- constrain @'wither'@ to be uniquely determined as the following default implementation.+-- +-- @wither f = fmap 'catMaybes' . 'T.traverse' f@+-- +-- If not to provide better-performing implementation,+-- it's not necessary to implement any one method of+-- @Witherable@. For example, if a type constructor @T@+-- already has instances of 'T.Traversable' and 'Filterable',+-- the next one line is sufficient to provide the @Witherable T@ instance.+--+-- > instance Witherable T class (T.Traversable t, Filterable t) => Witherable t where -- | Effectful 'mapMaybe'. -- -- @'wither' ('pure' . f) ≡ 'pure' . 'mapMaybe' f@+ -- wither :: Applicative f => (a -> f (Maybe b)) -> t a -> f (t b) wither f = fmap catMaybes . T.traverse f {-# INLINE wither #-}@@ -156,6 +176,8 @@ wither f (Just a) = f a {-# INLINABLE wither #-} +#if !MIN_VERSION_base(4,16,0)+ instance Filterable Option where mapMaybe f = (>>= Option . f) {-# INLINE mapMaybe #-}@@ -168,6 +190,8 @@ --instance FilterableWithIndex () Option --instance WitherableWithIndex () Option +#endif+ instance Monoid e => Filterable (Either e) where mapMaybe _ (Left e) = Left e mapMaybe f (Right a) = maybe (Left mempty) Right $ f a@@ -252,36 +276,8 @@ wither f = fmap V.fromList . wither f . V.toList {-# INLINABLE wither #-} - witherM f = unstreamM . bundleWitherM f . V.B.lift . VG.stream+ witherM = V.mapMaybeM {-# INLINE witherM #-}---- This is not yet in any released Vector-unstreamM :: Monad m => V.MB.Bundle m v a -> m (V.Vector a)-unstreamM s = do- xs <- V.MB.toList s- return $ VG.unstream $ V.B.unsafeFromList (V.MB.size s) xs-{-# INLINE unstreamM #-}--bundleWitherM :: Monad m => (a -> m (Maybe b)) -> V.MB.Bundle m v a -> V.MB.Bundle m v b-bundleWitherM g V.MB.Bundle {V.MB.sElems = s, V.MB.sSize = n} =- V.MB.fromStream (streamWitherM g s) (V.BS.toMax n)-{-# INLINE bundleWitherM #-}--streamWitherM :: Monad m => (a -> m (Maybe b)) -> V.MS.Stream m a -> V.MS.Stream m b-streamWitherM g (V.MS.Stream step t) = V.MS.Stream step' t- where- {-# INLINE step' #-}- step' s = do- r <- step s- case r of- V.MS.Yield x s' -> do- b <- g x- case b of- Just y -> return $ V.MS.Yield y s'- Nothing -> return $ V.MS.Skip s'- V.MS.Skip s' -> return $ V.MS.Skip s'- V.MS.Done -> return $ V.MS.Done-{-# INLINE streamWitherM #-} instance Filterable S.Seq where mapMaybe f = S.fromList . mapMaybe f . F.toList
tests/tests.hs view
@@ -1,14 +1,19 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Main (main) where +import Control.Arrow (first) import Control.Monad ((<=<))-import Control.Monad.Trans.State (runState, state)+import Control.Monad.Trans.State (State, runState, state) import Data.Hashable (Hashable) import Data.Coerce (coerce) import Data.Function (on)+import Data.Functor.Compose (Compose (..)) import Data.List (nub, nubBy)+import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable, typeRep) import Test.QuickCheck (Arbitrary (..), Fun, Property, applyFun, Function (..), functionMap, CoArbitrary, (===))@@ -36,6 +41,7 @@ , filterableLaws (Proxy @IntMap.IntMap) , filterableLaws (Proxy @(Map.Map K)) , filterableLaws (Proxy @(HashMap.HashMap K))+ , filterableLaws (Proxy @Wicked) ] , testGroup "Witherable"@@ -44,9 +50,14 @@ , witherableLaws (Proxy @(Either String)) , witherableLaws (Proxy @V.Vector) , witherableLaws (Proxy @Seq.Seq)+#if MIN_VERSION_containers(0,6,3)+ -- traverse @IntMap is broken , witherableLaws (Proxy @IntMap.IntMap)+#endif , witherableLaws (Proxy @(Map.Map K)) , witherableLaws (Proxy @(HashMap.HashMap K))+ -- Wicked is not Witherable, see https://github.com/fumieval/witherable/issues/63#issuecomment-834631975+ -- , witherableLaws (Proxy @Wicked) ] , nubProperties@@ -118,26 +129,60 @@ [ testProperty "default wither" prop_default_wither , testProperty "default witherM" prop_default_witherM , testProperty "default filterA" prop_default_filterA+ , testProperty "identity" prop_identity+ , testProperty "composition" prop_composition ] where prop_default_wither :: S -> Fun (A, S) (Maybe B, S) -> f A -> Property- prop_default_wither s0 f' xs =- runState (wither f xs) s0 === runState (fmap catMaybes (traverse f xs)) s0+ prop_default_wither s0 f' xs = equalState s0 xs+ (wither f)+ (fmap catMaybes . traverse f) where+ f :: A -> State S (Maybe B) f a = state $ \s -> applyFun f' (a, s) prop_default_witherM :: S -> Fun (A, S) (Maybe B, S) -> f A -> Property- prop_default_witherM s0 f' xs =- runState (witherM f xs) s0 === runState (wither f xs) s0+ prop_default_witherM s0 f' xs = equalState s0 xs+ (witherM f)+ (wither f) where f a = state $ \s -> applyFun f' (a, s) prop_default_filterA :: S -> Fun (A, S) (Bool, S) -> f A -> Property- prop_default_filterA s0 f' xs =- runState (filterA f xs) s0 === runState (wither (\a -> (\b -> if b then Just a else Nothing) <$> f a) xs) s0+ prop_default_filterA s0 f' xs = equalState s0 xs+ (filterA f)+ (wither (\a -> (\b -> if b then Just a else Nothing) <$> f a)) where f a = state $ \s -> applyFun f' (a, s) + prop_identity :: S -> Fun (A, S) (B, S) -> f A -> Property+ prop_identity s0 f' xs = equalState s0 xs+ (wither (fmap Just . f))+ (traverse f)+ where+ f a = state $ \s -> applyFun f' (a, s)++ prop_composition :: S -> S -> Fun (B, S) (Maybe C, S) -> Fun (A, S) (Maybe B, S) -> f A -> Property+ prop_composition s0 s1 f' g' xs = equalStateC s0 s1 xs+ (Compose . fmap (wither f) . wither g)+ (wither (Compose . fmap (wither f) . g))+ where+ f a = state $ \s -> applyFun f' (a, s)+ g b = state $ \s -> applyFun g' (b, s)++ equalState+ :: (Eq b, Show b)+ => S -> a -> (a -> State S b) -> (a -> State S b) -> Property+ equalState s0 xs f g = runState (f xs) s0 === runState (g xs) s0++ equalStateC+ :: forall a b. (Eq b, Show b)+ => S -> S -> a -> (a -> Compose (State S) (State S) b) -> (a -> Compose (State S) (State S) b) -> Property+ equalStateC s0 s1 xs f g = run (f xs) === run (g xs)+ where+ run :: Compose (State S) (State S) b -> ((b, S), S)+ run m = first (\x -> runState x s1) (runState (getCompose m) s0)+ ------------------------------------------------------------------------------- -- Nub "laws" -------------------------------------------------------------------------------@@ -207,3 +252,22 @@ instance Function S where function = functionMap coerce S++-------------------------------------------------------------------------------+-- Wicked+-------------------------------------------------------------------------------++newtype Wicked a = W [a]+ deriving (Eq, Show, Functor, Foldable, Traversable)++instance Filterable Wicked where+ -- mapMaybe f (W [a1,a2,...]) = W [b1, b2, ...]+ -- if all of [f a1, f a2, ...] are Just. Otherwise, it returns (W []).+ mapMaybe f = fromMaybe (W []) . traverse f++-- default implementation in terms of Filterable+instance Witherable Wicked++instance Arbitrary a => Arbitrary (Wicked a) where+ arbitrary = W <$> arbitrary+ shrink (W xs) = map W (shrink xs)
witherable.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: witherable-version: 0.4.1+version: 0.4.2 synopsis: filterable traversable description: A stronger variant of `traverse` which can remove elements and generalised mapMaybe, catMaybes, filter homepage: https://github.com/fumieval/witherable@@ -12,7 +12,7 @@ category: Data build-type: Simple extra-source-files: CHANGELOG.md-tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 source-repository head type: git@@ -29,7 +29,7 @@ hashable >=1.2.7.0 && <1.4, transformers >=0.5.2.0 && <0.6, unordered-containers >=0.2.12.0 && <0.3,- vector >=0.12 && <0.13,+ vector >=0.12.2.0 && <0.13, indexed-traversable >=0.1.1 && <0.2, indexed-traversable-instances >=0.1 && <0.2 hs-source-dirs: src