non-empty 0.0 → 0.1

raw patch · 6 files changed

+431/−134 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• non-empty.cabal +7/−2
• src/Data/Empty.hs +46/−0
• src/Data/NonEmpty.hs +10/−8
• src/Data/NonEmpty/Class.hs +36/−29
• src/Data/NonEmpty/Mixed.hs +15/−48
• src/Data/NonEmptyPrivate.hs +317/−47

@@ -1,5 +1,5 @@ Name:             non-empty-Version:          0.0+Version:          0.1 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -20,6 +20,10 @@   .   Similar packages:   .+  * @semigroups@, @semigroupoids@:+    restricted to lists, minimum number of elements: 1,+    provides more type classes tailored to the use of non-empty lists.+  .   * @NonEmptyList@:     restricted to lists, minimum number of elements: 1   .@@ -46,7 +50,7 @@ Build-Type:       Simple  Source-Repository this-  Tag:         0.0+  Tag:         0.1   Type:        darcs   Location:    http://code.haskell.org/~thielema/non-empty @@ -66,5 +70,6 @@     Data.NonEmpty     Data.NonEmpty.Class     Data.NonEmpty.Mixed+    Data.Empty   Other-Modules:     Data.NonEmptyPrivate

@@ -0,0 +1,46 @@+module Data.Empty where++import qualified Data.NonEmpty.Class as C++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Control.Applicative (pure, )++import qualified Test.QuickCheck as QC+++data T a = Cons+   deriving (Eq, Ord)++instance Show (T a) where+   show Cons = "Empty.Cons"++instance C.Show T where+   showsPrec _p Cons = showString "Empty.Cons"++instance Functor T where+   fmap _ Cons = Cons++instance Fold.Foldable T where+   foldr _ y Cons = y++instance Trav.Traversable T where+   sequenceA Cons = pure Cons++instance C.View T where+   viewL _ = Nothing++instance QC.Arbitrary (T a) where+   arbitrary = return Cons+   shrink _ = []++instance C.Empty T where+   empty = Cons++instance C.Zip T where+   zipWith _f Cons Cons = Cons++instance C.Reverse T where reverse = id++instance C.Sort T where+   sortBy _ Cons = Cons

@@ -4,7 +4,6 @@    force,    apply,    bind,-   Empty(Empty),    toList,    flatten,    fetch,@@ -16,17 +15,20 @@    init,    last,    foldl1,-   maximum,-   minimum,+   maximum, maximumBy, maximumKey,+   minimum, minimumBy, minimumKey,    sum,    product,-   append,+   append, appendLeft, appendRight,    cycle,    zipWith,-   sortBy,-   sort,-   insertBy,-   insert,+   mapAdjacent,+   sortBy, sort,+   Insert(insertBy), insert,+   scanl, scanr,+   transposeClip,+   Tails(tails),+   RemoveEach(removeEach),    ) where  import Data.NonEmptyPrivate

@@ -1,13 +1,13 @@ module Data.NonEmpty.Class where +import qualified Data.List.HT as ListHT import qualified Data.List as List import Control.Monad (liftM2, )-import Data.Tuple.HT (forcePair, mapSnd, )-import qualified Data.List.HT as ListHT  import qualified Test.QuickCheck as QC -import Prelude hiding (zipWith, )+import qualified Prelude as P+import Prelude hiding (Show, showsPrec, zipWith, reverse, )   class Empty f where@@ -56,7 +56,14 @@ infixr 5 `cons`, `append`  -class Zip f where+{- |+It must hold:++> fmap f xs+>    = zipWith (\x _ -> f x) xs xs+>    = zipWith (\_ x -> f x) xs xs+-}+class Functor f => Zip f where    zipWith :: (a -> b -> c) -> f a -> f b -> f c  instance Zip [] where@@ -69,43 +76,43 @@ zip = zipWith (,)  +class Repeat f where+   repeat :: a -> f a++instance Repeat [] where+   repeat = List.repeat++ class Sort f where    sortBy :: (a -> a -> Ordering) -> f a -> f a-   insertBy :: (a -> a -> Ordering) -> a -> f a -> (a, f a)  instance Sort [] where    sortBy = List.sortBy-   insertBy f y xt =-      forcePair $-      case xt of-         [] -> (y, xt)-         x:xs ->-            case f y x of-               GT -> (x, List.insertBy f y xs)-               _ -> (y, xt)  instance Sort Maybe where    sortBy _f = id-   insertBy f y mx =-      forcePair $-      case mx of-         Nothing -> (y, Nothing)-         Just x ->-            mapSnd Just $-            case f y x of-               GT -> (x, y)-               _ -> (y, x)  sort :: (Ord a, Sort f) => f a -> f a sort = sortBy compare -{- |-Insert an element into an ordered list while preserving the order.-The first element of the resulting list is returned individually.-We need this for construction of a non-empty list.--}-insert :: (Ord a, Sort f) => a -> f a -> (a, f a)-insert = insertBy compare++class Reverse f where+   reverse :: f a -> f a++instance Reverse [] where reverse = P.reverse+instance Reverse Maybe where reverse = id+++class Show f where+   showsPrec :: P.Show a => Int -> f a -> ShowS++instance Show [] where+   showsPrec p xs =+      if null xs+        then showString "[]"+        else showParen (p>5) $+             foldr (.) (showString "[]") $+             map (\x -> P.showsPrec 6 x . showString ":") xs   class Arbitrary f where

@@ -1,16 +1,18 @@ {- | Functions that cope both with plain and non-empty structures.++If there are two versions of a function,+where one works on fixed-length lists,+the place the fixed-length list variant to NonEmpty+and the other one here. -}-module Data.NonEmpty.Mixed (-   module Data.NonEmpty.Mixed,-   Priv.appendRight) where+module Data.NonEmpty.Mixed where  import qualified Data.NonEmpty.Class as C-import qualified Data.NonEmptyPrivate as Priv import qualified Data.NonEmpty as NonEmpty import Data.Foldable (Foldable, foldr, ) -import Prelude hiding (foldr, )+import Prelude hiding (foldr, scanl, scanr, )   groupBy ::@@ -40,51 +42,12 @@            else (x : fst ys, snd ys))       ([],[]) -scanl :: (a -> b -> a) -> a -> [b] -> NonEmpty.T [] a-scanl f =-   let go a bt =-          NonEmpty.Cons a $-          case bt of-             [] -> []-             b:bs -> NonEmpty.flatten $ go (f a b) bs-   in  go--{--Fusable and generic, but not as lazy as 'scanl'.--}-genericScanl ::-   (Foldable f) =>-   (a -> b -> a) -> a -> f b -> NonEmpty.T [] a-genericScanl f a0 xs =-   NonEmpty.force $-   foldr-      (\ b go a ->-          NonEmpty.Cons a $ NonEmpty.flatten $ go $ f a b)-      (\ a -> NonEmpty.Cons a [])-      xs-      a0---insertBy ::-   (C.Sort f) =>-   (a -> a -> Ordering) -> a -> f a -> NonEmpty.T f a-insertBy f y xs = uncurry NonEmpty.Cons $ C.insertBy f y xs--insert :: (Ord a, C.Sort f) => a -> f a -> NonEmpty.T f a-insert = insertBy compare+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)  -infixl 5 `appendLeft`--appendLeft ::-   (C.Append f, C.View f, C.Cons f) =>-   f a -> NonEmpty.T f a -> NonEmpty.T f a-appendLeft xt yt =-   NonEmpty.force $-   case C.viewL xt of-      Nothing -> yt-      Just (x,xs) -> NonEmpty.Cons x $ C.append xs $ NonEmpty.flatten yt- tails ::    (C.View f, C.Empty f) =>    f a -> NonEmpty.T [] (f a)@@ -102,3 +65,7 @@    case C.viewL xt of       Nothing -> []       Just (x,xs) -> map (C.cons x) $ NonEmpty.flatten $ inits xs+++appendLeft :: (C.Cons f) => [a] -> f a -> f a+appendLeft = flip $ foldr C.cons

@@ -1,19 +1,23 @@ module Data.NonEmptyPrivate where  import qualified Data.NonEmpty.Class as C+import qualified Data.Empty as Empty  import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold-import Data.Traversable (Traversable, )+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Traversable (Traversable, mapAccumL, mapAccumR) import Data.Foldable (Foldable, ) import Control.Monad (Monad, return, (=<<), ) import Control.Applicative (Applicative, liftA2, pure, (<*>), )  import Data.Functor (Functor, fmap, ) import Data.Function (flip, const, ($), (.), )-import Data.Maybe (Maybe(Just, Nothing), maybe, )-import Data.Ord (Ord, Ordering(GT), compare, )-import Data.Tuple.HT (forcePair, )+import Data.Maybe (Maybe(Just, Nothing), maybe, mapMaybe, )+import Data.Ord (Ord, Ordering(GT), (<), (>), compare, comparing, )+import Data.Tuple.HT (mapSnd, )+import Data.Tuple (fst, snd, ) import qualified Prelude as P import Prelude (Eq, Show, Num, uncurry, ) @@ -44,11 +48,19 @@ * @T (T Empty) a@ is a list that contains exactly two elements. -} data T f a = Cons { head :: a, tail :: f a }-   deriving (Eq, Ord, Show)+   deriving (Eq, Ord) +instance (C.Show f, Show a) => Show (T f a) where+   showsPrec = C.showsPrec -infixr 5 !:, `append`, `appendRight`+instance (C.Show f) => C.Show (T f) where+   showsPrec p (Cons x xs) =+      P.showParen (p>5) $+      P.showsPrec 6 x . P.showString "!:" . C.showsPrec 5 xs ++infixr 5 !:, `append`, `appendRight`, `appendLeft`+ (!:) :: a -> f a -> T f a (!:) = Cons @@ -122,26 +134,6 @@    appendRight (k x) (flatten . k =<< xs)  -data Empty a = Empty-   deriving (Eq, Ord, Show)--instance Functor Empty where-   fmap _ Empty = Empty--instance Foldable Empty where-   foldr _ y Empty = y--instance Traversable Empty where-   sequenceA Empty = pure Empty--instance C.View Empty where-   viewL _ = Nothing--instance QC.Arbitrary (Empty a) where-   arbitrary = return Empty-   shrink _ = []-- toList :: Foldable f => T f a -> [a] toList (Cons x xs) = x : Fold.toList xs @@ -158,9 +150,11 @@ cons :: C.Cons f => a -> T f a -> T f a cons x0 (Cons x1 xs) = x0 !: C.cons x1 xs +-- snoc :: T f a -> a -> T f a+snocExtend :: Traversable f => f a -> a -> T f a+snocExtend xs y0 =+   uncurry Cons $ mapAccumR (\y x -> (x,y)) y0 xs -instance C.Empty Empty where-   empty = Empty  instance C.Empty f => C.Singleton (T f) where    singleton = singleton@@ -168,10 +162,20 @@ singleton :: C.Empty f => a -> T f a singleton x = x !: C.empty -reverse :: (Foldable f, C.Cons f, C.Empty f) => T f a -> T f a-reverse (Cons x xs) =-   Fold.foldl (flip cons) (singleton x) xs +{-+This implementation needs quadratic time+with respect to the number of 'Cons'.+Maybe a linear time solution can be achieved using a type function+that maps a container type to the type of the reversed container.+-}+reverse :: (Traversable f, C.Reverse f) => T f a -> T f a+reverse (Cons x xs) = snocExtend (C.reverse xs) x++instance (Traversable f, C.Reverse f) => C.Reverse (T f) where+   reverse = reverse++ mapHead :: (a -> a) -> T f a -> T f a mapHead f (Cons x xs) = f x !: xs @@ -187,7 +191,17 @@ foldl1 :: (Foldable f) => (a -> a -> a) -> T f a -> a foldl1 f (Cons x xs) = Fold.foldl f x xs +{- |+It holds: +> foldl1Map g f = 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++ -- | maximum is a total function maximum :: (Ord a, Foldable f) => T f a -> a maximum = foldl1 P.max@@ -196,6 +210,41 @@ minimum :: (Ord a, Foldable f) => T f a -> a minimum = foldl1 P.min +-- | maximumBy is a total function+maximumBy :: (Foldable f) => (a -> a -> Ordering) -> T f a -> a+maximumBy f = foldl1 (\x y -> case f x y of P.LT -> y; _ -> x)++-- | minimumBy is a total function+minimumBy :: (Foldable f) => (a -> a -> Ordering) -> T f a -> a+minimumBy f = foldl1 (\x y -> case f x y of P.GT -> y; _ -> x)++-- | maximumKey is a total function+maximumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a+maximumKey f =+   snd .+   foldl1Map (attachKey f)+      (\ky0 ky1 -> if fst ky0 < fst ky1 then ky1 else ky0)++-- | minimumKey is a total function+minimumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a+minimumKey f =+   snd .+   foldl1Map (attachKey f)+      (\ky0 ky1 -> if fst ky0 > fst ky1 then ky1 else ky0)++-- | maximumKey is a total function+_maximumKey :: (Ord b, Foldable f, Functor f) => (a -> b) -> T f a -> a+_maximumKey f =+   snd . maximumBy (comparing fst) . fmap (attachKey f)++-- | minimumKey is a total function+_minimumKey :: (Ord b, Foldable f, Functor f) => (a -> b) -> T f a -> a+_minimumKey f =+   snd . minimumBy (comparing fst) . fmap (attachKey f)++attachKey :: (a -> b) -> a -> (b, a)+attachKey f a = (f a, a)+ -- | sum does not need a zero for initialization sum :: (Num a, Foldable f) => T f a -> a sum = foldl1 (P.+)@@ -214,6 +263,20 @@ appendRight :: (C.Append f) => T f a -> f a -> T f a appendRight (Cons x xs) ys = Cons x (C.append xs ys) +appendLeft ::+   (C.Append f, C.View f, C.Cons f) =>+   f a -> T f a -> T f a+appendLeft xt yt =+   force $+   case C.viewL xt of+      Nothing -> yt+      Just (x,xs) -> Cons x $ C.append xs $ flatten yt+++{- |+generic variants:+'Data.Monoid.HT.cycle' or better @Semigroup.cycle@+-} cycle :: (C.Cons f, C.Append f) => T f a -> T f a cycle x =    let y = append x y@@ -227,32 +290,239 @@ zipWith f (Cons a as) (Cons b bs) = Cons (f a b) (C.zipWith f as bs)  -instance (C.Sort f) => C.Sort (T f) where+instance (C.Repeat f) => C.Repeat (T f) where+   repeat a = Cons a $ C.repeat a+++instance (C.Sort f, Insert f) => C.Sort (T f) where    sortBy = sortBy-   insertBy f y xt@(Cons x xs) =-      forcePair $-      case f y x of-         GT -> (x, uncurry Cons $ C.insertBy f y xs)-         _ -> (y, xt)  {- | If you nest too many non-empty lists then the efficient merge-sort (linear-logarithmic runtime) will degenerate to an inefficient insert-sort (quadratic runtime). -}-sortBy :: (C.Sort f) => (a -> a -> Ordering) -> T f a -> T f a+sortBy :: (C.Sort f, Insert f) => (a -> a -> Ordering) -> T f a -> T f a sortBy f (Cons x xs) =-   uncurry Cons $ C.insertBy f x $ C.sortBy f xs+   insertBy f x $ C.sortBy f xs -sort :: (Ord a, C.Sort f) => T f a -> T f a+sort :: (Ord a, C.Sort f, Insert f) => T f a -> T f a sort = sortBy compare -insertBy ::-   (C.Sort f, C.Cons f) =>-   (a -> a -> Ordering) -> a -> T f a -> T f a-insertBy f y = uncurry cons . C.insertBy f y -insert ::-   (Ord a, C.Sort f, C.Cons f) =>-   a -> T f a -> T f a++class Insert f where+   insertBy :: (a -> a -> Ordering) -> a -> f a -> T f a++instance (Insert f) => Insert (T f) where+   insertBy f y xt@(Cons x xs) =+      uncurry Cons $+      case f y x of+         GT -> (x, insertBy f y xs)+         _ -> (y, xt)++instance Insert Empty.T where+   insertBy _ x Empty.Cons = Cons x Empty.Cons++instance Insert [] where+   insertBy f y xt =+      uncurry Cons $+      case xt of+         [] -> (y, xt)+         x:xs ->+            case f y x of+               GT -> (x, List.insertBy f y xs)+               _ -> (y, xt)++instance Insert Maybe where+   insertBy f y mx =+      uncurry Cons $+      case mx of+         Nothing -> (y, Nothing)+         Just x ->+            mapSnd Just $+            case f y x of+               GT -> (x, y)+               _ -> (y, x)+++{- |+Insert an element into an ordered list while preserving the order.+The first element of the resulting list is returned individually.+We need this for construction of a non-empty list.+-}+insert :: (Ord a, Insert f, C.Sort f) => a -> f a -> T f a insert = insertBy compare++++class Functor f => RemoveEach f where+   removeEach :: T f a -> T f (a, f a)++instance RemoveEach [] where+   removeEach (Cons x xs) =+      Cons (x, xs) (fmap (mapSnd (x:)) $ ListHT.removeEach xs)++instance RemoveEach Empty.T where+   removeEach (Cons x Empty.Cons) = Cons (x, Empty.Cons) Empty.Cons++instance RemoveEach f => RemoveEach (T f) where+   removeEach (Cons x xs) =+      Cons (x, xs) (fmap (mapSnd (x !:)) $ removeEach xs)++instance RemoveEach Maybe where+   removeEach (Cons x0 xs) =+      (\ ~(a,b) -> Cons (x0, a) b) $+      case xs of+         Nothing -> (Nothing, Nothing)+         Just x1 -> (Just x1, Just (x1, Just x0))+++{-+It is somehow better than the variant in NonEmpty.Mixed,+since it can be applied to nested NonEmptys.+-}+class Tails f where+   tails :: (C.Cons g, C.Empty g) => f a -> T f (g a)++instance Tails [] where+   tails xt =+      force $+      case C.viewL xt of+         Nothing -> Cons C.empty C.empty+         Just (x, xs) ->+            case tails xs of+               xss -> cons (C.cons x $ head xss) xss++instance Tails Empty.T where+   tails Empty.Cons = Cons C.empty Empty.Cons++instance Tails f => Tails (T f) where+   tails (Cons x xs) =+      case tails xs of+         xss -> Cons (C.cons x $ head xss) xss++instance Tails Maybe where+   tails xs =+      force $+      case xs of+         Nothing -> Cons C.empty Nothing+         Just x -> Cons (C.cons x C.empty) (Just C.empty)++++newtype Zip f a = Zip {unZip :: f a}++instance Functor f => Functor (Zip f) where+   fmap f (Zip xs) = Zip $ fmap f xs++instance (C.Zip f, C.Repeat f) => Applicative (Zip f) where+   pure a = Zip $ C.repeat a+   Zip f <*> Zip x = Zip $ C.zipWith ($) f x++++{- |+Always returns a rectangular list+by clipping all dimensions to the shortest slice.+Be aware that @transpose [] == repeat []@.+-}+transposeClip ::+   (Traversable f, C.Zip g, C.Repeat g) =>+   f (g a) -> g (f a)+transposeClip =+   unZip . Trav.sequenceA . fmap Zip+++{-+Not exorted by NonEmpty.+I think the transposeClip function is better.+-}+class TransposeOuter f where+   transpose :: TransposeInner g => f (g a) -> g (f a)++instance TransposeOuter [] where+   transpose =+      let go [] = transposeStart+          go (xs : xss) = zipHeadTail xs $ go xss+      in  go++{-+We cannot define this instance,+because @transpose ([] !: [2] !: []) = [2 !: []]@++instance TransposeOuter f => TransposeOuter (T f) where+   transpose =+      let go (Cons xs xss) = zipHeadTail xs $ go xss+      in  go+-}++class TransposeInner g where+   transposeStart :: g a+   zipHeadTail :: (C.Singleton f, C.Cons f) => g a -> g (f a) -> g (f a)++instance TransposeInner [] where+   transposeStart = []+   zipHeadTail =+      let go (x:xs) (ys:yss) = C.cons x ys : go xs yss+          go [] yss = yss+          go xs [] = fmap C.singleton xs+      in  go++{-+We cannot define this instance,+because @transpose ([] :: [NonEmpty.T [] Int]) = []@,+but in order to satisfy the types it must be ([] !: []).++instance TransposeInner f => TransposeInner (T f) where+   transposeStart = Cons ??? transposeStart+   zipHeadTail (Cons x xs) (Cons ys yss) =+      Cons (C.cons x ys) (zipHeadTail xs yss)+-}++{-+transpose :: [[a]] -> [[a]]+transpose =+   let go [] = []+       go (xs : xss) = zipHeadTail xs $ go xss+   in  go++zipHeadTail :: [a] -> [[a]] -> [[a]]+zipHeadTail (x:xs) (ys:yss) = (x:ys) : zipHeadTail xs yss+zipHeadTail [] yss = yss+zipHeadTail xs [] = fmap (:[]) xs+-}++transposePrelude :: [[a]] -> [[a]]+transposePrelude =+   let go [] = []+       go ([] : xss) = go xss+       go ((x:xs) : xss) =+          case ListHT.unzip $ mapMaybe ListHT.viewL xss of+             (ys, yss) -> (x : ys) : go (xs : yss)+   in  go++propTranspose :: [[P.Int]] -> P.Bool+propTranspose xs =+   List.transpose xs P.== transpose xs++propTransposePrelude :: [[P.Int]] -> P.Bool+propTransposePrelude xs =+   List.transpose xs P.== transposePrelude xs++++scanl :: Traversable f => (b -> a -> b) -> b -> f a -> T f b+scanl f b =+   Cons b . snd .+   mapAccumL (\b0 -> (\b1 -> (b1,b1)) . f b0) b++scanr :: Traversable f => (a -> b -> b) -> b -> f a -> T f b+scanr f b =+   uncurry Cons .+   mapAccumR (\b0 -> flip (,) b0 . flip f b0) b++mapAdjacent ::+   (Traversable f) => (a -> a -> b) -> T f a -> f b+mapAdjacent f (Cons x xs) =+   snd $ mapAccumL (\a0 a1 -> (a1, f a0 a1)) x xs