diff --git a/non-empty.cabal b/non-empty.cabal --- a/non-empty.cabal +++ b/non-empty.cabal @@ -1,5 +1,5 @@ Name: non-empty -Version: 0.2 +Version: 0.2.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -40,6 +40,10 @@ . * @Cardinality@:@NeverEmptyList@ . + * @mono-traversable@:@Data.MinLen@: + allows to specify a minimum number of elements using type families + and works also for monomorphic data structures like 'ByteString' + . * . Related packages: @@ -47,17 +51,22 @@ * @Stream@: Lists that contain always infinitely many elements. . + * @fixed-length@: + Uses the data structure of this package + and defines a closed-world class for fixed-length lists + and an according index type. + . * @fixed-list@: Uses the same data structure as this package but is intended for fixing the number of elements in a list. Requires multi-parameter type classes with functional dependencies. -Tested-With: GHC==7.4.1 +Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.1 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository this - Tag: 0.2 + Tag: 0.2.1 Type: darcs Location: http://code.haskell.org/~thielema/non-empty/ @@ -78,6 +87,7 @@ Data.NonEmpty Data.NonEmpty.Class Data.NonEmpty.Mixed + Data.NonEmpty.Match Data.NonEmpty.Set Data.NonEmpty.Map Data.Empty diff --git a/src/Data/Empty.hs b/src/Data/Empty.hs --- a/src/Data/Empty.hs +++ b/src/Data/Empty.hs @@ -58,3 +58,9 @@ -} instance C.Repeat T where repeat _ = Cons + +{- +This instance allows us to iterate on fixed length lists. +-} +instance C.Iterate T where + iterate _ _ = Cons diff --git a/src/Data/NonEmpty.hs b/src/Data/NonEmpty.hs --- a/src/Data/NonEmpty.hs +++ b/src/Data/NonEmpty.hs @@ -16,6 +16,7 @@ init, last, foldl1, + foldl1Map, foldBalanced, maximum, maximumBy, maximumKey, minimum, minimumBy, minimumKey, @@ -29,6 +30,7 @@ InsertBy(insertBy), scanl, scanr, Tails(tails), + inits, initsRev, RemoveEach(removeEach), ) where diff --git a/src/Data/NonEmpty/Class.hs b/src/Data/NonEmpty/Class.hs --- a/src/Data/NonEmpty/Class.hs +++ b/src/Data/NonEmpty/Class.hs @@ -185,6 +185,7 @@ repeat = List.repeat +-- might be replaced by Mixed.iterate based on Traversable class Repeat f => Iterate f where iterate :: (a -> a) -> a -> f a diff --git a/src/Data/NonEmpty/Map.hs b/src/Data/NonEmpty/Map.hs --- a/src/Data/NonEmpty/Map.hs +++ b/src/Data/NonEmpty/Map.hs @@ -3,25 +3,35 @@ insert, singleton, member, + size, + elems, + keys, + keysSet, lookup, minViewWithKey, maxViewWithKey, fromList, toAscList, + fetch, flatten, union, unionLeft, unionRight, ) where +import qualified Data.NonEmpty.Set as NonEmptySet import qualified Data.NonEmpty as NonEmpty import qualified Data.Map as Map import Data.Map (Map, ) import Control.Monad (mzero, ) +import Control.Applicative (liftA2, ) +import Data.Traversable (Traversable, traverse, ) +import Data.Foldable (Foldable, foldMap, ) +import Data.Monoid (mappend, ) import Data.Maybe (fromMaybe, ) -import Data.Tuple.HT (forcePair, ) +import Data.Tuple.HT (forcePair, mapSnd, ) import Data.Ord.HT (comparing, ) import Prelude hiding (lookup, ) @@ -39,7 +49,17 @@ showString "NonEmptyMap.fromList " . showsPrec 11 (toAscList xs) +instance (Ord k) => Functor (T k) where + fmap f (Cons x xs) = Cons (mapSnd f x) (fmap f xs) +instance (Ord k) => Foldable (T k) where + foldMap f (Cons x xs) = mappend (f (snd x)) (foldMap f xs) + +instance (Ord k) => Traversable (T k) where + traverse f (Cons x xs) = + liftA2 Cons (fmap ((,) (fst x)) $ f (snd x)) (traverse f xs) + + insert :: Ord k => k -> a -> Map k a -> T k a insert = curry $ insertGen fst @@ -60,6 +80,19 @@ member y (Cons x xs) = y == fst x || Map.member y xs +size :: T k a -> Int +size (Cons _ xs) = 1 + Map.size xs + +elems :: T k a -> NonEmpty.T [] a +elems (Cons x xs) = NonEmpty.cons (snd x) (Map.elems xs) + +keys :: T k a -> NonEmpty.T [] k +keys (Cons x xs) = NonEmpty.cons (fst x) (Map.keys xs) + +-- 'insert' could be optimized to 'Cons' +keysSet :: (Ord k) => T k a -> NonEmptySet.T k +keysSet (Cons x xs) = NonEmptySet.insert (fst x) (Map.keysSet xs) + lookup :: (Ord k) => k -> T k a -> Maybe a lookup y (Cons x xs) = if y == fst x @@ -81,6 +114,9 @@ toAscList :: T k a -> NonEmpty.T [] (k,a) toAscList (Cons x xs) = NonEmpty.cons x $ Map.toAscList xs + +fetch :: (Ord k) => Map k a -> Maybe (T k a) +fetch = fmap (uncurry Cons) . Map.minViewWithKey flatten :: (Ord k) => T k a -> Map k a flatten (Cons x xs) = uncurry Map.insert x xs diff --git a/src/Data/NonEmpty/Match.hs b/src/Data/NonEmpty/Match.hs new file mode 100644 --- /dev/null +++ b/src/Data/NonEmpty/Match.hs @@ -0,0 +1,51 @@ +{- | +Generalized version of utility-ht:"Data.List.Match". +-} +module Data.NonEmpty.Match (take, replicate) where + +import qualified Data.NonEmpty.Class as C + +import Control.Functor.HT (void, ) + +import Prelude hiding (take, replicate, ) + + +{- | Make a list as long as another one -} +{- +@flip (zipWith const)@ is not as lazy, +e.g. would be @take [] undefined = undefined@, +but it should be @take [] undefined = []@. +-} +take :: (C.Zip f) => f b -> f a -> f a +take = C.zipWith (flip const) + + +{- | +Check whether two lists with different element types have equal length. +It is equivalent to @length xs == length ys@ but more efficient. +-} +{- +I'd prefer a type constructor class Eq +-} +_equalLength :: (Functor f, Eq (f ())) => f a -> f b -> Bool +_equalLength xs ys = + void xs == void ys + +{- | +Compare the length of two lists over different types. +It is equivalent to @(compare (length xs) (length ys))@ +but more efficient. +-} +{- +I'd prefer a type constructor class Ord +-} +_compareLength :: (Functor f, Ord (f ())) => f a -> f b -> Ordering +_compareLength xs ys = + compare (void xs) (void ys) + + +{- | +the same as @($>)@ +-} +replicate :: (Functor f) => f a -> b -> f b +replicate xs y = fmap (const y) xs diff --git a/src/Data/NonEmpty/Mixed.hs b/src/Data/NonEmpty/Mixed.hs --- a/src/Data/NonEmpty/Mixed.hs +++ b/src/Data/NonEmpty/Mixed.hs @@ -3,16 +3,20 @@ If there are two versions of a function, where one works on fixed-length lists, -the place the fixed-length list variant to NonEmpty +then place the fixed-length list variant in NonEmpty and the other one here. -} module Data.NonEmpty.Mixed where import qualified Data.NonEmpty.Class as C import qualified Data.NonEmpty as NonEmpty +import qualified Data.Empty as Empty +import qualified Data.List.HT as ListHT +import Data.Traversable (Traversable, mapAccumL, sequenceA, ) import Data.Foldable (Foldable, foldr, ) +import Data.Tuple.HT (mapFst, mapSnd, ) -import Prelude hiding (foldr, scanl, scanr, ) +import Prelude hiding (splitAt, take, foldr, scanl, scanr, ) groupBy :: @@ -31,6 +35,20 @@ in NonEmpty.Cons x0 xr : yr) [] +segmentAfter :: + (Foldable f) => + (a -> Bool) -> f a -> ([NonEmpty.T [] a], [a]) +segmentAfter p = + foldr + (\x ~(ys,zs) -> + if p x + then (NonEmpty.singleton x : ys, zs) + else + case ys of + [] -> (ys, x:zs) + w:ws -> (C.cons x w : ws, zs)) + ([],[]) + segmentBefore :: (Foldable f) => (a -> Bool) -> f a -> ([a], [NonEmpty.T [] a]) @@ -42,12 +60,55 @@ else (x : fst ys, snd ys)) ([],[]) +filterToInfixes :: + (Foldable f) => + (a -> Bool) -> f a -> [NonEmpty.T [] a] +filterToInfixes p = + let cons = uncurry $ maybe id (:) . NonEmpty.fetch + in cons . + foldr + (\x yzs -> + if p x + then mapFst (x:) yzs + else ([], cons yzs)) + ([], []) + mapAdjacent :: (C.Cons f, C.Zip f) => (a -> a -> b) -> NonEmpty.T f a -> f b mapAdjacent f xs = C.zipWith f (NonEmpty.flatten xs) (NonEmpty.tail xs) +take :: + (C.View g, C.Repeat f, Traversable f) => + g a -> Maybe (f a) +take = fst . splitAt + +splitAt :: + (C.View g, C.Repeat f, Traversable f) => + g a -> (Maybe (f a), g a) +splitAt xs0 = + (\(xs1, mys) -> (mys, maybe xs0 (const xs1) mys)) $ + mapSnd sequenceA $ + mapAccumL + (\xt () -> + case C.viewL xt of + Nothing -> (xt, Nothing) + Just (x,xs) -> (xs, Just x)) + xs0 (C.repeat ()) + +sliceVertical :: + (C.View g, C.Repeat f, Traversable f) => + g a -> ([f a], g a) +sliceVertical x0 = + case splitAt x0 of + (my,x1) -> + case my of + Nothing -> ([], x1) + Just y -> mapFst (y:) $ sliceVertical x1 + + + {- | This implementation is more efficient for Sequence than 'NonEmpty.viewR'. -} @@ -88,3 +149,30 @@ appendLeft :: (C.Cons f) => [a] -> f a -> f a appendLeft = flip $ foldr C.cons + + +iterate :: (C.Repeat f, Traversable f) => (a -> a) -> a -> f a +iterate f x0 = + snd $ mapAccumL (\xi fi -> (fi xi, xi)) x0 $ C.repeat f + + +class Choose f where + {- | + Select tuples of list elements: + @choose "abc" == ['a'!:'b'!:empty,'a'!:'c'!:empty,'b'!:'c'!:empty]@ + -} + choose :: [a] -> [f a] + +instance Choose Empty.T where + choose _ = [Empty.Cons] + +instance (Choose f) => Choose (NonEmpty.T f) where + choose xs = do + (y:ys) <- ListHT.tails xs + map (NonEmpty.cons y) $ choose ys + +instance Choose [] where + choose [] = [[]] + choose (x:xs) = + let ys = choose xs + in map (x:) ys ++ ys diff --git a/src/Data/NonEmpty/Set.hs b/src/Data/NonEmpty/Set.hs --- a/src/Data/NonEmpty/Set.hs +++ b/src/Data/NonEmpty/Set.hs @@ -3,6 +3,7 @@ insert, singleton, member, + size, minView, maxView, fromList, @@ -75,6 +76,9 @@ member :: (Ord a) => a -> T a -> Bool member y (Cons x xs) = y==x || Set.member y xs + +size :: T a -> Int +size (Cons _ xs) = 1 + Set.size xs minView :: T a -> (a, Set a) minView (Cons x xs) = (x,xs) diff --git a/src/Data/NonEmptyPrivate.hs b/src/Data/NonEmptyPrivate.hs --- a/src/Data/NonEmptyPrivate.hs +++ b/src/Data/NonEmptyPrivate.hs @@ -19,9 +19,11 @@ import Data.Functor (Functor, fmap, ) import Data.Function (flip, const, ($), (.), ) import Data.Maybe (Maybe(Just, Nothing), maybe, mapMaybe, ) +import Data.Bool.HT (if', ) +import Data.Bool (Bool(True), (&&), ) import Data.Ord (Ord, Ordering(GT), (<), (>), compare, comparing, ) import Data.Eq ((==), ) -import Data.Tuple.HT (mapSnd, swap, ) +import Data.Tuple.HT (mapFst, mapSnd, swap, ) import Data.Tuple (fst, snd, ) import qualified Prelude as P import Prelude (Eq, Show, Num, uncurry, ) @@ -170,6 +172,16 @@ fetch = fmap (uncurry Cons) . C.viewL +{- | +Caution: +@viewL (NonEmpty.Cons x []) = Nothing@ +because the tail is empty, and thus cannot be NonEmpty! + +This instance mainly exist to allow cascaded applications of 'fetch'. +-} +instance C.ViewL f => C.ViewL (T f) where + viewL (Cons x xs) = fmap ((,) x) $ fetch xs + instance C.Cons f => C.Cons (T f) where cons x0 (Cons x1 xs) = x0 !: C.cons x1 xs @@ -224,12 +236,12 @@ {- | It holds: -> foldl1Map g f = foldl1 f . fmap g +> foldl1Map f g = foldl1 f . fmap g but 'foldl1Map' does not need a 'Functor' instance. -} -foldl1Map :: (Foldable f) => (a -> b) -> (b -> b -> b) -> T f a -> b -foldl1Map g f (Cons x xs) = Fold.foldl (\b a -> f b (g a)) (g x) xs +foldl1Map :: (Foldable f) => (b -> b -> b) -> (a -> b) -> T f a -> b +foldl1Map f g (Cons x xs) = Fold.foldl (\b a -> f b (g a)) (g x) xs -- cf. NumericPrelude: Algebra.Additive.sumNestedCommutative @@ -292,15 +304,17 @@ maximumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a maximumKey f = snd . - foldl1Map (attachKey f) + foldl1Map (\ky0 ky1 -> if fst ky0 < fst ky1 then ky1 else ky0) + (attachKey f) -- | minimumKey is a total function minimumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a minimumKey f = snd . - foldl1Map (attachKey f) + foldl1Map (\ky0 ky1 -> if fst ky0 > fst ky1 then ky1 else ky0) + (attachKey f) -- | maximumKey is a total function _maximumKey :: (Ord b, Foldable f, Functor f) => (a -> b) -> T f a -> a @@ -489,8 +503,23 @@ Seq.EmptyL -> (y, xt) w Seq.:< ws -> (w, ws Seq.>< y Seq.<| zs) +{- +Certainly not as efficient as insertBy as class method +since all elements of the list are touched. +-} +insertByTraversable :: + (Traversable f) => + (a -> a -> Ordering) -> a -> f a -> T f a +insertByTraversable cmp y0 = + uncurry (flip snoc . snd) . + mapAccumL + (\(searching,y) x -> + let stillSearching = searching && cmp y x == GT + in mapFst ((,) stillSearching) $ if' stillSearching (y,x) (x,y)) + (True, y0) + class Functor f => RemoveEach f where removeEach :: T f a -> T f (a, f a) @@ -521,7 +550,7 @@ tails :: (C.Cons g, C.Empty g) => f a -> T f (g a) instance Tails [] where - tails = tailsDefault + tails = tailsTraversable instance Tails Empty.T where tails Empty.Cons = Cons C.empty Empty.Cons @@ -539,20 +568,31 @@ Just x -> Cons (C.cons x C.empty) (Just C.empty) instance Tails Seq where - tails = tailsDefault + tails = tailsTraversable -tailsDefault :: - (C.Cons f, C.Empty f, C.ViewL f, Tails f, - C.Cons g, C.Empty g) => +tailsTraversable :: (Traversable f, C.Cons g, C.Empty g) => f a -> T f (g a) +tailsTraversable = + uncurry cons . mapAccumR (\xs x -> (C.cons x xs, xs)) C.empty + + +{- | +Only advised for structures with efficient appending of single elements +like 'Sequence'. +Alternatively you may consider 'initsRev'. +-} +inits :: + (Traversable f, C.Snoc g, C.Empty g) => f a -> T f (g a) -tailsDefault xt = - force $ - case C.viewL xt of - Nothing -> Cons C.empty C.empty - Just (x, xs) -> - case tails xs of - xss -> C.cons (C.cons x $ head xss) xss +inits = scanl C.snoc C.empty +{- +suggested in + +-} +initsRev :: + (Traversable f, C.Cons g, C.Empty g, C.Reverse g) => + f a -> T f (g a) +initsRev = fmap C.reverse . scanl (flip C.cons) C.empty {- Not exported by NonEmpty. diff --git a/src/Data/NonEmptyTest.hs b/src/Data/NonEmptyTest.hs --- a/src/Data/NonEmptyTest.hs +++ b/src/Data/NonEmptyTest.hs @@ -1,8 +1,36 @@ module Data.NonEmptyTest where +import qualified Data.NonEmpty.Mixed as NonEmptyMixed import qualified Data.NonEmptyPrivate as NonEmpty +import Control.Monad (guard, ) +import qualified Data.List.HT as ListHT +import Data.Tuple.HT (mapFst, ) + + foldBalanced :: NonEmpty.T [] Integer -> Bool foldBalanced xs = NonEmpty.foldBalanced (+) xs == NonEmpty.sum xs + + + +filterToInfixesAlt :: (a -> Bool) -> [a] -> [NonEmpty.T [] a] +filterToInfixesAlt p = + snd . + foldr + (\x ~(b1, yt) -> + let b0 = p x + in (b0, + if b0 + then uncurry (:) $ + mapFst (NonEmpty.cons x) $ + case guard b1 >> ListHT.viewL yt of + Just (y,ys) -> (NonEmpty.flatten y, ys) + Nothing -> ([], yt) + else yt)) + (True, []) + +filterToInfixes :: [Int] -> Bool +filterToInfixes xs = + NonEmptyMixed.filterToInfixes (>0) xs == filterToInfixesAlt (>0) xs diff --git a/src/Data/Optional.hs b/src/Data/Optional.hs --- a/src/Data/Optional.hs +++ b/src/Data/Optional.hs @@ -17,12 +17,12 @@ import qualified Test.QuickCheck as QC import Control.Monad (return, ) -import Data.Functor (Functor, fmap, ) +import Data.Functor (fmap, ) import Data.Function (($), (.), ) import Data.Ord (Ord, Ordering(GT), (>), ) import Data.Tuple.HT (mapSnd, ) import qualified Prelude as P -import Prelude (Eq, Show, Num, uncurry, ) +import Prelude (Eq, uncurry, ) data T f a = Nil | Cons a (f a)