forked from openkylin/haskell-witherable
Import Upstream version 0.4.2
This commit is contained in:
luoyaoming
commit
9ec3ea6720
|
|
@ -0,0 +1,89 @@
|
|||
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
|
||||
-------
|
||||
|
||||
* Make `wither` and `witherM` methods of `Witherable []` instance
|
||||
good consumers for list fusion.
|
||||
* Added instances for `Reverse`, `Backwards`, `ZipList`, and types from `GHC.Generics`
|
||||
* Added `Wither`, `WitherLike`, `Wither'` and `WitherLike'`, deprecating `Filter` and the variants
|
||||
* Moved `Filterable` and `Witherable` into a separate package, `witherable-class`
|
||||
|
||||
0.3.4
|
||||
-------
|
||||
* Exported `WrappedFoldable`
|
||||
|
||||
0.3.3
|
||||
-------
|
||||
|
||||
* Added `FilterableWithIndex` and `WitherableWithIndex`.
|
||||
* Added `WrappedFoldable`
|
||||
|
||||
0.3.2
|
||||
----------
|
||||
|
||||
* Added `Filterable (MonoidalMap k)` and `Witherable (MonoidalMap k)`
|
||||
|
||||
0.3.1
|
||||
-------
|
||||
* Added `(<$?>)` as an alias for `mapMaybe`, with fixity matching `(<$>)`.
|
||||
* Added `(<&?>) = flip (<$?>)`, with fixity matching `(<&>)`.
|
||||
|
||||
0.3
|
||||
-------
|
||||
* Added `(Filterable f, Filterable g) => Filterable (Product f g)`
|
||||
* Added `(Witherable f, Witherable g) => Witherable (Product f g)`
|
||||
* Added `(Filterable f, Filterable g) => Filterable (Sum f g)`
|
||||
* Added `(Witherable f, Witherable g) => Witherable (Sum f g)`
|
||||
* Added `Filterable f => Filterable (IdentityT f)`
|
||||
* Added `Witherable f => Witherable (IdentityT f)`
|
||||
* Switched from strict `HashMap` operations to lazy ones. This
|
||||
matches the behavior of the rest of the instances.
|
||||
* Changed the definition of `witherM`
|
||||
|
||||
0.2
|
||||
-------
|
||||
* Added `Traversable t => Witherable (MaybeT t)`
|
||||
* New class: `Filterable`
|
||||
* `Witherable t` is equivalent to `(Traversable t, Filterable t)`
|
||||
* Removed `Chipped`
|
||||
|
||||
0.1.3.3
|
||||
-------
|
||||
* Added `forMaybeOf` and `forMaybe`
|
||||
|
||||
0.1.3.2
|
||||
-------
|
||||
* Exported `witherM`, `blightM`
|
||||
* Fixed the default definition of `catMaybes`
|
||||
|
||||
0.1.3
|
||||
-------
|
||||
* Now `witherable` depends on `base-orphans` to prevent a tragedy of duplicate orphans
|
||||
* Added generalized combinators according to the `lens` convention
|
||||
|
||||
0.1.2.3
|
||||
-------
|
||||
* Added `ordNub`, `hashNub`
|
||||
* Data.Witherable is now Trustworthy
|
||||
|
||||
0.1.2.2
|
||||
-------
|
||||
* Added `Chipped`
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2014, Fumiaki Kinoshita
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Fumiaki Kinoshita nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE Trustworthy #-}
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.Witherable
|
||||
-- Copyright : (c) Fumiaki Kinoshita 2015
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>
|
||||
-- Stability : provisional
|
||||
-- Portability : non-portable
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Data.Witherable {-# DEPRECATED "Use Witherable instead" #-}
|
||||
( Filterable(..)
|
||||
, (<$?>)
|
||||
, (<&?>)
|
||||
, Witherable(..)
|
||||
, ordNub
|
||||
, ordNubOn
|
||||
, hashNub
|
||||
, hashNubOn
|
||||
, forMaybe
|
||||
-- * Indexed variants
|
||||
, FilterableWithIndex(..)
|
||||
, WitherableWithIndex(..)
|
||||
-- * Generalization
|
||||
, WitherLike, Wither, WitherLike', Wither'
|
||||
, FilterLike, Filter, FilterLike', Filter'
|
||||
, witherOf
|
||||
, forMaybeOf
|
||||
, mapMaybeOf
|
||||
, catMaybesOf
|
||||
, filterAOf
|
||||
, filterOf
|
||||
, ordNubOf
|
||||
, ordNubOnOf
|
||||
, hashNubOf
|
||||
, hashNubOnOf
|
||||
-- * Cloning
|
||||
, cloneFilter
|
||||
, Peat(..)
|
||||
-- * Wrapper
|
||||
, WrappedFoldable(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Functor.Identity
|
||||
import Witherable
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.HashSet as HSet
|
||||
import Control.Monad.Trans.State.Strict
|
||||
import Data.Hashable
|
||||
import Data.Coerce
|
||||
|
||||
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 = (\a -> a `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 #-}
|
||||
|
||||
-- | Remove the duplicate elements through a filter.
|
||||
ordNubOf :: Ord a => FilterLike' (State (Set.Set a)) s a -> s -> s
|
||||
ordNubOf w = ordNubOnOf w id
|
||||
|
||||
-- | Remove the duplicate elements through a filter.
|
||||
ordNubOnOf :: Ord b => FilterLike' (State (Set.Set b)) s a -> (a -> b) -> s -> s
|
||||
ordNubOnOf w p t = evalState (w f t) Set.empty
|
||||
where
|
||||
f a = let b = p a in state $ \s -> if Set.member b s
|
||||
then (Nothing, s)
|
||||
else (Just a, Set.insert b 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 = hashNubOnOf w id
|
||||
|
||||
-- | Remove the duplicate elements through a filter.
|
||||
hashNubOnOf :: (Eq b, Hashable b) => FilterLike' (State (HSet.HashSet b)) s a -> (a -> b) -> s -> s
|
||||
hashNubOnOf w p t = evalState (w f t) HSet.empty
|
||||
where
|
||||
f a = let b = p a in state $ \s -> if HSet.member b s
|
||||
then (Nothing, s)
|
||||
else (Just a, HSet.insert b s)
|
||||
{-# INLINE hashNubOf #-}
|
||||
|
|
@ -0,0 +1,727 @@
|
|||
{-# 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 #-}
|
||||
|
||||
{-# 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)
|
||||
{-# 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)
|
||||
{-# 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 #-}
|
||||
|
||||
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
|
||||
|
||||
instance Filterable ZipList where
|
||||
mapMaybe f = ZipList . Maybe.mapMaybe f . getZipList
|
||||
catMaybes = ZipList . Maybe.catMaybes . getZipList
|
||||
filter f = ZipList . Prelude.filter f . getZipList
|
||||
|
||||
-- | 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
|
||||
|
||||
instance Witherable IM.IntMap where
|
||||
|
||||
instance Filterable (M.Map k) where
|
||||
mapMaybe = M.mapMaybe
|
||||
filter = M.filter
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
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 #-}
|
||||
|
||||
-- | @'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 #-}
|
||||
|
||||
-- | Indexed variant of 'Witherable'.
|
||||
class (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 . 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 'ordNub',
|
||||
-- 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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
cabal-version: 2.4
|
||||
name: witherable
|
||||
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
|
||||
license: BSD-3-Clause
|
||||
license-file: LICENSE
|
||||
author: Fumiaki Kinoshita
|
||||
maintainer: Fumiaki Kinoshita <fumiexcel@gmail.com>
|
||||
copyright: Copyright (c) 2014 Fumiaki Kinoshita
|
||||
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.4 || ==9.0.1
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/fumieval/witherable.git
|
||||
subdir: witherable
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Witherable
|
||||
Data.Witherable
|
||||
build-depends: base >=4.9 && <5,
|
||||
base-orphans >=0.8.4 && <0.9,
|
||||
containers >=0.5.7.1 && <0.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.2.0 && <0.13,
|
||||
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,
|
||||
QuickCheck >=2.14.2,
|
||||
quickcheck-instances,
|
||||
tasty,
|
||||
tasty-quickcheck,
|
||||
transformers,
|
||||
unordered-containers,
|
||||
vector
|
||||
Loading…
Reference in New Issue