From 9ec3ea6720ed2ab0df61e88ea408c4d1ea79c849 Mon Sep 17 00:00:00 2001 From: luoyaoming Date: Thu, 17 Nov 2022 09:46:08 +0800 Subject: [PATCH] Import Upstream version 0.4.2 --- CHANGELOG.md | 89 +++++ LICENSE | 30 ++ Setup.hs | 2 + src/Data/Witherable.hs | 163 +++++++++ src/Witherable.hs | 727 +++++++++++++++++++++++++++++++++++++++++ tests/tests.hs | 273 ++++++++++++++++ witherable.cabal | 55 ++++ 7 files changed, 1339 insertions(+) create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 src/Data/Witherable.hs create mode 100644 src/Witherable.hs create mode 100644 tests/tests.hs create mode 100644 witherable.cabal diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..1ba01b3 --- /dev/null +++ b/CHANGELOG.md @@ -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` diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1994a4c --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Witherable.hs b/src/Data/Witherable.hs new file mode 100644 index 0000000..51211f3 --- /dev/null +++ b/src/Data/Witherable.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Witherable +-- Copyright : (c) Fumiaki Kinoshita 2015 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- 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 , +-- 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 #-} diff --git a/src/Witherable.hs b/src/Witherable.hs new file mode 100644 index 0000000..a3cf98e --- /dev/null +++ b/src/Witherable.hs @@ -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 +-- 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) diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 index 0000000..e54b22c --- /dev/null +++ b/tests/tests.hs @@ -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) diff --git a/witherable.cabal b/witherable.cabal new file mode 100644 index 0000000..1112ffa --- /dev/null +++ b/witherable.cabal @@ -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 +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