witherable 0.4 → 0.4.1
raw patch · 5 files changed
+361/−34 lines, 5 filesdep +QuickCheckdep +quickcheck-instancesdep +tastydep −transformers-compatdep −voiddep ~basedep ~base-orphansdep ~containers
Dependencies added: QuickCheck, quickcheck-instances, tasty, tasty-quickcheck, witherable
Dependencies removed: transformers-compat, void
Dependency ranges changed: base, base-orphans, containers, hashable, indexed-traversable, indexed-traversable-instances, transformers, unordered-containers, vector
Files
- CHANGELOG.md +8/−0
- src/Data/Witherable.hs +19/−6
- src/Witherable.hs +95/−10
- tests/tests.hs +209/−0
- witherable.cabal +30/−18
CHANGELOG.md view
@@ -1,3 +1,11 @@+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)
src/Data/Witherable.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Witherable@@ -17,7 +18,9 @@ , (<&?>) , Witherable(..) , ordNub+ , ordNubOn , hashNub+ , hashNubOn , forMaybe -- * Indexed variants , FilterableWithIndex(..)@@ -32,7 +35,9 @@ , filterAOf , filterOf , ordNubOf+ , ordNubOnOf , hashNubOf+ , hashNubOnOf -- * Cloning , cloneFilter , Peat(..)@@ -132,19 +137,27 @@ -- | Remove the duplicate elements through a filter. ordNubOf :: Ord a => FilterLike' (State (Set.Set a)) s a -> s -> s-ordNubOf w t = evalState (w f t) Set.empty+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 = state $ \s -> if Set.member a s+ f a = let b = p a in state $ \s -> if Set.member b s then (Nothing, s)- else (Just a, Set.insert a 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 t = evalState (w f t) HSet.empty+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 = state $ \s -> if HSet.member a s+ f a = let b = p a in state $ \s -> if HSet.member b s then (Nothing, s)- else (Just a, HSet.insert a s)+ else (Just a, HSet.insert b s) {-# INLINE hashNubOf #-}
src/Witherable.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE EmptyCase #-}+{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Witherable@@ -22,7 +23,9 @@ , (<&?>) , Witherable(..) , ordNub+ , ordNubOn , hashNub+ , hashNubOn , forMaybe -- * Indexed variants , FilterableWithIndex(..)@@ -37,7 +40,7 @@ import Control.Applicative.Backwards (Backwards (..)) import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe-import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.State.Lazy (evalState, state) import Data.Bool (bool) import Data.Coerce (coerce) import Data.Foldable.WithIndex@@ -65,6 +68,11 @@ import qualified Data.Set as Set import qualified Data.Traversable as T import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Fusion.Bundle as V.B+import qualified Data.Vector.Fusion.Bundle.Size as V.BS+import qualified Data.Vector.Fusion.Bundle.Monadic as V.MB+import qualified Data.Vector.Fusion.Stream.Monadic as V.MS import qualified GHC.Generics as Generics import qualified Prelude @@ -237,12 +245,44 @@ {-# 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 f = unstreamM . bundleWitherM f . V.B.lift . VG.stream+ {-# INLINE witherM #-}++-- This is not yet in any released Vector+unstreamM :: Monad m => V.MB.Bundle m v a -> m (V.Vector a)+unstreamM s = do+ xs <- V.MB.toList s+ return $ VG.unstream $ V.B.unsafeFromList (V.MB.size s) xs+{-# INLINE unstreamM #-}++bundleWitherM :: Monad m => (a -> m (Maybe b)) -> V.MB.Bundle m v a -> V.MB.Bundle m v b+bundleWitherM g V.MB.Bundle {V.MB.sElems = s, V.MB.sSize = n} =+ V.MB.fromStream (streamWitherM g s) (V.BS.toMax n)+{-# INLINE bundleWitherM #-}++streamWitherM :: Monad m => (a -> m (Maybe b)) -> V.MS.Stream m a -> V.MS.Stream m b+streamWitherM g (V.MS.Stream step t) = V.MS.Stream step' t+ where+ {-# INLINE step' #-}+ step' s = do+ r <- step s+ case r of+ V.MS.Yield x s' -> do+ b <- g x+ case b of+ Just y -> return $ V.MS.Yield y s'+ Nothing -> return $ V.MS.Skip s'+ V.MS.Skip s' -> return $ V.MS.Skip s'+ V.MS.Done -> return $ V.MS.Done+{-# INLINE streamWitherM #-}+ instance Filterable S.Seq where mapMaybe f = S.fromList . mapMaybe f . F.toList {-# INLINABLE mapMaybe #-}@@ -591,23 +631,68 @@ -- | 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 t = evalState (witherM f t) Set.empty where- f a = state $ \s -> if Set.member a s- then (Nothing, s)- else (Just a, Set.insert a s)+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 t = evalState (witherM f t) HSet.empty- where- f a = state $ \s -> if HSet.member a s- then (Nothing, s)- else (Just a, HSet.insert a s)+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
+ tests/tests.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Main (main) where++import Control.Monad ((<=<))+import Control.Monad.Trans.State (runState, state)+import Data.Hashable (Hashable)+import Data.Coerce (coerce)+import Data.Function (on)+import Data.List (nub, nubBy)+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))+ ]++ , testGroup "Witherable"+ [ witherableLaws (Proxy @[])+ , witherableLaws (Proxy @Maybe)+ , witherableLaws (Proxy @(Either String))+ , witherableLaws (Proxy @V.Vector)+ , witherableLaws (Proxy @Seq.Seq)+ , witherableLaws (Proxy @IntMap.IntMap)+ , witherableLaws (Proxy @(Map.Map K))+ , witherableLaws (Proxy @(HashMap.HashMap K))+ ]++ , 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+ ]+ where+ prop_default_wither :: S -> Fun (A, S) (Maybe B, S) -> f A -> Property+ prop_default_wither s0 f' xs =+ runState (wither f xs) s0 === runState (fmap catMaybes (traverse f xs)) s0+ where+ f a = state $ \s -> applyFun f' (a, s)++ prop_default_witherM :: S -> Fun (A, S) (Maybe B, S) -> f A -> Property+ prop_default_witherM s0 f' xs =+ runState (witherM f xs) s0 === runState (wither f xs) s0+ where+ f a = state $ \s -> applyFun f' (a, s)++ prop_default_filterA :: S -> Fun (A, S) (Bool, S) -> f A -> Property+ prop_default_filterA s0 f' xs =+ runState (filterA f xs) s0 === runState (wither (\a -> (\b -> if b then Just a else Nothing) <$> f a) xs) s0+ where+ f a = state $ \s -> applyFun f' (a, s)++-------------------------------------------------------------------------------+-- 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
witherable.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: witherable-version: 0.4+version: 0.4.1 synopsis: filterable traversable description: A stronger variant of `traverse` which can remove elements and generalised mapMaybe, catMaybes, filter homepage: https://github.com/fumieval/witherable@@ -12,32 +12,44 @@ category: Data build-type: Simple extra-source-files: CHANGELOG.md-tested-With: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3, GHC == 8.8.1+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3 source-repository head type: git location: https://github.com/fumieval/witherable.git+ subdir: witherable library exposed-modules: Witherable Data.Witherable- -- other-modules:- -- other-extensions:- build-depends: base == 4.*,- base-orphans,- containers >= 0.5,- hashable,- transformers,- transformers-compat,- unordered-containers,- vector,- indexed-traversable,- indexed-traversable-instances,- if impl(ghc < 7.9)- build-depends: void+ 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 && <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- if (impl(ghc>=8))- ghc-options: -Wcompat++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