diff --git a/src/Data/Witherable.hs b/src/Data/Witherable.hs --- a/src/Data/Witherable.hs +++ b/src/Data/Witherable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, UndecidableInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -11,7 +12,26 @@ -- Portability : non-portable -- ----------------------------------------------------------------------------- -module Data.Witherable where +module Data.Witherable (Witherable(..) + , ordNub + , hashNub + -- * Generalization + , FilterLike, Filter, FilterLike', Filter' + , witherOf + , mapMaybeOf + , catMaybesOf + , filterAOf + , filterOf + , ordNubOf + , hashNubOf + -- * Cloning + , cloneFilter + , Dungeon(..) + -- * Witherable from Traversable + , Chipped(..) + ) + +where import qualified Data.Maybe as Maybe import qualified Data.IntMap.Lazy as IM import qualified Data.Map.Lazy as M @@ -28,10 +48,56 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.State.Strict import Data.Monoid +import Data.Orphans () #if (MIN_VERSION_base(4,7,0)) import Data.Proxy #endif +type FilterLike f s t a b = (a -> f (Maybe b)) -> s -> f t +type Filter s t a b = forall f. Applicative f => FilterLike f s t a b +type FilterLike' f s a = FilterLike f s s a a +type Filter' s a = forall f. Applicative f => FilterLike' f s a + +newtype Dungeon a b t = Dungeon { runDungeon :: forall f. Applicative f => (a -> f (Maybe b)) -> f t } + +instance Functor (Dungeon a b) where + fmap f (Dungeon k) = Dungeon (fmap f . k) + {-# INLINE fmap #-} + +instance Applicative (Dungeon a b) where + pure a = Dungeon $ const (pure a) + {-# INLINE pure #-} + Dungeon f <*> Dungeon g = Dungeon $ \h -> f h <*> g h + {-# INLINE (<*>) #-} + +cloneFilter :: FilterLike (Dungeon a b) s t a b -> Filter s t a b +cloneFilter l f = (`runDungeon` f) . l (\a -> Dungeon $ \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 #-} + +-- | 'mapMaybe' through a filter. +mapMaybeOf :: FilterLike Identity s t a b -> (a -> Maybe b) -> s -> t +mapMaybeOf w f = runIdentity . w (Identity . f) +{-# INLINE mapMaybeOf #-} + +-- | 'catMaybes' through a filter. +catMaybesOf :: FilterLike Identity s t (Maybe a) a -> s -> t +catMaybesOf w = mapMaybeOf w id +{-# INLINE catMaybesOf #-} + +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 (Identity . f) +{-# INLINE filterOf #-} + -- | Like `traverse`, but you can remove elements instead of updating them. -- -- @'traverse' f ≡ 'wither' ('fmap' 'Just' . f)@ @@ -53,20 +119,21 @@ wither :: Applicative f => (a -> f (Maybe b)) -> t a -> f (t b) wither f = fmap catMaybes . T.traverse f + {-# INLINE wither #-} mapMaybe :: (a -> Maybe b) -> t a -> t b - mapMaybe f = runIdentity . wither (Identity . f) + mapMaybe = mapMaybeOf wither {-# INLINE mapMaybe #-} catMaybes :: t (Maybe a) -> t a - catMaybes = mapMaybe id + catMaybes = catMaybesOf wither {-# INLINE catMaybes #-} 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) + filterA = filterAOf wither filter :: (a -> Bool) -> t a -> t a - filter f = runIdentity . filterA (Identity . f) + filter = filterOf wither {-# INLINE filter #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 {-# MINIMAL wither | mapMaybe | catMaybes #-} @@ -81,28 +148,40 @@ blightM = flip witherM {-# INLINE blightM #-} --- | Removes duplicate elements from a list, keeping only the first --- occurrence. This is exponentially quicker than using --- 'Data.List.nub' from 'Data.List'. -ordNub :: (Witherable t, Ord a) => t a -> t a -ordNub t = evalState (filterA f t) Set.empty +-- | Remove the duplicate elements through a filter. +ordNubOf :: Ord a => FilterLike' (State (Set.Set a)) s a -> s -> s +ordNubOf w t = evalState (filterAOf w f t) Set.empty where f a = state $ \s -> case Set.member a s of True -> (False, s) False -> (True, Set.insert a s) -{-# INLINE ordNub #-} +{-# INLINE ordNubOf #-} --- | Removes duplicate elements from a list, keeping only the first --- occurrence. This is usually faster than 'ordNub', especially for --- things that have a slow comparion (like 'String') -hashNub :: (Witherable t, Eq a, Hashable a) => t a -> t a -hashNub t = evalState (filterA f t) HSet.empty +-- | 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 (filterAOf w f t) HSet.empty where f a = state $ \s -> case HSet.member a s of True -> (False, s) False -> (True, HSet.insert a s) +{-# INLINE hashNubOf #-} + +-- | Removes duplicate elements from a list, keeping only the first +-- occurrence. This is exponentially quicker than using +-- 'Data.List.nub' from 'Data.List'. +ordNub :: (Witherable t, Ord a) => t a -> t a +ordNub = ordNubOf wither +{-# INLINE ordNub #-} + +-- | Removes duplicate elements from a list, keeping only the first +-- occurrence. This is usually faster than 'ordNub', especially for +-- things that have a slow comparion (like 'String') +-- hashNubOf :: (Witherable t, Eq a, Hashable a) => t a -> t a +hashNub :: (Witherable t, Eq a, Hashable a) => t a -> t a +hashNub = hashNubOf wither {-# INLINE hashNub #-} instance Witherable Maybe where @@ -148,22 +227,6 @@ #if (MIN_VERSION_base(4,7,0)) instance Witherable Proxy where wither _ Proxy = pure Proxy -#endif - -#if !(MIN_VERSION_base(4,7,0)) -instance F.Foldable (Const r) where - foldMap _ _ = mempty - -instance T.Traversable (Const r) where - traverse _ (Const r) = pure (Const r) - -instance F.Foldable (Either a) where - foldMap _ (Left _) = mempty - foldMap f (Right a) = f a - -instance T.Traversable (Either a) where - traverse _ (Left x) = pure (Left x) - traverse f (Right y) = Right <$> f y #endif instance Witherable (Const r) where diff --git a/witherable.cabal b/witherable.cabal --- a/witherable.cabal +++ b/witherable.cabal @@ -1,22 +1,28 @@ -name: witherable -version: 0.1.2.3 -synopsis: Generalization of filter and catMaybes --- description: -homepage: https://github.com/fumieval/witherable -license: BSD3 -license-file: LICENSE -author: Fumiaki Kinoshita -maintainer: Fumiaki Kinoshita -copyright: Copyright (c) 2014 Fumiaki Kinoshita -category: Data -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 - -library - exposed-modules: Data.Witherable - -- other-modules: - -- other-extensions: - build-depends: base == 4.*, containers, vector, unordered-containers, hashable, transformers - hs-source-dirs: src - default-language: Haskell2010 +name: witherable +version: 0.1.3 +synopsis: Generalization of filter and catMaybes +-- description: +homepage: https://github.com/fumieval/witherable +license: BSD3 +license-file: LICENSE +author: Fumiaki Kinoshita +maintainer: Fumiaki Kinoshita +copyright: Copyright (c) 2014 Fumiaki Kinoshita +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Data.Witherable + -- other-modules: + -- other-extensions: + build-depends: base == 4.*, + base-orphans, + containers, + hashable, + transformers, + unordered-containers, + vector + hs-source-dirs: src + default-language: Haskell2010