witherable 0.3.5 → 0.5
raw patch · 5 files changed
Files
- CHANGELOG.md +27/−0
- src/Data/Witherable.hs +0/−398
- src/Witherable.hs +753/−0
- tests/tests.hs +273/−0
- witherable.cabal +35/−22
CHANGELOG.md view
@@ -1,3 +1,30 @@+0.5+---++* `FilterableWithIndex` is a superclass of `WitherableWithIndex`.+* Remove deprecated `Data.Witherable` module. Use `Witherable` module.+* Relax `FilterableWithIndex` composition law so list-like instances are lawful.+* Add `drain :: f a -> f b` method (with default implementation `drain = mapMaybe (Const Nothing)`) to the `Filterable`.++0.4.2+-------++* Supported GHC 9.2+* Improved the instances for `vector`++0.4.1+-------+* Added `ordNubBy`, `hashNubBy`, `ordNubByOf`, and `hashNubByOf`.+* Use `alterF` for nub-function implementations+* Implement `witherM` in `Witherable Vector` instance.+* Mark modules as Trustworthy+* `ordNub` and `hashNub` are productive, start to produce results immediately and work for infinite lists.++0.4+-------+* `FilterableWithIndex` and `WitherableWithIndex` are now subclasses of the ones from [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable)+* Removed the orphan instances for `MonoidalMap`+ 0.3.5 -------
− src/Data/Witherable.hs
@@ -1,398 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE EmptyCase #-}--------------------------------------------------------------------------------- |--- Module : Data.Witherable--- Copyright : (c) Fumiaki Kinoshita 2015--- License : BSD3------ Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : provisional--- Portability : non-portable----------------------------------------------------------------------------------module Data.Witherable- ( Filterable(..)- , (<$?>)- , (<&?>)- , Witherable(..)- , ordNub- , hashNub- , forMaybe- -- * Indexed variants- , FilterableWithIndex(..)- , WitherableWithIndex(..)- -- * Generalization- , WitherLike, Wither, WitherLike', Wither'- , FilterLike, Filter, FilterLike', Filter'- , witherOf- , forMaybeOf- , mapMaybeOf- , catMaybesOf- , filterAOf- , filterOf- , ordNubOf- , hashNubOf- -- * Cloning- , cloneFilter- , Peat(..)- -- * Wrapper- , WrappedFoldable(..)- )--where-import qualified Control.Lens as Lens-import Data.Witherable.Class-import qualified Data.IntMap.Lazy as IM-import qualified Data.Map.Lazy as M-import qualified Data.Map.Monoidal as MM-import qualified Data.Sequence as S-import qualified Data.Vector as V-import qualified Data.HashMap.Lazy as HM-import qualified Data.Set as Set-import qualified Data.HashSet as HSet-import Control.Applicative-import qualified Data.Traversable as T-import qualified Data.Foldable as F-import Data.Functor.Compose-import Data.Functor.Product as P-import Data.Functor.Sum as Sum-import Control.Monad.Trans.Identity-import Data.Hashable-import Data.Functor.Identity-import Data.Functor.Reverse (Reverse (..))-import Control.Applicative.Backwards (Backwards (..))-import Control.Monad.Trans.State.Strict-import Data.Monoid-import Data.Orphans ()-import Data.Proxy-import Data.Void-import Data.Coerce (coerce)-import Prelude hiding (filter)--type Filter s t a b = Wither s t a b-{-# DEPRECATED Filter "Use Wither instead" #-}-type FilterLike f s t a b = WitherLike f s t a b-{-# DEPRECATED FilterLike "Use WitherLike instead" #-}-type Filter' s a = Wither' s a-{-# DEPRECATED Filter' "Use Filter' instead" #-}-type FilterLike' f s a = WitherLike' f s a-{-# DEPRECATED FilterLike' "Use WitherLike' instead" #-}---- | This type allows combinators to take a 'Filter' specializing the parameter @f@.-type WitherLike f s t a b = (a -> f (Maybe b)) -> s -> f t---- | A 'Wither' is like a <http://hackage.haskell.org/package/lens-4.13.2.1/docs/Control-Lens-Type.html#t:Traversal Traversal>,--- but you can also remove targets.-type Wither s t a b = forall f. Applicative f => WitherLike f s t a b---- | A simple 'WitherLike'.-type WitherLike' f s a = WitherLike f s s a a---- | A simple 'Wither'.-type Wither' s a = forall f. Applicative f => WitherLike' f s a---- | This is used to characterize and clone a 'Filter'.--- Since @FilterLike (Peat a b) s t a b@ is monomorphic, it can be used to store a filter in a container.-newtype Peat a b t = Peat { runPeat :: forall f. Applicative f => (a -> f (Maybe b)) -> f t }--instance Functor (Peat a b) where- fmap f (Peat k) = Peat (fmap f . k)- {-# INLINE fmap #-}--instance Applicative (Peat a b) where- pure a = Peat $ const (pure a)- {-# INLINE pure #-}- Peat f <*> Peat g = Peat $ \h -> f h <*> g h- {-# INLINE (<*>) #-}-#if MIN_VERSION_base(4,10,0)- liftA2 f (Peat xs) (Peat ys) = Peat $ \h -> liftA2 f (xs h) (ys h)- {-# INLINE liftA2 #-}-#endif---- | 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)-{-# INLINABLE cloneFilter #-}---- | 'witherOf' is actually 'id', but left for consistency.-witherOf :: FilterLike f s t a b -> (a -> f (Maybe b)) -> s -> f t-witherOf = id-{-# INLINE witherOf #-}---- | @'forMaybeOf' ≡ 'flip'@-forMaybeOf :: FilterLike f s t a b -> s -> (a -> f (Maybe b)) -> f t-forMaybeOf = flip-{-# INLINE forMaybeOf #-}---- In case mapMaybeOf or filterOf is called with a function of--- unknown arity, we don't want to slow things down to raise--- its arity.-idDot :: (a -> b) -> a -> Identity b-idDot = coerce---- | 'mapMaybe' through a filter.-mapMaybeOf :: FilterLike Identity s t a b -> (a -> Maybe b) -> s -> t-mapMaybeOf w f = runIdentity . w (idDot f)-{-# INLINE mapMaybeOf #-}---- | 'catMaybes' through a filter.-catMaybesOf :: FilterLike Identity s t (Maybe a) a -> s -> t-catMaybesOf w = mapMaybeOf w id-{-# INLINE catMaybesOf #-}---- | 'filterA' through a filter.-filterAOf :: Functor f => FilterLike' f s a -> (a -> f Bool) -> s -> f s-filterAOf w f = w $ \a -> (\b -> if b then Just a else Nothing) <$> f a-{-# INLINABLE filterAOf #-}---- | Filter each element of a structure targeted by a 'Filter'.-filterOf :: FilterLike' Identity s a -> (a -> Bool) -> s -> s-filterOf w f = runIdentity . filterAOf w (idDot f)-{-# INLINE filterOf #-}---- | An infix alias for 'mapMaybe'. The name of the operator alludes--- to '<$>', and has the same fixity.------ @since 0.3.1-(<$?>) :: Filterable f => (a -> Maybe b) -> f a -> f b-(<$?>) = mapMaybe-infixl 4 <$?>---- | Flipped version of '<$?>', the 'Filterable' version of--- 'Data.Functor.<&>'. It has the same fixity as 'Data.Functor.<&>'.------ @--- ('<&?>') = 'flip' 'mapMaybe'--- @------ @since 0.3.1-(<&?>) :: Filterable f => f a -> (a -> Maybe b) -> f b-as <&?> f = mapMaybe f as-infixl 1 <&?>---- | Indexed variant of 'Filterable'.-class (Lens.FunctorWithIndex i t, Filterable t) => FilterableWithIndex i t | t -> i where- imapMaybe :: (i -> a -> Maybe b) -> t a -> t b- imapMaybe f = catMaybes . Lens.imap f- {-# INLINE imapMaybe #-}-- -- | @'ifilter' f . 'ifilter' g ≡ ifilter (\i -> 'liftA2' ('&&') (f i) (g i))@- ifilter :: (i -> a -> Bool) -> t a -> t a- ifilter f = imapMaybe $ \i a -> if f i a then Just a else Nothing- {-# INLINE ifilter #-}---- | @'forMaybe' = 'flip' 'wither'@-forMaybe :: (Witherable t, Applicative f) => t a -> (a -> f (Maybe b)) -> f (t b)-forMaybe = flip wither-{-# INLINE forMaybe #-}---- | Indexed variant of 'Witherable'.-class (Lens.TraversableWithIndex i t, Witherable t) => WitherableWithIndex i t | t -> i where- -- | Effectful 'imapMaybe'.- --- -- @'iwither' (\ i -> 'pure' . f i) ≡ 'pure' . 'imapMaybe' f@- iwither :: (Applicative f) => (i -> a -> f (Maybe b)) -> t a -> f (t b)- iwither f = fmap catMaybes . Lens.itraverse f-- -- | @Monadic variant of 'wither'. This may have more efficient implementation.@- iwitherM :: (Monad m) => (i -> a -> m (Maybe b)) -> t a -> m (t b)- iwitherM = iwither-- ifilterA :: (Applicative f) => (i -> a -> f Bool) -> t a -> f (t a)- ifilterA f = iwither (\i a -> (\b -> if b then Just a else Nothing) <$> f i a)---- | Remove the duplicate elements through a filter.-ordNubOf :: Ord a => FilterLike' (State (Set.Set a)) s a -> s -> s-ordNubOf w t = evalState (w f t) Set.empty- where- f a = state $ \s -> if Set.member a s- then (Nothing, s)- else (Just a, Set.insert a s)-{-# INLINE ordNubOf #-}---- | Remove the duplicate elements through a filter.--- It is often faster than 'ordNubOf', especially when the comparison is expensive.-hashNubOf :: (Eq a, Hashable a) => FilterLike' (State (HSet.HashSet a)) s a -> s -> s-hashNubOf w t = evalState (w f t) HSet.empty- where- f a = state $ \s -> if HSet.member a s- then (Nothing, s)- else (Just a, HSet.insert a s)-{-# INLINE hashNubOf #-}---- | Removes duplicate elements from a list, keeping only the first--- occurrence. This is asymptotically faster than using--- 'Data.List.nub' from "Data.List".-ordNub :: (Witherable t, Ord a) => t a -> t a-ordNub = ordNubOf witherM-{-# INLINE ordNub #-}---- | Removes duplicate elements from a list, keeping only the first--- occurrence. This is usually faster than 'ordNub', especially for--- things that have a slow comparison (like 'String').-hashNub :: (Witherable t, Eq a, Hashable a) => t a -> t a-hashNub = hashNubOf witherM-{-# INLINE hashNub #-}---- | A default implementation for 'mapMaybe'.-mapMaybeDefault :: (F.Foldable f, Alternative f) => (a -> Maybe b) -> f a -> f b-mapMaybeDefault p = F.foldr (\x xs -> case p x of- Just a -> pure a <|> xs- _ -> xs) empty-{-# INLINABLE mapMaybeDefault #-}---- | A default implementation for 'imapMaybe'.-imapMaybeDefault :: (Lens.FoldableWithIndex i f, Alternative f) => (i -> a -> Maybe b) -> f a -> f b-imapMaybeDefault p = Lens.ifoldr (\i x xs -> case p i x of- Just a -> pure a <|> xs- _ -> xs) empty-{-# INLINABLE imapMaybeDefault #-}--newtype WrappedFoldable f a = WrapFilterable {unwrapFoldable :: f a}- deriving (Functor, F.Foldable, T.Traversable, Applicative, Alternative)--instance (Lens.FunctorWithIndex i f) => Lens.FunctorWithIndex i (WrappedFoldable f) where- imap f = WrapFilterable . Lens.imap f . unwrapFoldable--instance (Lens.FoldableWithIndex i f) => Lens.FoldableWithIndex i (WrappedFoldable f) where- ifoldMap f = Lens.ifoldMap f . unwrapFoldable--instance (Lens.TraversableWithIndex i f) => Lens.TraversableWithIndex i (WrappedFoldable f) where- itraverse f = fmap WrapFilterable . Lens.itraverse f . unwrapFoldable--instance (F.Foldable f, Alternative f) => Filterable (WrappedFoldable f) where- {-#INLINE mapMaybe#-}- mapMaybe = mapMaybeDefault--instance (Lens.FunctorWithIndex i f, Lens.FoldableWithIndex i f, Alternative f) => FilterableWithIndex i (WrappedFoldable f) where- {-# INLINE imapMaybe #-}- imapMaybe = imapMaybeDefault--instance FilterableWithIndex () Maybe--instance WitherableWithIndex () Maybe---- Option doesn't have the necessary instances in Lens---instance FilterableWithIndex () Option---instance WitherableWithIndex () Option--instance FilterableWithIndex Int []--instance FilterableWithIndex Int ZipList--instance (Alternative f, T.Traversable f) => Witherable (WrappedFoldable f)--instance WitherableWithIndex Int []--instance WitherableWithIndex Int ZipList--instance FilterableWithIndex Int IM.IntMap where- imapMaybe = IM.mapMaybeWithKey- ifilter = IM.filterWithKey--instance WitherableWithIndex Int IM.IntMap where--instance FilterableWithIndex k (M.Map k) where- imapMaybe = M.mapMaybeWithKey- ifilter = M.filterWithKey--instance WitherableWithIndex k (M.Map k) where-#if MIN_VERSION_containers(0,5,8)- iwither = M.traverseMaybeWithKey-#endif--instance Filterable (MM.MonoidalMap k) where- mapMaybe = MM.mapMaybe- filter = MM.filter--instance Witherable (MM.MonoidalMap k)--instance FilterableWithIndex k (MM.MonoidalMap k) where- imapMaybe = MM.mapMaybeWithKey- ifilter = MM.filterWithKey--instance WitherableWithIndex k (MM.MonoidalMap k)--instance (Eq k, Hashable k) => FilterableWithIndex k (HM.HashMap k) where- imapMaybe = HM.mapMaybeWithKey- ifilter = HM.filterWithKey--instance (Eq k, Hashable k) => WitherableWithIndex k (HM.HashMap k) where--instance FilterableWithIndex Void Proxy--instance WitherableWithIndex Void Proxy--instance FilterableWithIndex Int V.Vector where- imapMaybe = V.imapMaybe- ifilter = V.ifilter--instance WitherableWithIndex Int V.Vector--instance FilterableWithIndex Int S.Seq--instance WitherableWithIndex Int S.Seq--instance (Lens.FunctorWithIndex i f, FilterableWithIndex j g) => FilterableWithIndex (i, j) (Compose f g) where- imapMaybe f = Compose . Lens.imap (\i -> imapMaybe (\j -> f (i, j))) . getCompose- ifilter p = Compose . Lens.imap (\i -> ifilter (\j -> p (i, j))) . getCompose--instance (Lens.TraversableWithIndex i f, WitherableWithIndex j g) => WitherableWithIndex (i, j) (Compose f g) where- iwither f = fmap Compose . Lens.itraverse (\i -> iwither (\j -> f (i, j))) . getCompose- iwitherM f = fmap Compose . Lens.imapM (\i -> iwitherM (\j -> f (i, j))) . getCompose- ifilterA p = fmap Compose . Lens.itraverse (\i -> ifilterA (\j -> p (i, j))) . getCompose--instance (FilterableWithIndex i f, FilterableWithIndex j g) => FilterableWithIndex (Either i j) (P.Product f g) where- imapMaybe f (P.Pair x y) = P.Pair (imapMaybe (f . Left) x) (imapMaybe (f . Right) y)- ifilter p (P.Pair x y) = P.Pair (ifilter (p . Left) x) (ifilter (p . Right) y)--instance (WitherableWithIndex i f, WitherableWithIndex j g) => WitherableWithIndex (Either i j) (P.Product f g) where- iwither f (P.Pair x y) = liftA2 P.Pair (iwither (f . Left) x) (iwither (f . Right) y)- iwitherM f (P.Pair x y) = liftA2 P.Pair (iwitherM (f . Left) x) (iwitherM (f . Right) y)- ifilterA p (P.Pair x y) = liftA2 P.Pair (ifilterA (p . Left) x) (ifilterA (p . Right) y)--instance (FilterableWithIndex i f, FilterableWithIndex j g) => FilterableWithIndex (Either i j) (Sum.Sum f g) where- imapMaybe f (Sum.InL x) = Sum.InL (imapMaybe (f . Left) x)- imapMaybe f (Sum.InR y) = Sum.InR (imapMaybe (f . Right) y)-- ifilter f (Sum.InL x) = Sum.InL (ifilter (f . Left) x)- ifilter f (Sum.InR y) = Sum.InR (ifilter (f . Right) y)--instance (WitherableWithIndex i f, WitherableWithIndex j g) => WitherableWithIndex (Either i j) (Sum.Sum f g) where- iwither f (Sum.InL x) = Sum.InL <$> iwither (f . Left) x- iwither f (Sum.InR y) = Sum.InR <$> iwither (f . Right) y-- iwitherM f (Sum.InL x) = Sum.InL <$> iwitherM (f . Left) x- iwitherM f (Sum.InR y) = Sum.InR <$> iwitherM (f . Right) y-- ifilterA f (Sum.InL x) = Sum.InL <$> ifilterA (f . Left) x- ifilterA f (Sum.InR y) = Sum.InR <$> ifilterA (f . Right) y--deriving instance (FilterableWithIndex i f) => FilterableWithIndex i (IdentityT f)--instance (WitherableWithIndex i f) => WitherableWithIndex i (IdentityT f) where- iwither f (IdentityT m) = IdentityT <$> iwither f m- iwitherM f (IdentityT m) = IdentityT <$> iwitherM f m- ifilterA p (IdentityT m) = IdentityT <$> ifilterA p m--deriving instance FilterableWithIndex i t => FilterableWithIndex i (Reverse t)---- | Wither from right to left.-instance WitherableWithIndex i t => WitherableWithIndex i (Reverse t) where- iwither f (Reverse t) = fmap Reverse . forwards $ iwither (\i -> Backwards . f i) t- -- We can't do anything special with iwitherM, because Backwards m is not- -- generally a Monad.- ifilterA p (Reverse t) = fmap Reverse . forwards $ ifilterA (\i -> Backwards . p i) t--deriving instance FilterableWithIndex i t => FilterableWithIndex i (Backwards t)--instance WitherableWithIndex i t => WitherableWithIndex i (Backwards t) where- iwither f (Backwards xs) = Backwards <$> iwither f xs- iwitherM f (Backwards xs) = Backwards <$> iwitherM f xs- ifilterA f (Backwards xs) = Backwards <$> ifilterA f xs
+ src/Witherable.hs view
@@ -0,0 +1,753 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Module : Witherable+-- Copyright : (c) Fumiaki Kinoshita 2020+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module Witherable+ ( Filterable(..)+ , (<$?>)+ , (<&?>)+ , Witherable(..)+ , ordNub+ , ordNubOn+ , hashNub+ , hashNubOn+ , forMaybe+ -- * Indexed variants+ , FilterableWithIndex(..)+ , WitherableWithIndex(..)+ -- * Wrapper+ , WrappedFoldable(..)+ )++where++import Control.Applicative+import Control.Applicative.Backwards (Backwards (..))+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Lazy (evalState, state)+import Data.Bool (bool)+import Data.Coerce (coerce)+import Data.Foldable.WithIndex+import Data.Functor.Compose+import Data.Functor.Product as P+import Data.Functor.Reverse (Reverse (..))+import Data.Functor.Sum as Sum+import Data.Functor.WithIndex+import Data.Functor.WithIndex.Instances ()+import Data.Hashable+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)+import qualified Data.Foldable as F+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HSet+import qualified Data.IntMap.Lazy as IM+import qualified Data.Map.Lazy as M+import qualified Data.Maybe as Maybe+import qualified Data.Sequence as S+import qualified Data.Set as Set+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified GHC.Generics as Generics+import qualified Prelude++-- | Like 'Functor', but you can remove elements instead of updating them.+--+-- Formally, the class 'Filterable' represents a functor from @Kleisli Maybe@ to @Hask@.+--+-- A definition of 'mapMaybe' must satisfy the following laws:+--+-- [/conservation/]+-- @'mapMaybe' (Just . f) ≡ 'fmap' f@+--+-- [/composition/]+-- @'mapMaybe' f . 'mapMaybe' g ≡ 'mapMaybe' (f <=< g)@+--+class Functor f => Filterable f where+ -- | Like 'Maybe.mapMaybe'.+ mapMaybe :: (a -> Maybe b) -> f a -> f b+ mapMaybe f = catMaybes . fmap f+ {-# INLINE mapMaybe #-}++ -- | @'catMaybes' ≡ 'mapMaybe' 'id'@+ catMaybes :: f (Maybe a) -> f a+ catMaybes = mapMaybe id+ {-# INLINE catMaybes #-}++ -- | @'filter' f . 'filter' g ≡ filter ('liftA2' ('&&') g f)@+ filter :: (a -> Bool) -> f a -> f a+ filter f = mapMaybe $ \a -> if f a then Just a else Nothing+ {-# INLINE filter #-}++ -- | Empty a filterable.+ --+ -- @'drain' ≡ 'mapMaybe' (const Nothing)@+ --+ drain :: f a -> f b+ drain = mapMaybe (const Nothing)+ {-# INLINE drain #-}++ {-# MINIMAL mapMaybe | catMaybes #-}++-- | An enhancement of 'Traversable' with 'Filterable'+--+-- A definition of 'wither' must satisfy the following laws:+--+-- [/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:+--+-- [/naturality/]+-- @t . 'wither' f ≡ 'wither' (t . f)@+--+-- 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 #-}++ -- | @Monadic variant of 'wither'. This may have more efficient implementation.@+ witherM :: Monad m => (a -> m (Maybe b)) -> t a -> m (t b)+ witherM = wither++ filterA :: Applicative f => (a -> f Bool) -> t a -> f (t a)+ filterA f = wither $ \a -> (\b -> if b then Just a else Nothing) <$> f a++ witherMap :: (Applicative m) => (t b -> r) -> (a -> m (Maybe b)) -> t a -> m r+ witherMap p f = fmap p . wither f+ {-# INLINE witherMap #-}++ {-# MINIMAL #-}++instance Filterable Maybe where+ mapMaybe f = (>>= f)+ drain _ = Nothing+ {-# INLINE mapMaybe #-}++instance Witherable Maybe where+ wither _ Nothing = pure Nothing+ wither f (Just a) = f a+ {-# INLINABLE wither #-}++#if !MIN_VERSION_base(4,16,0)++instance Filterable Option where+ mapMaybe f = (>>= Option . f)+ drain _ = Option Nothing+ {-# INLINE mapMaybe #-}++instance Witherable Option where+ wither f (Option x) = Option <$> wither f x+ {-# INLINE wither #-}++-- Option doesn't have the necessary instances in Lens+--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+ {-# INLINABLE mapMaybe #-}++ drain (Left e) = Left e+ drain (Right _) = Left mempty++instance Monoid e => Witherable (Either e) where+ wither _ (Left e) = pure (Left e)+ wither f (Right a) = fmap (maybe (Left mempty) Right) (f a)+ {-# INLINABLE wither #-}++instance Filterable [] where+ mapMaybe = Maybe.mapMaybe+ catMaybes = Maybe.catMaybes+ filter = Prelude.filter+ drain _ = []++instance Filterable ZipList where+ mapMaybe f = ZipList . Maybe.mapMaybe f . getZipList+ catMaybes = ZipList . Maybe.catMaybes . getZipList+ filter f = ZipList . Prelude.filter f . getZipList+ drain _ = ZipList []++-- | Methods are good consumers for fusion.+instance Witherable [] where+ wither f = foldr go (pure []) where+ go x r = liftA2 (maybe id (:)) (f x) r+ {-# INLINE wither #-}+ witherM f = foldr go (pure []) where+ go x r = f x >>=+ (\z -> case z of+ Nothing -> r+ Just y -> ((:) y) <$> r+ )+ {-# INLINE witherM #-}++ -- Compared to the default, this fuses an fmap into a liftA2.+ filterA p = go where+ go (x:xs) = liftA2 (bool id (x :)) (p x) (go xs)+ go [] = pure []++instance Witherable ZipList where+ wither f = fmap ZipList . wither f . getZipList++instance Filterable IM.IntMap where+ mapMaybe = IM.mapMaybe+ filter = IM.filter+ drain _ = IM.empty++instance Witherable IM.IntMap where++instance Filterable (M.Map k) where+ mapMaybe = M.mapMaybe+ filter = M.filter+ drain _ = M.empty++instance Witherable (M.Map k) where+#if MIN_VERSION_containers(0,5,8)+ wither f = M.traverseMaybeWithKey (const f)+#endif++instance (Eq k, Hashable k) => Filterable (HM.HashMap k) where+ mapMaybe = HM.mapMaybe+ filter = HM.filter+ drain _ = HM.empty++instance (Eq k, Hashable k) => Witherable (HM.HashMap k) where++instance Filterable Proxy where+ mapMaybe _ Proxy = Proxy++instance Witherable Proxy where+ wither _ Proxy = pure Proxy++instance Filterable (Const r) where+ mapMaybe _ (Const r) = Const r+ {-# INLINABLE mapMaybe #-}++instance Witherable (Const r) where+ wither _ (Const r) = pure (Const r)+ {-# INLINABLE wither #-}++instance Filterable V.Vector where+ filter = V.filter+ mapMaybe = V.mapMaybe+ drain _ = V.empty++instance Witherable V.Vector where+ wither f = fmap V.fromList . wither f . V.toList+ {-# INLINABLE wither #-}++ witherM = V.mapMaybeM+ {-# INLINE witherM #-}++instance Filterable S.Seq where+ mapMaybe f = S.fromList . mapMaybe f . F.toList+ {-# INLINABLE mapMaybe #-}+ filter = S.filter+ drain _ = S.empty++instance Witherable S.Seq where+ wither f = fmap S.fromList . wither f . F.toList+ {-# INLINABLE wither #-}++{-+ -- TODO: try to figure out whether the following is better or worse for+ -- typical applications. It builds the sequence incrementally rather than+ -- building a list and converting. This is basically the same approach+ -- currently used by Data.Sequence.filter.++ witherM f = F.foldlM go S.empty+ where+ --go :: S.Seq b -> a -> m (S.Seq b)+ go s a = do+ mb <- f a+ case mb of+ Nothing -> pure s+ Just b -> pure $! s S.|> b+ {-# INLINABLE witherM #-}+-}++-- The instances for Compose, Product, and Sum are not entirely+-- unique. Any particular composition, product, or sum of functors+-- may support a variety of 'wither' implementations.++instance (Functor f, Filterable g) => Filterable (Compose f g) where+ mapMaybe f = Compose . fmap (mapMaybe f) . getCompose+ filter p = Compose . fmap (filter p) . getCompose+ catMaybes = Compose . fmap catMaybes . getCompose+ drain = Compose . fmap drain . getCompose++instance (T.Traversable f, Witherable g) => Witherable (Compose f g) where+ wither f = fmap Compose . T.traverse (wither f) . getCompose+ witherM f = fmap Compose . T.mapM (witherM f) . getCompose+ filterA p = fmap Compose . T.traverse (filterA p) . getCompose++instance (Filterable f, Filterable g) => Filterable (P.Product f g) where+ mapMaybe f (P.Pair x y) = P.Pair (mapMaybe f x) (mapMaybe f y)+ filter p (P.Pair x y) = P.Pair (filter p x) (filter p y)+ catMaybes (P.Pair x y) = P.Pair (catMaybes x) (catMaybes y)+ drain (P.Pair x y) = P.Pair (drain x) (drain y)++instance (Witherable f, Witherable g) => Witherable (P.Product f g) where+ wither f (P.Pair x y) = liftA2 P.Pair (wither f x) (wither f y)+ witherM f (P.Pair x y) = liftA2 P.Pair (witherM f x) (witherM f y)+ filterA p (P.Pair x y) = liftA2 P.Pair (filterA p x) (filterA p y)++instance (Filterable f, Filterable g) => Filterable (Sum.Sum f g) where+ mapMaybe f (Sum.InL x) = Sum.InL (mapMaybe f x)+ mapMaybe f (Sum.InR y) = Sum.InR (mapMaybe f y)++ catMaybes (Sum.InL x) = Sum.InL (catMaybes x)+ catMaybes (Sum.InR y) = Sum.InR (catMaybes y)++ filter p (Sum.InL x) = Sum.InL (filter p x)+ filter p (Sum.InR y) = Sum.InR (filter p y)++ drain (Sum.InL x) = Sum.InL (drain x)+ drain (Sum.InR y) = Sum.InR (drain y)++instance (Witherable f, Witherable g) => Witherable (Sum.Sum f g) where+ wither f (Sum.InL x) = Sum.InL <$> wither f x+ wither f (Sum.InR y) = Sum.InR <$> wither f y++ witherM f (Sum.InL x) = Sum.InL <$> witherM f x+ witherM f (Sum.InR y) = Sum.InR <$> witherM f y++ filterA f (Sum.InL x) = Sum.InL <$> filterA f x+ filterA f (Sum.InR y) = Sum.InR <$> filterA f y++deriving instance Filterable f => Filterable (IdentityT f)++instance Witherable f => Witherable (IdentityT f) where+ wither f (IdentityT m) = IdentityT <$> wither f m+ witherM f (IdentityT m) = IdentityT <$> witherM f m+ filterA p (IdentityT m) = IdentityT <$> filterA p m++instance Functor f => Filterable (MaybeT f) where+ mapMaybe f = MaybeT . fmap (mapMaybe f) . runMaybeT++instance (T.Traversable t) => Witherable (MaybeT t) where+ wither f = fmap MaybeT . T.traverse (wither f) . runMaybeT+ witherM f = fmap MaybeT . T.mapM (wither f) . runMaybeT++deriving instance Filterable t => Filterable (Reverse t)++-- | Wither from right to left.+instance Witherable t => Witherable (Reverse t) where+ wither f (Reverse t) =+ fmap Reverse . forwards $ wither (coerce f) t+ -- We can't do anything special with witherM, because Backwards m is not+ -- generally a Monad.+ filterA f (Reverse t) =+ fmap Reverse . forwards $ filterA (coerce f) t++deriving instance Filterable t => Filterable (Backwards t)++instance Witherable t => Witherable (Backwards t) where+ wither f (Backwards xs) = Backwards <$> wither f xs+ witherM f (Backwards xs) = Backwards <$> witherM f xs+ filterA f (Backwards xs) = Backwards <$> filterA f xs++instance Filterable Generics.V1 where+ mapMaybe _ v = case v of {}+ catMaybes v = case v of {}+ filter _ v = case v of {}++instance Witherable Generics.V1 where+ wither _ v = pure $ case v of {}+ filterA _ v = pure $ case v of {}++instance Filterable Generics.U1 where+ mapMaybe _ _ = Generics.U1+ catMaybes _ = Generics.U1+ filter _ _ = Generics.U1++instance Witherable Generics.U1 where+ wither _ _ = pure Generics.U1+ filterA _ _ = pure Generics.U1++instance Filterable (Generics.K1 i c) where+ mapMaybe _ (Generics.K1 a) = Generics.K1 a+ catMaybes (Generics.K1 a) = Generics.K1 a+ filter _ (Generics.K1 a) = Generics.K1 a++instance Witherable (Generics.K1 i c) where+ wither _ (Generics.K1 a) = pure (Generics.K1 a)+ filterA _ (Generics.K1 a) = pure (Generics.K1 a)++instance Filterable f => Filterable (Generics.Rec1 f) where+ mapMaybe f (Generics.Rec1 a) = Generics.Rec1 (mapMaybe f a)+ catMaybes (Generics.Rec1 a) = Generics.Rec1 (catMaybes a)+ filter f (Generics.Rec1 a) = Generics.Rec1 (filter f a)++instance Witherable f => Witherable (Generics.Rec1 f) where+ wither f (Generics.Rec1 a) = fmap Generics.Rec1 (wither f a)+ witherM f (Generics.Rec1 a) = fmap Generics.Rec1 (witherM f a)+ filterA f (Generics.Rec1 a) = fmap Generics.Rec1 (filterA f a)++instance Filterable f => Filterable (Generics.M1 i c f) where+ mapMaybe f (Generics.M1 a) = Generics.M1 (mapMaybe f a)+ catMaybes (Generics.M1 a) = Generics.M1 (catMaybes a)+ filter f (Generics.M1 a) = Generics.M1 (filter f a)++instance Witherable f => Witherable (Generics.M1 i c f) where+ wither f (Generics.M1 a) = fmap Generics.M1 (wither f a)+ witherM f (Generics.M1 a) = fmap Generics.M1 (witherM f a)+ filterA f (Generics.M1 a) = fmap Generics.M1 (filterA f a)++instance (Filterable f, Filterable g) => Filterable ((Generics.:*:) f g) where+ mapMaybe f (a Generics.:*: b) = mapMaybe f a Generics.:*: mapMaybe f b+ catMaybes (a Generics.:*: b) = catMaybes a Generics.:*: catMaybes b+ filter f (a Generics.:*: b) = filter f a Generics.:*: filter f b++instance (Witherable f, Witherable g) => Witherable ((Generics.:*:) f g) where+ wither f (a Generics.:*: b) = liftA2 (Generics.:*:) (wither f a) (wither f b)+ witherM f (a Generics.:*: b) = liftA2 (Generics.:*:) (witherM f a) (witherM f b)+ filterA f (a Generics.:*: b) = liftA2 (Generics.:*:) (filterA f a) (filterA f b)++instance (Filterable f, Filterable g) => Filterable ((Generics.:+:) f g) where+ mapMaybe f (Generics.L1 a) = Generics.L1 (mapMaybe f a)+ mapMaybe f (Generics.R1 a) = Generics.R1 (mapMaybe f a)+ catMaybes (Generics.L1 a) = Generics.L1 (catMaybes a)+ catMaybes (Generics.R1 a) = Generics.R1 (catMaybes a)+ filter f (Generics.L1 a) = Generics.L1 (filter f a)+ filter f (Generics.R1 a) = Generics.R1 (filter f a)++instance (Witherable f, Witherable g) => Witherable ((Generics.:+:) f g) where+ wither f (Generics.L1 a) = fmap Generics.L1 (wither f a)+ wither f (Generics.R1 a) = fmap Generics.R1 (wither f a)+ witherM f (Generics.L1 a) = fmap Generics.L1 (witherM f a)+ witherM f (Generics.R1 a) = fmap Generics.R1 (witherM f a)+ filterA f (Generics.L1 a) = fmap Generics.L1 (filterA f a)+ filterA f (Generics.R1 a) = fmap Generics.R1 (filterA f a)++instance (Functor f, Filterable g) => Filterable ((Generics.:.:) f g) where+ mapMaybe f = Generics.Comp1 . fmap (mapMaybe f) . Generics.unComp1+ catMaybes = Generics.Comp1 . fmap catMaybes . Generics.unComp1+ filter f = Generics.Comp1 . fmap (filter f) . Generics.unComp1++instance (T.Traversable f, Witherable g) => Witherable ((Generics.:.:) f g) where+ wither f = fmap Generics.Comp1 . T.traverse (wither f) . Generics.unComp1+ witherM f = fmap Generics.Comp1 . T.mapM (witherM f) . Generics.unComp1+ filterA f = fmap Generics.Comp1 . T.traverse (filterA f) . Generics.unComp1++-- | Indexed variant of 'Filterable'.+class (FunctorWithIndex i t, Filterable t) => FilterableWithIndex i t | t -> i where+ imapMaybe :: (i -> a -> Maybe b) -> t a -> t b+ imapMaybe f = catMaybes . imap f+ {-# INLINE imapMaybe #-}++ -- | @'filter' f . 'ifilter' g ≡ ifilter (\i x -> f x '&&' g i x)@+ ifilter :: (i -> a -> Bool) -> t a -> t a+ ifilter f = imapMaybe $ \i a -> if f i a then Just a else Nothing+ {-# INLINE ifilter #-}++-- | Indexed variant of 'Witherable'.+class (TraversableWithIndex i t, FilterableWithIndex i t, Witherable t) => WitherableWithIndex i t | t -> i where+ -- | Effectful 'imapMaybe'.+ --+ -- @'iwither' (\ i -> 'pure' . f i) ≡ 'pure' . 'imapMaybe' f@+ iwither :: (Applicative f) => (i -> a -> f (Maybe b)) -> t a -> f (t b)+ iwither f = fmap catMaybes . itraverse f++ -- | @Monadic variant of 'wither'. This may have more efficient implementation.@+ iwitherM :: (Monad m) => (i -> a -> m (Maybe b)) -> t a -> m (t b)+ iwitherM = iwither++ ifilterA :: (Applicative f) => (i -> a -> f Bool) -> t a -> f (t a)+ ifilterA f = iwither (\i a -> (\b -> if b then Just a else Nothing) <$> f i a)++instance FilterableWithIndex () Maybe++instance WitherableWithIndex () Maybe++-- Option doesn't have the necessary instances in Lens+--instance FilterableWithIndex () Option+--instance WitherableWithIndex () Option++instance FilterableWithIndex Int []++instance FilterableWithIndex Int ZipList++instance WitherableWithIndex Int []++instance WitherableWithIndex Int ZipList++instance FilterableWithIndex Int IM.IntMap where+ imapMaybe = IM.mapMaybeWithKey+ ifilter = IM.filterWithKey++instance WitherableWithIndex Int IM.IntMap where++instance FilterableWithIndex k (M.Map k) where+ imapMaybe = M.mapMaybeWithKey+ ifilter = M.filterWithKey++instance WitherableWithIndex k (M.Map k) where+#if MIN_VERSION_containers(0,5,8)+ iwither = M.traverseMaybeWithKey+#endif++instance (Eq k, Hashable k) => FilterableWithIndex k (HM.HashMap k) where+ imapMaybe = HM.mapMaybeWithKey+ ifilter = HM.filterWithKey++instance (Eq k, Hashable k) => WitherableWithIndex k (HM.HashMap k) where++instance FilterableWithIndex Void Proxy++instance WitherableWithIndex Void Proxy++instance FilterableWithIndex Int V.Vector where+ imapMaybe = V.imapMaybe+ ifilter = V.ifilter++instance WitherableWithIndex Int V.Vector++instance FilterableWithIndex Int S.Seq++instance WitherableWithIndex Int S.Seq++instance (FunctorWithIndex i f, FilterableWithIndex j g) => FilterableWithIndex (i, j) (Compose f g) where+ imapMaybe f = Compose . imap (\i -> imapMaybe (\j -> f (i, j))) . getCompose+ ifilter p = Compose . imap (\i -> ifilter (\j -> p (i, j))) . getCompose++instance (TraversableWithIndex i f, WitherableWithIndex j g) => WitherableWithIndex (i, j) (Compose f g) where+ iwither f = fmap Compose . itraverse (\i -> iwither (\j -> f (i, j))) . getCompose+ iwitherM f = fmap Compose . imapM (\i -> iwitherM (\j -> f (i, j))) . getCompose+ ifilterA p = fmap Compose . itraverse (\i -> ifilterA (\j -> p (i, j))) . getCompose++instance (FilterableWithIndex i f, FilterableWithIndex j g) => FilterableWithIndex (Either i j) (P.Product f g) where+ imapMaybe f (P.Pair x y) = P.Pair (imapMaybe (f . Left) x) (imapMaybe (f . Right) y)+ ifilter p (P.Pair x y) = P.Pair (ifilter (p . Left) x) (ifilter (p . Right) y)++instance (WitherableWithIndex i f, WitherableWithIndex j g) => WitherableWithIndex (Either i j) (P.Product f g) where+ iwither f (P.Pair x y) = liftA2 P.Pair (iwither (f . Left) x) (iwither (f . Right) y)+ iwitherM f (P.Pair x y) = liftA2 P.Pair (iwitherM (f . Left) x) (iwitherM (f . Right) y)+ ifilterA p (P.Pair x y) = liftA2 P.Pair (ifilterA (p . Left) x) (ifilterA (p . Right) y)++instance (FilterableWithIndex i f, FilterableWithIndex j g) => FilterableWithIndex (Either i j) (Sum.Sum f g) where+ imapMaybe f (Sum.InL x) = Sum.InL (imapMaybe (f . Left) x)+ imapMaybe f (Sum.InR y) = Sum.InR (imapMaybe (f . Right) y)++ ifilter f (Sum.InL x) = Sum.InL (ifilter (f . Left) x)+ ifilter f (Sum.InR y) = Sum.InR (ifilter (f . Right) y)++instance (WitherableWithIndex i f, WitherableWithIndex j g) => WitherableWithIndex (Either i j) (Sum.Sum f g) where+ iwither f (Sum.InL x) = Sum.InL <$> iwither (f . Left) x+ iwither f (Sum.InR y) = Sum.InR <$> iwither (f . Right) y++ iwitherM f (Sum.InL x) = Sum.InL <$> iwitherM (f . Left) x+ iwitherM f (Sum.InR y) = Sum.InR <$> iwitherM (f . Right) y++ ifilterA f (Sum.InL x) = Sum.InL <$> ifilterA (f . Left) x+ ifilterA f (Sum.InR y) = Sum.InR <$> ifilterA (f . Right) y++deriving instance (FilterableWithIndex i f) => FilterableWithIndex i (IdentityT f)++instance (WitherableWithIndex i f) => WitherableWithIndex i (IdentityT f) where+ iwither f (IdentityT m) = IdentityT <$> iwither f m+ iwitherM f (IdentityT m) = IdentityT <$> iwitherM f m+ ifilterA p (IdentityT m) = IdentityT <$> ifilterA p m++deriving instance FilterableWithIndex i t => FilterableWithIndex i (Reverse t)++-- | Wither from right to left.+instance WitherableWithIndex i t => WitherableWithIndex i (Reverse t) where+ iwither f (Reverse t) = fmap Reverse . forwards $ iwither (\i -> Backwards . f i) t+ -- We can't do anything special with iwitherM, because Backwards m is not+ -- generally a Monad.+ ifilterA p (Reverse t) = fmap Reverse . forwards $ ifilterA (\i -> Backwards . p i) t++deriving instance FilterableWithIndex i t => FilterableWithIndex i (Backwards t)++instance WitherableWithIndex i t => WitherableWithIndex i (Backwards t) where+ iwither f (Backwards xs) = Backwards <$> iwither f xs+ iwitherM f (Backwards xs) = Backwards <$> iwitherM f xs+ ifilterA f (Backwards xs) = Backwards <$> ifilterA f xs++-- | An infix alias for 'mapMaybe'. The name of the operator alludes+-- to '<$>', and has the same fixity.+--+-- @since 0.3.1+(<$?>) :: Filterable f => (a -> Maybe b) -> f a -> f b+(<$?>) = mapMaybe+infixl 4 <$?>++-- | Flipped version of '<$?>', the 'Filterable' version of+-- 'Data.Functor.<&>'. It has the same fixity as 'Data.Functor.<&>'.+--+-- @+-- ('<&?>') = 'flip' 'mapMaybe'+-- @+--+-- @since 0.3.1+(<&?>) :: Filterable f => f a -> (a -> Maybe b) -> f b+as <&?> f = mapMaybe f as+infixl 1 <&?>++-- | @'forMaybe' = 'flip' 'wither'@+forMaybe :: (Witherable t, Applicative f) => t a -> (a -> f (Maybe b)) -> f (t b)+forMaybe = flip wither+{-# INLINE forMaybe #-}++-- | Removes duplicate elements from a list, keeping only the first+-- occurrence. This is asymptotically faster than using+-- 'Data.List.nub' from "Data.List".+--+-- >>> ordNub [3,2,1,3,2,1]+-- [3,2,1]+--+ordNub :: (Witherable t, Ord a) => t a -> t a+ordNub = ordNubOn id+{-# INLINE ordNub #-}++-- | The 'ordNubOn' function behaves just like 'ordNub',+-- except it uses a another type to determine equivalence classes.+--+-- >>> ordNubOn fst [(True, 'x'), (False, 'y'), (True, 'z')]+-- [(True,'x'),(False,'y')]+--+ordNubOn :: (Witherable t, Ord b) => (a -> b) -> t a -> t a+ordNubOn p t = evalState (witherM f t) Set.empty where+ f a = state $ \s ->+#if MIN_VERSION_containers(0,6,3)+ -- insert in one go+ -- having if outside is important for performance,+ -- \x -> (if x ... , True) -- is slower+ case Set.alterF (\x -> BoolPair x True) (p a) s of+ BoolPair True s' -> (Nothing, s')+ BoolPair False s' -> (Just a, s')+#else+ if Set.member (p a) s+ then (Nothing, s)+ else (Just a, Set.insert (p a) s)+#endif+{-# INLINE ordNubOn #-}++-- | Removes duplicate elements from a list, keeping only the first+-- occurrence. This is usually faster than 'ordNub', especially for+-- things that have a slow comparison (like 'String').+--+-- >>> hashNub [3,2,1,3,2,1]+-- [3,2,1]+--+hashNub :: (Witherable t, Eq a, Hashable a) => t a -> t a+hashNub = hashNubOn id+{-# INLINE hashNub #-}++-- | The 'hashNubOn' function behaves just like 'hashNub',+-- except it uses a another type to determine equivalence classes.+--+-- >>> hashNubOn fst [(True, 'x'), (False, 'y'), (True, 'z')]+-- [(True,'x'),(False,'y')]+--+hashNubOn :: (Witherable t, Eq b, Hashable b) => (a -> b) -> t a -> t a+hashNubOn p t = evalState (witherM f t) HSet.empty+ where+ f a = state $ \s ->+ let g Nothing = BoolPair False (Just ())+ g (Just _) = BoolPair True (Just ())+ -- there is no HashSet.alterF, but toMap / fromMap are newtype wrappers.+ in case HM.alterF g (p a) (HSet.toMap s) of+ BoolPair True s' -> (Nothing, HSet.fromMap s')+ BoolPair False s' -> (Just a, HSet.fromMap s')+{-# INLINE hashNubOn #-}++-- used to implement *Nub functions.+data BoolPair a = BoolPair !Bool a deriving Functor++-- | A default implementation for 'mapMaybe'.+mapMaybeDefault :: (F.Foldable f, Alternative f) => (a -> Maybe b) -> f a -> f b+mapMaybeDefault p = F.foldr (\x xs -> case p x of+ Just a -> pure a <|> xs+ _ -> xs) empty+{-# INLINABLE mapMaybeDefault #-}++-- | A default implementation for 'imapMaybe'.+imapMaybeDefault :: (FoldableWithIndex i f, Alternative f) => (i -> a -> Maybe b) -> f a -> f b+imapMaybeDefault p = ifoldr (\i x xs -> case p i x of+ Just a -> pure a <|> xs+ _ -> xs) empty+{-# INLINABLE imapMaybeDefault #-}++newtype WrappedFoldable f a = WrapFilterable {unwrapFoldable :: f a}+ deriving (Functor, F.Foldable, T.Traversable, Applicative, Alternative)++instance (FunctorWithIndex i f) => FunctorWithIndex i (WrappedFoldable f) where+ imap f = WrapFilterable . imap f . unwrapFoldable++instance (FoldableWithIndex i f) => FoldableWithIndex i (WrappedFoldable f) where+ ifoldMap f = ifoldMap f . unwrapFoldable++instance (TraversableWithIndex i f) => TraversableWithIndex i (WrappedFoldable f) where+ itraverse f = fmap WrapFilterable . itraverse f . unwrapFoldable++instance (F.Foldable f, Alternative f) => Filterable (WrappedFoldable f) where+ {-#INLINE mapMaybe#-}+ mapMaybe = mapMaybeDefault++instance (FunctorWithIndex i f, FoldableWithIndex i f, Alternative f) => FilterableWithIndex i (WrappedFoldable f) where+ {-# INLINE imapMaybe #-}+ imapMaybe = imapMaybeDefault++instance (Alternative f, T.Traversable f) => Witherable (WrappedFoldable f)
+ tests/tests.hs view
@@ -0,0 +1,273 @@+{-# 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 (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, (===))+import Test.QuickCheck.Instances ()+import Test.Tasty (defaultMain, testGroup, TestTree)+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.HashMap.Lazy as HashMap+import qualified Data.IntMap as IntMap+import qualified Data.Map.Lazy as Map+import qualified Data.Vector as V+import qualified Data.Sequence as Seq++import Witherable+import Prelude hiding (filter)++main :: IO ()+main = defaultMain $ testGroup "witherable"+ [ testGroup "Filterable"+ [ filterableLaws (Proxy @[])+ , filterableLaws (Proxy @Maybe)+ , filterableLaws (Proxy @(Either String))+ , filterableLaws (Proxy @V.Vector)+ , filterableLaws (Proxy @Seq.Seq)+ , filterableLaws (Proxy @IntMap.IntMap)+ , filterableLaws (Proxy @(Map.Map K))+ , filterableLaws (Proxy @(HashMap.HashMap K))+ , filterableLaws (Proxy @Wicked)+ ]++ , testGroup "Witherable"+ [ witherableLaws (Proxy @[])+ , witherableLaws (Proxy @Maybe)+ , 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+ ]++-------------------------------------------------------------------------------+-- Filterable laws+-------------------------------------------------------------------------------++filterableLaws+ :: forall f.+ ( Filterable f, Typeable f+ , Arbitrary (f A), Show (f A), Eq (f A)+ , Arbitrary (f (Maybe A)), Show (f (Maybe A))+ , Show (f B), Eq (f B), Show (f C), Eq (f C)+ )+ => Proxy f+ -> TestTree+filterableLaws p = testGroup (show (typeRep p))+ [ testProperty "conservation" prop_conservation+ , testProperty "composition" prop_composition+ , testProperty "default filter" prop_default_filter+ , testProperty "default mapMaybe" prop_default_mapMaybe+ , testProperty "default catMaybes" prop_default_catMaybes+ ]+ where+ prop_conservation :: Fun A B -> f A -> Property+ prop_conservation f' xs =+ mapMaybe (Just . f) xs === fmap f xs+ where+ f = applyFun f'++ prop_composition :: Fun B (Maybe C) -> Fun A (Maybe B) -> f A -> Property+ prop_composition f' g' xs =+ mapMaybe f (mapMaybe g xs) === mapMaybe (f <=< g) xs+ where+ f = applyFun f'+ g = applyFun g'++ prop_default_filter :: Fun A Bool -> f A -> Property+ prop_default_filter f' xs =+ filter f xs === mapMaybe (\a -> if f a then Just a else Nothing) xs+ where+ f = applyFun f'++ prop_default_mapMaybe :: Fun A (Maybe B) -> f A -> Property+ prop_default_mapMaybe f' xs =+ mapMaybe f xs === catMaybes (fmap f xs)+ where+ f = applyFun f'++ prop_default_catMaybes :: f (Maybe A) -> Property+ prop_default_catMaybes xs = catMaybes xs === mapMaybe id xs++-------------------------------------------------------------------------------+-- Witherable laws+-------------------------------------------------------------------------------++witherableLaws+ :: forall f.+ ( Witherable f, Typeable f+ , Arbitrary (f A), Show (f A), Eq (f A)+ , Arbitrary (f (Maybe A)), Show (f (Maybe A))+ , Show (f B), Eq (f B), Show (f C), Eq (f C)+ )+ => Proxy f+ -> TestTree+witherableLaws p = testGroup (show (typeRep p))+ [ 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 = 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 = 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 = 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"+-------------------------------------------------------------------------------++nubProperties :: TestTree+nubProperties = testGroup "nub"+ [ testProperty "ordNub" prop_ordNub+ , testProperty "ordNubOn" prop_ordNubOn+ , testProperty "hashNub" prop_hashNub+ , testProperty "hashNubOn" prop_hashNubOn+ , testProperty "ordNub is lazy" prop_lazy_ordNub+ , testProperty "hashNub is lazy" prop_lazy_hashNub+ ]+ where+ prop_ordNub :: [A] -> Property+ prop_ordNub xs = nub xs === ordNub xs++ prop_hashNub :: [A] -> Property+ prop_hashNub xs = nub xs === hashNub xs++ prop_ordNubOn :: Fun A B -> [A] -> Property+ prop_ordNubOn f' xs = nubBy ((==) `on` f) xs === ordNubOn f xs+ where+ f = applyFun f'++ prop_hashNubOn :: Fun A B -> [A] -> Property+ prop_hashNubOn f' xs = nubBy ((==) `on` f) xs === hashNubOn f xs+ where+ f = applyFun f'++ prop_lazy_ordNub :: Property+ prop_lazy_ordNub = take 3 (ordNub ('x' : 'y' : 'z' : 'z' : error "bottom")) === "xyz"++ prop_lazy_hashNub :: Property+ prop_lazy_hashNub = take 3 (hashNub ('x' : 'y' : 'z' : 'z' : error "bottom")) === "xyz"++-------------------------------------------------------------------------------+-- "Poly"+-------------------------------------------------------------------------------++newtype A = A Int+ deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)++instance Function A where+ function = functionMap coerce A++newtype B = B Int+ deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)++instance Function B where+ function = functionMap coerce B++newtype C = C Int+ deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)++instance Function C where+ function = functionMap coerce C++newtype K = K Int+ deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)++instance Function K where+ function = functionMap coerce K++newtype S = S Int+ deriving (Eq, Ord, Show, Hashable, Arbitrary, CoArbitrary)++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,9 +1,10 @@+cabal-version: 2.4 name: witherable-version: 0.3.5+version: 0.5 synopsis: filterable traversable description: A stronger variant of `traverse` which can remove elements and generalised mapMaybe, catMaybes, filter homepage: https://github.com/fumieval/witherable-license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Fumiaki Kinoshita maintainer: Fumiaki Kinoshita <fumiexcel@gmail.com>@@ -11,32 +12,44 @@ category: Data build-type: Simple extra-source-files: CHANGELOG.md-cabal-version: >=1.10-tested-With: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3, GHC == 8.8.1+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 ||+ ==9.0.1 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 || ==9.10.1 source-repository head type: git location: https://github.com/fumieval/witherable.git+ subdir: witherable library- exposed-modules: Data.Witherable- -- other-modules:- -- other-extensions:- build-depends: base == 4.*,- base-orphans,- containers >= 0.5,+ exposed-modules:+ Witherable+ build-depends: base >=4.9 && <5,+ base-orphans >=0.8.4 && <0.10,+ containers >=0.5.7.1 && <0.8,+ hashable >=1.2.7.0 && <1.5,+ transformers >=0.5.2.0 && <0.7,+ unordered-containers >=0.2.12.0 && <0.3,+ vector >=0.12.2.0 && <0.14,+ indexed-traversable >=0.1.1 && <0.2,+ indexed-traversable-instances >=0.1 && <0.2+ hs-source-dirs: src+ ghc-options: -Wall -Wcompat+ default-language: Haskell2010++test-suite witherable-tests+ type: exitcode-stdio-1.0+ main-is: tests.hs+ hs-source-dirs: tests+ ghc-options: -Wall -Wcompat+ default-language: Haskell2010+ build-depends: base,+ witherable,+ containers, hashable,- lens,- monoidal-containers,+ QuickCheck >=2.14.2,+ quickcheck-instances,+ tasty,+ tasty-quickcheck, transformers,- transformers-compat, unordered-containers,- vector,- witherable-class- if impl(ghc < 7.9)- build-depends: void- hs-source-dirs: src- ghc-options: -Wall- default-language: Haskell2010- if (impl(ghc>=8))- ghc-options: -Wcompat+ vector