diff --git a/Control/Monad/Stream.hs b/Control/Monad/Stream.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Stream.hs @@ -0,0 +1,352 @@ +{-# OPTIONS_GHC -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Stream +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'Functor', 'Monad' and 'MonadPlus' classes, +-- with some useful operations on monads. + +module Control.Monad.Stream + ( + -- * Functor and monad classes + + Functor(fmap) + , Monad((>>=), (>>), return, fail) + + , MonadPlus ( -- class context: Monad + mzero -- :: (MonadPlus m) => m a + , mplus -- :: (MonadPlus m) => m a -> m a -> m a + ) + -- * Functions + + -- ** Naming conventions + -- $naming + + -- ** Basic functions from the "Prelude" + + , mapM -- :: (Monad m) => (a -> m b) -> [a] -> m [b] + , mapM_ -- :: (Monad m) => (a -> m b) -> [a] -> m () + , forM -- :: (Monad m) => [a] -> (a -> m b) -> m [b] + , forM_ -- :: (Monad m) => [a] -> (a -> m b) -> m () + , sequence -- :: (Monad m) => [m a] -> m [a] + , sequence_ -- :: (Monad m) => [m a] -> m () + , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b + , (>=>) -- :: (Monad m) => (a -> m b) -> (b -> m c) -> (a -> m c) + , (<=<) -- :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c) + , forever -- :: (Monad m) => m a -> m () + + -- ** Generalisations of list functions + + , join -- :: (Monad m) => m (m a) -> m a + , msum -- :: (MonadPlus m) => [m a] -> m a + , filterM -- :: (Monad m) => (a -> m Bool) -> [a] -> m [a] + , mapAndUnzipM -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) + , zipWithM -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] + , zipWithM_ -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () + , foldM -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a + , foldM_ -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m () + , replicateM -- :: (Monad m) => Int -> m a -> m [a] + , replicateM_ -- :: (Monad m) => Int -> m a -> m () + + -- ** Conditional execution of monadic expressions + + , guard -- :: (MonadPlus m) => Bool -> m () + , when -- :: (Monad m) => Bool -> m () -> m () + , unless -- :: (Monad m) => Bool -> m () -> m () + + -- ** Monadic lifting operators + + , liftM -- :: (Monad m) => (a -> b) -> (m a -> m b) + , liftM2 -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c) + , liftM3 -- :: ... + , liftM4 -- :: ... + , liftM5 -- :: ... + + , ap -- :: (Monad m) => m (a -> b) -> m a -> m b + + ) where + +import Data.Maybe + +#ifdef __GLASGOW_HASKELL__ +import GHC.List +import qualified Data.Stream as Stream +import GHC.Base +#endif + +#ifdef __GLASGOW_HASKELL__ +infixr 1 =<< + +-- ----------------------------------------------------------------------------- +-- Prelude monad functions + +-- | Same as '>>=', but with the arguments interchanged. +{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} +(=<<) :: Monad m => (a -> m b) -> m a -> m b +f =<< x = x >>= f + +-- | Evaluate each action in the sequence from left to right, +-- and collect the results. +sequence :: Monad m => [m a] -> m [a] +{-# INLINE sequence #-} +sequence ms = foldr k (return []) ms + where + k m m' = do { x <- m; xs <- m'; return (x:xs) } + +-- | Evaluate each action in the sequence from left to right, +-- and ignore the results. +sequence_ :: Monad m => [m a] -> m () +{-# INLINE sequence_ #-} +sequence_ ms = foldr (>>) (return ()) ms + +-- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@. +mapM :: Monad m => (a -> m b) -> [a] -> m [b] +{-# INLINE mapM #-} +mapM f as = sequence (map f as) + +-- | @'mapM_' f@ is equivalent to @'sequence_' . 'map' f@. +mapM_ :: Monad m => (a -> m b) -> [a] -> m () +{-# INLINE mapM_ #-} +mapM_ f as = sequence_ (map f as) + +#endif /* __GLASGOW_HASKELL__ */ + +-- ----------------------------------------------------------------------------- +-- The MonadPlus class definition + +-- | Monads that also support choice and failure. +class Monad m => MonadPlus m where + -- | the identity of 'mplus'. It should also satisfy the equations + -- + -- > mzero >>= f = mzero + -- > v >> mzero = mzero + -- + -- (but the instance for 'System.IO.IO' defined in "Control.Monad.Error" + -- does not satisfy the second one). + mzero :: m a + -- | an associative operation + mplus :: m a -> m a -> m a + +instance MonadPlus [] where + mzero = [] + mplus = (++) + +instance MonadPlus Maybe where + mzero = Nothing + + Nothing `mplus` ys = ys + xs `mplus` _ys = xs + +-- ----------------------------------------------------------------------------- +-- Functions mandated by the Prelude + +-- | @'guard' b@ is @'return' ()@ if @b@ is 'True', +-- and 'mzero' if @b@ is 'False'. +guard :: (MonadPlus m) => Bool -> m () +guard True = return () +guard False = mzero + +-- | This generalizes the list-based 'filter' function. + +filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] +filterM p xs = foldr k (return []) xs + where + k x xs' = do + flg <- p x + ys <- xs' + return (if flg then x:ys else ys) + +-- | 'forM' is 'mapM' with its arguments flipped +forM :: Monad m => [a] -> (a -> m b) -> m [b] +{-# INLINE forM #-} +forM = flip mapM + +-- | 'forM_' is 'mapM_' with its arguments flipped +forM_ :: Monad m => [a] -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | This generalizes the list-based 'concat' function. + +msum :: MonadPlus m => [m a] -> m a +{-# INLINE msum #-} +msum = foldr mplus mzero + +infixr 1 <=<, >=> + +-- | Left-to-right Kleisli composition of monads. +(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) +f >=> g = \x -> f x >>= g + +-- | Right-to-left Kleisli composition of monads. '(>=>)', with the arguments flipped +(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) +(<=<) = flip (>=>) + +-- | @'forever' act@ repeats the action infinitely. +forever :: (Monad m) => m a -> m () +forever a = a >> forever a + +-- ----------------------------------------------------------------------------- +-- Other monad functions + +-- | The 'join' function is the conventional monad join operator. It is used to +-- remove one level of monadic structure, projecting its bound argument into the +-- outer level. +join :: (Monad m) => m (m a) -> m a +join x = x >>= id + +-- | The 'mapAndUnzipM' function maps its first argument over a list, returning +-- the result as a pair of lists. This function is mainly used with complicated +-- data structures or a state-transforming monad. +mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) +mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip + +-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads. +zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +zipWithM f xs ys = sequence (zipWith f xs ys) + +-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result. +zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () +zipWithM_ f xs ys = sequence_ (zipWith f xs ys) + +{- | The 'foldM' function is analogous to 'foldl', except that its result is +encapsulated in a monad. Note that 'foldM' works from left-to-right over +the list arguments. This could be an issue where '(>>)' and the `folded +function' are not commutative. + + +> foldM f a1 [x1, x2, ..., xm ] + +== + +> do +> a2 <- f a1 x1 +> a3 <- f a2 x2 +> ... +> f am xm + +If right-to-left evaluation is required, the input list should be reversed. +-} + +foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldM _ a [] = return a +foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs +{-# INLINE [1] foldM #-} + +{-# RULES +"foldM -> fusible" [~1] forall f z xs. + foldM f z xs = Stream.foldM f z (Stream.stream xs) +"foldM -> unfused" [1] forall f z xs. + Stream.foldM f z (Stream.stream xs) = foldM f z xs + #-} + +-- | Like 'foldM', but discards the result. +foldM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m () +foldM_ f a xs = foldM f a xs >> return () +{-# INLINE [1] foldM_ #-} + +{-# RULES +"foldM_ -> fusible" [~1] forall f z xs. + foldM_ f z xs = Stream.foldM_ f z (Stream.stream xs) +"foldM_ -> unfused" [1] forall f z xs. + Stream.foldM_ f z (Stream.stream xs) = foldM_ f z xs + #-} + +-- | @'replicateM' n act@ performs the action @n@ times, +-- gathering the results. +replicateM :: (Monad m) => Int -> m a -> m [a] +replicateM n x = sequence (replicate n x) + +-- | Like 'replicateM', but discards the result. +replicateM_ :: (Monad m) => Int -> m a -> m () +replicateM_ n x = sequence_ (replicate n x) + +{- | Conditional execution of monadic expressions. For example, + +> when debug (putStr "Debugging\n") + +will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True', +and otherwise do nothing. +-} + +when :: (Monad m) => Bool -> m () -> m () +when p s = if p then s else return () + +-- | The reverse of 'when'. + +unless :: (Monad m) => Bool -> m () -> m () +unless p s = if p then return () else s + +-- | Promote a function to a monad. +liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r +liftM f m1 = do { x1 <- m1; return (f x1) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right. For example, +-- +-- > liftM2 (+) [0,1] [0,2] = [0,2,1,3] +-- > liftM2 (+) (Just 1) Nothing = Nothing +-- +liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r +liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r +liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r +liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r +liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } + +{- | In many situations, the 'liftM' operations can be replaced by uses of +'ap', which promotes function application. + +> return f `ap` x1 `ap` ... `ap` xn + +is equivalent to + +> liftMn f x1 x2 ... xn + +-} + +ap :: (Monad m) => m (a -> b) -> m a -> m b +ap = liftM2 id + + +{- $naming + +The functions in this library use the following naming conventions: + +* A postfix \'@M@\' always stands for a function in the Kleisli category: + The monad type constructor @m@ is added to function results + (modulo currying) and nowhere else. So, for example, + +> filter :: (a -> Bool) -> [a] -> [a] +> filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] + +* A postfix \'@_@\' changes the result type from @(m a)@ to @(m ())@. + Thus, for example: + +> sequence :: Monad m => [m a] -> m [a] +> sequence_ :: Monad m => [m a] -> m () + +* A prefix \'@m@\' generalizes an existing function to a monadic form. + Thus, for example: + +> sum :: Num a => [a] -> a +> msum :: MonadPlus m => [m a] -> m a + +-} diff --git a/Data/List/Stream.hs b/Data/List/Stream.hs new file mode 100644 --- /dev/null +++ b/Data/List/Stream.hs @@ -0,0 +1,2453 @@ +{-# OPTIONS_GHC -O2 -fbang-patterns -fdicts-cheap #-} +-- | +-- Module : Data.List.Stream +-- Copyright : (c) Duncan Coutts 2007 +-- (c) Don Stewart 2007 +-- License : BSD-style +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable +-- +-- A reimplementation of the standard Haskell list library to take advantage of +-- stream fusion, and new GHC optimisations. The fusion mechanism is +-- based on that described in: +-- +-- /Rewriting Haskell Strings/, by Duncan Coutts, Don Stewart and +-- Roman Leshchinskiy, Practical Aspects of Declarative Languages +-- 8th International Symposium, PADL 2007, 2007. +-- +-- +-- +-- This library is a drop in replacement for "Data.List". +-- +module Data.List.Stream ( + + -- $fusion_intro + + -- * Basic interface + (++), -- :: [a] -> [a] -> [a] + head, -- :: [a] -> a + last, -- :: [a] -> a + tail, -- :: [a] -> [a] + init, -- :: [a] -> [a] + null, -- :: [a] -> Bool + length, -- :: [a] -> Int + + -- * List transformations + map, -- :: (a -> b) -> [a] -> [b] + reverse, -- :: [a] -> [a] + intersperse, -- :: a -> [a] -> [a] + intercalate, -- :: [a] -> [[a]] -> [a] + transpose, -- :: [[a]] -> [[a]] + + -- * Reducing lists (folds) + foldl, -- :: (a -> b -> a) -> a -> [b] -> a + foldl', -- :: (a -> b -> a) -> a -> [b] -> a + foldl1, -- :: (a -> a -> a) -> [a] -> a + foldl1', -- :: (a -> a -> a) -> [a] -> a + foldr, -- :: (a -> b -> b) -> b -> [a] -> b + foldr1, -- :: (a -> a -> a) -> [a] -> a + + -- ** Special folds + concat, -- :: [[a]] -> [a] + concatMap, -- :: (a -> [b]) -> [a] -> [b] + and, -- :: [Bool] -> Bool + or, -- :: [Bool] -> Bool + any, -- :: (a -> Bool) -> [a] -> Bool + all, -- :: (a -> Bool) -> [a] -> Bool + sum, -- :: Num a => [a] -> a + product, -- :: Num a => [a] -> a + maximum, -- :: Ord a => [a] -> a + minimum, -- :: Ord a => [a] -> a + + -- * Building lists + -- ** Scans + scanl, -- :: (a -> b -> a) -> a -> [b] -> [a] + scanl1, -- :: (a -> a -> a) -> [a] -> [a] + scanr, -- :: (a -> b -> b) -> b -> [a] -> [b] + scanr1, -- :: (a -> a -> a) -> [a] -> [a] + + -- ** Accumulating maps + mapAccumL, -- :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) + mapAccumR, -- :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) + + -- ** Infinite lists + iterate, -- :: (a -> a) -> a -> [a] + repeat, -- :: a -> [a] + replicate, -- :: Int -> a -> [a] + cycle, -- :: [a] -> [a] + + -- ** Unfolding + unfoldr, -- :: (b -> Maybe (a, b)) -> b -> [a] + + -- * Sublists + -- ** Extracting sublists + take, -- :: Int -> [a] -> [a] + drop, -- :: Int -> [a] -> [a] + splitAt, -- :: Int -> [a] -> ([a], [a]) + takeWhile, -- :: (a -> Bool) -> [a] -> [a] + dropWhile, -- :: (a -> Bool) -> [a] -> [a] + span, -- :: (a -> Bool) -> [a] -> ([a], [a]) + break, -- :: (a -> Bool) -> [a] -> ([a], [a]) + group, -- :: Eq a => [a] -> [[a]] + inits, -- :: [a] -> [[a]] + tails, -- :: [a] -> [[a]] + + -- * Predicates + isPrefixOf, -- :: Eq a => [a] -> [a] -> Bool + isSuffixOf, -- :: Eq a => [a] -> [a] -> Bool + isInfixOf, -- :: Eq a => [a] -> [a] -> Bool + + -- * Searching lists + -- ** Searching by equality + elem, -- :: Eq a => a -> [a] -> Bool + notElem, -- :: Eq a => a -> [a] -> Bool + lookup, -- :: Eq a => a -> [(a, b)] -> Maybe b + + -- ** Searching with a predicate + find, -- :: (a -> Bool) -> [a] -> Maybe a + filter, -- :: (a -> Bool) -> [a] -> [a] + partition, -- :: (a -> Bool) -> [a] -> ([a], [a]) + + -- * Indexing lists + + -- | These functions treat a list @xs@ as a indexed collection, + -- with indices ranging from 0 to @'length' xs - 1@. + (!!), -- :: [a] -> Int -> a + elemIndex, -- :: Eq a => a -> [a] -> Maybe Int + elemIndices, -- :: Eq a => a -> [a] -> [Int] + findIndex, -- :: (a -> Bool) -> [a] -> Maybe Int + findIndices, -- :: (a -> Bool) -> [a] -> [Int] + + -- * Zipping and unzipping lists + zip, -- :: [a] -> [b] -> [(a, b)] + zip3, -- :: [a] -> [b] -> [c] -> [(a, b, c)] + zip4, + zip5, + zip6, + zip7, + + -- | The zipWith family generalises the zip family by zipping with the + -- function given as the first argument, instead of a tupling function. + zipWith, -- :: (a -> b -> c) -> [a] -> [b] -> [c] + zipWith3, -- :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] + zipWith4, + zipWith5, + zipWith6, + zipWith7, + + unzip, -- :: [(a, b)] -> ([a], [b]) + unzip3, -- :: [(a, b, c)] -> ([a], [b], [c]) + unzip4, + unzip5, + unzip6, + unzip7, + + -- * Special lists + -- ** Functions on strings + lines, -- :: String -> [String] + words, -- :: String -> [String] + unlines, -- :: [String] -> String + unwords, -- :: [String] -> String + + -- ** \"Set\" operations + nub, -- :: Eq a => [a] -> [a] + delete, -- :: Eq a => a -> [a] -> [a] + (\\), -- :: Eq a => [a] -> [a] -> [a] + union, -- :: Eq a => [a] -> [a] -> [a] + intersect, -- :: Eq a => [a] -> [a] -> [a] + + -- ** Ordered lists + sort, -- :: Ord a => [a] -> [a] + insert, -- :: Ord a => a -> [a] -> [a] + + -- * Generalized functions + -- ** The \"By\" operations + + -- | By convention, overloaded functions have a non-overloaded + -- counterpart whose name is suffixed with \`@By@\'. + -- + -- It is often convenient to use these functions together with + -- 'Data.Function.on', for instance @'sortBy' ('compare' + -- \`on\` 'fst')@. + + -- *** User-supplied equality (replacing an Eq context) + + -- | The predicate is assumed to define an equivalence. + nubBy, -- :: (a -> a -> Bool) -> [a] -> [a] + deleteBy, -- :: (a -> a -> Bool) -> a -> [a] -> [a] + deleteFirstsBy, -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + unionBy, -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + intersectBy, -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + groupBy, -- :: (a -> a -> Bool) -> [a] -> [[a]] + + -- *** User-supplied comparison (replacing an Ord context) + sortBy, -- :: (a -> a -> Ordering) -> [a] -> [a] + insertBy, -- :: (a -> a -> Ordering) -> a -> [a] -> [a] + maximumBy, -- :: (a -> a -> Ordering) -> [a] -> a + minimumBy, -- :: (a -> a -> Ordering) -> [a] -> a + + -- * The \"generic\" operations + -- | The prefix \`@generic@\' indicates an overloaded function that + -- is a generalized version of a "Prelude" function. + genericLength, -- :: Num i => [b] -> i + genericTake, -- :: Integral i => i -> [a] -> [a] + genericDrop, -- :: Integral i => i -> [a] -> [a] + genericSplitAt, -- :: Integral i => i -> [a] -> ([a], [a]) + genericIndex, -- :: Integral a => [b] -> a -> b + genericReplicate, -- :: Integral i => i -> a -> [a] + + -- helper for GHC.List + errorEmptyList -- :: String -> a + + ) where + +#ifndef EXTERNAL_PACKAGE + +import {-# SOURCE #-} GHC.Err ( error ) +import {-# SOURCE #-} GHC.Real (Integral) +import {-# SOURCE #-} GHC.Num (Num(..)) +import {-# SOURCE #-} GHC.Unicode (isSpace) + +import GHC.Base (Int, Eq(..), Ord(..), Ordering(..), + Bool(..), not, Ordering(..), + seq, otherwise, flip, + Monad(..), + Char, String, + Int(I#), Int#, (+#), + -- we just reuse these: + foldr, (++), map + ) + +import Data.Maybe (Maybe(..)) + +#else + +import GHC.Exts (Int(I#), Int#, (+#)) +import Prelude (Int, + Integral, + Num(..), Eq(..), Ord(..), Ordering(..), + Bool(..), not, Maybe(..), Char, String, + error, seq, otherwise, flip) + +import Data.Char (isSpace) + +#endif + + +import qualified Data.Stream as Stream +import Data.Stream (stream ,unstream) + +-- ----------------------------------------------------------------------------- + +#ifdef EXTERNAL_PACKAGE +infixr 5 ++ +#endif + +infix 5 \\ -- comment to fool cpp +infixl 9 !! +infix 4 `elem`, `notElem` + +-- ----------------------------------------------------------------------------- + +-- $fusion_intro +-- +-- The functions in this library marked with /fusion/ are +-- (transparently) rewritten by the compiler to stream functions, using +-- the fusion framework described in /Rewriting Haskell Strings/. +-- +-- For example: +-- +-- > map f xs +-- +-- is transformed via rewrite rules to: +-- +-- > (unstream . mapS f . stream) xs +-- +-- The 'unstream' and 'stream' functions identify the allocation points +-- for each function. +-- +-- When two or more fusible functions are in close proximity (i.e. +-- directly composed, or with only intermediate lets and cases), the +-- fusion rule will fire, removing the intermediate structures. +-- +-- Consider: +-- +-- > map f . map g +-- +-- The rewrite engine will transform this code to: +-- +-- > unstream . mapS f . stream . unstream . mapS g . stream +-- +-- The fusion rule will then fire: +-- +-- > unstream . mapS f . mapS g . stream +-- +-- Removing the intermeidate list that is allocated. The compiler then +-- optimises the result. +-- +-- Functions that fail to fuse are not left in stream form. In the final +-- simplifier phase any remaining unfused functions of the form: +-- +-- > unstream . g . stream +-- +-- Will be transformed back to their original list implementation. +-- + +-- +-- Notes on simplifer phasing +-- +-- * api functions should be rewritten to fusible forms as soon as possble +-- * This implies a NOINLINE [1] on the top level functions, so if ghc wants +-- to inline them they'll only have their bodies inlined at the end. +-- * These rewrite rules can then fire in any but the last phase: +-- "++ -> fusible" [~1] forall xs ys. +-- * Finally, if we reach the final phase, rewrite back to best effort [a] forms: +-- "++ -> unfused" [1] forall xs ys. +-- * And then inline the result. +-- +-- If fusion occurs though, hang on to those 'stream' and 'unstream' pairs: +-- {-# INLINE [0] unstream #-} -- hmm? +-- +-- Todo: notes on the phasing of Streams +-- + +-- ----------------------------------------------------------------------------- +-- Fusion for the constructors: + +-- +-- We do not enable fusion for (:), as it leads to a massive massive +-- slow down in compilation time. +-- +{- RULES +"(:) -> fusible" [~1] forall x xs. + x : xs = unstream (Stream.cons x (stream xs)) +"(:) -> unfused" [1] forall x xs. + unstream (Stream.cons x (stream xs)) = x : xs + -} + +-- ----------------------------------------------------------------------------- +-- Basic interface + +-- | /O(n)/, /fusion/. Append two lists, i.e., +-- +-- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn] +-- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...] +-- +-- If the first list is not finite, the result is the first list. +-- The spine of the first list argument must be copied. + +#ifdef EXTERNAL_PACKAGE +(++) :: [a] -> [a] -> [a] +(++) [] ys = ys +(++) (x:xs) ys = x : xs ++ ys +{-# NOINLINE [1] (++) #-} +#endif + +-- NOTE: This is quite subtle as we do not want to copy the last list in +-- +-- xs1 ++ xs2 ++ ... ++ xsn +-- +-- Indeed, we don't really want to fuse the above at all unless at least +-- one of the arguments has the form (unstream s) or the result of the +-- concatenation is streamed. The rules below do precisely that. Note they +-- really fuse instead of just rewriting things into a fusible form so there +-- is no need to rewrite back. + +{-# RULES +"++ -> fused on 1st arg" [~1] forall xs ys. + unstream xs ++ ys = Stream.append1 xs ys +"++ -> fused on 2nd arg" [~1] forall xs ys. + Stream.append1 xs (unstream ys) = unstream (Stream.append xs ys) +"++ -> fused (1)" [~1] forall xs ys. + stream (xs ++ ys) = Stream.append (stream xs) (stream ys) +"++ -> fused (2)" [~1] forall xs ys. + stream (Stream.append1 xs ys) = Stream.append xs (stream ys) + +"++ -> 1st arg empty" forall xs. + [] ++ xs = xs +"++ -> 2nd arg empty" forall xs. + xs ++ [] = xs +"++ / :" forall x xs ys. + (x:xs) ++ ys = x : (xs ++ ys) + #-} + +-- | /O(1)/, /fusion/. Extract the first element of a list, which must be +-- non-empty. +head :: [a] -> a +head (x:_) = x +head [] = errorEmptyList "head" +{-# NOINLINE [1] head #-} + +{-# RULES +"head -> fusible" [~1] forall xs. + head xs = Stream.head (stream xs) +"head -> unfused" [1] forall xs. + Stream.head (stream xs) = head xs + #-} + +-- | /O(n)/, /fusion/. Extract the last element of a list, which must be finite +-- and non-empty. +last :: [a] -> a +last [] = errorEmptyList "last" +last (x:xs) = last' x xs + where + last' y [] = y + last' _ (y:ys) = last' y ys +{-# NOINLINE [1] last #-} + +{-# RULES +"last -> fusible" [~1] forall xs. + last xs = Stream.last (stream xs) +"last -> unfused" [1] forall xs. + Stream.last (stream xs) = last xs + #-} + +-- | /O(1)/, /fusion/. Extract the elements after the head of a list, which +-- must be non-empty. +tail :: [a] -> [a] +tail (_:xs) = xs +tail [] = errorEmptyList "tail" +{-# NOINLINE [1] tail #-} + +{-# RULES +"tail -> fusible" [~1] forall xs. + tail xs = unstream (Stream.tail (stream xs)) +"tail -> unfused" [1] forall xs. + unstream (Stream.tail (stream xs)) = tail xs + #-} + +-- | /O(n)/, /fusion/. Return all the elements of a list except the last one. +-- The list must be finite and non-empty. +init :: [a] -> [a] +init [] = errorEmptyList "init" +init (x:xs) = init' x xs + where + init' _ [] = [] + init' y (z:zs) = y : init' z zs +{-# NOINLINE [1] init #-} + +{-# RULES +"init -> fusible" [~1] forall xs. + init xs = unstream (Stream.init (stream xs)) +"init -> unfused" [1] forall xs. + unstream (Stream.init (stream xs)) = init xs + #-} + +-- | /O(1)/, /fusion/. Test whether a list is empty. +null :: [a] -> Bool +null [] = True +null (_:_) = False +{-# NOINLINE [1] null #-} + +{-# RULES +"null -> fusible" [~1] forall xs. + null xs = Stream.null (stream xs) +"null -> unfused" [1] forall xs. + Stream.null (stream xs) = null xs + #-} + +-- | /O(n)/, /fusion/. 'length' returns the length of a finite list as an 'Int'. +-- It is an instance of the more general 'Data.List.genericLength', +-- the result type of which may be any kind of number. +length :: [a] -> Int +length xs0 = len xs0 0# +#ifndef __HADDOCK__ + where + len :: [a] -> Int# -> Int + len [] a# = I# a# + len (_:xs) a# = len xs (a# +# 1#) +#endif +{-# NOINLINE [1] length #-} + +{-# RULES +"length -> fusible" [~1] forall xs. + length xs = Stream.length (stream xs) +"length -> unfused" [1] forall xs. + Stream.length (stream xs) = length xs + #-} + +-- --------------------------------------------------------------------- +-- List transformations + +-- | /O(n)/, /fusion/. 'map' @f xs@ is the list obtained by applying @f@ to each element +-- of @xs@, i.e., +-- +-- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn] +-- > map f [x1, x2, ...] == [f x1, f x2, ...] +-- +-- Properties: +-- +-- > map f . map g = map (f . g) +-- > map f (repeat x) = repeat (f x) +-- > map f (replicate n x) = replicate n (f x) + +#ifdef EXTERNAL_PACKAGE +map :: (a -> b) -> [a] -> [b] +map _ [] = [] +map f (x:xs) = f x : map f xs +{-# NOINLINE [1] map #-} +#endif + +{-# RULES +"map -> fusible" [~1] forall f xs. + map f xs = unstream (Stream.map f (stream xs)) +"map -> unfused" [1] forall f xs. + unstream (Stream.map f (stream xs)) = map f xs + #-} + +-- | /O(n)/, /fusion/. 'reverse' @xs@ returns the elements of @xs@ in reverse order. +-- @xs@ must be finite. Will fuse as a consumer only. +reverse :: [a] -> [a] +reverse = foldl' (flip (:)) [] +{-# INLINE reverse #-} + +{- +reverse l = rev l [] + where + rev [] a = a + rev (x:xs) a = rev xs (x:a) +-} + +{- +--TODO: I'm sure there are some cunning things we can do with optimising +-- reverse. Of course if we try and fuse we may need to still force the +-- sping of the list: eg reverse . reverse = forceSpine + +forceSpine :: [a] -> [a] +forceSpine xs = forceSpine' xs `seq` xs +{-# INLINE forceSpine #-} + +-- The idea of this slightly odd construction is that we inline the above form +-- and in the context we may then be able to use xs directly and just keep +-- around the fact that xs must be forced at some point. Remember, seq does not +-- imply any evaluation order. + +forceSpine' :: [a] -> () +forceSpine' [] = () +forceSpine' (_:xs') = forceSpine' xs' +{-# NOINLINE forceSpine' #-} +-} + +-- | /O(n)/, /fusion/. The 'intersperse' function takes an element and a list and +-- \`intersperses\' that element between the elements of the list. +-- For example, +-- +-- > intersperse ',' "abcde" == "a,b,c,d,e" +-- +intersperse :: a -> [a] -> [a] +intersperse _ [] = [] +intersperse sep (x0:xs0) = x0 : go xs0 + where + go [] = [] + go (x:xs) = sep : x : go xs +{-# NOINLINE [1] intersperse #-} + +{- RULES +"intersperse -> fusible" [~1] forall x xs. + intersperse x xs = unstream (Stream.intersperse x (stream xs)) +"intersperse -> unfused" [1] forall x xs. + unstream (Stream.intersperse x (stream xs)) = intersperse x xs + -} + +-- | /O(n)/, /fusion/. 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@. +-- It inserts the list @xs@ in between the lists in @xss@ and concatenates the +-- result. +-- +-- > intercalate = concat . intersperse +-- +intercalate :: [a] -> [[a]] -> [a] +intercalate sep xss = go (intersperse sep xss) + where + go [] = [] + go (y:ys) = y ++ go ys +{-# NOINLINE [1] intercalate #-} + +{- +intercalate _ [] = [] +intercalate sep (xs0:xss0) = go xs0 xss0 + where + go [] xss = to xss + go (x:xs) xss = x : go xs xss + + to [] = [] + to (xs:xss) = go' sep xs xss + + go' [] xs xss = go xs xss + go' (s:ss) xs xss = s : go' ss xs xss +{-# NOINLINE [1] intercalate #-} +-} + +-- fusion rule based on: +-- intercalate = concat . intersperse +-- +{- RULES +"intercalate -> fusible" [~1] forall x xs. + intercalate x xs = Stream.concat (Stream.intersperse x (stream xs)) +"intercalate -> unfused" [1] forall x xs. + Stream.concat (Stream.intersperse x (stream xs)) = intercalate x xs + -} + +-- | The 'transpose' function transposes the rows and columns of its argument. +-- For example, +-- +-- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]] +-- +transpose :: [[a]] -> [[a]] +transpose [] = [] +transpose ([] : xss) = transpose xss +transpose ((x:xs) : xss) = (x : [h | (h:_t) <- xss]) + : transpose (xs : [ t | (_h:t) <- xss]) + +-- TODO fuse + +-- --------------------------------------------------------------------- +-- Reducing lists (folds) + +-- | /O(n)/, /fusion/. 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a list, reduces the list +-- using the binary operator, from left to right: +-- +-- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- +-- The list must be finite. +-- +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z0 xs0 = go z0 xs0 + where + go z [] = z + go z (x:xs) = go (f z x) xs +{-# INLINE [1] foldl #-} + +{-# RULES +"foldl -> fusible" [~1] forall f z xs. + foldl f z xs = Stream.foldl f z (stream xs) +"foldl -> unfused" [1] forall f z xs. + Stream.foldl f z (stream xs) = foldl f z xs + #-} + +-- | /O(n)/, /fusion/. A strict version of 'foldl'. +foldl' :: (a -> b -> a) -> a -> [b] -> a +foldl' f z0 xs0 = go z0 xs0 + where + go !z [] = z + go !z (x:xs) = go (f z x) xs +{-# INLINE [1] foldl' #-} + +{-# RULES +"foldl' -> fusible" [~1] forall f z xs. + foldl' f z xs = Stream.foldl' f z (stream xs) +"foldl' -> unfused" [1] forall f z xs. + Stream.foldl' f z (stream xs) = foldl' f z xs + #-} + +-- | /O(n)/, /fusion/. 'foldl1' is a variant of 'foldl' that has no starting value argument, +-- and thus must be applied to non-empty lists. +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 _ [] = errorEmptyList "foldl1" +foldl1 f (x0:xs0) = go x0 xs0 + where + go z [] = z + go z (x:xs) = go (f z x) xs +{-# INLINE [1] foldl1 #-} + +{-# RULES +"foldl1 -> fusible" [~1] forall f xs. + foldl1 f xs = Stream.foldl1 f (stream xs) +"foldl1 -> unfused" [1] forall f xs. + Stream.foldl1 f (stream xs) = foldl1 f xs + #-} + +-- | /O(n)/, /fusion/. A strict version of 'foldl1' +foldl1' :: (a -> a -> a) -> [a] -> a +foldl1' _ [] = errorEmptyList "foldl1'" +foldl1' f (x0:xs0) = go x0 xs0 + where + go !z [] = z + go !z (x:xs) = go (f z x) xs +{-# INLINE [1] foldl1' #-} + +{-# RULES +"foldl1' -> fusible" [~1] forall f xs. + foldl1' f xs = Stream.foldl1' f (stream xs) +"foldl1 -> unfused" [1] forall f xs. + Stream.foldl1' f (stream xs) = foldl1' f xs + #-} + +-- | /O(n)/, /fusion/. 'foldr', applied to a binary operator, a starting value (typically +-- the right-identity of the operator), and a list, reduces the list +-- using the binary operator, from right to left: +-- +-- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) + +#ifdef EXTERNAL_PACKAGE +foldr :: (a -> b -> b) -> b -> [a] -> b +foldr k z xs = go xs + where + go [] = z + go (y:ys) = y `k` go ys +{-# INLINE [0] foldr #-} +#endif + +{-# RULES +"foldr -> fusible" [~1] forall f z xs. + foldr f z xs = Stream.foldr f z (stream xs) +"foldr -> unfused" [1] forall f z xs. + Stream.foldr f z (stream xs) = foldr f z xs + #-} + +-- | /O(n)/, /fusion/. 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty lists. +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 _ [] = errorEmptyList "foldr1" +foldr1 k (x0:xs0) = go x0 xs0 + where go x [] = x + go x (x':xs) = k x (go x' xs) +{-# INLINE [1] foldr1 #-} + +{-# RULES +"foldr1 -> fusible" [~1] forall f xs. + foldr1 f xs = Stream.foldr1 f (stream xs) +"foldr1 -> unfused" [1] forall f xs. + Stream.foldr1 f (stream xs) = foldr1 f xs + #-} + +-- --------------------------------------------------------------------- +-- Special folds + +-- | /O(n)/, /fusion/. Concatenate a list of lists. +concat :: [[a]] -> [a] +concat xss0 = to xss0 + where go [] xss = to xss + go (x:xs) xss = x : go xs xss + + to [] = [] + to (xs:xss) = go xs xss -- hmm, this is slower than the old concat? +{-# NOINLINE [1] concat #-} + +-- +-- fuse via concatMap, as the Stream (Stream a) is too hard to construct +-- +-- or via foldr (++) ? +-- +{-# RULES +"concat -> fused" [~1] forall xs. + concat xs = Stream.concat (stream xs) +"concat -> unfused" [1] forall xs. + Stream.concat (stream xs) = concat xs + #-} + +-- | /O(n)/, /fusion/. Map a function over a list and concatenate the results. +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = foldr (\x y -> f x ++ y) [] -- at least it will fuse. +{-# INLINE concatMap #-} + +{- +concatMap f as0 = to as0 + where + go [] as = to as + go (b:bs) as = b : go bs as + + to [] = [] + to (a:as) = go (f a) as +{-# NOINLINE [1] concatMap #-} +-} +{- RULES +"concatMap -> fusible" [~1] forall f xs. + concatMap f xs = Stream.concatMap f (stream xs) +"concatMap -> unfused" [1] forall f xs. + Stream.concatMap f (stream xs) = concatMap f xs + -} + +-- | /O(n)/, /fusion/. 'and' returns the conjunction of a Boolean list. For the result to be +-- 'True', the list must be finite; 'False', however, results from a 'False' +-- value at a finite index of a finite or infinite list. +-- +and :: [Bool] -> Bool +and [] = True +and (False:_ ) = False +and (_ :xs) = and xs +{-# NOINLINE [1] and #-} + +{-# RULES +"and -> fused" [~1] forall xs. + and xs = Stream.and (stream xs) +"and -> unfused" [1] forall xs. + Stream.and (stream xs) = and xs + #-} + +-- | /O(n)/, /fusion/. 'or' returns the disjunction of a Boolean list. For the result to be +-- 'False', the list must be finite; 'True', however, results from a 'True' +-- value at a finite index of a finite or infinite list. +or :: [Bool] -> Bool +or [] = False +or (True:_ ) = True +or (_ :xs) = or xs +{-# NOINLINE [1] or #-} + +{-# RULES +"or -> fused" [~1] forall xs. + or xs = Stream.or (stream xs) +"or -> unfused" [1] forall xs. + Stream.or (stream xs) = or xs + #-} + +-- | /O(n)/, /fusion/. Applied to a predicate and a list, 'any' determines if any element +-- of the list satisfies the predicate. +any :: (a -> Bool) -> [a] -> Bool +any p xs0 = go xs0 + where go [] = False + go (x:xs) = case p x of + True -> True + False -> go xs +{-# NOINLINE [1] any #-} + +--TODO: check if being lazy in p is a cost, +-- should we do [] as a special case and then strictly evaluate p? + +{-# RULES +"any -> fusible" [~1] forall f xs. + any f xs = Stream.any f (stream xs) +"any -> unfused" [1] forall f xs. + Stream.any f (stream xs) = any f xs + #-} + +-- | Applied to a predicate and a list, 'all' determines if all elements +-- of the list satisfy the predicate. +all :: (a -> Bool) -> [a] -> Bool +all p xs0 = go xs0 + where go [] = True + go (x:xs) = case p x of + True -> go xs + False -> False +{-# NOINLINE [1] all #-} + +{-# RULES +"all -> fusible" [~1] forall f xs. + all f xs = Stream.all f (stream xs) +"all -> unfused" [1] forall f xs. + Stream.all f (stream xs) = all f xs + #-} + +-- | /O(n)/, /fusion/. The 'sum' function computes the sum of a finite list of numbers. +sum :: Num a => [a] -> a +sum l = sum' l 0 +#ifndef __HADDOCK__ + where + sum' [] a = a + sum' (x:xs) a = sum' xs (a+x) +#endif +{-# NOINLINE [1] sum #-} + +sumInt :: [Int] -> Int +sumInt l = sum' l 0 +#ifndef __HADDOCK__ + where + sum' [] a = a + sum' (x:xs) !a = sum' xs (a+x) +#endif +{-# NOINLINE [1] sumInt #-} + +{-# RULES +"sum spec Int" sum = sumInt :: [Int] -> Int + #-} + +{-# RULES +"sum -> fusible" [~1] forall xs. + sum xs = Stream.sum (stream xs) +"sum -> unfused" [1] forall xs. + Stream.sum (stream xs) = sum xs + #-} + +{-# RULES +"sumInt -> fusible" [~1] forall (xs :: [Int]). + sumInt xs = Stream.sum (stream xs) +"sumInt -> unfused" [1] forall (xs :: [Int]). + Stream.sum (stream xs) = sumInt xs + #-} + +-- | /O(n)/,/fusion/. The 'product' function computes the product of a finite list of numbers. +product :: Num a => [a] -> a +product l = prod l 1 +#ifndef __HADDOCK__ + where + prod [] a = a + prod (x:xs) a = prod xs (a*x) +#endif +{-# NOINLINE [1] product #-} + +productInt :: [Int] -> Int +productInt l = product' l 0 +#ifndef __HADDOCK__ + where + product' [] a = a + product' (x:xs) !a = product' xs (a*x) +#endif +{-# NOINLINE [1] productInt #-} + +{-# RULES +"product spec Int" product = productInt :: [Int] -> Int + #-} + +{-# RULES +"product -> fused" [~1] forall xs. + product xs = Stream.product (stream xs) +"product -> unfused" [1] forall xs. + Stream.product (stream xs) = product xs + #-} + +{-# RULES +"productInt -> fusible" [~1] forall (xs :: [Int]). + productInt xs = Stream.product (stream xs) +"productInt -> unfused" [1] forall (xs :: [Int]). + Stream.product (stream xs) = productInt xs + #-} + +-- | /O(n)/,/fusion/. 'maximum' returns the maximum value from a list, +-- which must be non-empty, finite, and of an ordered type. +-- It is a special case of 'Data.List.maximumBy', which allows the +-- programmer to supply their own comparison function. +maximum :: Ord a => [a] -> a +maximum [] = errorEmptyList "maximum" +maximum xs = foldl1 max xs +{-# NOINLINE [1] maximum #-} + +{-# RULES +"maximum -> fused" [~1] forall xs. + maximum xs = Stream.maximum (stream xs) +"maximum -> unfused" [1] forall xs. + Stream.maximum (stream xs) = maximum xs + #-} + +-- We can't make the overloaded version of maximum strict without +-- changing its semantics (max might not be strict), but we can for +-- the version specialised to 'Int'. + +{-# RULES + "maximumInt" maximum = (strictMaximum :: [Int] -> Int); + "maximumChar" maximum = (strictMaximum :: [Char] -> Char) + #-} + +strictMaximum :: (Ord a) => [a] -> a +strictMaximum [] = errorEmptyList "maximum" +strictMaximum xs = foldl1' max xs +{-# NOINLINE [1] strictMaximum #-} + +{-# RULES +"strictMaximum -> fused" [~1] forall xs. + maximum xs = Stream.strictMaximum (stream xs) +"strictMaximum -> unfused" [1] forall xs. + Stream.strictMaximum (stream xs) = strictMaximum xs + #-} + +-- | /O(n)/,/fusion/. 'minimum' returns the minimum value from a list, +-- which must be non-empty, finite, and of an ordered type. +-- It is a special case of 'Data.List.minimumBy', which allows the +-- programmer to supply their own comparison function. +minimum :: Ord a => [a] -> a +minimum [] = errorEmptyList "minimum" +minimum xs = foldl1 min xs +{-# NOINLINE [1] minimum #-} + +{-# RULES +"minimum -> fused" [~1] forall xs. + minimum xs = Stream.minimum (stream xs) +"minimum -> unfused" [1] forall xs. + Stream.minimum (stream xs) = minimum xs + #-} + +{-# RULES + "minimumInt" minimum = (strictMinimum :: [Int] -> Int); + "minimumChar" minimum = (strictMinimum :: [Char] -> Char) + #-} + +strictMinimum :: (Ord a) => [a] -> a +strictMinimum [] = errorEmptyList "maximum" +strictMinimum xs = foldl1' min xs +{-# NOINLINE [1] strictMinimum #-} + +{-# RULES +"strictMinimum -> fused" [~1] forall xs. + maximum xs = Stream.strictMinimum (stream xs) +"strictMinimum -> unfused" [1] forall xs. + Stream.strictMinimum (stream xs) = strictMinimum xs + #-} + +-- --------------------------------------------------------------------- +-- * Building lists +-- ** Scans + +-- | /O(n)/, /fusion/. 'scanl' is similar to 'foldl', but returns a list of successive +-- reduced values from the left: +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Properties: +-- +-- > last (scanl f z xs) == foldl f z x +-- +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q ls = q : case ls of + [] -> [] + x:xs -> scanl f (f q x) xs +{-# INLINE [1] scanl #-} + +{- or perhaps: +scanl f q xs0 = q : go q xs0 + where go q [] = [] + go q (x:xs) = let q' = f q x + in q' : go q' xs +-} + +-- +-- note: Haskell's 'scan' is a bit weird, as it always puts the initial +-- state as a prefix. this complicates the rules. +-- + +{-# RULES +"scanl -> fusible" [~1] forall f z xs. + scanl f z xs = unstream (Stream.scanl f z (Stream.snoc (stream xs) bottom)) +"scanl -> unfused" [1] forall f z xs. + unstream (Stream.scanl f z (Stream.snoc (stream xs) bottom)) = scanl f z xs + #-} + +-- | /O(n)/,/fusion/. 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +-- +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs +scanl1 _ [] = [] +{-# INLINE [1] scanl1 #-} + +{-# RULES +"scanl1 -> fusible" [~1] forall f xs. + scanl1 f xs = unstream (Stream.scanl1 f (Stream.snoc (stream xs) bottom)) +"scanl1 -> unfused" [1] forall f xs. + unstream (Stream.scanl1 f (Stream.snoc (stream xs) bottom)) = scanl1 f xs + #-} + + +-- | /O(n)/. 'scanr' is the right-to-left dual of 'scanl'. +-- Properties: +-- +-- > head (scanr f z xs) == foldr f z xs +-- +scanr :: (a -> b -> b) -> b -> [a] -> [b] +scanr _ q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs +{-# INLINE [1] scanr #-} + +{- RULES +"scanr -> fusible" [~1] forall f z xs. + scanr f z xs = unstream (Stream.scanr f z (Stream.cons bottom (stream xs))) +"scanr -> unfused" [1] forall f z xs. + unstream (Stream.scanr f z (Stream.cons bottom (stream xs))) = scanr f z xs + -} + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 _ [] = [] +scanr1 _ [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs + +-- TODO fuse + +-- --------------------------------------------------------------------- +-- ** Accumulating maps + +-- | The 'mapAccumL' function behaves like a combination of 'map' and +-- 'foldl'; it applies a function to each element of a list, passing +-- an accumulating parameter from left to right, and returning a final +-- value of this accumulator together with the new list. +-- +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) +mapAccumL _ s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +-- TODO fuse + +-- | The 'mapAccumR' function behaves like a combination of 'map' and +-- 'foldr'; it applies a function to each element of a list, passing +-- an accumulating parameter from right to left, and returning a final +-- value of this accumulator together with the new list. +-- +mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) +mapAccumR _ s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs + +-- TODO fuse + +------------------------------------------------------------------------ +-- ** Infinite lists + +-- | /fusion/. 'iterate' @f x@ returns an infinite list of repeated applications +-- of @f@ to @x@: +-- +-- > iterate f x == [x, f x, f (f x), ...] +iterate :: (a -> a) -> a -> [a] +iterate f x = x : iterate f (f x) +{-# NOINLINE [1] iterate #-} + +{-# RULES +"iterate -> fusible" [~1] forall f x. + iterate f x = unstream (Stream.iterate f x) +"iterate -> unfused" [1] forall f x. + unstream (Stream.iterate f x) = iterate f x + #-} + +-- | /fusion/. 'repeat' @x@ is an infinite list, with @x@ the value of every element. +repeat :: a -> [a] +repeat x = xs where xs = x : xs +{-# INLINE [1] repeat #-} + +{-# RULES +"repeat -> fusible" [~1] forall x. + repeat x = unstream (Stream.repeat x) +"repeat -> unfused" [1] forall x. + unstream (Stream.repeat x) = repeat x + #-} + +-- | /O(n)/, /fusion/. 'replicate' @n x@ is a list of length @n@ with @x@ the value of +-- every element. +-- It is an instance of the more general 'Data.List.genericReplicate', +-- in which @n@ may be of any integral type. +-- +replicate :: Int -> a -> [a] +replicate n0 _ | n0 <= 0 = [] +replicate n0 x = go n0 + where + go 0 = [] + go n = x : go (n-1) +{-# NOINLINE [1] replicate #-} + +{-# RULES +"replicate -> fusible" [~1] + replicate = \n x -> unstream (Stream.replicate n x) +"replicate -> unfused" [1] forall n x. + unstream (Stream.replicate n x) = replicate n x + #-} + +-- | /fusion/. 'cycle' ties a finite list into a circular one, or equivalently, +-- the infinite repetition of the original list. It is the identity +-- on infinite lists. +-- +cycle :: [a] -> [a] +cycle [] = error "Prelude.cycle: empty list" +cycle xs0 = go xs0 + where + go [] = go xs0 + go (x:xs) = x : go xs +{-# NOINLINE [1] cycle #-} + +{-# RULES +"cycle -> fusible" [~1] forall xs. + cycle xs = unstream (Stream.cycle (stream xs)) +"cycle -> unfused" [1] forall xs. + unstream (Stream.cycle (stream xs)) = cycle xs + #-} + +-- --------------------------------------------------------------------- +-- ** Unfolding + +-- | /fusion/. The 'unfoldr' function is a \`dual\' to 'foldr': while 'foldr' +-- reduces a list to a summary value, 'unfoldr' builds a list from +-- a seed value. The function takes the element and returns 'Nothing' +-- if it is done producing the list or returns 'Just' @(a,b)@, in which +-- case, @a@ is a prepended to the list and @b@ is used as the next +-- element in a recursive call. For example, +-- +-- > iterate f == unfoldr (\x -> Just (x, f x)) +-- +-- In some cases, 'unfoldr' can undo a 'foldr' operation: +-- +-- > unfoldr f' (foldr f z xs) == xs +-- +-- if the following holds: +-- +-- > f' (f x y) = Just (x,y) +-- > f' z = Nothing +-- +-- A simple use of unfoldr: +-- +-- > unfoldr (\b -> if b == 0 then Nothing else Just (b, b-1)) 10 +-- > [10,9,8,7,6,5,4,3,2,1] +-- +unfoldr :: (b -> Maybe (a, b)) -> b -> [a] +unfoldr f b0 = unfold b0 + where + unfold b = case f b of + Just (a,b') -> a : unfold b' + Nothing -> [] +{-# INLINE [1] unfoldr #-} + +{-# RULES +"unfoldr -> fusible" [~1] forall f x. + unfoldr f x = unstream (Stream.unfoldr f x) +"unfoldr -> unfused" [1] forall f x. + unstream (Stream.unfoldr f x) = unfoldr f x + #-} + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +-- | /O(n)/,/fusion/. 'take' @n@, applied to a list @xs@, returns the prefix of @xs@ +-- of length @n@, or @xs@ itself if @n > 'length' xs@: +-- +-- > take 5 "Hello World!" == "Hello" +-- > take 3 [1,2,3,4,5] == [1,2,3] +-- > take 3 [1,2] == [1,2] +-- > take 3 [] == [] +-- > take (-1) [1,2] == [] +-- > take 0 [1,2] == [] +-- +-- It is an instance of the more general 'Data.List.genericTake', +-- in which @n@ may be of any integral type. +-- +take :: Int -> [a] -> [a] +take i _ | i <= 0 = [] +take i ls = take' i ls + where + take' :: Int -> [a] -> [a] + take' 0 _ = [] + take' _ [] = [] + take' n (x:xs) = x : take' (n-1) xs +{-# NOINLINE [1] take #-} + +{-# RULES +"take -> fusible" [~1] forall n x. + take n x = unstream (Stream.take n (stream x)) +"take -> unfused" [1] forall n x. + unstream (Stream.take n (stream x)) = take n x + #-} + +{- +take :: Int -> [a] -> [a] +take (I# n#) xs = takeUInt n# xs + +takeUInt :: Int# -> [b] -> [b] +takeUInt n xs + | n >=# 0# = take_unsafe_UInt n xs + | otherwise = [] + +take_unsafe_UInt :: Int# -> [b] -> [b] +take_unsafe_UInt 0# _ = [] +take_unsafe_UInt m ls = + case ls of + [] -> [] + (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs +-} + +-- | /O(n)/,/fusion/. 'drop' @n xs@ returns the suffix of @xs@ +-- after the first @n@ elements, or @[]@ if @n > 'length' xs@: +-- +-- > drop 6 "Hello World!" == "World!" +-- > drop 3 [1,2,3,4,5] == [4,5] +-- > drop 3 [1,2] == [] +-- > drop 3 [] == [] +-- > drop (-1) [1,2] == [1,2] +-- > drop 0 [1,2] == [1,2] +-- +-- It is an instance of the more general 'Data.List.genericDrop', +-- in which @n@ may be of any integral type. +-- +drop :: Int -> [a] -> [a] +drop n ls + | n < 0 = ls + | otherwise = drop' n ls + where + drop' :: Int -> [a] -> [a] + drop' 0 xs = xs + drop' _ xs@[] = xs + drop' m (_:xs) = drop' (m-1) xs +{-# NOINLINE [1] drop #-} + +{-# RULES +"drop -> fusible" [~1] forall n x. + drop n x = unstream (Stream.drop n (stream x)) +"drop -> unfused" [1] forall n x. + unstream (Stream.drop n (stream x)) = drop n x + #-} + +-- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of +-- length @n@ and second element is the remainder of the list: +-- +-- > splitAt 6 "Hello World!" == ("Hello ","World!") +-- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5]) +-- > splitAt 1 [1,2,3] == ([1],[2,3]) +-- > splitAt 3 [1,2,3] == ([1,2,3],[]) +-- > splitAt 4 [1,2,3] == ([1,2,3],[]) +-- > splitAt 0 [1,2,3] == ([],[1,2,3]) +-- > splitAt (-1) [1,2,3] == ([],[1,2,3]) +-- +-- It is equivalent to @('take' n xs, 'drop' n xs)@. +-- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt', +-- in which @n@ may be of any integral type. +-- +splitAt :: Int -> [a] -> ([a], [a]) +splitAt n ls + | n < 0 = ([], ls) + | otherwise = splitAt' n ls + where + splitAt' :: Int -> [a] -> ([a], [a]) + splitAt' 0 xs = ([], xs) + splitAt' _ xs@[] = (xs, xs) + splitAt' m (x:xs) = (x:xs', xs'') + where + (xs', xs'') = splitAt' (m-1) xs +{-# NOINLINE [1] splitAt #-} + +{- +splitAt n xs | n <= 0 = ([], xs) +splitAt _ [] = ([], []) +splitAt n (x:xs) = (x:xs', xs'') + where + (xs', xs'') = splitAt (n-1) xs +-} + +{-# RULES +"splitAt -> fusible" [~1] forall n xs. + splitAt n xs = Stream.splitAt n (stream xs) +"splitAt -> unfused" [1] forall n xs. + Stream.splitAt n (stream xs) = splitAt n xs + #-} + +-- | /O(n)/,/fusion/. 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the +-- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@: +-- +-- > takeWhile (< 3) [1,2,3,4,1,2,3,4] == [1,2] +-- > takeWhile (< 9) [1,2,3] == [1,2,3] +-- > takeWhile (< 0) [1,2,3] == [] +-- +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile _ [] = [] +takeWhile p xs0 = go xs0 + where + go [] = [] + go (x:xs) + | p x = x : go xs + | otherwise = [] +{-# NOINLINE [1] takeWhile #-} + +{-# RULES +"takeWhile -> fusible" [~1] forall f xs. + takeWhile f xs = unstream (Stream.takeWhile f (stream xs)) +"takeWhile -> unfused" [1] forall f xs. + unstream (Stream.takeWhile f (stream xs)) = takeWhile f xs + #-} + +-- | /O(n)/,/fusion/. 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@: +-- +-- > dropWhile (< 3) [1,2,3,4,5,1,2,3] == [3,4,5,1,2,3] +-- > dropWhile (< 9) [1,2,3] == [] +-- > dropWhile (< 0) [1,2,3] == [1,2,3] +-- +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile _ [] = [] +dropWhile p xs0 = go xs0 + where + go [] = [] + go xs@(x:xs') + | p x = go xs' + | otherwise = xs +{-# NOINLINE [1] dropWhile #-} + +{-# RULES +"dropWhile -> fusible" [~1] forall f xs. + dropWhile f xs = unstream (Stream.dropWhile f (stream xs)) +"dropWhile -> unfused" [1] forall f xs. + unstream (Stream.dropWhile f (stream xs)) = dropWhile f xs + #-} + +-- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where +-- first element is longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@ and second element is the remainder of the list: +-- +-- > span (< 3) [1,2,3,4,1,2,3,4] == ([1,2],[3,4,1,2,3,4]) +-- > span (< 9) [1,2,3] == ([1,2,3],[]) +-- > span (< 0) [1,2,3] == ([],[1,2,3]) +-- +-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ +span :: (a -> Bool) -> [a] -> ([a], [a]) +span _ [] = ([], []) +span p xs0 = go xs0 + where + go [] = ([], []) + go xs@(x:xs') + | p x = let (ys,zs) = go xs' + in (x:ys,zs) + | otherwise = ([],xs) + +-- TODO fuse +-- Hmm, these do a lot of sharing, but is it worth it? + +-- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where +-- first element is longest prefix (possibly empty) of @xs@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the list: +-- +-- > break (> 3) [1,2,3,4,1,2,3,4] == ([1,2,3],[4,1,2,3,4]) +-- > break (< 9) [1,2,3] == ([],[1,2,3]) +-- > break (> 9) [1,2,3] == ([1,2,3],[]) +-- +-- 'break' @p@ is equivalent to @'span' ('not' . p)@. +-- +break :: (a -> Bool) -> [a] -> ([a], [a]) +break _ [] = ([], []) +break p xs0 = go xs0 + where + go [] = ([], []) + go xs@(x:xs') + | p x = ([],xs) + | otherwise = let (ys,zs) = go xs' + in (x:ys,zs) + +-- TODO fuse + +-- | The 'group' function takes a list and returns a list of lists such +-- that the concatenation of the result is equal to the argument. Moreover, +-- each sublist in the result contains only equal elements. For example, +-- +-- > group "Mississippi" = ["M","i","ss","i","ss","i","pp","i"] +-- +-- It is a special case of 'groupBy', which allows the programmer to supply +-- their own equality test. +group :: Eq a => [a] -> [[a]] +group [] = [] +group (x:xs) = (x:ys) : group zs + where (ys,zs) = span (x ==) xs + +-- TODO fuse + +-- | The 'inits' function returns all initial segments of the argument, +-- shortest first. For example, +-- +-- > inits "abc" == ["","a","ab","abc"] +-- +inits :: [a] -> [[a]] +inits [] = [] : [] +inits (x:xs) = [] : map (x:) (inits xs) + +-- TODO fuse + +-- | The 'tails' function returns all final segments of the argument, +-- longest first. For example, +-- +-- > tails "abc" == ["abc", "bc", "c",""] +-- +tails :: [a] -> [[a]] +tails [] = [] : [] +tails xxs@(_:xs) = xxs : tails xs + +-- TODO fuse + +------------------------------------------------------------------------ +-- * Predicates + +-- | /O(n)/,/fusion/. The 'isPrefixOf' function takes two lists and +-- returns 'True' iff the first list is a prefix of the second. +-- +isPrefixOf :: Eq a => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (x:xs) (y:ys) | x == y = isPrefixOf xs ys + | otherwise = False +{-# NOINLINE [1] isPrefixOf #-} + +{-# RULES +"isPrefixOf -> fusible" [~1] forall xs ys. + isPrefixOf xs ys = Stream.isPrefixOf (stream xs) (stream ys) +"isPrefixOf -> unfused" [1] forall xs ys. + Stream.isPrefixOf (stream xs) (stream ys) = isPrefixOf xs ys + #-} + +-- | The 'isSuffixOf' function takes two lists and returns 'True' +-- iff the first list is a suffix of the second. +-- Both lists must be finite. +isSuffixOf :: Eq a => [a] -> [a] -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y + +-- TODO fuse + +-- | The 'isInfixOf' function takes two lists and returns 'True' +-- iff the first list is contained, wholly and intact, +-- anywhere within the second. +-- +-- Example: +-- +-- > isInfixOf "Haskell" "I really like Haskell." -> True +-- > isInfixOf "Ial" "I really like Haskell." -> False +-- +isInfixOf :: Eq a => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + +-- TODO fuse + +-- --------------------------------------------------------------------- +-- * Searching lists +-- ** Searching by equality + +-- | /O(n)/, /fusion/. 'elem' is the list membership predicate, usually written +-- in infix form, e.g., @x `elem` xs@. +-- +elem :: Eq a => a -> [a] -> Bool +elem _ [] = False +elem x (y:ys) + | x == y = True + | otherwise = elem x ys +{-# NOINLINE [1] elem #-} + +{-# RULES +"elem -> fusible" [~1] forall x xs. + elem x xs = Stream.elem x (stream xs) +"elem -> unfused" [1] forall x xs. + Stream.elem x (stream xs) = elem x xs + #-} + +-- | /O(n)/, /fusion/. 'notElem' is the negation of 'elem'. +notElem :: Eq a => a -> [a] -> Bool +notElem x xs = not (elem x xs) +{-# INLINE notElem #-} + +{- RULES +-- We don't provide an expicilty fusible version, since not . elem is +-- just as good. + +"notElem -> fusible" [~1] forall x xs. + notElem x xs = Stream.notElem x (stream xs) +"notElem -> unfused" [1] forall x xs. + Stream.notElem x (stream xs) = notElem x xs + -} + +-- | /O(n)/,/fusion/. 'lookup' @key assocs@ looks up a key in an association list. +lookup :: Eq a => a -> [(a, b)] -> Maybe b +lookup _ [] = Nothing +lookup key xys0 = go xys0 + where + go [] = Nothing + go ((x,y):xys) + | key == x = Just y + | otherwise = lookup key xys +{-# NOINLINE [1] lookup #-} + +{-# RULES +"lookup -> fusible" [~1] forall x xs. + lookup x xs = Stream.lookup x (stream xs) +"lookup -> unfused" [1] forall x xs. + Stream.lookup x (stream xs) = lookup x xs + #-} + +-- | /O(n)/,/fusion/. 'filter', applied to a predicate and a list, returns the list of +-- those elements that satisfy the predicate; i.e., +-- +-- > filter p xs = [ x | x <- xs, p x] +-- +-- Properties: +-- +-- > filter p (filter q s) = filter (\x -> q x && p x) s +-- +filter :: (a -> Bool) -> [a] -> [a] +filter _ [] = [] +filter p xs0 = go xs0 + where + go [] = [] + go (x:xs) + | p x = x : go xs + | otherwise = go xs +{-# NOINLINE [1] filter #-} + +{-# RULES +"filter -> fusible" [~1] forall f xs. + filter f xs = unstream (Stream.filter f (stream xs)) +"filter -> unfused" [1] forall f xs. + unstream (Stream.filter f (stream xs)) = filter f xs + #-} + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +-- | /O(n)/,/fusion/. The 'find' function takes a predicate and a list and returns the +-- first element in the list matching the predicate, or 'Nothing' if +-- there is no such element. +find :: (a -> Bool) -> [a] -> Maybe a +find _ [] = Nothing +find p xs0 = go xs0 + where + go [] = Nothing + go (x:xs) | p x = Just x + | otherwise = go xs +{-# NOINLINE [1] find #-} + +{-# RULES +"find -> fusible" [~1] forall f xs. + find f xs = Stream.find f (stream xs) +"find -> unfused" [1] forall f xs. + Stream.find f (stream xs) = find f xs + #-} + +-- | The 'partition' function takes a predicate a list and returns +-- the pair of lists of elements which do and do not satisfy the +-- predicate, respectively; i.e., +-- +-- > partition p xs == (filter p xs, filter (not . p) xs) +partition :: (a -> Bool) -> [a] -> ([a], [a]) +partition p xs = foldr (select p) ([],[]) xs +{-# INLINE partition #-} + +-- TODO fuse + +select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a]) +select p x ~(ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) + +------------------------------------------------------------------------ +-- * Indexing lists + +-- | /O(n)/,/fusion/. List index (subscript) operator, starting from 0. +-- It is an instance of the more general 'Data.List.genericIndex', +-- which takes an index of any integral type. +(!!) :: [a] -> Int -> a +xs0 !! n0 + | n0 < 0 = error "Prelude.(!!): negative index" + | otherwise = index xs0 n0 +#ifndef __HADDOCK__ + where + index [] _ = error "Prelude.(!!): index too large" + index (y:ys) n = if n == 0 then y else index ys (n-1) +#endif +{-# NOINLINE [1] (!!) #-} + +{-# RULES +"!! -> fusible" [~1] forall xs n. + xs !! n = Stream.index (stream xs) n +"!! -> unfused" [1] forall xs n. + Stream.index (stream xs) n = xs !! n + #-} + +-- | The 'elemIndex' function returns the index of the first element +-- in the given list which is equal (by '==') to the query element, +-- or 'Nothing' if there is no such element. +-- +-- Properties: +-- +-- > elemIndex x xs = listToMaybe [ n | (n,a) <- zip [0..] xs, a == x ] +-- > elemIndex x xs = findIndex (x==) xs +-- +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x==) +{-# INLINE elemIndex #-} +{- +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex y xs0 = loop_elemIndex xs0 0 +#ifndef __HADDOCK__ + where + loop_elemIndex [] !_ = Nothing + loop_elemIndex (x:xs) !n + | p x = Just n + | otherwise = loop_elemIndex xs (n + 1) + p = (y ==) +#endif +{-# NOINLINE [1] elemIndex #-} +-} +{- RULES +"elemIndex -> fusible" [~1] forall x xs. + elemIndex x xs = Stream.elemIndex x (stream xs) +"elemIndex -> unfused" [1] forall x xs. + Stream.elemIndex x (stream xs) = elemIndex x xs + -} + +-- | /O(n)/,/fusion/. The 'elemIndices' function extends 'elemIndex', by +-- returning the indices of all elements equal to the query element, in +-- ascending order. +-- +-- Properties: +-- +-- > length (filter (==a) xs) = length (elemIndices a xs) +-- +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x==) +{-# INLINE elemIndices #-} + +{- +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices y xs0 = loop_elemIndices xs0 0 +#ifndef __HADDOCK__ + where + loop_elemIndices [] !_ = [] + loop_elemIndices (x:xs) !n + | p x = n : loop_elemIndices xs (n + 1) + | otherwise = loop_elemIndices xs (n + 1) + p = (y ==) +#endif +{-# NOINLINE [1] elemIndices #-} +-} +{- RULES +"elemIndices -> fusible" [~1] forall x xs. + elemIndices x xs = unstream (Stream.elemIndices x (stream xs)) +"elemIndices -> unfused" [1] forall x xs. + unstream (Stream.elemIndices x (stream xs)) = elemIndices x xs + -} + +-- | The 'findIndex' function takes a predicate and a list and returns +-- the index of the first element in the list satisfying the predicate, +-- or 'Nothing' if there is no such element. +-- +-- Properties: +-- +-- > findIndex p xs = listToMaybe [ n | (n,x) <- zip [0..] xs, p x ] +-- +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p ls = loop_findIndex ls 0# + where + loop_findIndex [] _ = Nothing + loop_findIndex (x:xs) n + | p x = Just (I# n) + | otherwise = loop_findIndex xs (n +# 1#) +{-# NOINLINE [1] findIndex #-} + +{-# RULES +"findIndex -> fusible" [~1] forall f xs. + findIndex f xs = Stream.findIndex f (stream xs) +"findIndex -> unfused" [1] forall f xs. + Stream.findIndex f (stream xs) = findIndex f xs + #-} + +-- | /O(n)/,/fusion/. The 'findIndices' function extends 'findIndex', by +-- returning the indices of all elements satisfying the predicate, in +-- ascending order. +-- +-- Properties: +-- +-- > length (filter p xs) = length (findIndices p xs) +-- +findIndices :: (a -> Bool) -> [a] -> [Int] +findIndices p ls = loop_findIndices ls 0# + where + loop_findIndices [] _ = [] + loop_findIndices (x:xs) n + | p x = I# n : loop_findIndices xs (n +# 1#) + | otherwise = loop_findIndices xs (n +# 1#) +{-# NOINLINE [1] findIndices #-} + +{-# RULES +"findIndices -> fusible" [~1] forall p xs. + findIndices p xs = unstream (Stream.findIndices p (stream xs)) +"findIndices -> unfused" [1] forall p xs. + unstream (Stream.findIndices p (stream xs)) = findIndices p xs + #-} + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +-- | /O(n)/,/fusion/. 'zip' takes two lists and returns a list of +-- corresponding pairs. If one input list is short, excess elements of +-- the longer list are discarded. +-- +-- Properties: +-- +-- > zip a b = zipWith (,) a b +-- +zip :: [a] -> [b] -> [(a, b)] +zip (a:as) (b:bs) = (a,b) : zip as bs +zip _ _ = [] +{-# NOINLINE [1] zip #-} + +{-# RULES +"zip -> fusible" [~1] forall xs ys. + zip xs ys = unstream (Stream.zip (stream xs) (stream ys)) +"zip -> unfused" [1] forall xs ys. + unstream (Stream.zip (stream xs) (stream ys)) = zip xs ys + #-} + +-- | /O(n)/,/fusion/. 'zip3' takes three lists and returns a list of +-- triples, analogous to 'zip'. +-- +-- Properties: +-- +-- > zip3 a b c = zipWith (,,) a b c +-- +zip3 :: [a] -> [b] -> [c] -> [(a, b, c)] +zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs +zip3 _ _ _ = [] +{-# NOINLINE [1] zip3 #-} + +{-# RULES +"zip3 -> fusible" [~1] forall xs ys zs. + zip3 xs ys zs = unstream (Stream.zipWith3 (,,) (stream xs) (stream ys) (stream zs)) +"zip3 -> unfused" [1] forall xs ys zs. + unstream (Stream.zipWith3 (,,) (stream xs) (stream ys) (stream zs)) = zip3 xs ys zs + #-} + +-- | /O(n)/,/fusion/. The 'zip4' function takes four lists and returns a list of +-- quadruples, analogous to 'zip'. +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)] +zip4 = zipWith4 (,,,) +{-# INLINE zip4 #-} + +-- | The 'zip5' function takes five lists and returns a list of +-- five-tuples, analogous to 'zip'. +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)] +zip5 = zipWith5 (,,,,) + +-- | The 'zip6' function takes six lists and returns a list of six-tuples, +-- analogous to 'zip'. +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)] +zip6 = zipWith6 (,,,,,) + +-- | The 'zip7' function takes seven lists and returns a list of +-- seven-tuples, analogous to 'zip'. +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)] +zip7 = zipWith7 (,,,,,,) + +-- | /O(n)/,/fusion/. 'zipWith' generalises 'zip' by zipping with the +-- function given as the first argument, instead of a tupling function. +-- For example, @'zipWith' (+)@ is applied to two lists to produce the +-- list of corresponding sums. +-- Properties: +-- +-- > zipWith (,) = zip +-- +zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWith f (a:as) (b:bs) = f a b : zipWith f as bs +zipWith _ _ _ = [] +{-# INLINE [1] zipWith #-} + +--FIXME: If we change the above INLINE to NOINLINE then ghc goes into +-- a loop, why? Do we have some dodgy recursive rules somewhere? + +{-# RULES +"zipWith -> fusible" [~1] forall f xs ys. + zipWith f xs ys = unstream (Stream.zipWith f (stream xs) (stream ys)) +"zipWith -> unfused" [1] forall f xs ys. + unstream (Stream.zipWith f (stream xs) (stream ys)) = zipWith f xs ys + #-} + +-- | /O(n)/,/fusion/. The 'zipWith3' function takes a function which +-- combines three elements, as well as three lists and returns a list of +-- their point-wise combination, analogous to 'zipWith'. +-- +-- Properties: +-- +-- > zipWith3 (,,) = zip3 +-- +zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +zipWith3 z (a:as) (b:bs) (c:cs) = z a b c : zipWith3 z as bs cs +zipWith3 _ _ _ _ = [] +{-# NOINLINE [1] zipWith3 #-} + +{-# RULES +"zipWith3 -> fusible" [~1] forall f xs ys zs. + zipWith3 f xs ys zs = unstream (Stream.zipWith3 f (stream xs) (stream ys) (stream zs)) +"zipWith3 -> unfused" [1] forall f xs ys zs. + unstream (Stream.zipWith3 f (stream xs) (stream ys) (stream zs)) = zipWith3 f xs ys zs + #-} + +-- | /O(n)/,/fusion/. The 'zipWith4' function takes a function which combines four +-- elements, as well as four lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] +zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] +{-# NOINLINE [1] zipWith4 #-} + +{-# RULES +"zipWith4 -> fusible" [~1] forall f ws xs ys zs. + zipWith4 f ws xs ys zs = unstream (Stream.zipWith4 f (stream ws) (stream xs) (stream ys) (stream zs)) +"zipWith4 -> unfused" [1] forall f ws xs ys zs. + unstream (Stream.zipWith4 f (stream ws) (stream xs) (stream ys) (stream zs)) = zipWith4 f ws xs ys zs + #-} + +-- | The 'zipWith5' function takes a function which combines five +-- elements, as well as five lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith5 :: (a -> b -> c -> d -> e -> f) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] +zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] + +-- TODO fuse + +-- | The 'zipWith6' function takes a function which combines six +-- elements, as well as six lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] +zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] + +-- TODO fuse + +-- | The 'zipWith7' function takes a function which combines seven +-- elements, as well as seven lists and returns a list of their point-wise +-- combination, analogous to 'zipWith'. +zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h] +zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +zipWith7 _ _ _ _ _ _ _ _ = [] + +-- TODO fuse + +------------------------------------------------------------------------ +-- unzips + +-- | 'unzip' transforms a list of pairs into a list of first components +-- and a list of second components. +unzip :: [(a, b)] -> ([a], [b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) + +-- TODO fuse + +-- | The 'unzip3' function takes a list of triples and returns three +-- lists, analogous to 'unzip'. +unzip3 :: [(a, b, c)] -> ([a], [b], [c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) ([],[],[]) + +-- TODO fuse + +-- | The 'unzip4' function takes a list of quadruples and returns four +-- lists, analogous to 'unzip'. +unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) + +-- TODO fuse + +-- | The 'unzip5' function takes a list of five-tuples and returns five +-- lists, analogous to 'unzip'. +unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) + +-- TODO fuse + +-- | The 'unzip6' function takes a list of six-tuples and returns six +-- lists, analogous to 'unzip'. +unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) + +-- TODO fuse + +-- | The 'unzip7' function takes a list of seven-tuples and returns +-- seven lists, analogous to 'unzip'. +unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) + +-- TODO fuse + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +-- | /O(O)/,/fusion/. 'lines' breaks a string up into a list of strings +-- at newline characters. The resulting strings do not contain +-- newlines. +lines :: String -> [String] +lines [] = [] +lines s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines s'' +--TODO: can we do better than this and preserve the same strictness? + +{- +-- This implementation is fast but too strict :-( +-- it doesn't yield each line until it has seen the ending '\n' + +lines :: String -> [String] +lines [] = [] +lines cs0 = go [] cs0 + where + go l [] = reverse l : [] + go l ('\n':cs) = reverse l : case cs of + [] -> [] + _ -> go [] cs + go l ( c :cs) = go (c:l) cs +-} +{-# INLINE [1] lines #-} + +{- RULES +"lines -> fusible" [~1] forall xs. + lines xs = unstream (Stream.lines (stream xs)) +"lines -> unfused" [1] forall xs. + unstream (Stream.lines (stream xs)) = lines xs + -} + +-- | 'words' breaks a string up into a list of words, which were delimited +-- by white space. +words :: String -> [String] +words s = case dropWhile isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = break isSpace s' +-- TODO fuse +--TODO: can we do better than this and preserve the same strictness? + +{- +-- This implementation is fast but too strict :-( +-- it doesn't yield each word until it has seen the ending space + +words cs0 = dropSpaces cs0 + where + dropSpaces :: String -> [String] + dropSpaces [] = [] + dropSpaces (c:cs) + | isSpace c = dropSpaces cs + | otherwise = munchWord [c] cs + + munchWord :: String -> String -> [String] + munchWord w [] = reverse w : [] + munchWord w (c:cs) + | isSpace c = reverse w : dropSpaces cs + | otherwise = munchWord (c:w) cs +-} + +-- | /O(n)/,/fusion/. 'unlines' is an inverse operation to 'lines'. +-- It joins lines, after appending a terminating newline to each. +-- +-- > unlines xs = concatMap (++"\n") +-- +unlines :: [String] -> String +unlines css0 = to css0 + where go [] css = '\n' : to css + go (c:cs) css = c : go cs css + + to [] = [] + to (cs:css) = go cs css +{-# NOINLINE [1] unlines #-} + +-- +-- fuse via: +-- unlines xs = concatMap (snoc xs '\n') +-- +{- RULES +"unlines -> fusible" [~1] forall xs. + unlines xs = unstream (Stream.concatMap (\x -> Stream.snoc (stream x) '\n') (stream xs)) +"unlines -> unfused" [1] forall xs. + unstream (Stream.concatMap (\x -> Stream.snoc (stream x) '\n') (stream xs)) = unlines xs + -} + +-- | 'unwords' is an inverse operation to 'words'. +-- It joins words with separating spaces. +unwords :: [String] -> String +unwords [] = [] +unwords (cs0:css0) = go cs0 css0 + where go [] css = to css + go (c:cs) css = c : go cs css + + to [] = [] + to (cs:ccs) = ' ' : go cs ccs + +-- TODO fuse + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +-- | The 'nub' function removes duplicate elements from a list. +-- In particular, it keeps only the first occurrence of each element. +-- (The name 'nub' means \`essence\'.) +-- It is a special case of 'nubBy', which allows the programmer to supply +-- their own equality test. +-- +nub :: Eq a => [a] -> [a] +nub l = nub' l [] + where + nub' [] _ = [] + nub' (x:xs) ls + | x `elem` ls = nub' xs ls + | otherwise = x : nub' xs (x:ls) + +{- RULES +-- ndm's optimisation +"sort/nub" forall xs. sort (nub xs) = map head (group (sort xs)) + -} + +-- TODO fuse + +-- | 'delete' @x@ removes the first occurrence of @x@ from its list argument. +-- For example, +-- +-- > delete 'a' "banana" == "bnana" +-- +-- It is a special case of 'deleteBy', which allows the programmer to +-- supply their own equality test. +-- +delete :: Eq a => a -> [a] -> [a] +delete = deleteBy (==) + +-- TODO fuse + +-- | The '\\' function is list difference ((non-associative). +-- In the result of @xs@ '\\' @ys@, the first occurrence of each element of +-- @ys@ in turn (if any) has been removed from @xs@. Thus +-- +-- > (xs ++ ys) \\ xs == ys. +-- +-- It is a special case of 'deleteFirstsBy', which allows the programmer +-- to supply their own equality test. +(\\) :: Eq a => [a] -> [a] -> [a] +(\\) = foldl (flip delete) + +-- | The 'union' function returns the list union of the two lists. +-- For example, +-- +-- > "dog" `union` "cow" == "dogcw" +-- +-- Duplicates, and elements of the first list, are removed from the +-- the second list, but if the first list contains duplicates, so will +-- the result. +-- It is a special case of 'unionBy', which allows the programmer to supply +-- their own equality test. +-- +union :: Eq a => [a] -> [a] -> [a] +union = unionBy (==) + +-- TODO fuse + +-- | The 'intersect' function takes the list intersection of two lists. +-- For example, +-- +-- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4] +-- +-- If the first list contains duplicates, so will the result. +-- It is a special case of 'intersectBy', which allows the programmer to +-- supply their own equality test. +-- +intersect :: Eq a => [a] -> [a] -> [a] +intersect = intersectBy (==) + +-- TODO fuse + +------------------------------------------------------------------------ +-- ** Ordered lists + +-- TODO stuff in Ord can use Map/IntMap +-- TODO Hooray, an Ord constraint! we could use a better structure. + +-- | The 'sort' function implements a stable sorting algorithm. +-- It is a special case of 'sortBy', which allows the programmer to supply +-- their own comparison function. +-- +-- Properties: +-- +-- > not (null x) ==> (head . sort) x = minimum x +-- > not (null x) ==> (last . sort) x = maximum x +-- +sort :: Ord a => [a] -> [a] +sort l = mergesort compare l + +-- TODO fuse, we have an Ord constraint! + +-- | /O(n)/,/fusion/. The 'insert' function takes an element and a list and inserts the +-- element into the list at the last position where it is still less +-- than or equal to the next element. In particular, if the list +-- is sorted before the call, the result will also be sorted. +-- It is a special case of 'insertBy', which allows the programmer to +-- supply their own comparison function. +-- +insert :: Ord a => a -> [a] -> [a] +insert e ls = insertBy (compare) e ls +{-# INLINE insert #-} + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +-- | The 'nubBy' function behaves just like 'nub', except it uses a +-- user-supplied equality predicate instead of the overloaded '==' +-- function. +nubBy :: (a -> a -> Bool) -> [a] -> [a] +nubBy eq l = nubBy' l [] + where + nubBy' [] _ = [] + nubBy' (y:ys) xs + | elem_by eq y xs = nubBy' ys xs + | otherwise = y : nubBy' ys (y:xs) + +-- TODO fuse + +-- Not exported: +-- Note that we keep the call to `eq` with arguments in the +-- same order as in the reference implementation +-- 'xs' is the list of things we've seen so far, +-- 'y' is the potential new element +-- +elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool +elem_by _ _ [] = False +elem_by eq y (x:xs) = if x `eq` y then True else elem_by eq y xs + +-- | The 'deleteBy' function behaves like 'delete', but takes a +-- user-supplied equality predicate. +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteBy _ _ [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +-- TODO fuse + +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) + + +-- | The 'unionBy' function is the non-overloaded version of 'union'. +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs + +-- TODO fuse + +-- | The 'intersectBy' function is the non-overloaded version of 'intersect'. +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] + +-- TODO fuse + +-- | The 'groupBy' function is the non-overloaded version of 'group'. +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy _ [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs + where (ys,zs) = span (eq x) xs + +-- TODO fuse + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +-- | The 'sortBy' function is the non-overloaded version of 'sort'. +sortBy :: (a -> a -> Ordering) -> [a] -> [a] +sortBy cmp l = mergesort cmp l + +-- TODO fuse + +mergesort :: (a -> a -> Ordering) -> [a] -> [a] +mergesort cmp xs = mergesort' cmp (map wrap xs) + +mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a] +mergesort' _ [] = [] +mergesort' _ [xs] = xs +mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss) + +merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]] +merge_pairs _ [] = [] +merge_pairs _ [xs] = [xs] +merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss + +merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +merge _ xs [] = xs +merge _ [] ys = ys +merge cmp (x:xs) (y:ys) + = case x `cmp` y of + GT -> y : merge cmp (x:xs) ys + _ -> x : merge cmp xs (y:ys) + +wrap :: a -> [a] +wrap x = [x] + +-- | /O(n)/,/fusion/. The non-overloaded version of 'insert'. +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy _ x [] = [x] +insertBy cmp x ys@(y:ys') + = case cmp x y of + GT -> y : insertBy cmp x ys' + _ -> x : ys +{-# NOINLINE [1] insertBy #-} + +{-# RULES +"insertBy -> fusible" [~1] forall f x xs. + insertBy f x xs = unstream (Stream.insertBy f x (stream xs)) +"insertBy -> unfused" [1] forall f x xs. + unstream (Stream.insertBy f x (stream xs)) = insertBy f x xs + #-} + +-- | /O(n)/,/fusion/. The 'maximumBy' function takes a comparison function and a list +-- and returns the greatest element of the list by the comparison function. +-- The list must be finite and non-empty. +-- +maximumBy :: (a -> a -> Ordering) -> [a] -> a +maximumBy _ [] = error "List.maximumBy: empty list" +maximumBy cmp xs = foldl1 max' xs + where + max' x y = case cmp x y of + GT -> x + _ -> y +{-# NOINLINE [1] maximumBy #-} + +{-# RULES +"maximumBy -> fused" [~1] forall p xs. + maximumBy p xs = Stream.maximumBy p (stream xs) +"maximumBy -> unfused" [1] forall p xs. + Stream.maximumBy p (stream xs) = maximumBy p xs + #-} + +-- | /O(n)/,/fusion/. The 'minimumBy' function takes a comparison function and a list +-- and returns the least element of the list by the comparison function. +-- The list must be finite and non-empty. +minimumBy :: (a -> a -> Ordering) -> [a] -> a +minimumBy _ [] = error "List.minimumBy: empty list" +minimumBy cmp xs = foldl1 min' xs + where + min' x y = case cmp x y of + GT -> y + _ -> x +{-# NOINLINE [1] minimumBy #-} + +{-# RULES +"minimumBy -> fused" [~1] forall p xs. + minimumBy p xs = Stream.minimumBy p (stream xs) +"minimumBy -> unfused" [1] forall p xs. + Stream.minimumBy p (stream xs) = minimumBy p xs + #-} + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +-- | The 'genericLength' function is an overloaded version of 'length'. In +-- particular, instead of returning an 'Int', it returns any type which is +-- an instance of 'Num'. It is, however, less efficient than 'length'. +-- +genericLength :: Num i => [b] -> i +genericLength [] = 0 +genericLength (_:l) = 1 + genericLength l +{-# NOINLINE [1] genericLength #-} + +{-# RULES +"genericLength -> fusible" [~1] forall xs. + genericLength xs = Stream.genericLength (stream xs) +"genericLength -> unfused" [1] forall xs. + Stream.genericLength (stream xs) = genericLength xs + #-} + +{-# RULES +"genericLength -> length/Int" genericLength = length :: [a] -> Int + #-} + +-- | /O(n)/,/fusion/. The 'genericTake' function is an overloaded version of 'take', which +-- accepts any 'Integral' value as the number of elements to take. +genericTake :: Integral i => i -> [a] -> [a] +genericTake 0 _ = [] +genericTake _ [] = [] +genericTake n (x:xs) + | n > 0 = x : genericTake (n-1) xs + | otherwise = error "List.genericTake: negative argument" +{-# NOINLINE [1] genericTake #-} + +{-# RULES +"genericTake -> fusible" [~1] forall xs n. + genericTake n xs = unstream (Stream.genericTake n (stream xs)) +"genericTake -> unfused" [1] forall xs n. + unstream (Stream.genericTake n (stream xs)) = genericTake n xs + #-} + +{-# RULES +"genericTake -> take/Int" genericTake = take :: Int -> [a] -> [a] + #-} + +-- | /O(n)/,/fusion/. The 'genericDrop' function is an overloaded version of 'drop', which +-- accepts any 'Integral' value as the number of elements to drop. +genericDrop :: Integral i => i -> [a] -> [a] +genericDrop 0 xs = xs +genericDrop _ [] = [] +genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs +genericDrop _ _ = error "List.genericDrop: negative argument" +{-# NOINLINE [1] genericDrop #-} + +{-# RULES +"genericDrop -> fusible" [~1] forall xs n. + genericDrop n xs = unstream (Stream.genericDrop n (stream xs)) +"genericDrop -> unfused" [1] forall xs n. + unstream (Stream.genericDrop n (stream xs)) = genericDrop n xs + #-} + +{-# RULES +"genericDrop -> drop/Int" genericDrop = drop :: Int -> [a] -> [a] + #-} + +-- | /O(n)/,/fusion/. The 'genericIndex' function is an overloaded version of '!!', which +-- accepts any 'Integral' value as the index. +genericIndex :: Integral a => [b] -> a -> b +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = error "List.genericIndex: negative argument." +genericIndex _ _ = error "List.genericIndex: index too large." +{-# NOINLINE [1] genericIndex #-} + + +-- can we pull the n > 0 test out and do it just once? +-- probably not since we don't know what n-1 does!! +-- can only specialise it for sane Integral instances :-( + +{-# RULES +"genericIndex -> fusible" [~1] forall xs n. + genericIndex xs n = Stream.genericIndex (stream xs) n +"genericIndex -> unfused" [1] forall xs n. + Stream.genericIndex (stream xs) n = genericIndex n xs + #-} + +{-# RULES +"genericIndex -> index/Int" genericIndex = (!!) :: [a] -> Int -> a + #-} + +-- | /O(n)/,/fusion/. The 'genericSplitAt' function is an overloaded +-- version of 'splitAt', which accepts any 'Integral' value as the +-- position at which to split. +-- +genericSplitAt :: Integral i => i -> [a] -> ([a], [a]) +genericSplitAt 0 xs = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') + where (xs',xs'') = genericSplitAt (n-1) xs +genericSplitAt _ _ = error "List.genericSplitAt: negative argument" + +{-# RULES +"genericSplitAt -> fusible" [~1] forall xs n. + genericSplitAt n xs = Stream.genericSplitAt n (stream xs) +"genericSplitAt -> unfused" [1] forall xs n. + Stream.genericSplitAt n (stream xs) = genericSplitAt n xs + #-} + +{-# RULES +"genericSplitAt -> splitAt/Int" genericSplitAt = splitAt :: Int -> [a] -> ([a], [a]) + #-} + +-- | /O(n)/,/fusion/. The 'genericReplicate' function is an overloaded version of 'replicate', +-- which accepts any 'Integral' value as the number of repetitions to make. +-- +genericReplicate :: Integral i => i -> a -> [a] +genericReplicate n x = genericTake n (repeat x) +{-# INLINE genericReplicate #-} + +{-# RULES +"genericReplicate -> replicate/Int" genericReplicate = replicate :: Int -> a -> [a] + #-} + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyList :: String -> a +errorEmptyList fun = moduleError fun "empty list" +{-# NOINLINE errorEmptyList #-} + +moduleError :: String -> String -> a +moduleError fun msg = error ("Data.List." ++ fun ++ ':':' ':msg) +{-# NOINLINE moduleError #-} + +bottom :: a +bottom = error "Data.List.Stream: bottom" +{-# NOINLINE bottom #-} diff --git a/Data/Stream.hs b/Data/Stream.hs new file mode 100644 --- /dev/null +++ b/Data/Stream.hs @@ -0,0 +1,1795 @@ +-- #hide +{-# OPTIONS_GHC -fdicts-cheap -fbang-patterns #-} + +-- | +-- Module : Data.Stream +-- Copyright : (c) Duncan Coutts 2007 +-- (c) Don Stewart 2007 +-- License : BSD-style +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : portable, requires cpp +-- Tested with : GHC 6.6 +-- +-- Stream fusion for sequences. Described in: +-- +-- /Rewriting Haskell Strings/, by Duncan Coutts, Don Stewart and +-- Roman Leshchinskiy, Practical Aspects of Declarative Languages +-- 8th International Symposium, PADL 2007, 2007. +-- +-- /Stream Fusion: From Lists to Streams to Nothing at All/, by +-- Duncan Coutts, Roman Leshchinskiy and Don Stwwart, ICFP 2007. +-- +-- +-- +-- +module Data.Stream ( + + -- * The stream data type + Stream(Stream), + Step(..), + + -- * Conversions with lists + stream, -- :: [a] -> Stream a + unstream, -- :: Stream a -> [a] + + -- internal grunge + L(L), -- hmm, does this affect whether these get removed? + + -- * Basic stream functions + append, -- :: Stream a -> Stream a -> Stream a + append1, -- :: Stream a -> [a] -> [a] + cons, -- :: a -> Stream a -> Stream a + snoc, -- :: Stream a -> a -> Stream a + head, -- :: Stream a -> a + last, -- :: Stream a -> a + tail, -- :: Stream a -> Stream a + init, -- :: Stream a -> Stream a + null, -- :: Stream a -> Bool + length, -- :: Stream a -> Int + + -- * Stream transformations + map, -- :: (a -> b) -> Stream a -> Stream b + -- reverse, -- :: Stream a -> Stream a + intersperse, -- :: a -> Stream a -> Stream a + -- intercalate, -- :: Stream a -> Stream (Stream a) -> Stream a + -- transpose, -- :: Stream (Stream a) -> Stream (Stream a) + + -- * Reducing streams (folds) + foldl, -- :: (b -> a -> b) -> b -> Stream a -> b + foldl', -- :: (b -> a -> b) -> b -> Stream a -> b + foldl1, -- :: (a -> a -> a) -> Stream a -> a + foldl1', -- :: (a -> a -> a) -> Stream a -> a + foldr, -- :: (a -> b -> b) -> b -> Stream a -> b + foldr1, -- :: (a -> a -> a) -> Stream a -> a + + -- ** Special folds + concat, -- :: Stream [a] -> [a] + concatMap, -- :: (a -> Stream b) -> Stream a -> Stream b + and, -- :: Stream Bool -> Bool + or, -- :: Stream Bool -> Bool + any, -- :: (a -> Bool) -> Stream a -> Bool + all, -- :: (a -> Bool) -> Stream a -> Bool + sum, -- :: Num a => Stream a -> a + product, -- :: Num a => Stream a -> a + maximum, -- :: Ord a => Stream a -> a + minimum, -- :: Ord a => Stream a -> a + strictMaximum, -- :: Ord a => Stream a -> a + strictMinimum, -- :: Ord a => Stream a -> a + + -- * Building lists + -- ** Scans + scanl, -- :: (a -> b -> a) -> a -> Stream b -> Stream a + scanl1, -- :: (a -> a -> a) -> Stream a -> Stream a +{- + scanr, -- :: (a -> b -> b) -> b -> Stream a -> Stream b + scanr1, -- :: (a -> a -> a) -> Stream a -> Stream a +-} + +{- + -- ** Accumulating maps + mapAccumL, -- :: (acc -> x -> (acc, y)) -> acc -> Stream x -> (acc, Stream y) + mapAccumR, -- :: (acc -> x -> (acc, y)) -> acc -> Stream x -> (acc, Stream y) +-} + + -- ** Infinite streams + iterate, -- :: (a -> a) -> a -> Stream a + repeat, -- :: a -> Stream a + replicate, -- :: Int -> a -> Stream a + cycle, -- :: Stream a -> Stream a + + -- ** Unfolding + unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Stream a + + -- * Substreams + -- ** Extracting substreams + take, -- :: Int -> Stream a -> Stream a + drop, -- :: Int -> Stream a -> Stream a + splitAt, -- :: Int -> Stream a -> ([a], [a]) + takeWhile, -- :: (a -> Bool) -> Stream a -> Stream a + dropWhile, -- :: (a -> Bool) -> Stream a -> Stream a +{- + span, -- :: (a -> Bool) -> Stream a -> (Stream a, Stream a) + break, -- :: (a -> Bool) -> Stream a -> (Stream a, Stream a) + group, -- :: Eq a => Stream a -> Stream (Stream a) + inits, -- :: Stream a -> Stream (Stream a) + tails, -- :: Stream a -> Stream (Stream a) +-} + + -- * Predicates + isPrefixOf, -- :: Eq a => Stream a -> Stream a -> Bool +{- + isSuffixOf, -- :: Eq a => Stream a -> Stream a -> Bool + isInfixOf, -- :: Eq a => Stream a -> Stream a -> Bool +-} + + -- * Searching streams + -- ** Searching by equality + elem, -- :: Eq a => a -> Stream a -> Bool + lookup, -- :: Eq a => a -> Stream (a, b) -> Maybe b + + -- ** Searching with a predicate + find, -- :: (a -> Bool) -> Stream a -> Maybe a + filter, -- :: (a -> Bool) -> Stream a -> Stream a +-- partition, -- :: (a -> Bool) -> Stream a -> ([a], [a]) + + -- * Indexing streams + index, -- :: Stream a -> Int -> a + findIndex, -- :: (a -> Bool) -> Stream a -> Maybe Int + elemIndex, -- :: Eq a => a -> Stream a -> Maybe Int + elemIndices, -- :: Eq a => a -> Stream a -> Stream Int + findIndices, -- :: (a -> Bool) -> Stream a -> Stream Int + + -- * Zipping and unzipping streams + zip, -- :: Stream a -> Stream b -> Stream (a, b) + zip3, -- :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) + zip4, + zipWith, -- :: (a -> b -> c) -> Stream a -> Stream b -> Stream c + zipWith3, -- :: (a -> b -> c -> d) -> Stream a -> Stream b -> Stream c -> Stream d + zipWith4, + +{- + zip4, zip5, zip6, zip7, + + zipWith4, zipWith5, zipWith6, zipWith7, +-} + unzip, -- :: Stream (a, b) -> (Stream a, Stream b) +{- + unzip3, -- :: Stream (a, b, c) -> (Stream a, Stream b, Stream c) + unzip4, unzip5, unzip6, unzip7, +-} + + -- * Special streams + -- ** Functions on strings +{- + lines, -- :: Stream Char -> Stream [Char] + unlines, -- :: Stream (Stream Char) -> Stream Char + words, -- :: Stream Char -> Stream (Stream Char) + unwords, -- :: Stream (Stream Char) -> Stream Char +-} + +{- + -- ** \"Set\" operations + nub, -- :: Eq a => Stream a -> Stream a + delete, -- :: Eq a => a -> Stream a -> Stream a + (\\), -- :: Eq a => Stream a -> Stream a -> Stream a + union, -- :: Eq a => Stream a -> Stream a -> Stream a + intersect, -- :: Eq a => Stream a -> Stream a -> Stream a +-} + +{- + -- ** Ordered streams + sort, -- :: Ord a => Stream a -> Stream a + insert, -- :: Ord a => a -> Stream a -> Stream a +-} + +{- + -- * Generalized functions + -- ** The \"By\" operations + -- *** User-supplied equality (replacing an Eq context) + nubBy, -- :: (a -> a -> Bool) -> Stream a -> Stream a + deleteBy, -- :: (a -> a -> Bool) -> a -> Stream a -> Stream a + deleteFirstsBy, -- :: (a -> a -> Bool) -> Stream a -> Stream a -> Stream a + unionBy, -- :: (a -> a -> Bool) -> Stream a -> Stream a -> Stream a + intersectBy, -- :: (a -> a -> Bool) -> Stream a -> Stream a -> Stream a + groupBy, -- :: (a -> a -> Bool) -> Stream a -> Stream (Stream a) +-} + + -- *** User-supplied comparison (replacing an Ord context) + insertBy, -- :: (a -> a -> Ordering) -> a -> Stream a -> Stream a +{- + sortBy, -- :: (a -> a -> Ordering) -> Stream a -> Stream a +-} + maximumBy, -- :: (a -> a -> Ordering) -> Stream a -> a + minimumBy, -- :: (a -> a -> Ordering) -> Stream a -> a + + -- * The \"generic\" operations + genericLength, -- :: Num i => Stream b -> i + genericTake, -- :: Integral i => i -> Stream a -> Stream a + genericDrop, -- :: Integral i => i -> Stream a -> Stream a + genericIndex, -- :: Integral a => Stream b -> a -> b + genericSplitAt, -- :: Integral i => i -> Stream a -> ([a], [a]) + + -- * Enum + enumFromToInt, -- :: Int -> Int -> Stream Int + enumFromToChar, -- :: Char -> Char -> Stream Char + enumDeltaInteger, -- :: Integer -> Integer -> Stream Integer + + -- * Monad + foldM, -- :: Monad m => (b -> a -> m b) -> b -> Stream a -> m b + foldM_, -- :: Monad m => (b -> a -> m b) -> b -> Stream a -> m () + + -- * List comprehension desugaring + return, -- :: a -> Stream a + guard, -- :: Bool -> Stream a -> Stream a + bind, -- :: (a -> Bool) -> (a -> [b]) -> [a] -> [b] + mapFilter, -- :: (a -> Bool) -> (a -> b) -> [a] -> [b] + declare -- :: (a -> Stream b) -> a -> Stream b + + ) where + +#ifndef EXTERNAL_PACKAGE + +import {-# SOURCE #-} GHC.Err (error) +import {-# SOURCE #-} GHC.Num (Num(..),Integer) +import {-# SOURCE #-} GHC.Real (Integral(..)) + +import GHC.Base (Int, Char, Eq(..), Ord(..), Functor(..), Bool(..), (&&), + Ordering(..), + (||),(&&), ($), + seq, otherwise, ord, chr, + Monad((>>=), (>>)), -- why >> ? we're not using it + -- for error messages: + String, (++)) +import qualified GHC.Base as Monad (Monad(return)) + +import Data.Tuple () + +#else + +import Prelude ( + error, + Num(..), + Integral(..), + Integer, + Int, Char, Eq(..), Ord(..), Functor(..), Ordering(..), Bool(..), + (&&), (||), ($), + seq, otherwise, + Monad((>>=)), + -- for error messages: + String, (++)) +import qualified Prelude as Monad (Monad(return)) + +import Data.Char (ord,chr) + +#endif + +import qualified Data.Maybe (Maybe(..)) + + +------------------------------------------------------------------------ +-- The stream data type + +-- | A stream. +-- +-- It is important that we never construct a bottom stream, because the +-- fusion rule is not true for bottom streams. +-- +-- > (replicate 1 True) ++ (tail undefined) +-- +-- The suspicion is that under fusion the append will force the bottom. +-- +data Stream a = forall s. Unlifted s => + Stream !(s -> Step a s) -- ^ a stepper function + !s -- ^ an initial state + +-- | A stream step. +-- +-- A step either ends a stream, skips a value, or yields a value +-- +data Step a s = Yield a !s + | Skip !s + | Done + +instance Functor Stream where fmap = map + + +-- A class of strict unlifted types. The Unlifted constraint in the Stream +-- type above enforces a separation between user's types and the types used +-- in stream states. +-- +class Unlifted a where + + -- This expose function needs to be called in folds/loops that consume + -- streams to expose the structure of the stream state to the simplifier + -- In particular, to SpecConstr. + -- + expose :: a -> b -> b + expose = seq + + -- This makes GHC's optimiser happier; it sometimes produces really bad + -- code for single-method dictionaries + -- + unlifted_dummy :: a + unlifted_dummy = error "unlifted_dummy" + +-- +-- Unlifted versions of () and Bool for use in Stream states. +-- +data None = None +instance Unlifted None + +data Switch = S1 | S2 +instance Unlifted Switch + +-- Unlifted pairs, Maybe and Either +-- +data (Unlifted a, Unlifted b) => a :!: b = !a :!: !b +instance (Unlifted a, Unlifted b) => Unlifted (a :!: b) where + expose (a :!: b) s = expose a (expose b s) + {-# INLINE expose #-} + +data Unlifted a => Maybe a = Nothing | Just !a +instance Unlifted a => Unlifted (Maybe a) where + expose (Just a) s = expose a s + expose Nothing s = s + {-# INLINE expose #-} + +data (Unlifted a, Unlifted b) => Either a b = Left !a | Right !b +instance (Unlifted a, Unlifted b) => Unlifted (Either a b) where + expose (Left a) s = expose a s + expose (Right b) s = expose b s + {-# INLINE expose #-} + +-- Some stream functions (notably concatMap) need to use a stream as a state +-- +instance Unlifted (Stream a) where + expose (Stream next s0) s = seq next (seq s0 s) + {-# INLINE expose #-} + + +-- Boxes for user's state. This is the gateway for user's types into unlifted +-- stream states. The L is always safe since it's lifted/lazy, exposing/seqing +-- it does nothing. +-- S is unlifted and so is only suitable for users states that we know we can +-- be strict in. This requires attention and auditing. +-- +data L a = L a -- lazy / lifted +newtype S a = S a -- strict / unlifted + +instance Unlifted (L a) where + expose (L _) s = s + {-# INLINE expose #-} + +instance Unlifted (S a) where + expose (S a) s = seq a s + {-# INLINE expose #-} + +-- +-- coding conventions; +-- +-- * we tag local loops with their wrapper's name, so they're easier to +-- spot in Core output +-- + +-- --------------------------------------------------------------------- +-- List/Stream conversion + +-- | Construct an abstract stream from a list. +stream :: [a] -> Stream a +stream xs0 = Stream next (L xs0) + where + {-# INLINE next #-} + next (L []) = Done + next (L (x:xs)) = Yield x (L xs) +{-# INLINE [0] stream #-} + +-- | Flatten a stream back into a list. +unstream :: Stream a -> [a] +unstream (Stream next s0) = unfold_unstream s0 + where + unfold_unstream !s = case next s of + Done -> [] + Skip s' -> expose s' $ unfold_unstream s' + Yield x s' -> expose s' $ x : unfold_unstream s' +{-# INLINE [0] unstream #-} + +-- +-- /The/ stream fusion rule +-- + +{-# RULES +"STREAM stream/unstream fusion" forall s. + stream (unstream s) = s + #-} + +-- --------------------------------------------------------------------- +-- Basic stream functions + +-- (++) +append :: Stream a -> Stream a -> Stream a +append (Stream next0 s01) (Stream next1 s02) = Stream next (Left s01) + where + {-# INLINE next #-} + next (Left s1) = case next0 s1 of + Done -> Skip (Right s02) + Skip s1' -> Skip (Left s1') + Yield x s1' -> Yield x (Left s1') + next (Right s2) = case next1 s2 of + Done -> Done + Skip s2' -> Skip (Right s2') + Yield x s2' -> Yield x (Right s2') +{-# INLINE [0] append #-} + +-- version that can share the second list arg, really very similar +-- to unstream, but conses onto a given list rather than []: +-- unstream s = append1 s [] +-- +append1 :: Stream a -> [a] -> [a] +append1 (Stream next s0) xs = loop_append1 s0 + where + loop_append1 !s = case next s of + Done -> xs + Skip s' -> expose s' loop_append1 s' + Yield x s' -> expose s' $ x : loop_append1 s' +{-# INLINE [0] append1 #-} + +snoc :: Stream a -> a -> Stream a +snoc (Stream next0 xs0) w = Stream next (Just xs0) + where + {-# INLINE next #-} + next (Just xs) = case next0 xs of + Done -> Yield w Nothing + Skip xs' -> Skip (Just xs') + Yield x xs' -> Yield x (Just xs') + next Nothing = Done +{-# INLINE [0] snoc #-} + +cons :: a -> Stream a -> Stream a +cons w (Stream next0 s0) = Stream next (S2 :!: s0) + where + {-# INLINE next #-} + next (S2 :!: s) = Yield w (S1 :!: s) + next (S1 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S1 :!: s') + Yield x s' -> Yield x (S1 :!: s') +{-# INLINE [0] cons #-} + +-- head +head :: Stream a -> a +head (Stream next s0) = loop_head s0 + where + loop_head !s = case next s of + Yield x _ -> x + Skip s' -> expose s' $ loop_head s' + Done -> errorEmptyStream "head" +{-# INLINE [0] head #-} + +-- last +last :: Stream a -> a +last (Stream next s0) = loop0_last s0 + where + loop0_last !s = case next s of + Done -> errorEmptyStream "last" + Skip s' -> expose s' $ loop0_last s' + Yield x s' -> expose s' $ loop_last x s' + loop_last x !s = case next s of + Done -> x + Skip s' -> expose s' $ loop_last x s' + Yield x' s' -> expose s' $ loop_last x' s' +{-# INLINE [0] last #-} + +-- tail +tail :: Stream a -> Stream a +tail (Stream next0 s0) = Stream next (S1 :!: s0) + where + {-# INLINE next #-} + next (S1 :!: s) = case next0 s of + Done -> errorEmptyStream "tail" + Skip s' -> Skip (S1 :!: s') + Yield _ s' -> Skip (S2 :!: s') -- drop the head + next (S2 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S2 :!: s') + Yield x s' -> Yield x (S2 :!: s') +{-# INLINE [0] tail #-} + +-- init +init :: Stream a -> Stream a +init (Stream next0 s0) = Stream next (Nothing :!: s0) + where + {-# INLINE next #-} + next (Nothing :!: s) = case next0 s of + Done -> errorEmptyStream "init" + Skip s' -> Skip (Nothing :!: s') + Yield x s' -> Skip (Just (L x) :!: s') + next (Just (L x) :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (Just (L x) :!: s') + Yield x' s' -> Yield x (Just (L x') :!: s') +{-# INLINE [0] init #-} + +-- null +null :: Stream a -> Bool +null (Stream next s0) = loop_null s0 + where + loop_null !s = case next s of + Done -> True + Yield _ _ -> False + Skip s' -> expose s' $ loop_null s' +{-# INLINE [0] null #-} + +-- length +length :: Stream a -> Int +length (Stream next s0) = loop_length (0::Int) s0 + where + loop_length !z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_length z s' + Yield _ s' -> expose s' $ loop_length (z+1) s' +{-# INLINE [0] length #-} + +{- +-- For lazy bytestrings +length64 :: Stream a -> Int64 +length64 (Stream next s0) = loop (0::Int64) s0 + where + loop z !s = case next s of + Done -> z + Skip s' -> loop z s' + Yield _ s' -> loop (z+1) s' +{-# INLINE [0] length64 #-} +-} + +-- --------------------------------------------------------------------- +-- Stream transformations + +-- map +map :: (a -> b) -> Stream a -> Stream b +map f (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> Yield (f x) s' +{-# INLINE [0] map #-} + +-- +-- a convenient rule for map +-- +{-# RULES + "STREAM map/map fusion" forall f g s. + map f (map g s) = map (\x -> f (g x)) s + #-} + +-- +-- relies strongly on SpecConstr +-- + +intersperse :: a -> Stream a -> Stream a +intersperse sep (Stream next0 s0) = Stream next (s0 :!: Nothing :!: S1) + where + {-# INLINE next #-} + next (s :!: Nothing :!: S1) = case next0 s of + Done -> Done + Skip s' -> Skip (s' :!: Nothing :!: S1) + Yield x s' -> Skip (s' :!: Just (L x) :!: S1) + + next (s :!: Just (L x) :!: S1) = Yield x (s :!: Nothing :!: S2) + + next (s :!: Nothing :!: S2) = case next0 s of + Done -> Done + Skip s' -> Skip (s' :!: Nothing :!: S2) + Yield x s' -> Yield sep (s' :!: Just (L x) :!: S1) + + -- next (_ :!: (Just (L _))) :!: S2 -- can't happen + +{- +intersperse :: a -> Stream a -> [a] +intersperse sep (Stream next s0) = loop_intersperse_start s0 + where + loop_intersperse_start !s = case next s of + Done -> [] + Skip s' -> expose s' $ loop_intersperse_start s' + Yield x s' -> expose s' $ x : loop_intersperse_go s' + + loop_intersperse_go !s = case next s of + Done -> [] + Skip s' -> expose s' $ loop_intersperse_go s' + Yield x s' -> expose s' $ sep : x : loop_intersperse_go s' +-} + +-- intercalate :: Stream a -> Stream (Stream a) -> Stream a +-- transpose :: Stream (Stream a) -> Stream (Stream a) + +------------------------------------------------------------------------ + +-- * Reducing streams (folds) + +foldl :: (b -> a -> b) -> b -> Stream a -> b +foldl f z0 (Stream next s0) = loop_foldl z0 s0 + where + loop_foldl z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_foldl z s' + Yield x s' -> expose s' $ loop_foldl (f z x) s' +{-# INLINE [0] foldl #-} + +foldl' :: (b -> a -> b) -> b -> Stream a -> b +foldl' f z0 (Stream next s0) = loop_foldl' z0 s0 + where + loop_foldl' !z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_foldl' z s' + Yield x s' -> expose s' $ loop_foldl' (f z x) s' +{-# INLINE [0] foldl' #-} + +foldl1 :: (a -> a -> a) -> Stream a -> a +foldl1 f (Stream next s0) = loop0_foldl1 s0 + where + loop0_foldl1 !s = case next s of + Skip s' -> expose s' $ loop0_foldl1 s' + Yield x s' -> expose s' $ loop_foldl1 x s' + Done -> errorEmptyStream "foldl1" + + loop_foldl1 z !s = expose s $ case next s of + Done -> z + Skip s' -> expose s' $ loop_foldl1 z s' + Yield x s' -> expose s' $ loop_foldl1 (f z x) s' +{-# INLINE [0] foldl1 #-} + +foldl1' :: (a -> a -> a) -> Stream a -> a +foldl1' f (Stream next s0) = loop0_foldl1' s0 + where + loop0_foldl1' !s = case next s of + Skip s' -> expose s' $ loop0_foldl1' s' + Yield x s' -> expose s' $ loop_foldl1' x s' + Done -> errorEmptyStream "foldl1" + + loop_foldl1' !z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_foldl1' z s' + Yield x s' -> expose s' $ loop_foldl1' (f z x) s' +{-# INLINE [0] foldl1' #-} + +foldr :: (a -> b -> b) -> b -> Stream a -> b +foldr f z (Stream next s0) = loop_foldr s0 + where + loop_foldr !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_foldr s' + Yield x s' -> expose s' $ f x (loop_foldr s') +{-# INLINE [0] foldr #-} + +foldr1 :: (a -> a -> a) -> Stream a -> a +foldr1 f (Stream next s0) = loop0_foldr1 s0 + where + loop0_foldr1 !s = case next s of + Done -> errorEmptyStream "foldr1" + Skip s' -> expose s' $ loop0_foldr1 s' + Yield x s' -> expose s' $ loop_foldr1 x s' + + loop_foldr1 x !s = case next s of + Done -> x + Skip s' -> expose s' $ loop_foldr1 x s' + Yield x' s' -> expose s' $ f x (loop_foldr1 x' s') +{-# INLINE [0] foldr1 #-} + +------------------------------------------------------------------------ +-- ** Special folds + +-- concat +-- + +concat :: Stream [a] -> [a] +concat (Stream next s0) = loop_concat_to s0 + where + loop_concat_go [] !s = expose s $ loop_concat_to s + loop_concat_go (x:xs) !s = expose s $ x : loop_concat_go xs s + + loop_concat_to !s = case next s of + Done -> [] + Skip s' -> expose s' $ loop_concat_to s' + Yield xs s' -> expose s' $ loop_concat_go xs s' +{-# INLINE [0] concat #-} + +{- +concat :: Stream [a] -> Stream a +concat (Stream next0 s0) = Stream next (Nothing :!: s0) + where + {-# INLINE next #-} + next (Just (L []) :!: s) = expose s $ Skip (Nothing :!: s) + next (Just (L (x:xs)) :!: s) = expose s $ Yield x (Just (L xs) :!: s) + + next (Nothing :!: s) = case next0 s of + Done -> Done + Skip s' -> expose s' $ Skip (Nothing :!: s') + Yield xs s' -> expose s' $ Skip (Just (L xs) :!: s') +-} + +{- +concatMap :: (a -> [b]) -> Stream a -> [b] +concatMap f (Stream next s0) = loop_concatMap_to s0 + where + loop_concatMap_go [] !s = expose s $ loop_concatMap_to s + loop_concatMap_go (b:bs) !s = expose s $ b : loop_concatMap_go bs s + + loop_concatMap_to !s = case next s of + Done -> [] + Skip s' -> expose s' $ loop_concatMap_to s' + Yield a s' -> expose s' $ loop_concatMap_go (f a) s' +{-# INLINE [0] concatMap #-} +-} + +{- +concatMap :: (a -> [b]) -> Stream a -> Stream b +concatMap f (Stream next0 s0) = Stream next (Nothing :!: s0) + where + {-# INLINE next #-} + next (Just (L []) :!: s) = expose s $ Skip (Nothing :!: s) + next (Just (L (b:bs)) :!: s) = expose s $ Yield b (Just (L bs) :!: s) + + next (Nothing :!: s) = case next0 s of + Done -> Done + Skip s' -> expose s' $ Skip (Nothing :!: s') + Yield a s' -> expose s' $ Skip (Just (L (f a)) :!: s') + +-} +{- +Here's an approach to fusing concatMap fully: +we try and match the Stream inside in the argument to concatMap and pass that +directly to a concatMap' variant. The point here is that the step function does +not depend on 'x', something which the rule below does not enforce :-) +-} + +{- RULES +"dodgy concatMap rule" forall step f. + concatMap (\x -> unstream (Stream step (f x))) = \y -> unstream (concatMap' step f y) + -} + +{- +concatMap' :: Unlifted s => (s -> Step b s) -> (a -> s) -> Stream a -> Stream b +concatMap' nextb f (Stream nexta sa0) = Stream next (sa0 :!: Nothing) + where + {-# INLINE next #-} + next (sa :!: Just sb) = case nextb sb of + Done -> Skip (sa :!: Nothing) + Skip sb' -> Skip (sa :!: Just sb') + Yield b sb' -> Yield b (sa :!: Just sb') + + next (sa :!: Nothing) = case nexta sa of + Done -> Done + Skip sa' -> Skip (sa' :!: Nothing) + Yield a sa' -> Skip (sa' :!: Just (f a)) +-} + +{- +-- note the nested stream is a little hard to construct in a fusible +-- manner +-- +concat :: Stream (Stream a) -> Stream a +concat (Stream next0 s0) = Stream next (Right s0) + where + {-# INLINE next #-} + next (Left (Stream f t :!: s)) = case f t of + Done -> Skip (Right s) + Skip t' -> Skip (Left (Stream f t' :!: s)) + Yield x t' -> Yield x (Left (Stream f t' :!: s)) + next (Right s) = case next0 s of + Done -> Done + Skip s' -> Skip (Right s') + Yield x s' -> Skip (Left (x :!: s')) +{-# INLINE [0] concat #-} +-} + +concatMap :: (a -> Stream b) -> Stream a -> Stream b +concatMap f (Stream next0 s0) = Stream next (s0 :!: Nothing) + where + {-# INLINE next #-} + next (s :!: Nothing) = case next0 s of + Done -> Done + Skip s' -> Skip (s' :!: Nothing) + Yield x s' -> Skip (s' :!: Just (f x)) + + next (s :!: Just (Stream g t)) = case g t of + Done -> Skip (s :!: Nothing) + Skip t' -> Skip (s :!: Just (Stream g t')) + Yield x t' -> Yield x (s :!: Just (Stream g t')) + +{-# INLINE [0] concatMap #-} + +and :: Stream Bool -> Bool +and = foldr (&&) True +{-# INLINE and #-} + +or :: Stream Bool -> Bool +or = foldr (||) False +{-# INLINE or #-} + +any :: (a -> Bool) -> Stream a -> Bool +any p (Stream next s0) = loop_any s0 + where + loop_any !s = case next s of + Done -> False + Skip s' -> expose s' $ loop_any s' + Yield x s' | p x -> True + | otherwise -> expose s' $ loop_any s' +{-# INLINE [0] any #-} + +all :: (a -> Bool) -> Stream a -> Bool +all p (Stream next s0) = loop_all s0 + where + loop_all !s = case next s of + Done -> True + Skip s' -> expose s' $ loop_all s' + Yield x s' | p x -> expose s' $ loop_all s' + | otherwise -> False +{-# INLINE [0] all #-} + +sum :: Num a => Stream a -> a +sum (Stream next s0) = loop_sum 0 s0 + where + loop_sum !a !s = case next s of -- note: strict in the accumulator! + Done -> a + Skip s' -> expose s' $ loop_sum a s' + Yield x s' -> expose s' $ loop_sum (a + x) s' +{-# INLINE [0] sum #-} + +product :: Num a => Stream a -> a +product (Stream next s0) = loop_product 1 s0 -- note: strict in the accumulator! + where + loop_product !a !s = case next s of + Done -> a + Skip s' -> expose s' $ loop_product a s' + Yield x s' -> expose s' $ loop_product (a * x) s' +{-# INLINE [0] product #-} + +maximum :: Ord a => Stream a -> a +maximum (Stream next s0) = loop0_maximum s0 + where + loop0_maximum !s = case next s of + Done -> errorEmptyStream "maximum" + Skip s' -> expose s' $ loop0_maximum s' + Yield x s' -> expose s' $ loop_maximum x s' + loop_maximum z !s = case next s of -- note, lazy in the accumulator + Done -> z + Skip s' -> expose s' $ loop_maximum z s' + Yield x s' -> expose s' $ loop_maximum (max z x) s' +{-# INLINE [0] maximum #-} + +{-# RULES + "maximumInt" maximum = (strictMaximum :: Stream Int -> Int); + "maximumChar" maximum = (strictMaximum :: Stream Char -> Char) + #-} + +strictMaximum :: Ord a => Stream a -> a +strictMaximum (Stream next s0) = loop0_strictMaximum s0 + where + loop0_strictMaximum !s = case next s of + Done -> errorEmptyStream "maximum" + Skip s' -> expose s' $ loop0_strictMaximum s' + Yield x s' -> expose s' $ loop_strictMaximum x s' + loop_strictMaximum !z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_strictMaximum z s' + Yield x s' -> expose s' $ loop_strictMaximum (max z x) s' +{-# INLINE [0] strictMaximum #-} + +minimum :: Ord a => Stream a -> a +minimum (Stream next s0) = loop0_minimum s0 + where + loop0_minimum !s = case next s of + Done -> errorEmptyStream "minimum" + Skip s' -> expose s' $ loop0_minimum s' + Yield x s' -> expose s' $ loop_minimum x s' + loop_minimum z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_minimum z s' + Yield x s' -> expose s' $ loop_minimum (min z x) s' +{-# INLINE [0] minimum #-} + +{-# RULES + "minimumInt" minimum = (strictMinimum :: Stream Int -> Int); + "minimumChar" minimum = (strictMinimum :: Stream Char -> Char) + #-} + +strictMinimum :: Ord a => Stream a -> a +strictMinimum (Stream next s0) = loop0_strictMinimum s0 + where + loop0_strictMinimum !s = case next s of + Done -> errorEmptyStream "minimum" + Skip s' -> expose s' $ loop0_strictMinimum s' + Yield x s' -> expose s' $ loop_strictMinimum x s' + loop_strictMinimum !z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_strictMinimum z s' + Yield x s' -> expose s' $ loop_strictMinimum (min z x) s' +{-# INLINE [0] strictMinimum #-} + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +-- +-- FIXME: not a proper scanl. expects a list one longer than the input list, +-- in order to get the z0th element +-- +scanl :: (b -> a -> b) -> b -> Stream a -> Stream b +scanl f z0 (Stream next0 s0) = Stream next (L z0 :!: s0) + where + {-# INLINE next #-} + next (L z :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (L z :!: s') + Yield x s' -> Yield z (L (f z x) :!: s') +{-# INLINE [0] scanl #-} + +scanl1 :: (a -> a -> a) -> Stream a -> Stream a +scanl1 f (Stream next0 s0) = Stream next (Nothing :!: s0) + where + {-# INLINE next #-} + next (Nothing :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (Nothing :!: s') + Yield x s' -> Skip (Just (L x) :!: s') + next (Just (L z) :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (Just (L z) :!: s') + Yield x s' -> Yield z (Just (L (f z x)) :!: s') +{-# INLINE [0] scanl1 #-} + +-- +-- hmm. hard. +-- + +{- +scanr :: (b -> a -> b) -> b -> Stream a -> Stream b +scanr f z0 (Stream next s0) = Stream next' (Just s0) + where + next' (Just s) = case next s of + Done -> Yield z0 (Nothing, s) + Skip s' -> Skip (Just s') + Yield x s' -> -- hmm. + + next' Nothing = Done +{-# INLINE [0] scanl #-} +-} + + +{- +scanr :: (a -> b -> b) -> b -> Stream a -> Stream b +scanr f z0 (Stream next s0) = Stream next' (z0, s0) -- should be using strict pairs?? + where + next' (z, s) = case next s of + Done -> Done + Skip s' -> Skip (z, s') + Yield x s' -> Yield z (f x z, s') -- flip f +{-# INLINE [0] scanr #-} +-} + +{- +scanl1 :: (a -> a -> a) -> Stream a -> Stream a +scanr1 :: (a -> a -> a) -> Stream a -> Stream a +-} + +------------------------------------------------------------------------ +-- ** Accumulating maps + +{- +-- +-- not right: +-- +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> Stream x -> (acc, Stream y) +mapAccumL f acc (Stream step s) = Stream step' (s, acc) + where + step' (s, acc) = case step s of + Done -> Done + Skip s' -> Skip (s', acc) + Yield x s' -> let (acc', y) = f acc x in Yield y (s', acc') +{-# INLINE [0] mapAccumL #-} +-} + +{- +mapAccumR :: (acc -> x -> (acc, y)) -> acc -> Stream x -> (acc, Stream y) +-} + +------------------------------------------------------------------------ +-- ** Infinite streams + +iterate :: (a -> a) -> a -> Stream a +iterate f x0 = Stream next (L x0) + where + {-# INLINE next #-} + next (L x) = Yield x (L (f x)) +{-# INLINE [0] iterate #-} + +repeat :: a -> Stream a +repeat x = Stream next None + where + {-# INLINE next #-} + next _ = Yield x None +{-# INLINE [0] repeat #-} + +{-# RULES + "map/repeat" forall f x. map f (repeat x) = repeat (f x) + #-} + +replicate :: Int -> a -> Stream a +replicate n x = Stream next (L n) + where + {-# INLINE next #-} + next (L !i) | i <= 0 = Done + | otherwise = Yield x (L (i-1)) +{-# INLINE [0] replicate #-} + +{-# RULES + "map/replicate" forall f n x. map f (replicate n x) = replicate n (f x) + #-} + +--"reverse/replicate" forall n x. reverse (replicate n x) = replicate n x + +cycle :: Stream a -> Stream a +cycle (Stream next0 s0) = Stream next (s0 :!: S1) + where + {-# INLINE next #-} + next (s :!: S1) = case next0 s of + Done -> errorEmptyStream "cycle" + Skip s' -> Skip (s' :!: S1) + Yield x s' -> Yield x (s' :!: S2) + next (s :!: S2) = case next0 s of + Done -> Skip (s0 :!: S2) + Skip s' -> Skip (s' :!: S2) + Yield x s' -> Yield x (s' :!: S2) +{-# INLINE [0] cycle #-} + +------------------------------------------------------------------------ +-- ** Unfolding + +unfoldr :: (b -> Data.Maybe.Maybe (a, b)) -> b -> Stream a +unfoldr f s0 = Stream next (L s0) + where + {-# INLINE next #-} + next (L s) = case f s of + Data.Maybe.Nothing -> Done + Data.Maybe.Just (w, s') -> Yield w (L s') +{-# INLINE [0] unfoldr #-} + +------------------------------------------------------------------------ +-- * Substreams +-- ** Extracting substreams + +take :: Int -> Stream a -> Stream a +take n0 (Stream next0 s0) = Stream next (L n0 :!: s0) + where + {-# INLINE next #-} + next (L !n :!: s) + | n <= 0 = Done + | otherwise = case next0 s of + Done -> Done + Skip s' -> Skip (L n :!: s') + Yield x s' -> Yield x (L (n-1) :!: s') +{-# INLINE [0] take #-} + +drop :: Int -> Stream a -> Stream a +drop n0 (Stream next0 s0) = Stream next (Just (L (max 0 n0)) :!: s0) + where + {-# INLINE next #-} + next (Just (L !n) :!: s) + | n == 0 = Skip (Nothing :!: s) + | otherwise = case next0 s of + Done -> Done + Skip s' -> Skip (Just (L n) :!: s') + Yield _ s' -> Skip (Just (L (n-1)) :!: s') + next (Nothing :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (Nothing :!: s') + Yield x s' -> Yield x (Nothing :!: s') +{-# INLINE [0] drop #-} + +--TODO: could perhaps use 0 instead of Nothing, so long as +-- spec constr works with that + +splitAt :: Int -> Stream a -> ([a], [a]) +splitAt n0 (Stream next s0) + --TODO: we should not need this special case, (n < 0) should be as + -- cheap as pattern matching n against 0 + | n0 < 0 = ([], expose s0 $ unstream (Stream next s0)) + | otherwise = loop_splitAt n0 s0 + where + loop_splitAt 0 !s = ([], expose s $ unstream (Stream next s)) + loop_splitAt !n !s = case next s of + Done -> ([], []) + Skip s' -> expose s $ loop_splitAt n s' + Yield x s' -> (x:xs', xs'') + where + (xs', xs'') = expose s $ loop_splitAt (n-1) s' +{-# INLINE [0] splitAt #-} + +takeWhile :: (a -> Bool) -> Stream a -> Stream a +takeWhile p (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Done +{-# INLINE [0] takeWhile #-} + +dropWhile :: (a -> Bool) -> Stream a -> Stream a +dropWhile p (Stream next0 s0) = Stream next (S1 :!: s0) + where + {-# INLINE next #-} + next (S1 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S1 :!: s') + Yield x s' | p x -> Skip (S1 :!: s') + | otherwise -> Yield x (S2 :!: s') + next (S2 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S2 :!: s') + Yield x s' -> Yield x (S2 :!: s') +{-# INLINE [0] dropWhile #-} + +{- +span :: (a -> Bool) -> Stream a -> (Stream a, Stream a) +break :: (a -> Bool) -> Stream a -> (Stream a, Stream a) +group :: Eq a => Stream a -> Stream (Stream a) +inits :: Stream a -> Stream (Stream a) +tails :: Stream a -> Stream (Stream a) +-} + +------------------------------------------------------------------------ +-- * Predicates + +isPrefixOf :: Eq a => Stream a -> Stream a -> Bool +isPrefixOf (Stream stepa sa0) (Stream stepb sb0) = loop_isPrefixOf sa0 sb0 Nothing + where + loop_isPrefixOf !sa !sb Nothing = case stepa sa of + Done -> True + Skip sa' -> expose sa' $ loop_isPrefixOf sa' sb Nothing + Yield x sa' -> expose sa' $ loop_isPrefixOf sa' sb (Just (L x)) + + loop_isPrefixOf !sa !sb (Just (L x)) = case stepb sb of + Done -> False + Skip sb' -> expose sb' $ loop_isPrefixOf sa sb' (Just (L x)) + Yield y sb' | x == y -> expose sb' $ loop_isPrefixOf sa sb' Nothing + | otherwise -> False +{-# INLINE [0] isPrefixOf #-} + + +{- +isSuffixOf :: Eq a => Stream a -> Stream a -> Bool +isInfixOf :: Eq a => Stream a -> Stream a -> Bool +-} + +------------------------------------------------------------------------ +-- * Searching streams +-- ** Searching by equality + +elem :: Eq a => a -> Stream a -> Bool +elem x (Stream next s0) = loop_elem s0 + where + loop_elem !s = case next s of + Done -> False + Skip s' -> expose s' $ loop_elem s' + Yield y s' + | x == y -> True + | otherwise -> expose s' $ loop_elem s' +{-# INLINE [0] elem #-} + +{- +-- +-- No need to provide notElem, as not . elem is just as fusible. +-- You can only fuse on the rhs of elem anyway. +-- + +notElem :: Eq a => a -> Stream a -> Bool +notElem x (Stream next s0) = loop s0 + where + loop !s = case next s of + Done -> True + Skip s' -> loop s' + Yield y s' | x == y -> False + | otherwise -> loop s' +{-# INLINE [0] notElem #-} +-} + +lookup :: Eq a => a -> Stream (a, b) -> Data.Maybe.Maybe b +lookup key (Stream next s0) = loop_lookup s0 + where + loop_lookup !s = case next s of + Done -> Data.Maybe.Nothing + Skip s' -> expose s' $ loop_lookup s' + Yield (x, y) s' | key == x -> Data.Maybe.Just y + | otherwise -> expose s' $ loop_lookup s' +{-# INLINE [0] lookup #-} + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +find :: (a -> Bool) -> Stream a -> Data.Maybe.Maybe a +find p (Stream next s0) = loop_find s0 + where + loop_find !s = case next s of + Done -> Data.Maybe.Nothing + Skip s' -> expose s' $ loop_find s' + Yield x s' | p x -> Data.Maybe.Just x + | otherwise -> expose s' $ loop_find s' +{-# INLINE [0] find #-} + +filter :: (a -> Bool) -> Stream a -> Stream a +filter p (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next !s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Skip s' +{-# INLINE [0] filter #-} + +{-# RULES + "Stream filter/filter fusion" forall p q s. + filter p (filter q s) = filter (\x -> q x && p x) s + #-} + +--partition :: (a -> Bool) -> Stream a -> (Stream a, Stream a) + +------------------------------------------------------------------------ +-- * Indexing streams + +index :: Stream a -> Int -> a +index (Stream next s0) n0 + | n0 < 0 = error "Stream.(!!): negative index" + | otherwise = loop_index n0 s0 + where + loop_index !n !s = case next s of + Done -> error "Stream.(!!): index too large" + Skip s' -> expose s' $ loop_index n s' + Yield x s' | n == 0 -> x + | otherwise -> expose s' $ loop_index (n-1) s' +{-# INLINE [0] index #-} + +findIndex :: (a -> Bool) -> Stream a -> Data.Maybe.Maybe Int +findIndex p (Stream next s0) = loop_findIndex 0 s0 + where + loop_findIndex !i !s = case next s of + Done -> Data.Maybe.Nothing + Skip s' -> expose s' $ loop_findIndex i s' -- hmm. not caught by QC + Yield x s' | p x -> Data.Maybe.Just i + | otherwise -> expose s' $ loop_findIndex (i+1) s' +{-# INLINE [0] findIndex #-} + +elemIndex :: Eq a => a -> Stream a -> Data.Maybe.Maybe Int +elemIndex a (Stream next s0) = loop_elemIndex 0 s0 + where + loop_elemIndex !i !s = case next s of + Done -> Data.Maybe.Nothing + Skip s' -> expose s' $ loop_elemIndex i s' + Yield x s' | a == x -> Data.Maybe.Just i + | otherwise -> expose s' $ loop_elemIndex (i+1) s' +{-# INLINE [0] elemIndex #-} + +elemIndices :: Eq a => a -> Stream a -> Stream Int +elemIndices a (Stream next0 s0) = Stream next (S 0 :!: s0) + where + {-# INLINE next #-} + next (S n :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S n :!: s') + Yield x s' | x == a -> Yield n (S (n+1) :!: s') + | otherwise -> Skip (S (n+1) :!: s') +{-# INLINE [0] elemIndices #-} + +findIndices :: (a -> Bool) -> Stream a -> Stream Int +findIndices p (Stream next0 s0) = Stream next (S 0 :!: s0) + where + {-# INLINE next #-} + next (S n :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S n :!: s') + Yield x s' | p x -> Yield n (S (n+1) :!: s') + | otherwise -> Skip (S (n+1) :!: s') +{-# INLINE [0] findIndices #-} + +------------------------------------------------------------------------ +-- * Zipping and unzipping streams + +zip :: Stream a -> Stream b -> Stream (a, b) +zip = zipWith (,) +{-# INLINE zip #-} + +zip3 :: Stream a -> Stream b -> Stream c -> Stream (a, b, c) +zip3 = zipWith3 (,,) +{-# INLINE zip3 #-} + +zip4 :: Stream a -> Stream b -> Stream c -> Stream d -> Stream (a, b, c, d) +zip4 = zipWith4 (,,,) +{-# INLINE zip4 #-} + +{- +zip5 :: Stream a -> Stream b -> Stream c -> Stream d -> Stream e -> [(a, b, c, d, e)] +zip6 :: Stream a -> Stream b -> Stream c -> Stream d -> Stream e -> Stream f -> [(a, b, c, d, e, f)] +zip7 :: Stream a -> Stream b -> Stream c -> Stream d -> Stream e -> Stream f -> Stream g -> [(a, b, c, d, e, f, g)] +-} + +zipWith :: (a -> b -> c) -> Stream a -> Stream b -> Stream c +zipWith f (Stream next0 sa0) (Stream next1 sb0) = Stream next (sa0 :!: sb0 :!: Nothing) + where + {-# INLINE next #-} + next (sa :!: sb :!: Nothing) = case next0 sa of + Done -> Done + Skip sa' -> Skip (sa' :!: sb :!: Nothing) + Yield a sa' -> Skip (sa' :!: sb :!: Just (L a)) + + next (sa' :!: sb :!: Just (L a)) = case next1 sb of + Done -> Done + Skip sb' -> Skip (sa' :!: sb' :!: Just (L a)) + Yield b sb' -> Yield (f a b) (sa' :!: sb' :!: Nothing) +{-# INLINE [0] zipWith #-} + +zipWith3 :: (a -> b -> c -> d) -> Stream a -> Stream b -> Stream c -> Stream d +zipWith3 f (Stream nexta sa0) + (Stream nextb sb0) + (Stream nextc sc0) = Stream next (sa0 :!: sb0 :!: sc0 :!: Nothing) + where + {-# INLINE next #-} + next (sa :!: sb :!: sc :!: Nothing) = case nexta sa of + Done -> Done + Skip sa' -> Skip (sa' :!: sb :!: sc :!: Nothing) + Yield a sa' -> Skip (sa' :!: sb :!: sc :!: Just (L a :!: Nothing)) + + next (sa' :!: sb :!: sc :!: Just (L a :!: Nothing)) = case nextb sb of + Done -> Done + Skip sb' -> Skip (sa' :!: sb' :!: sc :!: Just (L a :!: Nothing)) + Yield b sb' -> Skip (sa' :!: sb' :!: sc :!: Just (L a :!: Just (L b))) + + next (sa' :!: sb' :!: sc :!: Just (L a :!: Just (L b))) = case nextc sc of + Done -> Done + Skip sc' -> Skip (sa' :!: sb' :!: sc' :!: Just (L a :!: Just (L b))) + Yield c sc' -> Yield (f a b c) (sa' :!: sb' :!: sc' :!: Nothing) +{-# INLINE [0] zipWith3 #-} + +zipWith4 :: (a -> b -> c -> d -> e) -> Stream a -> Stream b -> Stream c -> Stream d -> Stream e +zipWith4 f (Stream nexta sa0) + (Stream nextb sb0) + (Stream nextc sc0) + (Stream nextd sd0) = Stream next (sa0 :!: sb0 :!: sc0 :!: sd0 :!: Nothing) + where + {-# INLINE next #-} + next (sa :!: sb :!: sc :!: sd :!: Nothing) = + case nexta sa of + Done -> Done + Skip sa' -> Skip (sa' :!: sb :!: sc :!: sd :!: Nothing) + Yield a sa' -> Skip (sa' :!: sb :!: sc :!: sd :!: Just (L a :!: Nothing)) + + next (sa' :!: sb :!: sc :!: sd :!: Just (L a :!: Nothing)) = + case nextb sb of + Done -> Done + Skip sb' -> Skip (sa' :!: sb' :!: sc :!: sd :!: Just (L a :!: Nothing)) + Yield b sb' -> Skip (sa' :!: sb' :!: sc :!: sd :!: Just (L a :!: Just (L b :!: Nothing))) + + next (sa' :!: sb' :!: sc :!: sd :!: Just (L a :!: (Just (L b :!: Nothing)))) = + case nextc sc of + Done -> Done + Skip sc' -> Skip (sa' :!: sb' :!: sc' :!: sd :!: Just (L a :!: (Just (L b :!: Nothing)))) + Yield c sc' -> Skip (sa' :!: sb' :!: sc' :!: sd :!: Just (L a :!: (Just (L b :!: Just (L c))))) + + next (sa' :!: sb' :!: sc' :!: sd :!: Just (L a :!: (Just (L b :!: Just (L c))))) = + case nextd sd of + Done -> Done + Skip sd' -> Skip (sa' :!: sb' :!: sc' :!: sd' :!: Just (L a :!: (Just (L b :!: Just (L c))))) + Yield d sd' -> Yield (f a b c d) (sa' :!: sb' :!: sc' :!: sd' :!: Nothing) +{-# INLINE [0] zipWith4 #-} + +unzip :: Stream (a, b) -> ([a], [b]) +unzip = foldr (\(a,b) ~(as, bs) -> (a:as, b:bs)) ([], []) +{-# INLINE unzip #-} + +------------------------------------------------------------------------ +-- * Special streams +-- ** Functions on strings + +{- +-- +-- As a concatMap (snoc '\n') +-- +unlines :: Stream (Stream Char) -> Stream Char +unlines (Stream next s0) = Stream next' (Right s0) + where + next' (Left (Stream g t, s)) = case g t of + Done -> Skip (Right s) + Skip t' -> Skip (Left (Stream g t', s)) + Yield x t' -> Yield x (Left (Stream g t', s)) + + next' (Right s) = case next s of + Done -> Done + Skip s' -> Skip (Right s') + Yield x s' -> Skip (Left ((snoc x '\n'), s')) +{-# INLINE [0] unlines #-} +-} + +{- +-- +-- As a concat . intersperse +-- +unlines (Stream next s0) = Stream next' (Right s0) + where + -- go + next' (Left (Stream f t, s)) = case f t of + Done -> Yield '\n' (Right s) + Skip t' -> Skip (Left (Stream f t', s)) + Yield x t' -> Yield x (Left (Stream f t', s)) + + -- to + next' (Right s) = case next s of + Done -> Done + Skip s' -> Skip (Right s') + Yield x s' -> Skip (Left (x, s')) +-} + +{- +lines :: Stream Char -> Stream [Char] +lines (Stream next0 s0) = Stream next (Nothing :!: s0) + where + {-# INLINE next #-} + next (Nothing :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (Nothing :!: s') + Yield _ _ -> Skip (Just (S []) :!: s) -- ! + + next (Just (S acc) :!: s) = case next0 s of + Done -> Yield (reverse acc) (Nothing :!: s) -- ! + Skip s' -> Skip (Just (S acc) :!: s') + Yield '\n' s' -> Yield (reverse acc) (Nothing :!: s') -- reuse first state + Yield x s' -> Skip (Just (S (x:acc)) :!: s') + + {-# INLINE reverse #-} + reverse :: [Char] -> [Char] + reverse l = rev l [] + where + rev [] a = a + rev (x:xs) a = rev xs (x:a) +-} +{- +lines :: Stream Char -> Stream (Stream Char) +lines (Stream next s0 len) = Stream next' s0 len + where + next' s = case next s of + Done -> Done + Skip s' -> Skip s' +-} + + +{- +lines' [] = [] +lines' s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines' s'' +-} + +{- +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String +-} + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +{- +nub :: Eq a => Stream a -> Stream a +delete :: Eq a => a -> Stream a -> Stream a +difference :: Eq a => Stream a -> Stream a -> Stream a +union :: Eq a => Stream a -> Stream a -> Stream a +intersect :: Eq a => Stream a -> Stream a -> Stream a +-} + +-- ** Ordered streams + +{- +sort :: Ord a => Stream a -> Stream a +insert :: Ord a => a -> Stream a -> Stream a +-} + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +{- +nubBy :: (a -> a -> Bool) -> Stream a -> Stream a +deleteBy :: (a -> a -> Bool) -> a -> Stream a -> Stream a +deleteFirstsBy :: (a -> a -> Bool) -> Stream a -> Stream a -> Stream a +unionBy :: (a -> a -> Bool) -> Stream a -> Stream a -> Stream a +intersectBy :: (a -> a -> Bool) -> Stream a -> Stream a -> Stream a +groupBy :: (a -> a -> Bool) -> Stream a -> Stream (Stream a) +-} + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +{- +sortBy :: (a -> a -> Ordering) -> Stream a -> Stream a +-} + +insertBy :: (a -> a -> Ordering) -> a -> Stream a -> Stream a +insertBy cmp x (Stream next0 s0) = Stream next (S2 :!: s0) + where + {-# INLINE next #-} + -- find the insertion point + next (S2 :!: s) = case next0 s of + Done -> Yield x (S1 :!: s) -- a snoc + Skip s' -> Skip (S2 :!: s') + Yield y s' | GT == cmp x y -> Yield y (S2 :!: s') + | otherwise -> Yield x (S1 :!: s) -- insert + + -- we've inserted, now just yield the rest of the stream + next (S1 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S1 :!: s') + Yield y s' -> Yield y (S1 :!: s') +{-# INLINE [0] insertBy #-} + +maximumBy :: (a -> a -> Ordering) -> Stream a -> a +maximumBy cmp (Stream next s0) = loop0_maximumBy s0 + where + loop0_maximumBy !s = case next s of + Skip s' -> expose s' $ loop0_maximumBy s' + Yield x s' -> expose s' $ loop_maximumBy x s' + Done -> errorEmptyStream "maximumBy" + + loop_maximumBy z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_maximumBy z s' + Yield x s' -> expose s' $ loop_maximumBy (max' z x) s' + + max' x y = case cmp x y of + GT -> x + _ -> y +{-# INLINE [0] maximumBy #-} + +minimumBy :: (a -> a -> Ordering) -> Stream a -> a +minimumBy cmp (Stream next s0) = loop0_minimumBy s0 + where + loop0_minimumBy !s = case next s of + Skip s' -> expose s' $ loop0_minimumBy s' + Yield x s' -> expose s' $ loop_minimumBy x s' + Done -> errorEmptyStream "minimum" + + loop_minimumBy z !s = case next s of + Done -> z + Skip s' -> expose s' $ loop_minimumBy z s' + Yield x s' -> expose s' $ loop_minimumBy (min' z x) s' + + min' x y = case cmp x y of + GT -> y + _ -> x +{-# INLINE [0] minimumBy #-} + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +-- length +genericLength :: Num i => Stream b -> i +genericLength (Stream next s0) = loop_genericLength s0 + where + loop_genericLength !s = case next s of + Done -> 0 + Skip s' -> expose s' $ loop_genericLength s' + Yield _ s' -> expose s' $ 1 + loop_genericLength s' +{-# INLINE [0] genericLength #-} + +--TODO: specialised generic Length for strict/atomic and associative Num +-- instances like Int and Integer + +genericTake :: Integral i => i -> Stream a -> Stream a +genericTake n0 (Stream next0 s0) = Stream next (L n0 :!: s0) + where + {-# INLINE next #-} + next (L 0 :!: _) = Done + next (L n :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (L n :!: s') + Yield x s' + | n > 0 -> Yield x (L (n-1) :!: s') + | otherwise -> error "List.genericTake: negative argument" +{-# INLINE [0] genericTake #-} + +-- genericTake is defined so bizzarely! + +genericDrop :: Integral i => i -> Stream a -> Stream a +genericDrop n0 (Stream next0 s0) = Stream next (Just (L n0) :!: s0) + where + {-# INLINE next #-} + next (Just (L 0) :!: s) = Skip (Nothing :!: s) + next (Just (L n) :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (Just (L n) :!: s') + Yield _ s' | n > 0 -> Skip (Just (L (n-1)) :!: s') + | otherwise -> error "List.genericDrop: negative argument" + next (Nothing :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (Nothing :!: s') + Yield x s' -> Yield x (Nothing :!: s') +{-# INLINE [0] genericDrop #-} + +genericIndex :: Integral a => Stream b -> a -> b +genericIndex (Stream next s0) i0 = loop_genericIndex i0 s0 + where + loop_genericIndex i !s = case next s of + Done -> error "List.genericIndex: index too large." + Skip s' -> expose s' $ loop_genericIndex i s' + Yield x s' | i == 0 -> x + | i > 0 -> expose s' $ loop_genericIndex (i-1) s' + | otherwise -> error "List.genericIndex: negative argument." +{-# INLINE [0] genericIndex #-} + +-- can we pull the n > 0 test out and do it just once? +-- probably not since we don't know what n-1 does!! +-- can only specialise it for sane Integral instances :-( + + +genericSplitAt :: Integral i => i -> Stream a -> ([a], [a]) +genericSplitAt n0 (Stream next s0) = loop_genericSplitAt n0 s0 + where + loop_genericSplitAt 0 !s = ([], expose s $ unstream (Stream next s)) + loop_genericSplitAt n !s = case next s of + Done -> ([], []) + Skip s' -> expose s $ loop_genericSplitAt n s' + Yield x s' + | n > 0 -> (x:xs', xs'') + | otherwise -> error "List.genericSplitAt: negative argument" + where + (xs', xs'') = expose s $ loop_genericSplitAt (n-1) s' +{-# INLINE [0] genericSplitAt #-} + +{- +-- No need: +genericReplicate -- :: Integral i => i -> a -> Stream a +-} + +-- --------------------------------------------------------------------- +-- Enum + +{- +enumFromToNum :: (Ord a, Num a) => a -> a -> Stream a +enumFromToNum x y = Stream next (L x) + where + {-# INLINE next #-} + next (L !n) + | n > y = Done + | otherwise = Yield n (L (n+1)) +{-# INLINE [0] enumFromToNum #-} +-} + +enumFromToInt :: Int -> Int -> Stream Int +enumFromToInt x y = Stream next (L x) + where + {-# INLINE next #-} + next (L !n) + | n > y = Done + | otherwise = Yield n (L (n+1)) +{-# INLINE [0] enumFromToInt #-} + +enumDeltaInteger :: Integer -> Integer -> Stream Integer +enumDeltaInteger a d = Stream next (L a) + where + {-# INLINE next #-} + next (L !x) = Yield x (L (x+d)) +{-# INLINE [0] enumDeltaInteger #-} + +enumFromToChar :: Char -> Char -> Stream Char +enumFromToChar x y = Stream next (L (ord x)) + where + m = ord y + + {-# INLINE next #-} + next (L !n) + | n > m = Done + | otherwise = Yield (chr n) (L (n+1)) +{-# INLINE [0] enumFromToChar #-} + +-- --------------------------------------------------------------------- +-- Monadic stuff + +-- Most monadic list functions can be defined in terms of foldr so don't +-- need explicit stream implementations. The one exception is foldM: +-- + +foldM :: Monad m => (b -> a -> m b) -> b -> Stream a -> m b +foldM f z0 (Stream next s0) = loop_foldl z0 s0 + where + loop_foldl z !s = case next s of + Done -> Monad.return z + Skip s' -> expose s' $ loop_foldl z s' + Yield x s' -> expose s' $ f z x >>= \z' -> loop_foldl z' s' +{-# INLINE [0] foldM #-} + +foldM_ :: Monad m => (b -> a -> m b) -> b -> Stream a -> m () +foldM_ f z0 (Stream next s0) = loop_foldl z0 s0 + where + loop_foldl z !s = case next s of + Done -> Monad.return () + Skip s' -> expose s' $ loop_foldl z s' + Yield x s' -> expose s' $ f z x >>= \z' -> loop_foldl z' s' +{-# INLINE [0] foldM_ #-} + + +-- --------------------------------------------------------------------- +-- List comprehension desugaring + +return :: a -> Stream a +return e = Stream next S1 + where + {-# INLINE next #-} + next S1 = Yield e S2 + next S2 = Done +{-# INLINE [0] return #-} + +guard :: Bool -> Stream a -> Stream a +guard b (Stream next0 s0) = Stream next (S1 :!: s0) + where + {-# INLINE next #-} + next (S1 :!: s) = if b then Skip (S2 :!: s) else Done + next (S2 :!: s) = case next0 s of + Done -> Done + Skip s' -> Skip (S2 :!: s') + Yield x s' -> Yield x (S2 :!: s') +{-# INLINE [0] guard #-} + +bind :: (a -> Bool) -> (a -> Stream b) -> Stream a -> Stream b +bind b f (Stream next0 s0) = Stream next (s0 :!: Nothing) + where + {-# INLINE next #-} + next (s :!: Nothing) = case next0 s of + Done -> Done + Skip s' -> Skip (s' :!: Nothing) + Yield x s' + | b x -> Skip (s' :!: Just (f x)) + | otherwise -> Skip (s' :!: Nothing) + + next (s :!: Just (Stream next1 s1)) = case next1 s1 of + Done -> Skip (s :!: Nothing) + Skip s1' -> Skip (s :!: Just (Stream next1 s1')) + Yield x s1' -> Yield x (s :!: Just (Stream next1 s1')) +{-# INLINE [0] bind #-} + +mapFilter :: (a -> Bool) -> (a -> b) -> Stream a -> Stream b +mapFilter b f (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' + | b x -> Yield (f x) s' + | otherwise -> Skip s' +{-# INLINE [0] mapFilter #-} + +declare :: (a -> Stream b) -> a -> Stream b +declare f bs = Stream next (f bs) + where + {-# INLINE next #-} + next (Stream next0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (Stream next0 s') + Yield x s' -> Yield x (Stream next0 s') +{-# INLINE [0] declare #-} + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- Common up near identical calls to `error' to reduce the number +-- constant strings created when compiled: +errorEmptyStream :: String -> a +errorEmptyStream fun = moduleError fun "empty list" +{-# NOINLINE errorEmptyStream #-} + +moduleError :: String -> String -> a +moduleError fun msg = error ("List." ++ fun ++ ':':' ':msg) +{-# NOINLINE moduleError #-} diff --git a/GHC_BUILD b/GHC_BUILD new file mode 100644 --- /dev/null +++ b/GHC_BUILD @@ -0,0 +1,113 @@ + + + Build instructions for nobench + ghc with stream fusion + -------------------------------------------------------- + +* Grab a current ghc tree (we have a local cache): + + $ scp -r /home/chakcvs/darcs/streams/ghc . + +* Install our base fork into the tree: + + $ cd ghc/libraries + + $ darcs get /home/chakcvs/darcs/streams/base + Copying patch 1730 of 1730... done! + Finished getting. + + $ cd ../.. + +* Build as normal + + $ cat /home/dons/streams/build.mk + SRC_HC_OPTS = -H64m -O -fasm + GhcStage1HcOpts = -O -fasm + GhcStage2HcOpts = -O2 -fasm + GhcLibHcOpts = -O2 -fasm + GhcLibWays = + SplitObjs = NO + + $ cp /home/dons/streams/build.mk ./mk/ + + $ autoreconf + $ ./configure + $ make -j2 + +* Get nobench: + + $ cd /tmp/ + $ darcs get http://www.cse.unsw.edu.au/~dons/code/nobench + $ cd nobench + $ make boot + + Note the report generator needs the xhtml package. + +* Edit the config files: + + Just needs to point to the in-place GHC, and for ghc-old to be + your most recent non-stream ghc. Edit header.mk to have: + + COMPILERS = ghc ghc-old + + GHC = /home/dons/streams/build/compiler/stage2/ghc-inplace + GHC_OLD = ghc-6.7.20070224 + + GHC_OPTS = -Rghc-timing -O2 -fasm -fliberate-case-threshold100 -fdicts-cheap -fno-method-sharing -ddump-simpl-stats + +* Run a test: + + $ cd spectral/calendar + $ make + + Test: calendar (Bird and Wadlers calendar program) + http://www.cse.unsw.edu.au/~dons/code/nobench//calendar + ghc 3.79 seconds (1.0 x) + ghc-old 3.91 seconds (1.0 x) + +* Run just the ghc test: + + $ env ONLY=ghc make just + Updating results database with 1 new entries. + + Test: calendar (Bird and Wadlers calendar program) + http://www.cse.unsw.edu.au/~dons/code/nobench/spectral/calendar + ghc 3.84 seconds (1.0 x) + ghc-old 3.91 seconds (1.0 x) + +Compilation logs are kept in the 'ghc.compile' and 'ghc-old.compile' files. +You can also just run the tests by hand: + + $ /home/dons/streams/build/compiler/stage2/ghc-inplace -no-recomp + -Rghc-timing -O2 -fasm -fliberate-case-threshold100 -fdicts-cheap + -fno-method-sharing -ddump-simpl-stats --make -o calendar + calendar.hs + [1 of 1] Compiling Main ( calendar.hs, calendar.o ) + + 4 SC:$wloop_length0 + 6 SC:$wloop_length1 + 9 SC:$wloop_length2 + 2 SC:$wloop_length3 + 3 SC:$wunfold_unstream6 + 2 SC:$wunfold_unstream7 + 2 SC:$wunfold_unstream8 + 19 SC:unfold_unstream0 + 17 SC:unfold_unstream1 + 2 SC:unfold_unstream10 + 18 SC:unfold_unstream2 + 6 SC:unfold_unstream3 + 2 SC:unfold_unstream5 + 6 SC:unfold_unstream8 + 2 SC:unfold_unstream9 + 18 STREAM stream/unstream fusion + + ... + +To run a whole class of tests, cd into the directory and type 'make': + + cd spectral + make + +make at the top level runs everything. + +-- Don + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Duncan Coutts 2006-2007 +Copyright (c) Don Stewart 2006-2007 + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,33 @@ + Stream fusible lists + +Faster lists using stream fusion. + +The abstract from the paper: + + This paper presents an automatic deforestation system, \emph{stream + fusion}, based on equational transformations, that fuses a wider + range of functions than existing short-cut fusion systems. In + particular, stream fusion is able to fuse zips, left folds and + functions over nested lists, including list comprehensions. A + distinguishing feature of the framework is its simplicity: by + transforming list functions to expose their structure, intermediate + values are eliminated by general purpose compiler optimisations. + + We have reimplemented the Haskell standard List library on top of + our framework, providing stream fusion for Haskell lists. By + allowing a wider range of functions to fuse, we see an increase in + the number of occurrences of fusion in typical Haskell programs. We + present benchmarks documenting time and space improvements. + +Building: + + $ runhaskell Setup.lhs configure --prefix=/home/dons + $ runhaskell Setup.lhs build + $ runhaskell Setup.lhs install + +Use: + + import Data.List.Stream + +and use as you would for normal lists. +Compile with ghc -O2 for best results. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,170 @@ + +Functions that don't yet fuse: + + transpose :: [[a]] -> [[a]] + partition :: (a -> Bool) -> [a] -> ([a], [a]) + +* scanr :: (a -> b -> b) -> b -> [a] -> [b] +* scanr1 :: (a -> a -> a) -> [a] -> [a] + +*? mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) +*? mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) + span :: (a -> Bool) -> [a] -> ([a], [a]) + inits :: [a] -> [[a]] + tails :: [a] -> [[a]] + isSuffixOf :: Eq a => [a] -> [a] -> Bool +* isInfixOf :: Eq a => [a] -> [a] -> Bool + + words :: String -> [String] + unwords :: [String] -> String + +* nub :: Eq a => [a] -> [a] +* delete :: Eq a => a -> [a] -> [a] + +* nubBy :: (a -> a -> Bool) -> [a] -> [a] +* deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] + + sort :: Ord a => [a] -> [a] + union :: Eq a => [a] -> [a] -> [a] + intersect :: Eq a => [a] -> [a] -> [a] + group :: Eq a => [a] -> [[a]] + + unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] + groupBy :: (a -> a -> Bool) -> [a] -> [[a]] + intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] + sortBy + + +Internal GHC: + + * List comprehensions desugaring + +Think about scanl: + + "scanl -> fusible" [~1] forall f z xs. + scanl f z xs = unstream (Stream.scanl f z (stream (xs ++ [bottom]))) + +------------------------------------------------------------------------ + +Ideas at the Warren View, Sun Mar 18 19:37:09 EST 2007 + + * SPECCONSTR pragma (sent to spj) + + * rules with strictness annotations: + - pick between foldl foldl' based on strictness info + + * rules matching on constraints: + - so pick representation types for rules, e.g. + * bucketsort for Word8 + * IntMap/Map for nub on Ord + + * undefineds in QuickCheck + + +------------------------------------------------------------------------ + +TODO: + + * strict on any state we control. + * strict pairs expose constructors to SpecConstr, removing redundant + arguments. + +-- DeepSeq context on existentials. +-- All external values that are used in state, wrapped in Lazy +-- State strict by default. + +-- add test case for bottom streams. + +------------------------------------------------------------------------ + +instance (Eq a) => Eq [a] -- Defined in GHC.Base +instance Functor [] -- Defined in GHC.Base +instance (Ord a) => Ord [a] -- Defined in GHC.Base + +Enum +list comprehension desugaring + +------------------------------------------------------------------------ + +Queries about the H98 List spec: + +* intersperse (and therefore intercalate) are too strict. + +* unwords is too strict. + +* (genericTake :: Int -> [a] -> [a]) /= take + perhaps it should. In particular: + + genericTake _|_ [] = [] + take _|_ [] = _|_ + + genericTake 0 _|_ = _|_ + take 0 _|_ = [] + + genericTake (-1) xs = _|_ + take (-1) xs = [] + + It looks like the Spec is wrong here, genericTake is inconsistent + with take, genericDrop and genericSplitAt it has the initial clauses + this way round: + genericTake _ [] = [] + genericTake 0 _ = [] + when they should be the other way around, as they are for the other + functions. + +* Data.List.partition is too strict or perhaps the spec is too lazy + H98 says: partition p _|_ = (_|_, _|_) + Data.List.partition p _|_ = _|_ + +* Data.List.splitAt is too strict or perhaps the spec is too lazy + H98 says: splitAt _|_ _|_ = (_|_, _|_) + Data.List.splitAt _|_ _|_ = _|_ + +------------------------------------------------------------------------ + +If we had strictness info available in rules we could say: + +forall (f :: [[Char!]] -> b) xs. f (lines xs) = f (stricterLines xs) +erm that is if we're consuming lines an consuming each string in a +spine-strict way then we can use a more efficient lines implementation. +Same goes for words. + +Note how you can't easily talk about structural strictness properties by +putting annotations on types since that structure isn't fully exposed in +the type. + +------------------------------------------------------------------------ + +More stuff to stick in the paper: + +Limits on fusion. We conjecture that whenever an implementation relies +on sharing that it's realy not fusible, or when you 'fuse' it anyway you +get no performance advantage since it has to allocate internally anyway. +The best that could be done is if in the internal allocation used to get +sharing is more eficient. Eg with sort we might use a heap as the internal +state and stream into it and out of it. + +What does build/foldr do about sharing? + +* Binary sizes, fusion opportunties v foldr/build + +* Currently list comprehensions compile to build/foldr stuff. + -- this hurts us, since that no longer fuses. We could keep + build/foldr fusion for list comprehensions I guess? + -- e.g. paraffins + +------------------------------------------------------------------------ + +* imaginary/wheel_sieve1 : looks like a missing list comprehension fuse. + +* spectral/atom: some list comprehensions./e + +* calendar: a lot of fusion here. should be faster. + Still L constructors being left behind. + +* circsim, same story. Either's being left behind. + +* k-nucleotide, some different loops being generated. + +* primes, 9 foldr/app +* sorting, some list comprehensions diff --git a/desugar/Desugar.hs b/desugar/Desugar.hs new file mode 100644 --- /dev/null +++ b/desugar/Desugar.hs @@ -0,0 +1,399 @@ +-- Use like so: +-- +-- runghc Desugar.hs < Examples.hs > ExamplesDesugared.hs +-- +-- and watch out, the pretty printer sometimes misses (..)'s (wtf!!!) + +module Main (main) where + +import Data.List + +import Language.Haskell.Parser +import Language.Haskell.Syntax +import Language.Haskell.Pretty + +main = interact $ \input -> + let ParseOk (HsModule sl m es is decls) = parseModule input + decls' = [ decl + | (exp, stmts, context) <- extractListComps decls + , let exp' = desugar [0..] exp stmts + , decl <- [context (HsListComp exp stmts), context exp'] ] + in prettyPrint (HsModule sl m es is decls') ++ "\n" + +extractListComps :: [HsDecl] -> [(HsExp, [HsStmt], HsExp -> HsDecl)] +extractListComps decls = + [ (exp, stmts, + \rhs -> HsPatBind sl (HsPVar (HsIdent name)) + (HsUnGuardedRhs rhs) []) + | HsPatBind sl (HsPVar (HsIdent name)) + (HsUnGuardedRhs (HsListComp exp stmts)) [] <- decls ] + ++ [ (exp, stmts, + \rhs -> HsFunBind [HsMatch sl name ps (HsUnGuardedRhs rhs) ds]) + | HsFunBind [HsMatch sl name ps + (HsUnGuardedRhs (HsListComp exp stmts)) ds] <- decls ] + +{- + +Streams desugaring for list comprehensions: + +<< [ e | Q ] >> + + +<< [ e | ] >> = return e + +<< [ e | b, Q ] >> = gaurd b (<< [ e | Q ] >>) + +<< [ e | p <- l, Q ] >> = bind f g l + where + f p = Just (x1, ..., xn) + f _ = Nothing + + g (x1, ..., xn) = << [ e | Q ] >> + +<< [ e | let decls, Q ] >> = declare g (let decls in (x1, .., xn)) + where + g (x1, .., xn) = << [ e | Q ] >> + +We can optimise the common cases: + + +<< [ e | p <- l, b ] >> = mapFilter f l + where f p | b = Just e + f _ = Nothing + +<< [ e | p <- l, b, Q ] >> = bind f g l + where f p | b = Just (x1, ..., xn) + f _ = Nothing + + g (x1, ..., xn) = << [ e | Q ] >> + + +using the auxillary definitions: + +List: +----- + +return e = [e] + +guard True xs = xs +guard false xs = [] + +concatMap' f g xs = foldr h [] xs + where h x ys = case f x of + Just bs -> g bs ++ ys + Nothing -> ys + +declare g bs = g bs + +mapFilter f xs = foldr h [] xs + where h x ys = case f x of + Just y -> y : ys + Nothing -> ys + + +Stream: +------- + +return e = Stream next True + where + next True = Yield e False + next False = Done + +guard b (Stream next0 s0) = Stream next (b, s0) + where + next (False, s) = Done + next (True, s) = case next0 s of + Done -> Done + Skip s' -> Skip (True, s') + Yield x s' -> Yield x (True, s') + +bind f g (Stream next0 s0) = Stream next (s, Nothing) + where + next (s, Nothing) = case next0 s of + Done -> Done + Skip s' -> Skip (s', Nothing) + Yield x s' -> case f x of + Just bs -> Skip (s', Just (g bs)) + Nothing -> Skip (s', Nothing) + + next (s, Just (Stream next1 s1)) = case next1 s1 of + Done -> Done + Skip s1' -> Skip (s, Just (Stream next1 s1')) + Yield x s1' -> Yield x (s, Just (Stream next1 s1')) + +declare g bs = Stream next (g bs) + where next (Stream next0 s) = case next0 s of + Done -> Done + Skip s' -> Skip (Stream next0 s') + Yield x s' -> Yield x (Stream next0 s') + +mapFilter f (Stream next0 s0) = Stream next s0 + where + next s = case next0 s of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> case f x of + Just y -> Yield y s' + Nothing -> Skip s' + +-} + +hsJust = HsVar (UnQual (HsIdent "Just")) +hsNothing = HsVar (UnQual (HsIdent "Nothing")) + +hsReturn = HsVar (Qual (Module "L") (HsIdent "return")) +hsGuard = HsVar (Qual (Module "L") (HsIdent "guard")) +hsConcatMap = HsVar (Qual (Module "L") (HsIdent "concatMap")) +hsConcatMap' = HsVar (Qual (Module "L") (HsIdent "concatMap'")) +hsDeclare = HsVar (Qual (Module "L") (HsIdent "declare")) +hsMapFilter = HsVar (Qual (Module "L") (HsIdent "mapFilter")) +hsMap = HsVar (Qual (Module "L") (HsIdent "map")) + +desugar :: [Int] -> HsExp -> [HsStmt] -> HsExp + +-- [ e | ] = return e +desugar ns e [] = HsApp hsReturn e + +-- [ e | b, Q ] = gaurd b [ e | Q ] +desugar ns e (HsQualifier b : qs) = HsApp (HsApp hsGuard b) + (HsParen (desugar ns e qs)) + +-- special case: final generator for simple irrefutable pattern p +-- [ e | p <- l ] = let f p = e +-- in map f l +desugar (n:ns) e (HsGenerator sloc p@(HsPVar _) l : []) = + HsLet [HsFunBind [HsMatch sloc (HsIdent (f n)) [p] + {- = -} (HsUnGuardedRhs e) [] + ] + ] + (HsApp (HsApp hsMap (HsVar (UnQual (HsIdent (f n))))) + (HsParen l)) + +-- special case: final generator +-- [ e | p <- l ] = let f p = Just e +-- f _ = Nothing +-- in mapFilter f l +desugar (n:ns) e (HsGenerator sloc p l : []) = + HsLet [HsFunBind [HsMatch sloc (HsIdent (f n)) [p] + {- = -} (HsUnGuardedRhs (HsApp hsJust e)) [] + ,HsMatch sloc (HsIdent (f n)) [HsPWildCard] + {- = -} (HsUnGuardedRhs hsNothing) [] + ] + ] + (HsApp (HsApp hsMapFilter (HsVar (UnQual (HsIdent (f n))))) + (HsParen l)) + +-- special case: final generator with trailing condition +-- [ e | p <- l, b ] = let f p | b = Just e +-- f _ = Nothing +-- in mapFilter f l +desugar (n:ns) e (HsGenerator sloc p l : HsQualifier b : []) = + HsLet [HsFunBind [HsMatch sloc (HsIdent (f n)) [p] + {- = -} (HsGuardedRhss [HsGuardedRhs sloc b + (HsApp hsJust e)]) [] + ,HsMatch sloc (HsIdent (f n)) [HsPWildCard] + {- = -} (HsUnGuardedRhs hsNothing) [] + ] + ] + (HsApp (HsApp hsMapFilter (HsVar (UnQual (HsIdent (f n))))) + (HsParen l)) + +-- special case: generator with trailing condition +-- [ e | p <- l, b, Q ] = let f p | b = Just (x1, ..., xn) +-- f _ = Nothing +-- g (x1, ..., xn) = [ e | Q ] +-- in concatMap' f g l +desugar (n:ns) e (HsGenerator sloc p l : HsQualifier b : qs) = + let xs = patBinders p + `intersect` stmtsFV e qs -- optimisation: only bind used vars + in HsLet [HsFunBind [HsMatch sloc (HsIdent (f n)) [p] + {- = -} (HsGuardedRhss + [HsGuardedRhs sloc b + (HsApp hsJust (mkTupleExpr xs))]) [] + ,HsMatch sloc (HsIdent (f n)) [HsPWildCard] + {- = -} (HsUnGuardedRhs hsNothing) [] + ] + ,HsFunBind [HsMatch sloc (HsIdent (g n)) [mkTuplePat xs] + {- = -} (HsUnGuardedRhs (desugar ns e qs)) [] + ] + ] + (HsApp (HsApp (HsApp hsConcatMap' + (HsVar (UnQual (HsIdent (f n))))) + (HsVar (UnQual (HsIdent (g n))))) + (HsParen l)) + + +-- special case: for simple irrefutable pattern p +-- [ e | p <- l, Q ] = let g p = [ e | Q ] +-- in concatMap g l +desugar (n:ns) e (HsGenerator sloc p@(HsPVar _) l : qs) = + HsLet [HsFunBind [HsMatch sloc (HsIdent (g n)) [p] + {- = -} (HsUnGuardedRhs (desugar ns e qs)) [] + ] + ] + (HsApp (HsApp hsConcatMap (HsVar (UnQual (HsIdent (g n))))) + (HsParen l)) + +-- general case of a generator +-- [ e | p <- l, Q ] = let f p = Just (x1, ..., xn) +-- f _ = Nothing +-- g (x1, ..., xn) = [ e | Q ] +-- in concatMap' f g l +desugar (n:ns) e (HsGenerator sloc p l : qs) = + let xs = patBinders p + `intersect` stmtsFV e qs -- optimisation: only bind used vars + in HsLet [HsFunBind [HsMatch sloc (HsIdent (f n)) [p] + {- = -} (HsUnGuardedRhs + (HsApp hsJust (mkTupleExpr xs))) [] + ,HsMatch sloc (HsIdent (f n)) [HsPWildCard] + {- = -} (HsUnGuardedRhs hsNothing) [] + ] + ,HsFunBind [HsMatch sloc (HsIdent (g n)) [mkTuplePat xs] + {- = -} (HsUnGuardedRhs (desugar ns e qs)) [] + ] + ] + (HsApp (HsApp hsConcatMap (HsVar (UnQual (HsIdent (g n))))) + (HsParen l)) + +{- +-- TODO: need to get binders in decls for this one: + +-- [ e | let decls, Q ] = let g (x1, .., xn) = [ e | Q ] +-- in declare g (let decls in (x1, .., xn)) +desugar ns e (HsLetStmt decls : qs) = + HsLet decls (desugar ns e qs) +-} + +patBinders :: HsPat -> [HsName] +patBinders (HsPVar name) = [name] +patBinders (HsPLit _) = [] +patBinders (HsPNeg p) = patBinders p +patBinders (HsPInfixApp p1 _ p2) = patBinders p1 ++ patBinders p2 +patBinders (HsPApp _ ps) = concatMap patBinders ps +patBinders (HsPTuple ps) = concatMap patBinders ps +patBinders (HsPList ps) = concatMap patBinders ps +patBinders (HsPParen p) = patBinders p +patBinders (HsPRec _ fields) = concat [ patBinders p + | HsPFieldPat _ p <- fields ] +patBinders (HsPAsPat _ p) = patBinders p +patBinders (HsPWildCard) = [] +patBinders (HsPIrrPat p) = patBinders p + + +-- The following is for an optimisation, perhaps it's unnecessary. + +nameFV (Qual _ _) = [] +nameFV (UnQual n) = [n] +nameFV (Special _) = [] + +qopFV (HsQVarOp n) = nameFV n +qopFV _ = [] + +expFV :: HsExp -> [HsName] +expFV (HsVar n) = nameFV n +expFV (HsCon _) = [] +expFV (HsLit _) = [] +expFV (HsInfixApp e1 op e2) = qopFV op ++ expFV e1 ++ expFV e2 +expFV (HsApp e1 e2) = expFV e1 ++ expFV e2 +expFV (HsNegApp e) = expFV e +expFV (HsLambda _ ps e) = nub (expFV e) \\ concatMap patBinders ps +--expFV (HsLet [HsDecl] HsExp) +expFV (HsIf e1 e2 e3) = expFV e1 ++ expFV e2 ++ expFV e3 +--expFV (HsCase HsExp [HsAlt]) +expFV (HsDo stmts) = stmtsFV unit_con stmts +expFV (HsTuple es) = concatMap expFV es +expFV (HsList es) = concatMap expFV es +expFV (HsParen e) = expFV e +expFV (HsLeftSection e op) = qopFV op ++ expFV e +expFV (HsRightSection op e) = qopFV op ++ expFV e +--expFV (HsRecConstr HsQName [HsFieldUpdate]) record construction expression +--expFV (HsRecUpdate HsExp [HsFieldUpdate]) record update expression +expFV (HsEnumFrom e) = expFV e +expFV (HsEnumFromTo e1 e2) = expFV e1 ++ expFV e2 +expFV (HsEnumFromThen e1 e2) = expFV e1 ++ expFV e2 +expFV (HsEnumFromThenTo e1 e2 e3) = expFV e1 ++ expFV e2 ++ expFV e3 +expFV (HsListComp e stmts) = stmtsFV e stmts +expFV (HsExpTypeSig _ e _) = expFV e + +stmtsFV :: HsExp -> [HsStmt] -> [HsName] +stmtsFV e [] = expFV e +stmtsFV e (HsGenerator _ p e' : stmts) = nub (expFV e' ++ stmtsFV e stmts) \\ patBinders p +stmtsFV e (HsQualifier e' : stmts) = expFV e' ++ stmtsFV e stmts +--stmtsFV e (HsLetStmt decls) = + +mkTupleExpr [] = HsCon (Special HsUnitCon) +mkTupleExpr [n] = HsVar (UnQual n) +mkTupleExpr ns = HsTuple [ HsVar (UnQual n) | n <- ns ] + +mkTuplePat [] = HsPWildCard +mkTuplePat [n] = HsPVar n +mkTuplePat ns = HsPTuple [ HsPVar n | n <- ns ] + +f n = "f_" ++ show n +g n = "g_" ++ show n + + + + + + + + + + + + +{- + +Alternative streams desugaring for list comprehensions: + +<< [ e | Q ] P D >> :: Exp -> [Qual] -> (Pat -> Pat) -> Exp -> ([Clause], Exp) + +Translation scheme takes the list comp's expression and list of qualifiers +and as extra args, a pattern (with a hole) that gives the state pattern and an +expression giving the state to return to when done. It returns a list of +clauses for a 'next' stepper function and an initialiser expression for the +stream's initial state. + +To construct the top level we use: + +[ e | Q ] = Stream (FunDef "next" clauses) init + where (clauses, init) = << [ e | Q ] [.] Done >> + + +<< [ e | ] P D >> = (next:[], True) + where + next P[True] = Yield e P[False] + next P[False] = D + + +<< [ e | b, Q ] P D >> = (next:nexts, Nothing) + where + (nexts, init) = << [ e | Q ] P[Just[.]] D >> + + next P[Nothing] | b = Skip (P[Just init]) + | otherwise = D + + +<< [ e | let decls, Q ] P D >> = (next:nexts, Nothing) + where + (nexts, init) = << [ e | Q ] P[Just((x_n_0, , x_n_m) :!: [.])] D >> + + next P[Nothing] = Skip P[Just(let decls in (x_n_0, , x_n_m) :!: init)] + + {x_n_0, , x_n_m} = DV (decls) -- Defined variables + + +<< [ e | p <- l, Q ] P >> = (next:nexts, stream l :!: Nothing) + where + (nexts, init) = << [ e | Q ] P[(Stream next_n s_n :!: Just (p :!: [.]))] + P[(Stream next_n s_n :!: Nothing)] >> + + next P[(Stream next_n s_n :!: Nothing)] = case next_n s_n of + Done -> D + Skip s_n' -> Skip P[(Stream next_n s_n' :!: Nothing)] + Yield x s_n' -> case x of + p -> Skip P[(Stream next_n s_n' :!: Just (x :!: init))] + _ -> Skip P[(Stream next_n s_n' :!: Nothing)] + +-} diff --git a/desugar/Examples.hs b/desugar/Examples.hs new file mode 100644 --- /dev/null +++ b/desugar/Examples.hs @@ -0,0 +1,19 @@ +module Examples where + +map :: (a -> b) -> [a] -> [b] +map f as = [ f a | a <- as ] + +concat :: [[a]] -> [a] +concat ass = [ a | as <- ass, a <- as ] + +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f as = [ b | a <- as, b <- f a ] + +filter :: (a -> Bool) -> [a] -> [a] +filter p as = [ a | a <- as, p a ] + +prod xs ys = [ x * y | x <- xs, y <- ys ] + +foo xs ys = [ x * y | Left (x, _) <- xs, y <- ys ] + +bar xs ys zs = [ x * y | x <- xs, y <- ys, z <- zs ] diff --git a/setup-base.sh b/setup-base.sh new file mode 100644 --- /dev/null +++ b/setup-base.sh @@ -0,0 +1,56 @@ +#!/bin/sh + +# dump (and edit) the stream/list code into a copy of base-streams +# such that the whole thing builds. + +# +# assumes we're in the 'list' main repo +# + +ghc_base_path=$* +if [ -z "$ghc_base_path" ] ; then + echo "usage: ./setup-base.sh path_to_base_package" + exit 1 +fi + +# Where are we sending things? +echo -n "Preparing to set up streams stuff under: " +echo $ghc_base_path + +# Just double check its a base repo: +echo -n "Checking it looks like a proper base repo .... " +if [ -d "$ghc_base_path/_darcs/patches" ] ; then + looks_ok=True +else + looks_ok=False +fi +echo $looks_ok + +if [ "$looks_ok" = "False" ] ; then + echo "'$ghc_base_path' doesn't look like a darcs repo!" + exit 1 +fi + +# Work out if we need to create the Data/List subdir +echo -n "Checking if we need to create the Data/List subdir... " +ghc_base_streams="$ghc_base_path/Data/List" +if [ ! -d "$ghc_base_streams" ] ; then + create_streams=True +else + create_streams=False +fi +echo $create_streams + +if [ "$create_streams" = "True" ] ; then + mkdir $ghc_base_streams +fi + +# copy first +echo "{-# OPTIONS_GHC -fno-implicit-prelude #-}" > $ghc_base_streams/Stream.hs +echo "{-# OPTIONS_GHC -fno-implicit-prelude #-}" > $ghc_base_path/Data/Stream.hs + +cat Data/List/Stream.hs >> $ghc_base_streams/Stream.hs +cat Data/Stream.hs >> $ghc_base_path/Data/Stream.hs + + +echo "done." diff --git a/stream-fusion.cabal b/stream-fusion.cabal new file mode 100644 --- /dev/null +++ b/stream-fusion.cabal @@ -0,0 +1,25 @@ +Name: stream-fusion +Version: 0.1 +Author: Duncan Coutts, Don Stewart +Maintainer: duncan.coutts@worc.ox.ac.uk, dons@galois.com +License: BSD3 +License-file: LICENSE +Synopsis: Faster Haskell lists using stream fusion +Homepage: http://www.cse.unsw.edu.au/~dons/streams.html +Description: + This package provides the standard Haskell list library + reimplemented to allow stream fusion. This should in general + provide faster list operations, and faster code for list-heavy + programs. See the paper "Stream Fusion: From Lists to Streams to Nothing at All", + Coutts, Leshchinskiy and Stewart, 2007. + To use, simply import Data.List.Stream in place of Data.List, + and hide list functions from the Prelude. +Category: Data +Build-Depends: base +Stability: experimental +Tested-with: GHC==6.8 +Exposed-modules: Data.Stream + Data.List.Stream + Control.Monad.Stream +Extensions: CPP, BangPatterns, ExistentialQuantification +ghc-options: -fglasgow-exts -O2 -Wall -fno-warn-orphans -DEXTERNAL_PACKAGE -fliberate-case-threshold100 -fdicts-cheap -fno-method-sharing diff --git a/tests/Bench/Fusion.hs b/tests/Bench/Fusion.hs new file mode 100644 --- /dev/null +++ b/tests/Bench/Fusion.hs @@ -0,0 +1,151 @@ +{-# OPTIONS -cpp #-} +-- +-- Test the results of fusion +-- + +-- +-- N.B. make sure to disable down fusion when using only loopU fusion +-- + +import Data.Char +import Bench.Utils +import Text.Printf +import qualified Data.List.Stream as P -- ours + +-- minimum pipelines to trigger the various fusion forms +tests = + [("force0", [F (P.maximum)]) + ,("force1", [F (P.map (+1))]) + +-- non directional + ,("map/map", + [F ( + P.map (*2) . P.map (+4) -- 1 + )]) + ,("filter/filter", + [F ( + P.filter (/=101) . P.filter (/=102) -- 1 + )]) + ,("filter/map", + [F ( + P.filter (/=103) . P.map (+5) -- 1 + )]) + ,("map/filter", + [F ( + P.map (*3) . P.filter (/=104) -- 1 + )]) + ,("map/noacc", + [F ( + (P.map (+1) . P.filter (/=112)) . P.map (*2) -- 2 + )]) + ,("noacc/map", + [F ( + P.map (+1) . (P.map (+2) . P.filter (/=113)) -- 2 + )]) + ,("filter/noacc", + [F ( + (P.map (+1) . P.filter (/=101)) . P.filter (/=114) -- 2 + )]) + ,("noacc/filter", + [F ( + P.filter (/=101) . (P.map (*2) . P.filter (/=115)) -- 2 + )]) + ,("noacc/noacc", + [F ( + (P.map (*3) . P.filter (/=108)) . (P.map (*4) . P.filter (/=109)) -- 3 + )]) + +-- up loops + ,("up/up", + [F ( + P.foldl' (const.(+1)) (0::X) . P.scanl (flip const) (0::W) -- 1 + )]) + ,("map/up", + [F ( + P.foldl' (const.(+6)) (0::X) . P.map (*4) -- 1 + )]) + ,("up/map", + [F ( + P.map (+7) . P.scanl const (0::W) -- 1 + )]) + ,("filter/up", + [F ( + P.foldl' (const.(+8)) (0::X) . P.filter (/=105) -- 1 + )]) + ,("up/filter", + [F ( + P.filter (/=106) . P.scanl (flip const) (0::W) -- 1 + )]) + ,("noacc/up", + [F ( + P.foldl' (const.(+1)) (0::W) . (P.map (+1) . P.filter (/=110)) -- 2 + )]) + ,("up/noacc", + [F ( + (P.map (+1) . P.filter (/=111)) . P.scanl (flip const) (0::W) -- 2 + )]) + +-- down loops + ,("down/down", + [F ( + P.foldr (const (+9)) (0::W) . P.scanl (flip const) (0::W) -- 1 + )]) + ,("map/down", + [F ( + P.foldr (const (+10)) (0::W) . P.map (*2) -- 1 + )]) + ,("down/map", + [F ( + P.map (*2) . P.scanl (flip const) (0::W) -- 1 + )]) + ,("filter/down", + [F ( + P.foldr (const (+11)) (0::W) . P.filter (/=106) -- 1 + )]) + ,("down/filter", + [F ( + P.filter (/=107) . P.scanl (flip const) (0::W) -- 1 + )]) + ,("noacc/down", + [F ( + P.foldr (const (+1)) (0::W) . (P.map (+1) . P.filter (/=116)) -- 2 + )]) + ,("down/noacc", + [F ( + (P.map (+1) . P.filter (/=101)) . P.scanl (flip const) (0::W) -- 2 + )]) + +-- misc + ,("length/loop", + [F ( + P.length . P.filter (/=105) -- 1 + )]) + ,("maximum/loop", + [F ( + P.maximum . P.map (*4) -- 1 + )]) + ,("minimum/loop", + [F ( + P.minimum . P.map (+6) -- 1 + )]) + + ] + +-- and some longer ones to see the full effect +bigtests = + [("big map/map", + [F (P.map (subtract 3). P.map (+7) . P.map (*2) . P.map (+4) -- 3 + )]) + ,("big filter/filter", + [F (P.filter (/=103) . P.filter (/=104) . P.filter (/=101) . P.filter (/=102) -- 3 + )]) + ,("big filter/map", + [F (P.map (*2) . P.filter (/=104) . P.map (+6) . P.filter (/=103) . P.map (+5) --4 + )]) + ] + +main = do + force (string,string) + printf "#Byte\n" + run 5 (map (fromIntegral.ord) string) (tests ++ bigtests) + diff --git a/tests/Bench/ListVsBase.hs b/tests/Bench/ListVsBase.hs new file mode 100644 --- /dev/null +++ b/tests/Bench/ListVsBase.hs @@ -0,0 +1,416 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ unboxed strings +-- +-- Benchmark tool. +-- Compare a function against equivalent code from other libraries for +-- space and time. +-- +import Bench.Utils + +import qualified Data.List as L -- theirs +import qualified Data.List.Stream as S -- ours + +import Data.Char +import Data.Word +import Data.Int + +import System.IO +import Control.Monad +import Text.Printf + +main :: IO () +main = do + -- initialise + let input = Input (take 1000 string) string string2 (splitEvery 1000 string2) + force input + + putStrLn "Benchmarking Data.List.Stream <=> Data.List" + putStrLn "===========================================\n" + + printf "# Size of test data: %dk\n" ((floor $ (fromIntegral (length string)) / 1024) :: Int) + printf "#List\t List.Stream\n" + + + run 5 input tests + +------------------------------------------------------------------------ + +tests = + [ + -- * Basic interface + + ("++", -- should be identical + [F ( app (uncurry ((L.++) :: S -> S -> S) ) ) + ,F ( app (uncurry ((S.++) :: S -> S -> S) ) ) ] + ) + + , ("head", + [F ( app (L.head :: S -> Char) ) + ,F ( app (S.head :: S -> Char) )] + ) + + , ("last", + [F ( app (L.last :: S -> Char)) + ,F ( app (S.last :: S -> Char)) + ]) + + , ("init", + [F ( app (L.init :: S -> S)) + ,F ( app (S.init :: S -> S)) + ]) + + , ("null", + [F ( app (L.null :: S -> Bool)) + ,F ( app (S.null :: S -> Bool)) + ]) + + , ("length", + [F ( app (L.length :: S -> Int)) + ,F ( app (S.length :: S -> Int)) + ]) + + -- * List transformations + , ("map", + [F ( app ( L.map toUpper :: S -> S )) + ,F ( app ( S.map toUpper :: S -> S )) + ]) + + , ("reverse", + [F ( app (L.reverse :: S -> S )) + ,F ( app (S.reverse :: S -> S )) + ]) + + , ("intersperse", + [F ( app (L.intersperse 'x' :: S -> S) ) + ,F ( app (S.intersperse 'x' :: S -> S) ) ] + ) + + , ("intercalate", + [F ( app2 (L.intercalate :: S -> [S] -> S) ) + ,F ( app2 (S.intercalate :: S -> [S] -> S) ) ] + ) + + -- transpose is too slow. + + -- * Reducing lists (folds) + + , ("foldl'", + [F ( app ( L.foldl' (\a _ -> a+1) 0 :: S -> Int ) ) + ,F ( app ( S.foldl' (\a _ -> a+1) 0 :: S -> Int ) ) + ]) + +{- + , ("foldr", + [F ( app ( L.foldr (\_ a -> a+1) 0 :: S -> Int ) ) + ,F ( app ( S.foldr (\_ a -> a+1) 0 :: S -> Int ) ) + ]) +-} + + -- ** Special folds + + , ("concat", + [F ( app ((\ss -> L.concat (ss++ss++ss)) :: [S] -> S) ) + ,F ( app ((\ss -> S.concat (ss++ss++ss)) :: [S] -> S) ) ] + ) + + , ("concatMap", + [F ( app (L.concatMap (\c -> L.replicate 10 c) :: S -> S)) + ,F ( app (S.concatMap (\c -> S.replicate 10 c) :: S -> S)) ] + ) + + , ("any", + [F ( app ( L.any (=='x') :: S -> Bool )) + ,F ( app ( S.any (=='x') :: S -> Bool )) + ]) + , ("all", + [F ( app ( L.all (=='x') :: S -> Bool )) + ,F ( app ( S.all (=='x') :: S -> Bool )) + ]) + , ("maximum", + [{-F ( app (L.maximum :: S -> Char) ) + ,-}F ( app (S.maximum :: S -> Char) ) + ]) + , ("minimum", + [{-F ( app (L.minimum :: S -> Char) ) + ,-}F ( app (S.minimum :: S -> Char) ) + ]) + + -- * Building lists + -- ** Scans + + -- * Sublists + -- ** Extracting sublists + , ("take", + [F ( app ( L.take 100000 :: S -> S) ) + ,F ( app ( S.take 100000 :: S -> S) ) + ]) + , ("drop", + [F ( app ( L.drop 100000 :: S -> S) ) + ,F ( app ( S.drop 100000 :: S -> S) ) + ]) + + , ("takeWhile", + [F ( app ( L.takeWhile (/='z') :: S -> S )) + ,F ( app ( S.takeWhile (=='z') :: S -> S )) + ]) + , ("dropWhile", + [F ( app ( L.dropWhile (/='z') :: S -> S ) ) + ,F ( app ( S.dropWhile (/='z') :: S -> S ) ) + ]) + + -- * Searching lists + -- ** Searching by equality + , ("elem", + [F ( app (L.elem ('Z') :: S -> Bool) ) + ,F ( app (S.elem ('Z') :: S -> Bool) ) + ]) + , ("notElem", + [F ( app (L.notElem ('Z') :: S -> Bool) ) + ,F ( app (S.notElem ('Z') :: S -> Bool) ) + ]) + + -- ** Searching with a predicate + + , ("find", + [F ( app (L.find (=='Z') :: S -> Maybe Char) ) + ,F ( app (S.find (=='Z') :: S -> Maybe Char) ) + ]) + + , ("filter", + [F ( app ( L.filter isSpace :: S -> S )) + ,F ( app ( S.filter isSpace :: S -> S )) + ]) + + -- * Indexing lists + + , ("index", + [F ( app ((\x -> x L.!! 300000) :: S -> Char )) + ,F ( app ((\x -> x S.!! 300000) :: S -> Char )) + ]) + + , ("elemIndex", + [F ( app (L.elemIndex ('Z') :: S -> Maybe Int ) ) + ,F ( app (S.elemIndex ('Z') :: S -> Maybe Int ) ) + ]) + + , ("elemIndices", + [F ( app (L.elemIndices ('Z') :: S -> [Int] ) ) + ,F ( app (S.elemIndices ('Z') :: S -> [Int] ) ) + ]) + + , ("findIndex", + [F ( app (L.findIndex (=='Z') :: S -> Maybe Int ) ) + ,F ( app (S.findIndex (=='Z') :: S -> Maybe Int ) ) + ]) + + , ("findIndices", + [F ( app (L.findIndices (=='Z') :: S -> [Int] ) ) + ,F ( app (S.findIndices (=='Z') :: S -> [Int] ) ) + ]) + + -- * Zipping and unzipping lists + + , ("zip", + [F ( app (uncurry (L.zip) :: (S,S) -> [(Char, Char)] )) + ,F ( app (uncurry (S.zip) :: (S,S) -> [(Char, Char)] )) + ]) + + , ("zipWith", + [F ( app (uncurry (L.zipWith (,)) :: (S,S) -> [(Char, Char)] )) + ,F ( app (uncurry (S.zipWith (,)) :: (S,S) -> [(Char, Char)] )) + ]) + + , ("replicate", + [F ( const $ L.replicate 2000000 'x') + ,F ( const $ S.replicate 2000000 'x') + ]) + + ] + + +{- + + + , ("span", + [F ({-# SCC "span" #-} app $ B.span (/=122)) + ,F ({-# SCC "lazy span" #-} app $ L.span (/=122)) + ]) + , ("break", + [F ({-# SCC "break" #-} app $ B.break (==122)) + ,F ({-# SCC "lazy break" #-} app $ L.break (==122)) + ]) + , ("split", + [F ({-# SCC "split" #-} app $ B.split 0x0a) + ,F ({-# SCC "lazy split" #-} app $ L.split 0x0a) + ]) +-- , ("breakByte", +-- [F ({-# SCC "breakChar" #-} app $ B.breakByte 122) +-- ,F ({-# SCC "lazy breakChar" #-} app $ L.breakByte 122) +-- ]) +-- , ("spanByte", +-- [F ({-# SCC "spanChar" #-} app $ B.spanByte 122) +-- ,F ({-# SCC "lazy spanChar" #-} app $ L.spanByte 122) +-- ]) + + , ("cons", + [F ({-# SCC "cons" #-} app $ B.cons 120) + ,F ({-# SCC "lazy cons" #-} app $ L.cons 120) + ]) + , ("snoc", + [F ({-# SCC "snoc" #-} app $ flip B.snoc 120) + ,F ({-# SCC "lazy snoc" #-} app $ flip L.snoc 120) + ]) + , ("empty", + [F ({-# SCC "empty" #-} const B.empty) + ,F ({-# SCC "lazy empty" #-} const L.empty) + ]) + , ("head", + [F ({-# SCC "head" #-} app B.head) + ,F ({-# SCC "lazy head" #-} app L.head) + ]) + , ("tail", + [F ({-# SCC "tail" #-} app B.tail) + ,F ({-# SCC "lazy tail" #-} app L.tail) + ]) + + , ("count", + [F ({-# SCC "count" #-} app $ B.count 10) + ,F ({-# SCC "lazy count" #-} app $ L.count 10) + ]) + + , ("isPrefixOf", + [F ({-# SCC "isPrefixOf" #-} app $ B.isPrefixOf + (C.pack "The Project Gutenberg eBook")) + ,F ({-# SCC "lazy isPrefixOf" #-} app $ L.isPrefixOf + (L.pack [84,104,101,32,80,114,111,106,101 + ,99,116,32,71,117,116,101,110,98 + ,101,114,103,32,101,66,111,111,107])) + ]) + , ("join", + [F ({-# SCC "join" #-} app $ B.join (B.pack [1,2,3])) + ,F ({-# SCC "lazy join" #-} app $ L.join (L.pack [1,2,3])) + ]) +-- , ("joinWithByte", +-- [F ({-# SCC "joinWithByte" #-} app $ uncurry (B.joinWithByte 32)) +-- ,F ({-# SCC "lazy joinWithByte" #-} app $ uncurry (L.joinWithByte 32)) +-- ]) + + , ("elem", + [F ({-# SCC "elem" #-} app $ B.elem 122) + ,F ({-# SCC "lazy elem" #-} app $ L.elem 122) + ]) + , ("notElem", + [F ({-# SCC "notElem" #-} app $ B.notElem 122) + ,F ({-# SCC "lazy notElem" #-} app $ L.notElem 122) + ]) + , ("elemIndex", + [F ({-# SCC "elemIndex" #-} app $ B.elemIndex 122) + ,F ({-# SCC "lazy elemIndex" #-} app $ L.elemIndex 122) + ]) + , ("findIndices", + [F ({-# SCC "findIndicies" #-} app $ B.findIndices (==122)) + ,F ({-# SCC "lazy findIndices" #-} app $ L.findIndices (==122)) + ]) + , ("elemIndices", + [F ({-# SCC "elemIndicies" #-} app $ B.elemIndices 122) + ,F ({-# SCC "lazy elemIndices" #-} app $ L.elemIndices 122) + ]) + , ("splitAt", + [F ({-# SCC "splitAt" #-} app $ B.splitAt 10000) + ,F ({-# SCC "lazy splitAt" #-} app $ L.splitAt 10000) + ]) + , ("splitWith", + [F ({-# SCC "splitWith" #-} app $ B.splitWith (==122)) + ,F ({-# SCC "lazy splitWith" #-} app $ L.splitWith (==122)) + ]) + + , ("group", + [F ({-# SCC "group" #-} app B.group) + ,F ({-# SCC "lazy group" #-} app L.group) + ]) + , ("groupBy", + [F ({-# SCC "groupBy" #-} app $ B.groupBy (==)) + ,F ({-# SCC "lazy groupBy" #-} app $ L.groupBy (==)) + ]) + , ("inits", + [F ({-# SCC "inits" #-} app B.inits) + ]) + , ("tails", + [F ({-# SCC "tails" #-} app B.tails) + ]) +-- , ("transpose",[F ({-# SCC "transpose" #-}B.transpose [fps,fps'])]) + +------------------------------------------------------------------------ +-- +-- Char8 or ByteString only + + , ("intersperse", + [F ({-# SCC "intersperse" #-} app $ B.intersperse 120 ) + ]) + , ("sort", + [F ({-# SCC "sort" #-} app B.sort) + ]) +-- , ("lineIndices", +-- [F ({-# SCC "lineIndicies" #-} app C.lineIndices) +-- ]) + , ("elemIndexEnd", + [F ({-# SCC "elemIndexEnd" #-} app $ B.elemIndexEnd 122) + ]) +-- , ("breakSpace", +-- [F ({-# SCC "breakSpace" #-} app C.breakSpace) +-- ]) +-- , ("dropSpace", +-- [F ({-# SCC "dropSpace" #-} app C.dropSpace) +-- ]) +-- , ("dropSpaceEnd", +-- [F ({-# SCC "dropSpaceEnd" #-} app C.dropSpaceEnd) +-- ]) + +-- , ("zip",[F ({-# SCC "zip" #-} B.zip fps fps)]) + + , ("isSubstringOf", + [F ({-# SCC "isSubstringOf" #-} app $ B.isSubstringOf (C.pack "email news")) + ]) + , ("isSuffixOf", + [F ({-# SCC "isSuffixOf" #-} app $ B.isSuffixOf (C.pack "new eBooks")) + ]) + , ("spanEnd", + [F ({-# SCC "spanEnd" #-} app $ B.spanEnd (/=122)) + ]) + , ("lines", + [F ({-# SCC "lines" #-} app C.lines) + ]) + , ("unlines", + [F ({-# SCC "unlines" #-} app C.unlines) + ]) + , ("words", + [F ({-# SCC "words" #-} app C.words) + ]) + , ("unwords", + [F ({-# SCC "unwords" #-} app C.unwords) + ]) + + ] +-} + +------------------------------------------------------------------------ + +data Input = Input String String String [String] + +instance Forceable Input where + force (Input s x y xs) = force s >> force x >> force y >> force xs + +class (Eq a, Ord a) => Ap a where app :: (a -> b) -> Input -> b + +instance Ap String where app f (Input _ x _ _) = f x +instance Ap [String] where app f (Input _ _ _ xs) = f xs +instance Ap (String,String) where app f (Input _ x y _) = f (x, y) +instance Ap (String,[String]) where app f (Input s _ _ xs) = f (s, xs) + +app2 :: Ap (a, b) => (a -> b -> c) -> Input -> c +app2 = app . uncurry + +splitEvery :: Int -> [a] -> [[a]] +splitEvery n = L.unfoldr split + where split [] = Nothing + split s = Just (Prelude.splitAt n s) diff --git a/tests/Bench/StreamList.hs b/tests/Bench/StreamList.hs new file mode 100644 --- /dev/null +++ b/tests/Bench/StreamList.hs @@ -0,0 +1,390 @@ +-- +-- list like wrappers for abstract streams +-- +-- These specify the versions used when fusion occurs. +-- +-- So we can check our stream implementations, which are only used when +-- fusion happens, are fast. +-- + +module Bench.StreamList where + +import Prelude +import qualified Prelude +import Properties.Utils + +import qualified Data.Stream as Stream + +-- * Basic interface +cons :: a -> [a] -> [a] +snoc :: [a] -> a -> [a] +append :: [a] -> [a] -> [a] +head :: [a] -> a +last :: [a] -> a +tail :: [a] -> [a] +init :: [a] -> [a] +null :: [a] -> Bool +length :: [a] -> Int + + +-- * List transformations +map :: (a -> b) -> [a] -> [b] +--reverse :: [a] -> [a] +intersperse :: a -> [a] -> [a] +intercalate :: [a] -> [[a]] -> [a] +--transpose :: [[a]] -> [[a]] + +-- * Reducing lists (folds) +foldl :: (b -> a -> b) -> b -> [a] -> b +foldl' :: (b -> a -> b) -> b -> [a] -> b +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1' :: (a -> a -> a) -> [a] -> a +foldr :: (a -> b -> b) -> b -> [a] -> b +foldr1 :: (a -> a -> a) -> [a] -> a + +-- ** Special folds +concat :: [[a]] -> [a] +concatMap :: (a -> [b]) -> [a] -> [b] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (a -> Bool) -> [a] -> Bool +all :: (a -> Bool) -> [a] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: Ord a => [a] -> a +minimum :: Ord a => [a] -> a + +-- * Building lists +-- ** Scans +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl1 :: (a -> a -> a) -> [a] -> [a] + +{- +scanr :: (a -> b -> b) -> b -> [a] -> [b] +scanr1 :: (a -> a -> a) -> [a] -> [a] + +-- ** Accumulating maps +mapAccumL :: (c -> a -> (c, b)) -> c -> [a] -> (c, [b]) +mapAccumR :: (c -> a -> (c, b)) -> c -> [a] -> (c, [b]) +-} + +-- ** Infinite lists +iterate :: (a -> a) -> a -> [a] +repeat :: a -> [a] +replicate :: Int -> a -> [a] +cycle :: [a] -> [a] + +-- ** Unfolding +unfoldr :: (b -> Maybe (a, b)) -> b -> [a] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [a] -> [a] +drop :: Int -> [a] -> [a] +splitAt :: Int -> [a] -> ([a], [a]) +takeWhile :: (a -> Bool) -> [a] -> [a] +dropWhile :: (a -> Bool) -> [a] -> [a] + +{- +span :: (a -> Bool) -> [a] -> ([a], [a]) +break :: (a -> Bool) -> [a] -> ([a], [a]) +group :: [a] -> [[a]] +inits :: [a] -> [[a]] +tails :: [a] -> [[a]] +-} + +-- * Predicates +isPrefixOf :: Eq a => [a] -> [a] -> Bool +{- +isSuffixOf :: [a] -> [a] -> Bool +isInfixOf :: [a] -> [a] -> Bool +-} + +-- * Searching lists +-- ** Searching by equality +elem :: Eq a => a -> [a] -> Bool +--notElem :: Eq a => a -> [a] -> Bool +lookup :: Eq a => a -> [(a, b)] -> Maybe b + +-- ** Searching with a predicate +find :: (a -> Bool) -> [a] -> Maybe a +filter :: (a -> Bool) -> [a] -> [a] +--partition :: (a -> Bool) -> [a] -> ([a], [a]) + +-- * Indexing lists +(!!) :: [a] -> Int -> a +findIndex :: (a -> Bool) -> [a] -> Maybe Int +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndices :: Eq a => a -> [a] -> [Int] +findIndices :: (a -> Bool) -> [a] -> [Int] + +-- * Zipping and unzipping lists +zip :: [a] -> [b] -> [(a, b)] +zip3 :: [a] -> [b] -> [c] -> [(a, b, c)] +{- +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)] +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)] +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)] +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)] +-} + +zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +{- +zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] +zipWith5 :: (a -> b -> c -> d -> e -> f) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] +zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h] +-} + +unzip :: [(a, b)] -> ([a], [b]) +{- +unzip3 :: [(a, b, c)] -> ([a], [b], [c]) +unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) +unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e]) +unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f]) +unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g]) +-} + +-- * Special lists +-- ** Functions on strings +unlines :: [String] -> String +lines :: String -> [String] +{- +words :: String -> [String] +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [a] -> [a] +delete :: a -> [a] -> [a] +(\\) :: [a] -> [a] -> [a] +union :: [a] -> [a] -> [a] +intersect :: [a] -> [a] -> [a] + +-- ** Ordered lists +sort :: [a] -> [a] +insert :: a -> [a] -> [a] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (a -> a -> Bool) -> [a] -> [a] +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +-} + +-- *** User-supplied comparison (replacing an Ord context) +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +{- +sortBy :: (a -> a -> Ordering) -> [a] -> [a] +-} +maximumBy :: (a -> a -> Ordering) -> [a] -> a +minimumBy :: (a -> a -> Ordering) -> [a] -> a + +-- * The \"generic\" operations +genericLength :: [a] -> I +genericTake :: I -> [a] -> [a] +genericDrop :: I -> [a] -> [a] +genericIndex :: [a] -> I -> a +genericSplitAt :: I -> [a] -> ([a], [a]) +genericReplicate :: I -> a -> [a] + +s = Stream.stream +u = Stream.unstream + +-- * Basic interface +cons = \x xs -> u $ Stream.cons x (s xs) +snoc = \xs x -> u $ Stream.snoc (s xs) x +append = \xs ys -> u $ Stream.append (s xs) (s ys) +head = \xs -> Stream.head (s xs) +last = \xs -> Stream.last (s xs) +tail = \xs -> u $ Stream.tail (s xs) +init = \xs -> u $ Stream.init (s xs) +null = \xs -> Stream.null (s xs) +length = \xs -> Stream.length (s xs) + + +-- * List transformations +map = \f xs -> u $ Stream.map f (s xs) +--reverse = Stream.reverse +intersperse = \sep xs -> u $ Stream.intersperse sep (s xs) +intercalate = \sep xs -> Stream.concat (Stream.intersperse sep(s xs)) + +--transpose = Stream.transpose + +-- * Reducing lists (folds) +foldl = \f z xs -> Stream.foldl f z (s xs) +foldl' = \f z xs -> Stream.foldl' f z (s xs) +foldl1 = \f xs -> Stream.foldl1 f (s xs) +foldl1' = \f xs -> Stream.foldl1' f (s xs) +foldr = \f z xs -> Stream.foldr f z (s xs) +foldr1 = \f xs -> Stream.foldr1 f (s xs) + +-- ** Special folds +concat = \ xs -> Stream.concat (s xs) +concatMap = \f xs -> Stream.concatMap f (s xs) +and = \ xs -> Stream.and (s xs) +or = \ xs -> Stream.or (s xs) +any = \f xs -> Stream.any f (s xs) +all = \f xs -> Stream.all f (s xs) +sum = \ xs -> Stream.sum (s xs) +product = \ xs -> Stream.product (s xs) +maximum = \ xs -> Stream.maximum (s xs) +{-# INLINE maximum #-} +minimum = \ xs -> Stream.minimum (s xs) +{-# INLINE minimum #-} + +-- * Building lists +-- ** Scans +scanl = \f z xs -> u (Stream.scanl f z (Stream.snoc (s xs) bottom)) + where + bottom :: a + bottom = error "StreamProperties.bottom" + +scanl1 = \f xs -> u (Stream.scanl1 f (Stream.snoc (s xs) bottom)) + where + bottom :: a + bottom = error "StreamProperties.bottom" + +{- +scanr = \f z xs -> u (Stream.scanr f z (Stream.cons bottom (s xs))) + where + bottom :: a + bottom = error "StreamProperties.bottom" +-} + +{- +scanr1 = Stream.scanr1 + +-- ** Accumulating maps +mapAccumL = Stream.mapAccumL +mapAccumR = Stream.mapAccumR +-} +-- ** Infinite lists +iterate = \f x -> u $ Stream.iterate f x +repeat = \ x -> u $ Stream.repeat x +replicate = \n x -> u $ Stream.replicate n x +cycle = \ xs -> u $ Stream.cycle (s xs) + +-- ** Unfolding +unfoldr = \f x -> u $ Stream.unfoldr f x + +-- * Sublists +-- ** Extracting sublists +take = \n xs -> u $ Stream.take n (s xs) +drop = \n xs -> u $ Stream.drop n (s xs) +splitAt = \n xs -> Stream.splitAt n (s xs) +takeWhile = \f xs -> u $ Stream.takeWhile f (s xs) +dropWhile = \f xs -> u $ Stream.dropWhile f (s xs) +{- +span = Stream.span +break = Stream.break +group = Stream.group +inits = Stream.inits +tails = Stream.tails +-} + +-- * Predicates +isPrefixOf = \xs ys -> Stream.isPrefixOf (s xs) (s ys) +{- +isSuffixOf = Stream.isSuffixOf +isInfixOf = Stream.isInfixOf +-} +-- * Searching lists +-- ** Searching by equality +elem = \key xs -> Stream.elem key (s xs) +--notElem = Stream.notElem +lookup = \key xs -> Stream.lookup key (s xs) + +-- ** Searching with a predicate +find = \p xs -> Stream.find p (s xs) +filter = \p xs -> u $ Stream.filter p (s xs) +--partition = Stream.partition + +-- * Indexing lists +(!!) = \xs n -> Stream.index (Stream.stream xs) n +--Wirdness: Stream.index needs to be eta-expanded and fully applied for the +-- code to be any good +findIndex = \f xs -> Stream.findIndex f (s xs) +findIndices = \p xs -> u (Stream.findIndices p (s xs)) +elemIndex = \x xs -> Stream.findIndex (x==) (s xs) +elemIndices = \x xs -> u (Stream.findIndices (x==) (s xs)) +{-# INLINE elemIndex #-} +{-# INLINE elemIndices #-} + + +-- * Zipping and unzipping lists +zip = \xs ys -> u (Stream.zip (s xs) (s ys)) +zip3 = \xs ys zs -> u (Stream.zip3 (s xs) (s ys) (s zs)) + +zipWith = \f xs ys -> u (Stream.zipWith f (s xs) (s ys)) +zipWith3 = \f xs ys zs -> u (Stream.zipWith3 f (s xs) (s ys) (s zs)) + +unzip = Stream.unzip . s + +{- +zip4 = Stream.zip4 +zip5 = Stream.zip5 +zip6 = Stream.zip6 +zip7 = Stream.zip7 +zipWith4 = Stream.zipWith4 +zipWith5 = Stream.zipWith5 +zipWith6 = Stream.zipWith6 +zipWith7 = Stream.zipWith7 +unzip3 = Stream.unzip3 +unzip4 = Stream.unzip4 +unzip5 = Stream.unzip5 +unzip6 = Stream.unzip6 +unzip7 = Stream.unzip7 +-} + +-- * Special lists +-- ** Functions on strings +unlines = \xs -> Stream.concatMap (\x -> x ++ ['\n']) (s xs) +lines = \xs -> u (Stream.lines (s xs)) + +{- +words = Stream.words +unwords = Stream.unwords + +-- ** \"Set\" operations +nub = Stream.nub +delete = Stream.delete +(\\) = (Stream.\\) +union = Stream.union +intersect = Stream.intersect + +-- ** Ordered lists +sort = Stream.sort +insert = Stream.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Stream.nubBy +deleteBy = Stream.deleteBy +deleteFirstsBy = Stream.deleteFirstsBy +unionBy = Stream.unionBy +intersectBy = Stream.intersectBy +groupBy = Stream.groupBy +-} + +-- *** User-supplied comparison (replacing an Ord context) +{- +sortBy = Stream.sortBy +-} +insertBy = \cmp x xs -> u $ Stream.insertBy cmp x (s xs) + +maximumBy = \cmp xs -> Stream.maximumBy cmp (s xs) +minimumBy = \cmp xs -> Stream.minimumBy cmp (s xs) + +-- * The \"generic\" operations +genericLength = \xs -> Stream.genericLength (s xs) +genericTake = \n xs -> u $ Stream.genericTake n (s xs) +genericDrop = \n xs -> u $ Stream.genericDrop n (s xs) +genericIndex = \xs n -> Stream.genericIndex (s xs) n +genericSplitAt = \n xs -> Stream.genericSplitAt n (s xs) +genericReplicate = \n x -> genericTake n (Prelude.repeat x) diff --git a/tests/Bench/StreamVsList.hs b/tests/Bench/StreamVsList.hs new file mode 100644 --- /dev/null +++ b/tests/Bench/StreamVsList.hs @@ -0,0 +1,423 @@ +{-# OPTIONS -fglasgow-exts #-} +-- ^ unboxed strings +-- +-- Benchmark tool. +-- Compare a function against equivalent code from other libraries for +-- space and time. +-- +import Bench.Utils + +import qualified Data.List.Stream as L -- our list functions +import qualified Bench.StreamList as S -- our stream versions + +import qualified Data.Stream as Stream + +import Data.Char +import Data.Word +import Data.Int + +import System.IO +import Control.Monad +import Text.Printf + +main :: IO () +main = do + -- initialise + let input = Input (take 1000 string) string string2 (splitEvery 1000 string2) + force input + + putStrLn "Benchmarking Data.Stream <=> Data.List.Stream" + putStrLn "=============================================\n" + + printf "# Size of test data: %dk\n" ((floor $ (fromIntegral (length string)) / 1024) :: Int) + printf "#List\t List.Stream\n" + + + run 5 input tests + +------------------------------------------------------------------------ + +s = Stream.stream +u = Stream.unstream + + +tests = + [ + -- * Basic interface + + ("++", -- should be identical + [F ( app (uncurry ((L.++) :: S -> S -> S) ) ) + ,F ( app (uncurry ((S.append) :: S -> S -> S) ) ) ] + ) + + , ("head", + [F ( app (L.head :: S -> Char) ) + ,F ( app (S.head :: S -> Char) )] + ) + + , ("last", + [F ( app (L.last :: S -> Char)) + ,F ( app (S.last :: S -> Char)) + ]) + + , ("init", + [F ( app (L.init :: S -> S)) + ,F ( app (S.init :: S -> S)) + ]) + + , ("null", + [F ( app (L.null :: S -> Bool)) + ,F ( app (S.null :: S -> Bool)) + ]) + + , ("length", + [F ( app (L.length :: S -> Int)) + ,F ( app (S.length :: S -> Int)) + ]) + + -- * List transformations + , ("map", + [F ( app ( L.map toUpper :: S -> S )) + ,F ( app ( S.map toUpper :: S -> S )) + ]) +{- + , ("reverse", + [F ( app (L.reverse :: S -> S )) + ,F ( app (S.reverse :: S -> S )) + ]) +-} + , ("intersperse", + [F ( app (L.intersperse 'x' :: S -> S) ) + ,F ( app (S.intersperse 'x' :: S -> S) ) ] + ) + + , ("intercalate", + [F ( app2 (L.intercalate :: S -> [S] -> S) ) + ,F ( app2 (S.intercalate :: S -> [S] -> S) ) ] + ) + + -- transpose is too slow. + + -- * Reducing lists (folds) + + , ("foldl'", + [F ( app ( L.foldl' (\a _ -> a+1) 0 :: S -> Int ) ) + ,F ( app ( S.foldl' (\a _ -> a+1) 0 :: S -> Int ) ) + ]) + +{- + , ("foldr", + [F ( app ( L.foldr (\_ a -> a+1) 0 :: S -> Int ) ) + ,F ( app ( S.foldr (\_ a -> a+1) 0 :: S -> Int ) ) + ]) +-} + + -- ** Special folds + + , ("concat", + [F ( app ((\ss -> L.concat (ss++ss++ss)) :: [S] -> S) ) + ,F ( app ((\ss -> S.concat (ss++ss++ss)) :: [S] -> S) ) ] + ) + + , ("concatMap", + [F ( app (L.concatMap (\c -> [c, c, c]) :: S -> S)) + ,F ( app (S.concatMap (\c -> [c, c, c]) :: S -> S)) ] + ) + + , ("any", + [F ( app ( L.any (=='x') :: S -> Bool )) + ,F ( app ( S.any (=='x') :: S -> Bool )) + ]) + , ("all", + [F ( app ( L.all (=='x') :: S -> Bool )) + ,F ( app ( S.all (=='x') :: S -> Bool )) + ]) + , ("maximum", + [F ( app (L.maximum :: S -> Char) ) + ,F ( app (S.maximum :: S -> Char) ) + ]) + , ("minimum", + [F ( app (L.minimum :: S -> Char) ) + ,F ( app (S.minimum :: S -> Char) ) + ]) + + -- * Building lists + -- ** Scans + + -- * Sublists + -- ** Extracting sublists + , ("take", + [F ( app ( L.take 100000 :: S -> S) ) + ,F ( app ( S.take 100000 :: S -> S) ) + ]) + , ("drop", + [F ( app ( L.drop 100000 :: S -> S) ) + ,F ( app ( S.drop 100000 :: S -> S) ) + ]) + + , ("takeWhile", + [F ( app ( L.takeWhile (/='z') :: S -> S )) + ,F ( app ( S.takeWhile (=='z') :: S -> S )) + ]) + , ("dropWhile", + [F ( app ( L.dropWhile (/='z') :: S -> S ) ) + ,F ( app ( S.dropWhile (/='z') :: S -> S ) ) + ]) + + -- * Searching lists + -- ** Searching by equality + , ("elem", + [F ( app (L.elem ('Z') :: S -> Bool) ) + ,F ( app (S.elem ('Z') :: S -> Bool) ) + ]) +{- + , ("notElem", + [F ( app (L.notElem ('Z') :: S -> Bool) ) + ,F ( app (S.notElem ('Z') :: S -> Bool) ) + ]) +-} + -- ** Searching with a predicate + + , ("find", + [F ( app (L.find (=='Z') :: S -> Maybe Char) ) + ,F ( app (S.find (=='Z') :: S -> Maybe Char) ) + ]) + + , ("filter", + [F ( app ( L.filter isSpace :: S -> S )) + ,F ( app ( S.filter isSpace :: S -> S )) + ]) + + -- * Indexing lists + + , ("index", + [F ( app ((\x -> x L.!! 300000) :: S -> Char )) + ,F ( app ((\x -> x S.!! 300000) :: S -> Char )) + ]) + + , ("elemIndex", + [F ( app (L.elemIndex ('Z') :: S -> Maybe Int ) ) + ,F ( app (S.elemIndex ('Z') :: S -> Maybe Int ) ) + ]) + + , ("elemIndices", + [F ( app (L.elemIndices ('Z') :: S -> [Int] ) ) + ,F ( app (S.elemIndices ('Z') :: S -> [Int] ) ) + ]) + + , ("findIndex", + [F ( app (L.findIndex (=='Z') :: S -> Maybe Int ) ) + ,F ( app (S.findIndex (=='Z') :: S -> Maybe Int ) ) + ]) + + , ("findIndices", + [F ( app (L.findIndices (=='Z') :: S -> [Int] ) ) + ,F ( app (S.findIndices (=='Z') :: S -> [Int] ) ) + ]) + + -- * Zipping and unzipping lists + + , ("zip", + [F ( app (uncurry (L.zip) :: (S,S) -> [(Char, Char)] )) + ,F ( app (uncurry (S.zip) :: (S,S) -> [(Char, Char)] )) + ]) + + , ("zipWith", + [F ( app (uncurry (L.zipWith (,)) :: (S,S) -> [(Char, Char)] )) + ,F ( app (uncurry (S.zipWith (,)) :: (S,S) -> [(Char, Char)] )) + ]) + + , ("replicate", + [F ( const $ L.replicate 2000000 'x') + ,F ( const $ S.replicate 2000000 'x') + ]) + + ] + + +{- + + + , ("span", + [F ({-# SCC "span" #-} app $ B.span (/=122)) + ,F ({-# SCC "lazy span" #-} app $ L.span (/=122)) + ]) + , ("break", + [F ({-# SCC "break" #-} app $ B.break (==122)) + ,F ({-# SCC "lazy break" #-} app $ L.break (==122)) + ]) + , ("split", + [F ({-# SCC "split" #-} app $ B.split 0x0a) + ,F ({-# SCC "lazy split" #-} app $ L.split 0x0a) + ]) +-- , ("breakByte", +-- [F ({-# SCC "breakChar" #-} app $ B.breakByte 122) +-- ,F ({-# SCC "lazy breakChar" #-} app $ L.breakByte 122) +-- ]) +-- , ("spanByte", +-- [F ({-# SCC "spanChar" #-} app $ B.spanByte 122) +-- ,F ({-# SCC "lazy spanChar" #-} app $ L.spanByte 122) +-- ]) + + , ("cons", + [F ({-# SCC "cons" #-} app $ B.cons 120) + ,F ({-# SCC "lazy cons" #-} app $ L.cons 120) + ]) + , ("snoc", + [F ({-# SCC "snoc" #-} app $ flip B.snoc 120) + ,F ({-# SCC "lazy snoc" #-} app $ flip L.snoc 120) + ]) + , ("empty", + [F ({-# SCC "empty" #-} const B.empty) + ,F ({-# SCC "lazy empty" #-} const L.empty) + ]) + , ("head", + [F ({-# SCC "head" #-} app B.head) + ,F ({-# SCC "lazy head" #-} app L.head) + ]) + , ("tail", + [F ({-# SCC "tail" #-} app B.tail) + ,F ({-# SCC "lazy tail" #-} app L.tail) + ]) + + , ("count", + [F ({-# SCC "count" #-} app $ B.count 10) + ,F ({-# SCC "lazy count" #-} app $ L.count 10) + ]) + + , ("isPrefixOf", + [F ({-# SCC "isPrefixOf" #-} app $ B.isPrefixOf + (C.pack "The Project Gutenberg eBook")) + ,F ({-# SCC "lazy isPrefixOf" #-} app $ L.isPrefixOf + (L.pack [84,104,101,32,80,114,111,106,101 + ,99,116,32,71,117,116,101,110,98 + ,101,114,103,32,101,66,111,111,107])) + ]) + , ("join", + [F ({-# SCC "join" #-} app $ B.join (B.pack [1,2,3])) + ,F ({-# SCC "lazy join" #-} app $ L.join (L.pack [1,2,3])) + ]) +-- , ("joinWithByte", +-- [F ({-# SCC "joinWithByte" #-} app $ uncurry (B.joinWithByte 32)) +-- ,F ({-# SCC "lazy joinWithByte" #-} app $ uncurry (L.joinWithByte 32)) +-- ]) + + , ("elem", + [F ({-# SCC "elem" #-} app $ B.elem 122) + ,F ({-# SCC "lazy elem" #-} app $ L.elem 122) + ]) + , ("notElem", + [F ({-# SCC "notElem" #-} app $ B.notElem 122) + ,F ({-# SCC "lazy notElem" #-} app $ L.notElem 122) + ]) + , ("elemIndex", + [F ({-# SCC "elemIndex" #-} app $ B.elemIndex 122) + ,F ({-# SCC "lazy elemIndex" #-} app $ L.elemIndex 122) + ]) + , ("findIndices", + [F ({-# SCC "findIndicies" #-} app $ B.findIndices (==122)) + ,F ({-# SCC "lazy findIndices" #-} app $ L.findIndices (==122)) + ]) + , ("elemIndices", + [F ({-# SCC "elemIndicies" #-} app $ B.elemIndices 122) + ,F ({-# SCC "lazy elemIndices" #-} app $ L.elemIndices 122) + ]) + , ("splitAt", + [F ({-# SCC "splitAt" #-} app $ B.splitAt 10000) + ,F ({-# SCC "lazy splitAt" #-} app $ L.splitAt 10000) + ]) + , ("splitWith", + [F ({-# SCC "splitWith" #-} app $ B.splitWith (==122)) + ,F ({-# SCC "lazy splitWith" #-} app $ L.splitWith (==122)) + ]) + + , ("group", + [F ({-# SCC "group" #-} app B.group) + ,F ({-# SCC "lazy group" #-} app L.group) + ]) + , ("groupBy", + [F ({-# SCC "groupBy" #-} app $ B.groupBy (==)) + ,F ({-# SCC "lazy groupBy" #-} app $ L.groupBy (==)) + ]) + , ("inits", + [F ({-# SCC "inits" #-} app B.inits) + ]) + , ("tails", + [F ({-# SCC "tails" #-} app B.tails) + ]) +-- , ("transpose",[F ({-# SCC "transpose" #-}B.transpose [fps,fps'])]) + +------------------------------------------------------------------------ +-- +-- Char8 or ByteString only + + , ("intersperse", + [F ({-# SCC "intersperse" #-} app $ B.intersperse 120 ) + ]) + , ("sort", + [F ({-# SCC "sort" #-} app B.sort) + ]) +-- , ("lineIndices", +-- [F ({-# SCC "lineIndicies" #-} app C.lineIndices) +-- ]) + , ("elemIndexEnd", + [F ({-# SCC "elemIndexEnd" #-} app $ B.elemIndexEnd 122) + ]) +-- , ("breakSpace", +-- [F ({-# SCC "breakSpace" #-} app C.breakSpace) +-- ]) +-- , ("dropSpace", +-- [F ({-# SCC "dropSpace" #-} app C.dropSpace) +-- ]) +-- , ("dropSpaceEnd", +-- [F ({-# SCC "dropSpaceEnd" #-} app C.dropSpaceEnd) +-- ]) + +-- , ("zip",[F ({-# SCC "zip" #-} B.zip fps fps)]) + + , ("isSubstringOf", + [F ({-# SCC "isSubstringOf" #-} app $ B.isSubstringOf (C.pack "email news")) + ]) + , ("isSuffixOf", + [F ({-# SCC "isSuffixOf" #-} app $ B.isSuffixOf (C.pack "new eBooks")) + ]) + , ("spanEnd", + [F ({-# SCC "spanEnd" #-} app $ B.spanEnd (/=122)) + ]) + , ("lines", + [F ({-# SCC "lines" #-} app C.lines) + ]) + , ("unlines", + [F ({-# SCC "unlines" #-} app C.unlines) + ]) + , ("words", + [F ({-# SCC "words" #-} app C.words) + ]) + , ("unwords", + [F ({-# SCC "unwords" #-} app C.unwords) + ]) + + ] +-} + +------------------------------------------------------------------------ + +data Input = Input String String String [String] + +instance Forceable Input where + force (Input s x y xs) = force s >> force x >> force y >> force xs + +class (Eq a, Ord a) => Ap a where app :: (a -> b) -> Input -> b + +instance Ap String where app f (Input _ x _ _) = f x +instance Ap [String] where app f (Input _ _ _ xs) = f xs +instance Ap (String,String) where app f (Input _ x y _) = f (x, y) +instance Ap (String,[String]) where app f (Input s _ _ xs) = f (s, xs) + +app2 :: Ap (a, b) => (a -> b -> c) -> Input -> c +app2 = app . uncurry + +splitEvery :: Int -> [a] -> [[a]] +splitEvery n = L.unfoldr split + where split [] = Nothing + split s = Just (Prelude.splitAt n s) diff --git a/tests/Bench/Utils.hs b/tests/Bench/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Bench/Utils.hs @@ -0,0 +1,129 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} +module Bench.Utils where + +-- +-- Benchmark tool. +-- Compare a function against equivalent code from other libraries for +-- space and time. +-- + +import Data.List +import Data.Char +import Data.Word +import Data.Int + +import System.Mem +import Control.Concurrent + +import System.IO +import System.CPUTime +import System.IO.Unsafe +import Control.Monad +import Control.Exception +import Text.Printf + +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString as S + + +run :: Int -> a -> [(String, [F a])] -> IO () +run c x tests = sequence_ $ zipWith (doit c x) [1..] tests + + +doit :: Int -> a -> Int -> (String, [F a]) -> IO () +doit count x n (s,ls) = do + printf "%2d %s\n " n (show s) + fn ls + hFlush stdout + where fn xs = case xs of + [f,g] -> runN count f x >> putStr "\n " + >> runN count g x >> putStr "\n\n" + [f] -> runN count f x >> putStr "\n\n" + _ -> return () + run f x = dirtyCache fps >> performGC >> threadDelay 100 >> time f x + runN 0 f x = return () + runN c f x = run f x >> runN (c-1) f x + + +dirtyCache x = evaluate (S.foldl1' (+) x) +{-# NOINLINE dirtyCache #-} + + +time :: F a -> a -> IO () +time (F f) a = do + start <- getCPUTime + v <- force (f a) + case v of + B -> printf "--\t" + _ -> do + end <- getCPUTime + let diff = (fromIntegral (end - start)) / (10^12) + printf "%0.3f " (diff :: Double) + hFlush stdout + + +------------------------------------------------------------------------ +-- +-- an existential list of testables +-- +data F a = forall b . Forceable b => F (a -> b) + +data Result = T | B + +-- +-- a bit deepSeqish +-- +class Forceable a where + force :: a -> IO Result + force v = v `seq` return T + +#if !defined(HEAD) +instance Forceable P.ByteString where + force v = P.length v `seq` return T +#endif + +instance Forceable a => Forceable (Maybe a) where + force Nothing = return T + force (Just v) = force v `seq` return T + +instance Forceable a => Forceable [a] where + force xs = mapM_ force xs >> return T + +instance (Forceable a, Forceable b) => Forceable (a,b) where + force (a,b) = force a >> force b + +instance Forceable Int +instance Forceable Int64 +instance Forceable Bool +instance Forceable Char +instance Forceable Word8 +instance Forceable Ordering + +-- used to signal undefinedness +instance Forceable () where force () = return B + +------------------------------------------------------------------------ +-- +-- some large strings to play with +-- + +string :: String +string = P.unpack (unsafePerformIO (P.readFile dict)) +{-# NOINLINE string #-} + +string2 :: String +string2 = P.unpack (unsafePerformIO (P.readFile dict2)) +{-# NOINLINE string2 #-} + +-- just for dirtying the cache +fps :: P.ByteString +fps = (unsafePerformIO (P.readFile dict2)) +{-# NOINLINE fps #-} + +dict = "Bench/bigdata" +dict2 = "Bench/data" + +-- Some short hand. +type X = Int +type W = Word8 +type S = String diff --git a/tests/Bench/data b/tests/Bench/data new file mode 100644 --- /dev/null +++ b/tests/Bench/data @@ -0,0 +1,3925 @@ +The Project Gutenberg eBook, Utopia, by Thomas More, Edited by Henry Morley + + +This eBook is for the use of anyone anywhere at no cost and with +almost no restrictions whatsoever. You may copy it, give it away or +re-use it under the terms of the Project Gutenberg License included +with this eBook or online at www.gutenberg.net + + + + + +Title: Utopia + + +Author: Thomas More + +Release Date: April 22, 2005 [eBook #2130] + +Language: English + +Character set encoding: ISO-646-US (US-ASCII) + + +***START OF THE PROJECT GUTENBERG EBOOK UTOPIA*** + + + + + + +Transcribed from the 1901 Cassell & Company Edition by David Price, email +ccx074@coventry.ac.uk + + + + + +UTOPIA + + +INTRODUCTION + + +Sir Thomas More, son of Sir John More, a justice of the King's Bench, was +born in 1478, in Milk Street, in the city of London. After his earlier +education at St. Anthony's School, in Threadneedle Street, he was placed, +as a boy, in the household of Cardinal John Morton, Archbishop of +Canterbury and Lord Chancellor. It was not unusual for persons of wealth +or influence and sons of good families to be so established together in a +relation of patron and client. The youth wore his patron's livery, and +added to his state. The patron used, afterwards, his wealth or influence +in helping his young client forward in the world. Cardinal Morton had +been in earlier days that Bishop of Ely whom Richard III. sent to the +Tower; was busy afterwards in hostility to Richard; and was a chief +adviser of Henry VII., who in 1486 made him Archbishop of Canterbury, and +nine months afterwards Lord Chancellor. Cardinal Morton--of talk at +whose table there are recollections in "Utopia"--delighted in the quick +wit of young Thomas More. He once said, "Whoever shall live to try it, +shall see this child here waiting at table prove a notable and rare man." + +At the age of about nineteen, Thomas More was sent to Canterbury College, +Oxford, by his patron, where he learnt Greek of the first men who brought +Greek studies from Italy to England--William Grocyn and Thomas Linacre. +Linacre, a physician, who afterwards took orders, was also the founder of +the College of Physicians. In 1499, More left Oxford to study law in +London, at Lincoln's Inn, and in the next year Archbishop Morton died. + +More's earnest character caused him while studying law to aim at the +subduing of the flesh, by wearing a hair shirt, taking a log for a +pillow, and whipping himself on Fridays. At the age of twenty-one he +entered Parliament, and soon after he had been called to the bar he was +made Under-Sheriff of London. In 1503 he opposed in the House of Commons +Henry VII.'s proposal for a subsidy on account of the marriage portion of +his daughter Margaret; and he opposed with so much energy that the House +refused to grant it. One went and told the king that a beardless boy had +disappointed all his expectations. During the last years, therefore, of +Henry VII. More was under the displeasure of the king, and had thoughts +of leaving the country. + +Henry VII. died in April, 1509, when More's age was a little over thirty. +In the first years of the reign of Henry VIII. he rose to large practice +in the law courts, where it is said he refused to plead in cases which he +thought unjust, and took no fees from widows, orphans, or the poor. He +would have preferred marrying the second daughter of John Colt, of New +Hall, in Essex, but chose her elder sister, that he might not subject her +to the discredit of being passed over. + +In 1513 Thomas More, still Under-Sheriff of London, is said to have +written his "History of the Life and Death of King Edward V., and of the +Usurpation of Richard III." The book, which seems to contain the +knowledge and opinions of More's patron, Morton, was not printed until +1557, when its writer had been twenty-two years dead. It was then +printed from a MS. in More's handwriting. + +In the year 1515 Wolsey, Archbishop of York, was made Cardinal by Leo X.; +Henry VIII. made him Lord Chancellor, and from that year until 1523 the +King and the Cardinal ruled England with absolute authority, and called +no parliament. In May of the year 1515 Thomas More--not knighted yet--was +joined in a commission to the Low Countries with Cuthbert Tunstal and +others to confer with the ambassadors of Charles V., then only Archduke +of Austria, upon a renewal of alliance. On that embassy More, aged about +thirty-seven, was absent from England for six months, and while at +Antwerp he established friendship with Peter Giles (Latinised AEgidius), +a scholarly and courteous young man, who was secretary to the +municipality of Antwerp. + +Cuthbert Tunstal was a rising churchman, chancellor to the Archbishop of +Canterbury, who in that year (1515) was made Archdeacon of Chester, and +in May of the next year (1516) Master of the Rolls. In 1516 he was sent +again to the Low Countries, and More then went with him to Brussels, +where they were in close companionship with Erasmus. + +More's "Utopia" was written in Latin, and is in two parts, of which the +second, describing the place ([Greek text]--or Nusquama, as he called it +sometimes in his letters--"Nowhere"), was probably written towards the +close of 1515; the first part, introductory, early in 1516. The book was +first printed at Louvain, late in 1516, under the editorship of Erasmus, +Peter Giles, and other of More's friends in Flanders. It was then +revised by More, and printed by Frobenius at Basle in November, 1518. It +was reprinted at Paris and Vienna, but was not printed in England during +More's lifetime. Its first publication in this country was in the +English translation, made in Edward's VI.'s reign (1551) by Ralph +Robinson. It was translated with more literary skill by Gilbert Burnet, +in 1684, soon after he had conducted the defence of his friend Lord +William Russell, attended his execution, vindicated his memory, and been +spitefully deprived by James II. of his lectureship at St. Clement's. +Burnet was drawn to the translation of "Utopia" by the same sense of +unreason in high places that caused More to write the book. Burnet's is +the translation given in this volume. + +The name of the book has given an adjective to our language--we call an +impracticable scheme Utopian. Yet, under the veil of a playful fiction, +the talk is intensely earnest, and abounds in practical suggestion. It +is the work of a scholarly and witty Englishman, who attacks in his own +way the chief political and social evils of his time. Beginning with +fact, More tells how he was sent into Flanders with Cuthbert Tunstal, +"whom the king's majesty of late, to the great rejoicing of all men, did +prefer to the office of Master of the Rolls;" how the commissioners of +Charles met them at Bruges, and presently returned to Brussels for +instructions; and how More then went to Antwerp, where he found a +pleasure in the society of Peter Giles which soothed his desire to see +again his wife and children, from whom he had been four months away. Then +fact slides into fiction with the finding of Raphael Hythloday (whose +name, made of two Greek words [Greek text] and [Greek text], means +"knowing in trifles"), a man who had been with Amerigo Vespucci in the +three last of the voyages to the new world lately discovered, of which +the account had been first printed in 1507, only nine years before Utopia +was written. + +Designedly fantastic in suggestion of details, "Utopia" is the work of a +scholar who had read Plato's "Republic," and had his fancy quickened +after reading Plutarch's account of Spartan life under Lycurgus. Beneath +the veil of an ideal communism, into which there has been worked some +witty extravagance, there lies a noble English argument. Sometimes More +puts the case as of France when he means England. Sometimes there is +ironical praise of the good faith of Christian kings, saving the book +from censure as a political attack on the policy of Henry VIII. Erasmus +wrote to a friend in 1517 that he should send for More's "Utopia," if he +had not read it, and "wished to see the true source of all political +evils." And to More Erasmus wrote of his book, "A burgomaster of Antwerp +is so pleased with it that he knows it all by heart." + +H. M. + + + + +DISCOURSES OF RAPHAEL HYTHLODAY, OF THE BEST STATE OF A COMMONWEALTH + + +Henry VIII., the unconquered King of England, a prince adorned with all +the virtues that become a great monarch, having some differences of no +small consequence with Charles the most serene Prince of Castile, sent me +into Flanders, as his ambassador, for treating and composing matters +between them. I was colleague and companion to that incomparable man +Cuthbert Tonstal, whom the King, with such universal applause, lately +made Master of the Rolls; but of whom I will say nothing; not because I +fear that the testimony of a friend will be suspected, but rather because +his learning and virtues are too great for me to do them justice, and so +well known, that they need not my commendations, unless I would, +according to the proverb, "Show the sun with a lantern." Those that were +appointed by the Prince to treat with us, met us at Bruges, according to +agreement; they were all worthy men. The Margrave of Bruges was their +head, and the chief man among them; but he that was esteemed the wisest, +and that spoke for the rest, was George Temse, the Provost of Casselsee: +both art and nature had concurred to make him eloquent: he was very +learned in the law; and, as he had a great capacity, so, by a long +practice in affairs, he was very dexterous at unravelling them. After we +had several times met, without coming to an agreement, they went to +Brussels for some days, to know the Prince's pleasure; and, since our +business would admit it, I went to Antwerp. While I was there, among +many that visited me, there was one that was more acceptable to me than +any other, Peter Giles, born at Antwerp, who is a man of great honour, +and of a good rank in his town, though less than he deserves; for I do +not know if there be anywhere to be found a more learned and a better +bred young man; for as he is both a very worthy and a very knowing +person, so he is so civil to all men, so particularly kind to his +friends, and so full of candour and affection, that there is not, +perhaps, above one or two anywhere to be found, that is in all respects +so perfect a friend: he is extraordinarily modest, there is no artifice +in him, and yet no man has more of a prudent simplicity. His +conversation was so pleasant and so innocently cheerful, that his company +in a great measure lessened any longings to go back to my country, and to +my wife and children, which an absence of four months had quickened very +much. One day, as I was returning home from mass at St. Mary's, which is +the chief church, and the most frequented of any in Antwerp, I saw him, +by accident, talking with a stranger, who seemed past the flower of his +age; his face was tanned, he had a long beard, and his cloak was hanging +carelessly about him, so that, by his looks and habit, I concluded he was +a seaman. As soon as Peter saw me, he came and saluted me, and as I was +returning his civility, he took me aside, and pointing to him with whom +he had been discoursing, he said, "Do you see that man? I was just +thinking to bring him to you." I answered, "He should have been very +welcome on your account." "And on his own too," replied he, "if you knew +the man, for there is none alive that can give so copious an account of +unknown nations and countries as he can do, which I know you very much +desire." "Then," said I, "I did not guess amiss, for at first sight I +took him for a seaman." "But you are much mistaken," said he, "for he +has not sailed as a seaman, but as a traveller, or rather a philosopher. +This Raphael, who from his family carries the name of Hythloday, is not +ignorant of the Latin tongue, but is eminently learned in the Greek, +having applied himself more particularly to that than to the former, +because he had given himself much to philosophy, in which he knew that +the Romans have left us nothing that is valuable, except what is to be +found in Seneca and Cicero. He is a Portuguese by birth, and was so +desirous of seeing the world, that he divided his estate among his +brothers, ran the same hazard as Americus Vesputius, and bore a share in +three of his four voyages that are now published; only he did not return +with him in his last, but obtained leave of him, almost by force, that he +might be one of those twenty-four who were left at the farthest place at +which they touched in their last voyage to New Castile. The leaving him +thus did not a little gratify one that was more fond of travelling than +of returning home to be buried in his own country; for he used often to +say, that the way to heaven was the same from all places, and he that had +no grave had the heavens still over him. Yet this disposition of mind +had cost him dear, if God had not been very gracious to him; for after +he, with five Castalians, had travelled over many countries, at last, by +strange good fortune, he got to Ceylon, and from thence to Calicut, where +he, very happily, found some Portuguese ships; and, beyond all men's +expectations, returned to his native country." When Peter had said this +to me, I thanked him for his kindness in intending to give me the +acquaintance of a man whose conversation he knew would be so acceptable; +and upon that Raphael and I embraced each other. After those civilities +were past which are usual with strangers upon their first meeting, we all +went to my house, and entering into the garden, sat down on a green bank +and entertained one another in discourse. He told us that when Vesputius +had sailed away, he, and his companions that stayed behind in New +Castile, by degrees insinuated themselves into the affections of the +people of the country, meeting often with them and treating them gently; +and at last they not only lived among them without danger, but conversed +familiarly with them, and got so far into the heart of a prince, whose +name and country I have forgot, that he both furnished them plentifully +with all things necessary, and also with the conveniences of travelling, +both boats when they went by water, and waggons when they trained over +land: he sent with them a very faithful guide, who was to introduce and +recommend them to such other princes as they had a mind to see: and after +many days' journey, they came to towns, and cities, and to commonwealths, +that were both happily governed and well peopled. Under the equator, and +as far on both sides of it as the sun moves, there lay vast deserts that +were parched with the perpetual heat of the sun; the soil was withered, +all things looked dismally, and all places were either quite uninhabited, +or abounded with wild beasts and serpents, and some few men, that were +neither less wild nor less cruel than the beasts themselves. But, as +they went farther, a new scene opened, all things grew milder, the air +less burning, the soil more verdant, and even the beasts were less wild: +and, at last, there were nations, towns, and cities, that had not only +mutual commerce among themselves and with their neighbours, but traded, +both by sea and land, to very remote countries. There they found the +conveniencies of seeing many countries on all hands, for no ship went any +voyage into which he and his companions were not very welcome. The first +vessels that they saw were flat-bottomed, their sails were made of reeds +and wicker, woven close together, only some were of leather; but, +afterwards, they found ships made with round keels and canvas sails, and +in all respects like our ships, and the seamen understood both astronomy +and navigation. He got wonderfully into their favour by showing them the +use of the needle, of which till then they were utterly ignorant. They +sailed before with great caution, and only in summer time; but now they +count all seasons alike, trusting wholly to the loadstone, in which they +are, perhaps, more secure than safe; so that there is reason to fear that +this discovery, which was thought would prove so much to their advantage, +may, by their imprudence, become an occasion of much mischief to them. +But it were too long to dwell on all that he told us he had observed in +every place, it would be too great a digression from our present purpose: +whatever is necessary to be told concerning those wise and prudent +institutions which he observed among civilised nations, may perhaps be +related by us on a more proper occasion. We asked him many questions +concerning all these things, to which he answered very willingly; we made +no inquiries after monsters, than which nothing is more common; for +everywhere one may hear of ravenous dogs and wolves, and cruel +men-eaters, but it is not so easy to find states that are well and wisely +governed. + +As he told us of many things that were amiss in those new-discovered +countries, so he reckoned up not a few things, from which patterns might +be taken for correcting the errors of these nations among whom we live; +of which an account may be given, as I have already promised, at some +other time; for, at present, I intend only to relate those particulars +that he told us, of the manners and laws of the Utopians: but I will +begin with the occasion that led us to speak of that commonwealth. After +Raphael had discoursed with great judgment on the many errors that were +both among us and these nations, had treated of the wise institutions +both here and there, and had spoken as distinctly of the customs and +government of every nation through which he had past, as if he had spent +his whole life in it, Peter, being struck with admiration, said, "I +wonder, Raphael, how it comes that you enter into no king's service, for +I am sure there are none to whom you would not be very acceptable; for +your learning and knowledge, both of men and things, is such, that you +would not only entertain them very pleasantly, but be of great use to +them, by the examples you could set before them, and the advices you +could give them; and by this means you would both serve your own +interest, and be of great use to all your friends." "As for my friends," +answered he, "I need not be much concerned, having already done for them +all that was incumbent on me; for when I was not only in good health, but +fresh and young, I distributed that among my kindred and friends which +other people do not part with till they are old and sick: when they then +unwillingly give that which they can enjoy no longer themselves. I think +my friends ought to rest contented with this, and not to expect that for +their sakes I should enslave myself to any king whatsoever." "Soft and +fair!" said Peter; "I do not mean that you should be a slave to any king, +but only that you should assist them and be useful to them." "The change +of the word," said he, "does not alter the matter." "But term it as you +will," replied Peter, "I do not see any other way in which you can be so +useful, both in private to your friends and to the public, and by which +you can make your own condition happier." "Happier?" answered Raphael, +"is that to be compassed in a way so abhorrent to my genius? Now I live +as I will, to which I believe, few courtiers can pretend; and there are +so many that court the favour of great men, that there will be no great +loss if they are not troubled either with me or with others of my +temper." Upon this, said I, "I perceive, Raphael, that you neither +desire wealth nor greatness; and, indeed, I value and admire such a man +much more than I do any of the great men in the world. Yet I think you +would do what would well become so generous and philosophical a soul as +yours is, if you would apply your time and thoughts to public affairs, +even though you may happen to find it a little uneasy to yourself; and +this you can never do with so much advantage as by being taken into the +council of some great prince and putting him on noble and worthy actions, +which I know you would do if you were in such a post; for the springs +both of good and evil flow from the prince over a whole nation, as from a +lasting fountain. So much learning as you have, even without practice in +affairs, or so great a practice as you have had, without any other +learning, would render you a very fit counsellor to any king whatsoever." +"You are doubly mistaken," said he, "Mr. More, both in your opinion of me +and in the judgment you make of things: for as I have not that capacity +that you fancy I have, so if I had it, the public would not be one jot +the better when I had sacrificed my quiet to it. For most princes apply +themselves more to affairs of war than to the useful arts of peace; and +in these I neither have any knowledge, nor do I much desire it; they are +generally more set on acquiring new kingdoms, right or wrong, than on +governing well those they possess: and, among the ministers of princes, +there are none that are not so wise as to need no assistance, or at +least, that do not think themselves so wise that they imagine they need +none; and if they court any, it is only those for whom the prince has +much personal favour, whom by their fawning and flatteries they endeavour +to fix to their own interests; and, indeed, nature has so made us, that +we all love to be flattered and to please ourselves with our own notions: +the old crow loves his young, and the ape her cubs. Now if in such a +court, made up of persons who envy all others and only admire themselves, +a person should but propose anything that he had either read in history +or observed in his travels, the rest would think that the reputation of +their wisdom would sink, and that their interests would be much depressed +if they could not run it down: and, if all other things failed, then they +would fly to this, that such or such things pleased our ancestors, and it +were well for us if we could but match them. They would set up their +rest on such an answer, as a sufficient confutation of all that could be +said, as if it were a great misfortune that any should be found wiser +than his ancestors. But though they willingly let go all the good things +that were among those of former ages, yet, if better things are proposed, +they cover themselves obstinately with this excuse of reverence to past +times. I have met with these proud, morose, and absurd judgments of +things in many places, particularly once in England." "Were you ever +there?" said I. "Yes, I was," answered he, "and stayed some months +there, not long after the rebellion in the West was suppressed, with a +great slaughter of the poor people that were engaged in it. + +"I was then much obliged to that reverend prelate, John Morton, +Archbishop of Canterbury, Cardinal, and Chancellor of England; a man," +said he, "Peter (for Mr. More knows well what he was), that was not less +venerable for his wisdom and virtues than for the high character he bore: +he was of a middle stature, not broken with age; his looks begot +reverence rather than fear; his conversation was easy, but serious and +grave; he sometimes took pleasure to try the force of those that came as +suitors to him upon business by speaking sharply, though decently, to +them, and by that he discovered their spirit and presence of mind; with +which he was much delighted when it did not grow up to impudence, as +bearing a great resemblance to his own temper, and he looked on such +persons as the fittest men for affairs. He spoke both gracefully and +weightily; he was eminently skilled in the law, had a vast understanding, +and a prodigious memory; and those excellent talents with which nature +had furnished him were improved by study and experience. When I was in +England the King depended much on his counsels, and the Government seemed +to be chiefly supported by him; for from his youth he had been all along +practised in affairs; and, having passed through many traverses of +fortune, he had, with great cost, acquired a vast stock of wisdom, which +is not soon lost when it is purchased so dear. One day, when I was +dining with him, there happened to be at table one of the English +lawyers, who took occasion to run out in a high commendation of the +severe execution of justice upon thieves, 'who,' as he said, 'were then +hanged so fast that there were sometimes twenty on one gibbet!' and, upon +that, he said, 'he could not wonder enough how it came to pass that, +since so few escaped, there were yet so many thieves left, who were still +robbing in all places.' Upon this, I (who took the boldness to speak +freely before the Cardinal) said, 'There was no reason to wonder at the +matter, since this way of punishing thieves was neither just in itself +nor good for the public; for, as the severity was too great, so the +remedy was not effectual; simple theft not being so great a crime that it +ought to cost a man his life; no punishment, how severe soever, being +able to restrain those from robbing who can find out no other way of +livelihood. In this,' said I, 'not only you in England, but a great part +of the world, imitate some ill masters, that are readier to chastise +their scholars than to teach them. There are dreadful punishments +enacted against thieves, but it were much better to make such good +provisions by which every man might be put in a method how to live, and +so be preserved from the fatal necessity of stealing and of dying for +it.' 'There has been care enough taken for that,' said he; 'there are +many handicrafts, and there is husbandry, by which they may make a shift +to live, unless they have a greater mind to follow ill courses.' 'That +will not serve your turn,' said I, 'for many lose their limbs in civil or +foreign wars, as lately in the Cornish rebellion, and some time ago in +your wars with France, who, being thus mutilated in the service of their +king and country, can no more follow their old trades, and are too old to +learn new ones; but since wars are only accidental things, and have +intervals, let us consider those things that fall out every day. There +is a great number of noblemen among you that are themselves as idle as +drones, that subsist on other men's labour, on the labour of their +tenants, whom, to raise their revenues, they pare to the quick. This, +indeed, is the only instance of their frugality, for in all other things +they are prodigal, even to the beggaring of themselves; but, besides +this, they carry about with them a great number of idle fellows, who +never learned any art by which they may gain their living; and these, as +soon as either their lord dies, or they themselves fall sick, are turned +out of doors; for your lords are readier to feed idle people than to take +care of the sick; and often the heir is not able to keep together so +great a family as his predecessor did. Now, when the stomachs of those +that are thus turned out of doors grow keen, they rob no less keenly; and +what else can they do? For when, by wandering about, they have worn out +both their health and their clothes, and are tattered, and look ghastly, +men of quality will not entertain them, and poor men dare not do it, +knowing that one who has been bred up in idleness and pleasure, and who +was used to walk about with his sword and buckler, despising all the +neighbourhood with an insolent scorn as far below him, is not fit for the +spade and mattock; nor will he serve a poor man for so small a hire and +in so low a diet as he can afford to give him.' To this he answered, +'This sort of men ought to be particularly cherished, for in them +consists the force of the armies for which we have occasion; since their +birth inspires them with a nobler sense of honour than is to be found +among tradesmen or ploughmen.' 'You may as well say,' replied I, 'that +you must cherish thieves on the account of wars, for you will never want +the one as long as you have the other; and as robbers prove sometimes +gallant soldiers, so soldiers often prove brave robbers, so near an +alliance there is between those two sorts of life. But this bad custom, +so common among you, of keeping many servants, is not peculiar to this +nation. In France there is yet a more pestiferous sort of people, for +the whole country is full of soldiers, still kept up in time of peace (if +such a state of a nation can be called a peace); and these are kept in +pay upon the same account that you plead for those idle retainers about +noblemen: this being a maxim of those pretended statesmen, that it is +necessary for the public safety to have a good body of veteran soldiers +ever in readiness. They think raw men are not to be depended on, and +they sometimes seek occasions for making war, that they may train up +their soldiers in the art of cutting throats, or, as Sallust observed, +"for keeping their hands in use, that they may not grow dull by too long +an intermission." But France has learned to its cost how dangerous it is +to feed such beasts. The fate of the Romans, Carthaginians, and Syrians, +and many other nations and cities, which were both overturned and quite +ruined by those standing armies, should make others wiser; and the folly +of this maxim of the French appears plainly even from this, that their +trained soldiers often find your raw men prove too hard for them, of +which I will not say much, lest you may think I flatter the English. +Every day's experience shows that the mechanics in the towns or the +clowns in the country are not afraid of fighting with those idle +gentlemen, if they are not disabled by some misfortune in their body or +dispirited by extreme want; so that you need not fear that those well- +shaped and strong men (for it is only such that noblemen love to keep +about them till they spoil them), who now grow feeble with ease and are +softened with their effeminate manner of life, would be less fit for +action if they were well bred and well employed. And it seems very +unreasonable that, for the prospect of a war, which you need never have +but when you please, you should maintain so many idle men, as will always +disturb you in time of peace, which is ever to be more considered than +war. But I do not think that this necessity of stealing arises only from +hence; there is another cause of it, more peculiar to England.' 'What is +that?' said the Cardinal: 'The increase of pasture,' said I, 'by which +your sheep, which are naturally mild, and easily kept in order, may be +said now to devour men and unpeople, not only villages, but towns; for +wherever it is found that the sheep of any soil yield a softer and richer +wool than ordinary, there the nobility and gentry, and even those holy +men, the dobots! not contented with the old rents which their farms +yielded, nor thinking it enough that they, living at their ease, do no +good to the public, resolve to do it hurt instead of good. They stop the +course of agriculture, destroying houses and towns, reserving only the +churches, and enclose grounds that they may lodge their sheep in them. As +if forests and parks had swallowed up too little of the land, those +worthy countrymen turn the best inhabited places into solitudes; for when +an insatiable wretch, who is a plague to his country, resolves to enclose +many thousand acres of ground, the owners, as well as tenants, are turned +out of their possessions by trick or by main force, or, being wearied out +by ill usage, they are forced to sell them; by which means those +miserable people, both men and women, married and unmarried, old and +young, with their poor but numerous families (since country business +requires many hands), are all forced to change their seats, not knowing +whither to go; and they must sell, almost for nothing, their household +stuff, which could not bring them much money, even though they might stay +for a buyer. When that little money is at an end (for it will be soon +spent), what is left for them to do but either to steal, and so to be +hanged (God knows how justly!), or to go about and beg? and if they do +this they are put in prison as idle vagabonds, while they would willingly +work but can find none that will hire them; for there is no more occasion +for country labour, to which they have been bred, when there is no arable +ground left. One shepherd can look after a flock, which will stock an +extent of ground that would require many hands if it were to be ploughed +and reaped. This, likewise, in many places raises the price of corn. The +price of wool is also so risen that the poor people, who were wont to +make cloth, are no more able to buy it; and this, likewise, makes many of +them idle: for since the increase of pasture God has punished the avarice +of the owners by a rot among the sheep, which has destroyed vast numbers +of them--to us it might have seemed more just had it fell on the owners +themselves. But, suppose the sheep should increase ever so much, their +price is not likely to fall; since, though they cannot be called a +monopoly, because they are not engrossed by one person, yet they are in +so few hands, and these are so rich, that, as they are not pressed to +sell them sooner than they have a mind to it, so they never do it till +they have raised the price as high as possible. And on the same account +it is that the other kinds of cattle are so dear, because many villages +being pulled down, and all country labour being much neglected, there are +none who make it their business to breed them. The rich do not breed +cattle as they do sheep, but buy them lean and at low prices; and, after +they have fattened them on their grounds, sell them again at high rates. +And I do not think that all the inconveniences this will produce are yet +observed; for, as they sell the cattle dear, so, if they are consumed +faster than the breeding countries from which they are brought can afford +them, then the stock must decrease, and this must needs end in great +scarcity; and by these means, this your island, which seemed as to this +particular the happiest in the world, will suffer much by the cursed +avarice of a few persons: besides this, the rising of corn makes all +people lessen their families as much as they can; and what can those who +are dismissed by them do but either beg or rob? And to this last a man +of a great mind is much sooner drawn than to the former. Luxury likewise +breaks in apace upon you to set forward your poverty and misery; there is +an excessive vanity in apparel, and great cost in diet, and that not only +in noblemen's families, but even among tradesmen, among the farmers +themselves, and among all ranks of persons. You have also many infamous +houses, and, besides those that are known, the taverns and ale-houses are +no better; add to these dice, cards, tables, football, tennis, and +quoits, in which money runs fast away; and those that are initiated into +them must, in the conclusion, betake themselves to robbing for a supply. +Banish these plagues, and give orders that those who have dispeopled so +much soil may either rebuild the villages they have pulled down or let +out their grounds to such as will do it; restrain those engrossings of +the rich, that are as bad almost as monopolies; leave fewer occasions to +idleness; let agriculture be set up again, and the manufacture of the +wool be regulated, that so there may be work found for those companies of +idle people whom want forces to be thieves, or who now, being idle +vagabonds or useless servants, will certainly grow thieves at last. If +you do not find a remedy to these evils it is a vain thing to boast of +your severity in punishing theft, which, though it may have the +appearance of justice, yet in itself is neither just nor convenient; for +if you suffer your people to be ill-educated, and their manners to be +corrupted from their infancy, and then punish them for those crimes to +which their first education disposed them, what else is to be concluded +from this but that you first make thieves and then punish them?' + +"While I was talking thus, the Counsellor, who was present, had prepared +an answer, and had resolved to resume all I had said, according to the +formality of a debate, in which things are generally repeated more +faithfully than they are answered, as if the chief trial to be made were +of men's memories. 'You have talked prettily, for a stranger,' said he, +'having heard of many things among us which you have not been able to +consider well; but I will make the whole matter plain to you, and will +first repeat in order all that you have said; then I will show how much +your ignorance of our affairs has misled you; and will, in the last +place, answer all your arguments. And, that I may begin where I +promised, there were four things--' 'Hold your peace!' said the +Cardinal; 'this will take up too much time; therefore we will, at +present, ease you of the trouble of answering, and reserve it to our next +meeting, which shall be to-morrow, if Raphael's affairs and yours can +admit of it. But, Raphael,' said he to me, 'I would gladly know upon +what reason it is that you think theft ought not to be punished by death: +would you give way to it? or do you propose any other punishment that +will be more useful to the public? for, since death does not restrain +theft, if men thought their lives would be safe, what fear or force could +restrain ill men? On the contrary, they would look on the mitigation of +the punishment as an invitation to commit more crimes.' I answered, 'It +seems to me a very unjust thing to take away a man's life for a little +money, for nothing in the world can be of equal value with a man's life: +and if it be said, "that it is not for the money that one suffers, but +for his breaking the law," I must say, extreme justice is an extreme +injury: for we ought not to approve of those terrible laws that make the +smallest offences capital, nor of that opinion of the Stoics that makes +all crimes equal; as if there were no difference to be made between the +killing a man and the taking his purse, between which, if we examine +things impartially, there is no likeness nor proportion. God has +commanded us not to kill, and shall we kill so easily for a little money? +But if one shall say, that by that law we are only forbid to kill any +except when the laws of the land allow of it, upon the same grounds, laws +may be made, in some cases, to allow of adultery and perjury: for God +having taken from us the right of disposing either of our own or of other +people's lives, if it is pretended that the mutual consent of men in +making laws can authorise man-slaughter in cases in which God has given +us no example, that it frees people from the obligation of the divine +law, and so makes murder a lawful action, what is this, but to give a +preference to human laws before the divine? and, if this is once +admitted, by the same rule men may, in all other things, put what +restrictions they please upon the laws of God. If, by the Mosaical law, +though it was rough and severe, as being a yoke laid on an obstinate and +servile nation, men were only fined, and not put to death for theft, we +cannot imagine, that in this new law of mercy, in which God treats us +with the tenderness of a father, He has given us a greater licence to +cruelty than He did to the Jews. Upon these reasons it is, that I think +putting thieves to death is not lawful; and it is plain and obvious that +it is absurd and of ill consequence to the commonwealth that a thief and +a murderer should be equally punished; for if a robber sees that his +danger is the same if he is convicted of theft as if he were guilty of +murder, this will naturally incite him to kill the person whom otherwise +he would only have robbed; since, if the punishment is the same, there is +more security, and less danger of discovery, when he that can best make +it is put out of the way; so that terrifying thieves too much provokes +them to cruelty. + +"But as to the question, 'What more convenient way of punishment can be +found?' I think it much easier to find out that than to invent anything +that is worse; why should we doubt but the way that was so long in use +among the old Romans, who understood so well the arts of government, was +very proper for their punishment? They condemned such as they found +guilty of great crimes to work their whole lives in quarries, or to dig +in mines with chains about them. But the method that I liked best was +that which I observed in my travels in Persia, among the Polylerits, who +are a considerable and well-governed people: they pay a yearly tribute to +the King of Persia, but in all other respects they are a free nation, and +governed by their own laws: they lie far from the sea, and are environed +with hills; and, being contented with the productions of their own +country, which is very fruitful, they have little commerce with any other +nation; and as they, according to the genius of their country, have no +inclination to enlarge their borders, so their mountains and the pension +they pay to the Persian, secure them from all invasions. Thus they have +no wars among them; they live rather conveniently than with splendour, +and may be rather called a happy nation than either eminent or famous; +for I do not think that they are known, so much as by name, to any but +their next neighbours. Those that are found guilty of theft among them +are bound to make restitution to the owner, and not, as it is in other +places, to the prince, for they reckon that the prince has no more right +to the stolen goods than the thief; but if that which was stolen is no +more in being, then the goods of the thieves are estimated, and +restitution being made out of them, the remainder is given to their wives +and children; and they themselves are condemned to serve in the public +works, but are neither imprisoned nor chained, unless there happens to be +some extraordinary circumstance in their crimes. They go about loose and +free, working for the public: if they are idle or backward to work they +are whipped, but if they work hard they are well used and treated without +any mark of reproach; only the lists of them are called always at night, +and then they are shut up. They suffer no other uneasiness but this of +constant labour; for, as they work for the public, so they are well +entertained out of the public stock, which is done differently in +different places: in some places whatever is bestowed on them is raised +by a charitable contribution; and, though this way may seem uncertain, +yet so merciful are the inclinations of that people, that they are +plentifully supplied by it; but in other places public revenues are set +aside for them, or there is a constant tax or poll-money raised for their +maintenance. In some places they are set to no public work, but every +private man that has occasion to hire workmen goes to the market-places +and hires them of the public, a little lower than he would do a freeman. +If they go lazily about their task he may quicken them with the whip. By +this means there is always some piece of work or other to be done by +them; and, besides their livelihood, they earn somewhat still to the +public. They all wear a peculiar habit, of one certain colour, and their +hair is cropped a little above their ears, and a piece of one of their +ears is cut off. Their friends are allowed to give them either meat, +drink, or clothes, so they are of their proper colour; but it is death, +both to the giver and taker, if they give them money; nor is it less +penal for any freeman to take money from them upon any account +whatsoever: and it is also death for any of these slaves (so they are +called) to handle arms. Those of every division of the country are +distinguished by a peculiar mark, which it is capital for them to lay +aside, to go out of their bounds, or to talk with a slave of another +jurisdiction, and the very attempt of an escape is no less penal than an +escape itself. It is death for any other slave to be accessory to it; +and if a freeman engages in it he is condemned to slavery. Those that +discover it are rewarded--if freemen, in money; and if slaves, with +liberty, together with a pardon for being accessory to it; that so they +might find their account rather in repenting of their engaging in such a +design than in persisting in it. + +"These are their laws and rules in relation to robbery, and it is obvious +that they are as advantageous as they are mild and gentle; since vice is +not only destroyed and men preserved, but they are treated in such a +manner as to make them see the necessity of being honest and of employing +the rest of their lives in repairing the injuries they had formerly done +to society. Nor is there any hazard of their falling back to their old +customs; and so little do travellers apprehend mischief from them that +they generally make use of them for guides from one jurisdiction to +another; for there is nothing left them by which they can rob or be the +better for it, since, as they are disarmed, so the very having of money +is a sufficient conviction: and as they are certainly punished if +discovered, so they cannot hope to escape; for their habit being in all +the parts of it different from what is commonly worn, they cannot fly +away, unless they would go naked, and even then their cropped ear would +betray them. The only danger to be feared from them is their conspiring +against the government; but those of one division and neighbourhood can +do nothing to any purpose unless a general conspiracy were laid amongst +all the slaves of the several jurisdictions, which cannot be done, since +they cannot meet or talk together; nor will any venture on a design where +the concealment would be so dangerous and the discovery so profitable. +None are quite hopeless of recovering their freedom, since by their +obedience and patience, and by giving good grounds to believe that they +will change their manner of life for the future, they may expect at last +to obtain their liberty, and some are every year restored to it upon the +good character that is given of them. When I had related all this, I +added that I did not see why such a method might not be followed with +more advantage than could ever be expected from that severe justice which +the Counsellor magnified so much. To this he answered, 'That it could +never take place in England without endangering the whole nation.' As he +said this he shook his head, made some grimaces, and held his peace, +while all the company seemed of his opinion, except the Cardinal, who +said, 'That it was not easy to form a judgment of its success, since it +was a method that never yet had been tried; but if,' said he, 'when +sentence of death were passed upon a thief, the prince would reprieve him +for a while, and make the experiment upon him, denying him the privilege +of a sanctuary; and then, if it had a good effect upon him, it might take +place; and, if it did not succeed, the worst would be to execute the +sentence on the condemned persons at last; and I do not see,' added he, +'why it would be either unjust, inconvenient, or at all dangerous to +admit of such a delay; in my opinion the vagabonds ought to be treated in +the same manner, against whom, though we have made many laws, yet we have +not been able to gain our end.' When the Cardinal had done, they all +commended the motion, though they had despised it when it came from me, +but more particularly commended what related to the vagabonds, because it +was his own observation. + +"I do not know whether it be worth while to tell what followed, for it +was very ridiculous; but I shall venture at it, for as it is not foreign +to this matter, so some good use may be made of it. There was a Jester +standing by, that counterfeited the fool so naturally that he seemed to +be really one; the jests which he offered were so cold and dull that we +laughed more at him than at them, yet sometimes he said, as it were by +chance, things that were not unpleasant, so as to justify the old +proverb, 'That he who throws the dice often, will sometimes have a lucky +hit.' When one of the company had said that I had taken care of the +thieves, and the Cardinal had taken care of the vagabonds, so that there +remained nothing but that some public provision might be made for the +poor whom sickness or old age had disabled from labour, 'Leave that to +me,' said the Fool, 'and I shall take care of them, for there is no sort +of people whose sight I abhor more, having been so often vexed with them +and with their sad complaints; but as dolefully soever as they have told +their tale, they could never prevail so far as to draw one penny from me; +for either I had no mind to give them anything, or, when I had a mind to +do it, I had nothing to give them; and they now know me so well that they +will not lose their labour, but let me pass without giving me any +trouble, because they hope for nothing--no more, in faith, than if I were +a priest; but I would have a law made for sending all these beggars to +monasteries, the men to the Benedictines, to be made lay-brothers, and +the women to be nuns.' The Cardinal smiled, and approved of it in jest, +but the rest liked it in earnest. There was a divine present, who, +though he was a grave morose man, yet he was so pleased with this +reflection that was made on the priests and the monks that he began to +play with the Fool, and said to him, 'This will not deliver you from all +beggars, except you take care of us Friars.' 'That is done already,' +answered the Fool, 'for the Cardinal has provided for you by what he +proposed for restraining vagabonds and setting them to work, for I know +no vagabonds like you.' This was well entertained by the whole company, +who, looking at the Cardinal, perceived that he was not ill-pleased at +it; only the Friar himself was vexed, as may be easily imagined, and fell +into such a passion that he could not forbear railing at the Fool, and +calling him knave, slanderer, backbiter, and son of perdition, and then +cited some dreadful threatenings out of the Scriptures against him. Now +the Jester thought he was in his element, and laid about him freely. +'Good Friar,' said he, 'be not angry, for it is written, "In patience +possess your soul."' The Friar answered (for I shall give you his own +words), 'I am not angry, you hangman; at least, I do not sin in it, for +the Psalmist says, "Be ye angry and sin not."' Upon this the Cardinal +admonished him gently, and wished him to govern his passions. 'No, my +lord,' said he, 'I speak not but from a good zeal, which I ought to have, +for holy men have had a good zeal, as it is said, "The zeal of thy house +hath eaten me up;" and we sing in our church that those who mocked Elisha +as he went up to the house of God felt the effects of his zeal, which +that mocker, that rogue, that scoundrel, will perhaps feel.' 'You do +this, perhaps, with a good intention,' said the Cardinal, 'but, in my +opinion, it were wiser in you, and perhaps better for you, not to engage +in so ridiculous a contest with a Fool.' 'No, my lord,' answered he, +'that were not wisely done, for Solomon, the wisest of men, said, "Answer +a Fool according to his folly," which I now do, and show him the ditch +into which he will fall, if he is not aware of it; for if the many +mockers of Elisha, who was but one bald man, felt the effect of his zeal, +what will become of the mocker of so many Friars, among whom there are so +many bald men? We have, likewise, a bull, by which all that jeer us are +excommunicated.' When the Cardinal saw that there was no end of this +matter he made a sign to the Fool to withdraw, turned the discourse +another way, and soon after rose from the table, and, dismissing us, went +to hear causes. + +"Thus, Mr. More, I have run out into a tedious story, of the length of +which I had been ashamed, if (as you earnestly begged it of me) I had not +observed you to hearken to it as if you had no mind to lose any part of +it. I might have contracted it, but I resolved to give it you at large, +that you might observe how those that despised what I had proposed, no +sooner perceived that the Cardinal did not dislike it but presently +approved of it, fawned so on him and flattered him to such a degree, that +they in good earnest applauded those things that he only liked in jest; +and from hence you may gather how little courtiers would value either me +or my counsels." + +To this I answered, "You have done me a great kindness in this relation; +for as everything has been related by you both wisely and pleasantly, so +you have made me imagine that I was in my own country and grown young +again, by recalling that good Cardinal to my thoughts, in whose family I +was bred from my childhood; and though you are, upon other accounts, very +dear to me, yet you are the dearer because you honour his memory so much; +but, after all this, I cannot change my opinion, for I still think that +if you could overcome that aversion which you have to the courts of +princes, you might, by the advice which it is in your power to give, do a +great deal of good to mankind, and this is the chief design that every +good man ought to propose to himself in living; for your friend Plato +thinks that nations will be happy when either philosophers become kings +or kings become philosophers. It is no wonder if we are so far from that +happiness while philosophers will not think it their duty to assist kings +with their counsels." "They are not so base-minded," said he, "but that +they would willingly do it; many of them have already done it by their +books, if those that are in power would but hearken to their good advice. +But Plato judged right, that except kings themselves became philosophers, +they who from their childhood are corrupted with false notions would +never fall in entirely with the counsels of philosophers, and this he +himself found to be true in the person of Dionysius. + +"Do not you think that if I were about any king, proposing good laws to +him, and endeavouring to root out all the cursed seeds of evil that I +found in him, I should either be turned out of his court, or, at least, +be laughed at for my pains? For instance, what could I signify if I were +about the King of France, and were called into his cabinet council, where +several wise men, in his hearing, were proposing many expedients; as, by +what arts and practices Milan may be kept, and Naples, that has so often +slipped out of their hands, recovered; how the Venetians, and after them +the rest of Italy, may be subdued; and then how Flanders, Brabant, and +all Burgundy, and some other kingdoms which he has swallowed already in +his designs, may be added to his empire? One proposes a league with the +Venetians, to be kept as long as he finds his account in it, and that he +ought to communicate counsels with them, and give them some share of the +spoil till his success makes him need or fear them less, and then it will +be easily taken out of their hands; another proposes the hiring the +Germans and the securing the Switzers by pensions; another proposes the +gaining the Emperor by money, which is omnipotent with him; another +proposes a peace with the King of Arragon, and, in order to cement it, +the yielding up the King of Navarre's pretensions; another thinks that +the Prince of Castile is to be wrought on by the hope of an alliance, and +that some of his courtiers are to be gained to the French faction by +pensions. The hardest point of all is, what to do with England; a treaty +of peace is to be set on foot, and, if their alliance is not to be +depended on, yet it is to be made as firm as possible, and they are to be +called friends, but suspected as enemies: therefore the Scots are to be +kept in readiness to be let loose upon England on every occasion; and +some banished nobleman is to be supported underhand (for by the League it +cannot be done avowedly) who has a pretension to the crown, by which +means that suspected prince may be kept in awe. Now when things are in +so great a fermentation, and so many gallant men are joining counsels how +to carry on the war, if so mean a man as I should stand up and wish them +to change all their counsels--to let Italy alone and stay at home, since +the kingdom of France was indeed greater than could be well governed by +one man; that therefore he ought not to think of adding others to it; and +if, after this, I should propose to them the resolutions of the +Achorians, a people that lie on the south-east of Utopia, who long ago +engaged in war in order to add to the dominions of their prince another +kingdom, to which he had some pretensions by an ancient alliance: this +they conquered, but found that the trouble of keeping it was equal to +that by which it was gained; that the conquered people were always either +in rebellion or exposed to foreign invasions, while they were obliged to +be incessantly at war, either for or against them, and consequently could +never disband their army; that in the meantime they were oppressed with +taxes, their money went out of the kingdom, their blood was spilt for the +glory of their king without procuring the least advantage to the people, +who received not the smallest benefit from it even in time of peace; and +that, their manners being corrupted by a long war, robbery and murders +everywhere abounded, and their laws fell into contempt; while their king, +distracted with the care of two kingdoms, was the less able to apply his +mind to the interest of either. When they saw this, and that there would +be no end to these evils, they by joint counsels made an humble address +to their king, desiring him to choose which of the two kingdoms he had +the greatest mind to keep, since he could not hold both; for they were +too great a people to be governed by a divided king, since no man would +willingly have a groom that should be in common between him and another. +Upon which the good prince was forced to quit his new kingdom to one of +his friends (who was not long after dethroned), and to be contented with +his old one. To this I would add that after all those warlike attempts, +the vast confusions, and the consumption both of treasure and of people +that must follow them, perhaps upon some misfortune they might be forced +to throw up all at last; therefore it seemed much more eligible that the +king should improve his ancient kingdom all he could, and make it +flourish as much as possible; that he should love his people, and be +beloved of them; that he should live among them, govern them gently and +let other kingdoms alone, since that which had fallen to his share was +big enough, if not too big, for him:--pray, how do you think would such a +speech as this be heard?" + +"I confess," said I, "I think not very well." + +"But what," said he, "if I should sort with another kind of ministers, +whose chief contrivances and consultations were by what art the prince's +treasures might be increased? where one proposes raising the value of +specie when the king's debts are large, and lowering it when his revenues +were to come in, that so he might both pay much with a little, and in a +little receive a great deal. Another proposes a pretence of a war, that +money might be raised in order to carry it on, and that a peace be +concluded as soon as that was done; and this with such appearances of +religion as might work on the people, and make them impute it to the +piety of their prince, and to his tenderness for the lives of his +subjects. A third offers some old musty laws that have been antiquated +by a long disuse (and which, as they had been forgotten by all the +subjects, so they had also been broken by them), and proposes the levying +the penalties of these laws, that, as it would bring in a vast treasure, +so there might be a very good pretence for it, since it would look like +the executing a law and the doing of justice. A fourth proposes the +prohibiting of many things under severe penalties, especially such as +were against the interest of the people, and then the dispensing with +these prohibitions, upon great compositions, to those who might find +their advantage in breaking them. This would serve two ends, both of +them acceptable to many; for as those whose avarice led them to +transgress would be severely fined, so the selling licences dear would +look as if a prince were tender of his people, and would not easily, or +at low rates, dispense with anything that might be against the public +good. Another proposes that the judges must be made sure, that they may +declare always in favour of the prerogative; that they must be often sent +for to court, that the king may hear them argue those points in which he +is concerned; since, how unjust soever any of his pretensions may be, yet +still some one or other of them, either out of contradiction to others, +or the pride of singularity, or to make their court, would find out some +pretence or other to give the king a fair colour to carry the point. For +if the judges but differ in opinion, the clearest thing in the world is +made by that means disputable, and truth being once brought in question, +the king may then take advantage to expound the law for his own profit; +while the judges that stand out will be brought over, either through fear +or modesty; and they being thus gained, all of them may be sent to the +Bench to give sentence boldly as the king would have it; for fair +pretences will never be wanting when sentence is to be given in the +prince's favour. It will either be said that equity lies of his side, or +some words in the law will be found sounding that way, or some forced +sense will be put on them; and, when all other things fail, the king's +undoubted prerogative will be pretended, as that which is above all law, +and to which a religious judge ought to have a special regard. Thus all +consent to that maxim of Crassus, that a prince cannot have treasure +enough, since he must maintain his armies out of it; that a king, even +though he would, can do nothing unjustly; that all property is in him, +not excepting the very persons of his subjects; and that no man has any +other property but that which the king, out of his goodness, thinks fit +to leave him. And they think it is the prince's interest that there be +as little of this left as may be, as if it were his advantage that his +people should have neither riches nor liberty, since these things make +them less easy and willing to submit to a cruel and unjust government. +Whereas necessity and poverty blunts them, makes them patient, beats them +down, and breaks that height of spirit that might otherwise dispose them +to rebel. Now what if, after all these propositions were made, I should +rise up and assert that such counsels were both unbecoming a king and +mischievous to him; and that not only his honour, but his safety, +consisted more in his people's wealth than in his own; if I should show +that they choose a king for their own sake, and not for his; that, by his +care and endeavours, they may be both easy and safe; and that, therefore, +a prince ought to take more care of his people's happiness than of his +own, as a shepherd is to take more care of his flock than of himself? It +is also certain that they are much mistaken that think the poverty of a +nation is a mean of the public safety. Who quarrel more than beggars? +who does more earnestly long for a change than he that is uneasy in his +present circumstances? and who run to create confusions with so desperate +a boldness as those who, having nothing to lose, hope to gain by them? If +a king should fall under such contempt or envy that he could not keep his +subjects in their duty but by oppression and ill usage, and by rendering +them poor and miserable, it were certainly better for him to quit his +kingdom than to retain it by such methods as make him, while he keeps the +name of authority, lose the majesty due to it. Nor is it so becoming the +dignity of a king to reign over beggars as over rich and happy subjects. +And therefore Fabricius, a man of a noble and exalted temper, said 'he +would rather govern rich men than be rich himself; since for one man to +abound in wealth and pleasure when all about him are mourning and +groaning, is to be a gaoler and not a king.' He is an unskilful +physician that cannot cure one disease without casting his patient into +another. So he that can find no other way for correcting the errors of +his people but by taking from them the conveniences of life, shows that +he knows not what it is to govern a free nation. He himself ought rather +to shake off his sloth, or to lay down his pride, for the contempt or +hatred that his people have for him takes its rise from the vices in +himself. Let him live upon what belongs to him without wronging others, +and accommodate his expense to his revenue. Let him punish crimes, and, +by his wise conduct, let him endeavour to prevent them, rather than be +severe when he has suffered them to be too common. Let him not rashly +revive laws that are abrogated by disuse, especially if they have been +long forgotten and never wanted. And let him never take any penalty for +the breach of them to which a judge would not give way in a private man, +but would look on him as a crafty and unjust person for pretending to it. +To these things I would add that law among the Macarians--a people that +live not far from Utopia--by which their king, on the day on which he +began to reign, is tied by an oath, confirmed by solemn sacrifices, never +to have at once above a thousand pounds of gold in his treasures, or so +much silver as is equal to that in value. This law, they tell us, was +made by an excellent king who had more regard to the riches of his +country than to his own wealth, and therefore provided against the +heaping up of so much treasure as might impoverish the people. He +thought that moderate sum might be sufficient for any accident, if either +the king had occasion for it against the rebels, or the kingdom against +the invasion of an enemy; but that it was not enough to encourage a +prince to invade other men's rights--a circumstance that was the chief +cause of his making that law. He also thought that it was a good +provision for that free circulation of money so necessary for the course +of commerce and exchange. And when a king must distribute all those +extraordinary accessions that increase treasure beyond the due pitch, it +makes him less disposed to oppress his subjects. Such a king as this +will be the terror of ill men, and will be beloved by all the good. + +"If, I say, I should talk of these or such-like things to men that had +taken their bias another way, how deaf would they be to all I could say!" +"No doubt, very deaf," answered I; "and no wonder, for one is never to +offer propositions or advice that we are certain will not be entertained. +Discourses so much out of the road could not avail anything, nor have any +effect on men whose minds were prepossessed with different sentiments. +This philosophical way of speculation is not unpleasant among friends in +a free conversation; but there is no room for it in the courts of +princes, where great affairs are carried on by authority." "That is what +I was saying," replied he, "that there is no room for philosophy in the +courts of princes." "Yes, there is," said I, "but not for this +speculative philosophy, that makes everything to be alike fitting at all +times; but there is another philosophy that is more pliable, that knows +its proper scene, accommodates itself to it, and teaches a man with +propriety and decency to act that part which has fallen to his share. If +when one of Plautus' comedies is upon the stage, and a company of +servants are acting their parts, you should come out in the garb of a +philosopher, and repeat, out of _Octavia_, a discourse of Seneca's to +Nero, would it not be better for you to say nothing than by mixing things +of such different natures to make an impertinent tragi-comedy? for you +spoil and corrupt the play that is in hand when you mix with it things of +an opposite nature, even though they are much better. Therefore go +through with the play that is acting the best you can, and do not +confound it because another that is pleasanter comes into your thoughts. +It is even so in a commonwealth and in the councils of princes; if ill +opinions cannot be quite rooted out, and you cannot cure some received +vice according to your wishes, you must not, therefore, abandon the +commonwealth, for the same reasons as you should not forsake the ship in +a storm because you cannot command the winds. You are not obliged to +assault people with discourses that are out of their road, when you see +that their received notions must prevent your making an impression upon +them: you ought rather to cast about and to manage things with all the +dexterity in your power, so that, if you are not able to make them go +well, they may be as little ill as possible; for, except all men were +good, everything cannot be right, and that is a blessing that I do not at +present hope to see." "According to your argument," answered he, "all +that I could be able to do would be to preserve myself from being mad +while I endeavoured to cure the madness of others; for, if I speak with, +I must repeat what I have said to you; and as for lying, whether a +philosopher can do it or not I cannot tell: I am sure I cannot do it. But +though these discourses may be uneasy and ungrateful to them, I do not +see why they should seem foolish or extravagant; indeed, if I should +either propose such things as Plato has contrived in his 'Commonwealth,' +or as the Utopians practise in theirs, though they might seem better, as +certainly they are, yet they are so different from our establishment, +which is founded on property (there being no such thing among them), that +I could not expect that it would have any effect on them. But such +discourses as mine, which only call past evils to mind and give warning +of what may follow, leave nothing in them that is so absurd that they may +not be used at any time, for they can only be unpleasant to those who are +resolved to run headlong the contrary way; and if we must let alone +everything as absurd or extravagant--which, by reason of the wicked lives +of many, may seem uncouth--we must, even among Christians, give over +pressing the greatest part of those things that Christ hath taught us, +though He has commanded us not to conceal them, but to proclaim on the +housetops that which He taught in secret. The greatest parts of His +precepts are more opposite to the lives of the men of this age than any +part of my discourse has been, but the preachers seem to have learned +that craft to which you advise me: for they, observing that the world +would not willingly suit their lives to the rules that Christ has given, +have fitted His doctrine, as if it had been a leaden rule, to their +lives, that so, some way or other, they might agree with one another. But +I see no other effect of this compliance except it be that men become +more secure in their wickedness by it; and this is all the success that I +can have in a court, for I must always differ from the rest, and then I +shall signify nothing; or, if I agree with them, I shall then only help +forward their madness. I do not comprehend what you mean by your +'casting about,' or by 'the bending and handling things so dexterously +that, if they go not well, they may go as little ill as may be;' for in +courts they will not bear with a man's holding his peace or conniving at +what others do: a man must barefacedly approve of the worst counsels and +consent to the blackest designs, so that he would pass for a spy, or, +possibly, for a traitor, that did but coldly approve of such wicked +practices; and therefore when a man is engaged in such a society, he will +be so far from being able to mend matters by his 'casting about,' as you +call it, that he will find no occasions of doing any good--the ill +company will sooner corrupt him than be the better for him; or if, +notwithstanding all their ill company, he still remains steady and +innocent, yet their follies and knavery will be imputed to him; and, by +mixing counsels with them, he must bear his share of all the blame that +belongs wholly to others. + +"It was no ill simile by which Plato set forth the unreasonableness of a +philosopher's meddling with government. 'If a man,' says he, 'were to +see a great company run out every day into the rain and take delight in +being wet--if he knew that it would be to no purpose for him to go and +persuade them to return to their houses in order to avoid the storm, and +that all that could be expected by his going to speak to them would be +that he himself should be as wet as they, it would be best for him to +keep within doors, and, since he had not influence enough to correct +other people's folly, to take care to preserve himself.' + +"Though, to speak plainly my real sentiments, I must freely own that as +long as there is any property, and while money is the standard of all +other things, I cannot think that a nation can be governed either justly +or happily: not justly, because the best things will fall to the share of +the worst men; nor happily, because all things will be divided among a +few (and even these are not in all respects happy), the rest being left +to be absolutely miserable. Therefore, when I reflect on the wise and +good constitution of the Utopians, among whom all things are so well +governed and with so few laws, where virtue hath its due reward, and yet +there is such an equality that every man lives in plenty--when I compare +with them so many other nations that are still making new laws, and yet +can never bring their constitution to a right regulation; where, +notwithstanding every one has his property, yet all the laws that they +can invent have not the power either to obtain or preserve it, or even to +enable men certainly to distinguish what is their own from what is +another's, of which the many lawsuits that every day break out, and are +eternally depending, give too plain a demonstration--when, I say, I +balance all these things in my thoughts, I grow more favourable to Plato, +and do not wonder that he resolved not to make any laws for such as would +not submit to a community of all things; for so wise a man could not but +foresee that the setting all upon a level was the only way to make a +nation happy; which cannot be obtained so long as there is property, for +when every man draws to himself all that he can compass, by one title or +another, it must needs follow that, how plentiful soever a nation may be, +yet a few dividing the wealth of it among themselves, the rest must fall +into indigence. So that there will be two sorts of people among them, +who deserve that their fortunes should be interchanged--the former +useless, but wicked and ravenous; and the latter, who by their constant +industry serve the public more than themselves, sincere and modest +men--from whence I am persuaded that till property is taken away, there +can be no equitable or just distribution of things, nor can the world be +happily governed; for as long as that is maintained, the greatest and the +far best part of mankind, will be still oppressed with a load of cares +and anxieties. I confess, without taking it quite away, those pressures +that lie on a great part of mankind may be made lighter, but they can +never be quite removed; for if laws were made to determine at how great +an extent in soil, and at how much money, every man must stop--to limit +the prince, that he might not grow too great; and to restrain the people, +that they might not become too insolent--and that none might factiously +aspire to public employments, which ought neither to be sold nor made +burdensome by a great expense, since otherwise those that serve in them +would be tempted to reimburse themselves by cheats and violence, and it +would become necessary to find out rich men for undergoing those +employments, which ought rather to be trusted to the wise. These laws, I +say, might have such effect as good diet and care might have on a sick +man whose recovery is desperate; they might allay and mitigate the +disease, but it could never be quite healed, nor the body politic be +brought again to a good habit as long as property remains; and it will +fall out, as in a complication of diseases, that by applying a remedy to +one sore you will provoke another, and that which removes the one ill +symptom produces others, while the strengthening one part of the body +weakens the rest." "On the contrary," answered I, "it seems to me that +men cannot live conveniently where all things are common. How can there +be any plenty where every man will excuse himself from labour? for as the +hope of gain doth not excite him, so the confidence that he has in other +men's industry may make him slothful. If people come to be pinched with +want, and yet cannot dispose of anything as their own, what can follow +upon this but perpetual sedition and bloodshed, especially when the +reverence and authority due to magistrates falls to the ground? for I +cannot imagine how that can be kept up among those that are in all things +equal to one another." "I do not wonder," said he, "that it appears so +to you, since you have no notion, or at least no right one, of such a +constitution; but if you had been in Utopia with me, and had seen their +laws and rules, as I did, for the space of five years, in which I lived +among them, and during which time I was so delighted with them that +indeed I should never have left them if it had not been to make the +discovery of that new world to the Europeans, you would then confess that +you had never seen a people so well constituted as they." "You will not +easily persuade me," said Peter, "that any nation in that new world is +better governed than those among us; for as our understandings are not +worse than theirs, so our government (if I mistake not) being more +ancient, a long practice has helped us to find out many conveniences of +life, and some happy chances have discovered other things to us which no +man's understanding could ever have invented." "As for the antiquity +either of their government or of ours," said he, "you cannot pass a true +judgment of it unless you had read their histories; for, if they are to +be believed, they had towns among them before these parts were so much as +inhabited; and as for those discoveries that have been either hit on by +chance or made by ingenious men, these might have happened there as well +as here. I do not deny but we are more ingenious than they are, but they +exceed us much in industry and application. They knew little concerning +us before our arrival among them. They call us all by a general name of +'The nations that lie beyond the equinoctial line;' for their chronicle +mentions a shipwreck that was made on their coast twelve hundred years +ago, and that some Romans and Egyptians that were in the ship, getting +safe ashore, spent the rest of their days amongst them; and such was +their ingenuity that from this single opportunity they drew the advantage +of learning from those unlooked-for guests, and acquired all the useful +arts that were then among the Romans, and which were known to these +shipwrecked men; and by the hints that they gave them they themselves +found out even some of those arts which they could not fully explain, so +happily did they improve that accident of having some of our people cast +upon their shore. But if such an accident has at any time brought any +from thence into Europe, we have been so far from improving it that we do +not so much as remember it, as, in aftertimes perhaps, it will be forgot +by our people that I was ever there; for though they, from one such +accident, made themselves masters of all the good inventions that were +among us, yet I believe it would be long before we should learn or put in +practice any of the good institutions that are among them. And this is +the true cause of their being better governed and living happier than we, +though we come not short of them in point of understanding or outward +advantages." Upon this I said to him, "I earnestly beg you would +describe that island very particularly to us; be not too short, but set +out in order all things relating to their soil, their rivers, their +towns, their people, their manners, constitution, laws, and, in a word, +all that you imagine we desire to know; and you may well imagine that we +desire to know everything concerning them of which we are hitherto +ignorant." "I will do it very willingly," said he, "for I have digested +the whole matter carefully, but it will take up some time." "Let us go, +then," said I, "first and dine, and then we shall have leisure enough." +He consented; we went in and dined, and after dinner came back and sat +down in the same place. I ordered my servants to take care that none +might come and interrupt us, and both Peter and I desired Raphael to be +as good as his word. When he saw that we were very intent upon it he +paused a little to recollect himself, and began in this manner:-- + +"The island of Utopia is in the middle two hundred miles broad, and holds +almost at the same breadth over a great part of it, but it grows narrower +towards both ends. Its figure is not unlike a crescent. Between its +horns the sea comes in eleven miles broad, and spreads itself into a +great bay, which is environed with land to the compass of about five +hundred miles, and is well secured from winds. In this bay there is no +great current; the whole coast is, as it were, one continued harbour, +which gives all that live in the island great convenience for mutual +commerce. But the entry into the bay, occasioned by rocks on the one +hand and shallows on the other, is very dangerous. In the middle of it +there is one single rock which appears above water, and may, therefore, +easily be avoided; and on the top of it there is a tower, in which a +garrison is kept; the other rocks lie under water, and are very +dangerous. The channel is known only to the natives; so that if any +stranger should enter into the bay without one of their pilots he would +run great danger of shipwreck. For even they themselves could not pass +it safe if some marks that are on the coast did not direct their way; and +if these should be but a little shifted, any fleet that might come +against them, how great soever it were, would be certainly lost. On the +other side of the island there are likewise many harbours; and the coast +is so fortified, both by nature and art, that a small number of men can +hinder the descent of a great army. But they report (and there remains +good marks of it to make it credible) that this was no island at first, +but a part of the continent. Utopus, that conquered it (whose name it +still carries, for Abraxa was its first name), brought the rude and +uncivilised inhabitants into such a good government, and to that measure +of politeness, that they now far excel all the rest of mankind. Having +soon subdued them, he designed to separate them from the continent, and +to bring the sea quite round them. To accomplish this he ordered a deep +channel to be dug, fifteen miles long; and that the natives might not +think he treated them like slaves, he not only forced the inhabitants, +but also his own soldiers, to labour in carrying it on. As he set a vast +number of men to work, he, beyond all men's expectations, brought it to a +speedy conclusion. And his neighbours, who at first laughed at the folly +of the undertaking, no sooner saw it brought to perfection than they were +struck with admiration and terror. + +"There are fifty-four cities in the island, all large and well built, the +manners, customs, and laws of which are the same, and they are all +contrived as near in the same manner as the ground on which they stand +will allow. The nearest lie at least twenty-four miles' distance from +one another, and the most remote are not so far distant but that a man +can go on foot in one day from it to that which lies next it. Every city +sends three of their wisest senators once a year to Amaurot, to consult +about their common concerns; for that is the chief town of the island, +being situated near the centre of it, so that it is the most convenient +place for their assemblies. The jurisdiction of every city extends at +least twenty miles, and, where the towns lie wider, they have much more +ground. No town desires to enlarge its bounds, for the people consider +themselves rather as tenants than landlords. They have built, over all +the country, farmhouses for husbandmen, which are well contrived, and +furnished with all things necessary for country labour. Inhabitants are +sent, by turns, from the cities to dwell in them; no country family has +fewer than forty men and women in it, besides two slaves. There is a +master and a mistress set over every family, and over thirty families +there is a magistrate. Every year twenty of this family come back to the +town after they have stayed two years in the country, and in their room +there are other twenty sent from the town, that they may learn country +work from those that have been already one year in the country, as they +must teach those that come to them the next from the town. By this means +such as dwell in those country farms are never ignorant of agriculture, +and so commit no errors which might otherwise be fatal and bring them +under a scarcity of corn. But though there is every year such a shifting +of the husbandmen to prevent any man being forced against his will to +follow that hard course of life too long, yet many among them take such +pleasure in it that they desire leave to continue in it many years. These +husbandmen till the ground, breed cattle, hew wood, and convey it to the +towns either by land or water, as is most convenient. They breed an +infinite multitude of chickens in a very curious manner; for the hens do +not sit and hatch them, but a vast number of eggs are laid in a gentle +and equal heat in order to be hatched, and they are no sooner out of the +shell, and able to stir about, but they seem to consider those that feed +them as their mothers, and follow them as other chickens do the hen that +hatched them. They breed very few horses, but those they have are full +of mettle, and are kept only for exercising their youth in the art of +sitting and riding them; for they do not put them to any work, either of +ploughing or carriage, in which they employ oxen. For though their +horses are stronger, yet they find oxen can hold out longer; and as they +are not subject to so many diseases, so they are kept upon a less charge +and with less trouble. And even when they are so worn out that they are +no more fit for labour, they are good meat at last. They sow no corn but +that which is to be their bread; for they drink either wine, cider or +perry, and often water, sometimes boiled with honey or liquorice, with +which they abound; and though they know exactly how much corn will serve +every town and all that tract of country which belongs to it, yet they +sow much more and breed more cattle than are necessary for their +consumption, and they give that overplus of which they make no use to +their neighbours. When they want anything in the country which it does +not produce, they fetch that from the town, without carrying anything in +exchange for it. And the magistrates of the town take care to see it +given them; for they meet generally in the town once a month, upon a +festival day. When the time of harvest comes, the magistrates in the +country send to those in the towns and let them know how many hands they +will need for reaping the harvest; and the number they call for being +sent to them, they commonly despatch it all in one day. + + + +OF THEIR TOWNS, PARTICULARLY OF AMAUROT + + +"He that knows one of their towns knows them all--they are so like one +another, except where the situation makes some difference. I shall +therefore describe one of them, and none is so proper as Amaurot; for as +none is more eminent (all the rest yielding in precedence to this, +because it is the seat of their supreme council), so there was none of +them better known to me, I having lived five years all together in it. + +"It lies upon the side of a hill, or, rather, a rising ground. Its +figure is almost square, for from the one side of it, which shoots up +almost to the top of the hill, it runs down, in a descent for two miles, +to the river Anider; but it is a little broader the other way that runs +along by the bank of that river. The Anider rises about eighty miles +above Amaurot, in a small spring at first. But other brooks falling into +it, of which two are more considerable than the rest, as it runs by +Amaurot it is grown half a mile broad; but, it still grows larger and +larger, till, after sixty miles' course below it, it is lost in the +ocean. Between the town and the sea, and for some miles above the town, +it ebbs and flows every six hours with a strong current. The tide comes +up about thirty miles so full that there is nothing but salt water in the +river, the fresh water being driven back with its force; and above that, +for some miles, the water is brackish; but a little higher, as it runs by +the town, it is quite fresh; and when the tide ebbs, it continues fresh +all along to the sea. There is a bridge cast over the river, not of +timber, but of fair stone, consisting of many stately arches; it lies at +that part of the town which is farthest from the sea, so that the ships, +without any hindrance, lie all along the side of the town. There is, +likewise, another river that runs by it, which, though it is not great, +yet it runs pleasantly, for it rises out of the same hill on which the +town stands, and so runs down through it and falls into the Anider. The +inhabitants have fortified the fountain-head of this river, which springs +a little without the towns; that so, if they should happen to be +besieged, the enemy might not be able to stop or divert the course of the +water, nor poison it; from thence it is carried, in earthen pipes, to the +lower streets. And for those places of the town to which the water of +that small river cannot be conveyed, they have great cisterns for +receiving the rain-water, which supplies the want of the other. The town +is compassed with a high and thick wall, in which there are many towers +and forts; there is also a broad and deep dry ditch, set thick with +thorns, cast round three sides of the town, and the river is instead of a +ditch on the fourth side. The streets are very convenient for all +carriage, and are well sheltered from the winds. Their buildings are +good, and are so uniform that a whole side of a street looks like one +house. The streets are twenty feet broad; there lie gardens behind all +their houses. These are large, but enclosed with buildings, that on all +hands face the streets, so that every house has both a door to the street +and a back door to the garden. Their doors have all two leaves, which, +as they are easily opened, so they shut of their own accord; and, there +being no property among them, every man may freely enter into any house +whatsoever. At every ten years' end they shift their houses by lots. +They cultivate their gardens with great care, so that they have both +vines, fruits, herbs, and flowers in them; and all is so well ordered and +so finely kept that I never saw gardens anywhere that were both so +fruitful and so beautiful as theirs. And this humour of ordering their +gardens so well is not only kept up by the pleasure they find in it, but +also by an emulation between the inhabitants of the several streets, who +vie with each other. And there is, indeed, nothing belonging to the +whole town that is both more useful and more pleasant. So that he who +founded the town seems to have taken care of nothing more than of their +gardens; for they say the whole scheme of the town was designed at first +by Utopus, but he left all that belonged to the ornament and improvement +of it to be added by those that should come after him, that being too +much for one man to bring to perfection. Their records, that contain the +history of their town and State, are preserved with an exact care, and +run backwards seventeen hundred and sixty years. From these it appears +that their houses were at first low and mean, like cottages, made of any +sort of timber, and were built with mud walls and thatched with straw. +But now their houses are three storeys high, the fronts of them are faced +either with stone, plastering, or brick, and between the facings of their +walls they throw in their rubbish. Their roofs are flat, and on them +they lay a sort of plaster, which costs very little, and yet is so +tempered that it is not apt to take fire, and yet resists the weather +more than lead. They have great quantities of glass among them, with +which they glaze their windows; they use also in their windows a thin +linen cloth, that is so oiled or gummed that it both keeps out the wind +and gives free admission to the light. + + + +OF THEIR MAGISTRATES + + +"Thirty families choose every year a magistrate, who was anciently called +the Syphogrant, but is now called the Philarch; and over every ten +Syphogrants, with the families subject to them, there is another +magistrate, who was anciently called the Tranibore, but of late the +Archphilarch. All the Syphogrants, who are in number two hundred, choose +the Prince out of a list of four who are named by the people of the four +divisions of the city; but they take an oath, before they proceed to an +election, that they will choose him whom they think most fit for the +office: they give him their voices secretly, so that it is not known for +whom every one gives his suffrage. The Prince is for life, unless he is +removed upon suspicion of some design to enslave the people. The +Tranibors are new chosen every year, but yet they are, for the most part, +continued; all their other magistrates are only annual. The Tranibors +meet every third day, and oftener if necessary, and consult with the +Prince either concerning the affairs of the State in general, or such +private differences as may arise sometimes among the people, though that +falls out but seldom. There are always two Syphogrants called into the +council chamber, and these are changed every day. It is a fundamental +rule of their government, that no conclusion can be made in anything that +relates to the public till it has been first debated three several days +in their council. It is death for any to meet and consult concerning the +State, unless it be either in their ordinary council, or in the assembly +of the whole body of the people. + +"These things have been so provided among them that the Prince and the +Tranibors may not conspire together to change the government and enslave +the people; and therefore when anything of great importance is set on +foot, it is sent to the Syphogrants, who, after they have communicated it +to the families that belong to their divisions, and have considered it +among themselves, make report to the senate; and, upon great occasions, +the matter is referred to the council of the whole island. One rule +observed in their council is, never to debate a thing on the same day in +which it is first proposed; for that is always referred to the next +meeting, that so men may not rashly and in the heat of discourse engage +themselves too soon, which might bias them so much that, instead of +consulting the good of the public, they might rather study to support +their first opinions, and by a perverse and preposterous sort of shame +hazard their country rather than endanger their own reputation, or +venture the being suspected to have wanted foresight in the expedients +that they at first proposed; and therefore, to prevent this, they take +care that they may rather be deliberate than sudden in their motions. + + + +OF THEIR TRADES, AND MANNER OF LIFE + + +"Agriculture is that which is so universally understood among them that +no person, either man or woman, is ignorant of it; they are instructed in +it from their childhood, partly by what they learn at school, and partly +by practice, they being led out often into the fields about the town, +where they not only see others at work but are likewise exercised in it +themselves. Besides agriculture, which is so common to them all, every +man has some peculiar trade to which he applies himself; such as the +manufacture of wool or flax, masonry, smith's work, or carpenter's work; +for there is no sort of trade that is in great esteem among them. +Throughout the island they wear the same sort of clothes, without any +other distinction except what is necessary to distinguish the two sexes +and the married and unmarried. The fashion never alters, and as it is +neither disagreeable nor uneasy, so it is suited to the climate, and +calculated both for their summers and winters. Every family makes their +own clothes; but all among them, women as well as men, learn one or other +of the trades formerly mentioned. Women, for the most part, deal in wool +and flax, which suit best with their weakness, leaving the ruder trades +to the men. The same trade generally passes down from father to son, +inclinations often following descent: but if any man's genius lies +another way he is, by adoption, translated into a family that deals in +the trade to which he is inclined; and when that is to be done, care is +taken, not only by his father, but by the magistrate, that he may be put +to a discreet and good man: and if, after a person has learned one trade, +he desires to acquire another, that is also allowed, and is managed in +the same manner as the former. When he has learned both, he follows that +which he likes best, unless the public has more occasion for the other. + +The chief, and almost the only, business of the Syphogrants is to take +care that no man may live idle, but that every one may follow his trade +diligently; yet they do not wear themselves out with perpetual toil from +morning to night, as if they were beasts of burden, which as it is indeed +a heavy slavery, so it is everywhere the common course of life amongst +all mechanics except the Utopians: but they, dividing the day and night +into twenty-four hours, appoint six of these for work, three of which are +before dinner and three after; they then sup, and at eight o'clock, +counting from noon, go to bed and sleep eight hours: the rest of their +time, besides that taken up in work, eating, and sleeping, is left to +every man's discretion; yet they are not to abuse that interval to luxury +and idleness, but must employ it in some proper exercise, according to +their various inclinations, which is, for the most part, reading. It is +ordinary to have public lectures every morning before daybreak, at which +none are obliged to appear but those who are marked out for literature; +yet a great many, both men and women, of all ranks, go to hear lectures +of one sort or other, according to their inclinations: but if others that +are not made for contemplation, choose rather to employ themselves at +that time in their trades, as many of them do, they are not hindered, but +are rather commended, as men that take care to serve their country. After +supper they spend an hour in some diversion, in summer in their gardens, +and in winter in the halls where they eat, where they entertain each +other either with music or discourse. They do not so much as know dice, +or any such foolish and mischievous games. They have, however, two sorts +of games not unlike our chess; the one is between several numbers, in +which one number, as it were, consumes another; the other resembles a +battle between the virtues and the vices, in which the enmity in the +vices among themselves, and their agreement against virtue, is not +unpleasantly represented; together with the special opposition between +the particular virtues and vices; as also the methods by which vice +either openly assaults or secretly undermines virtue; and virtue, on the +other hand, resists it. But the time appointed for labour is to be +narrowly examined, otherwise you may imagine that since there are only +six hours appointed for work, they may fall under a scarcity of necessary +provisions: but it is so far from being true that this time is not +sufficient for supplying them with plenty of all things, either necessary +or convenient, that it is rather too much; and this you will easily +apprehend if you consider how great a part of all other nations is quite +idle. First, women generally do little, who are the half of mankind; and +if some few women are diligent, their husbands are idle: then consider +the great company of idle priests, and of those that are called religious +men; add to these all rich men, chiefly those that have estates in land, +who are called noblemen and gentlemen, together with their families, made +up of idle persons, that are kept more for show than use; add to these +all those strong and lusty beggars that go about pretending some disease +in excuse for their begging; and upon the whole account you will find +that the number of those by whose labours mankind is supplied is much +less than you perhaps imagined: then consider how few of those that work +are employed in labours that are of real service, for we, who measure all +things by money, give rise to many trades that are both vain and +superfluous, and serve only to support riot and luxury: for if those who +work were employed only in such things as the conveniences of life +require, there would be such an abundance of them that the prices of them +would so sink that tradesmen could not be maintained by their gains; if +all those who labour about useless things were set to more profitable +employments, and if all they that languish out their lives in sloth and +idleness (every one of whom consumes as much as any two of the men that +are at work) were forced to labour, you may easily imagine that a small +proportion of time would serve for doing all that is either necessary, +profitable, or pleasant to mankind, especially while pleasure is kept +within its due bounds: this appears very plainly in Utopia; for there, in +a great city, and in all the territory that lies round it, you can scarce +find five hundred, either men or women, by their age and strength capable +of labour, that are not engaged in it. Even the Syphogrants, though +excused by the law, yet do not excuse themselves, but work, that by their +examples they may excite the industry of the rest of the people; the like +exemption is allowed to those who, being recommended to the people by the +priests, are, by the secret suffrages of the Syphogrants, privileged from +labour, that they may apply themselves wholly to study; and if any of +these fall short of those hopes that they seemed at first to give, they +are obliged to return to work; and sometimes a mechanic that so employs +his leisure hours as to make a considerable advancement in learning is +eased from being a tradesman and ranked among their learned men. Out of +these they choose their ambassadors, their priests, their Tranibors, and +the Prince himself, anciently called their Barzenes, but is called of +late their Ademus. + +"And thus from the great numbers among them that are neither suffered to +be idle nor to be employed in any fruitless labour, you may easily make +the estimate how much may be done in those few hours in which they are +obliged to labour. But, besides all that has been already said, it is to +be considered that the needful arts among them are managed with less +labour than anywhere else. The building or the repairing of houses among +us employ many hands, because often a thriftless heir suffers a house +that his father built to fall into decay, so that his successor must, at +a great cost, repair that which he might have kept up with a small +charge; it frequently happens that the same house which one person built +at a vast expense is neglected by another, who thinks he has a more +delicate sense of the beauties of architecture, and he, suffering it to +fall to ruin, builds another at no less charge. But among the Utopians +all things are so regulated that men very seldom build upon a new piece +of ground, and are not only very quick in repairing their houses, but +show their foresight in preventing their decay, so that their buildings +are preserved very long with but very little labour, and thus the +builders, to whom that care belongs, are often without employment, except +the hewing of timber and the squaring of stones, that the materials may +be in readiness for raising a building very suddenly when there is any +occasion for it. As to their clothes, observe how little work is spent +in them; while they are at labour they are clothed with leather and +skins, cut carelessly about them, which will last seven years, and when +they appear in public they put on an upper garment which hides the other; +and these are all of one colour, and that is the natural colour of the +wool. As they need less woollen cloth than is used anywhere else, so +that which they make use of is much less costly; they use linen cloth +more, but that is prepared with less labour, and they value cloth only by +the whiteness of the linen or the cleanness of the wool, without much +regard to the fineness of the thread. While in other places four or five +upper garments of woollen cloth of different colours, and as many vests +of silk, will scarce serve one man, and while those that are nicer think +ten too few, every man there is content with one, which very often serves +him two years; nor is there anything that can tempt a man to desire more, +for if he had them he would neither be the, warmer nor would he make one +jot the better appearance for it. And thus, since they are all employed +in some useful labour, and since they content themselves with fewer +things, it falls out that there is a great abundance of all things among +them; so that it frequently happens that, for want of other work, vast +numbers are sent out to mend the highways; but when no public undertaking +is to be performed, the hours of working are lessened. The magistrates +never engage the people in unnecessary labour, since the chief end of the +constitution is to regulate labour by the necessities of the public, and +to allow the people as much time as is necessary for the improvement of +their minds, in which they think the happiness of life consists. + + + +OF THEIR TRAFFIC + + +"But it is now time to explain to you the mutual intercourse of this +people, their commerce, and the rules by which all things are distributed +among them. + +"As their cities are composed of families, so their families are made up +of those that are nearly related to one another. Their women, when they +grow up, are married out, but all the males, both children and +grand-children, live still in the same house, in great obedience to their +common parent, unless age has weakened his understanding, and in that +case he that is next to him in age comes in his room; but lest any city +should become either too great, or by any accident be dispeopled, +provision is made that none of their cities may contain above six +thousand families, besides those of the country around it. No family may +have less than ten and more than sixteen persons in it, but there can be +no determined number for the children under age; this rule is easily +observed by removing some of the children of a more fruitful couple to +any other family that does not abound so much in them. By the same rule +they supply cities that do not increase so fast from others that breed +faster; and if there is any increase over the whole island, then they +draw out a number of their citizens out of the several towns and send +them over to the neighbouring continent, where, if they find that the +inhabitants have more soil than they can well cultivate, they fix a +colony, taking the inhabitants into their society if they are willing to +live with them; and where they do that of their own accord, they quickly +enter into their method of life and conform to their rules, and this +proves a happiness to both nations; for, according to their constitution, +such care is taken of the soil that it becomes fruitful enough for both, +though it might be otherwise too narrow and barren for any one of them. +But if the natives refuse to conform themselves to their laws they drive +them out of those bounds which they mark out for themselves, and use +force if they resist, for they account it a very just cause of war for a +nation to hinder others from possessing a part of that soil of which they +make no use, but which is suffered to lie idle and uncultivated, since +every man has, by the law of nature, a right to such a waste portion of +the earth as is necessary for his subsistence. If an accident has so +lessened the number of the inhabitants of any of their towns that it +cannot be made up from the other towns of the island without diminishing +them too much (which is said to have fallen out but twice since they were +first a people, when great numbers were carried off by the plague), the +loss is then supplied by recalling as many as are wanted from their +colonies, for they will abandon these rather than suffer the towns in the +island to sink too low. + +"But to return to their manner of living in society: the oldest man of +every family, as has been already said, is its governor; wives serve +their husbands, and children their parents, and always the younger serves +the elder. Every city is divided into four equal parts, and in the +middle of each there is a market-place. What is brought thither, and +manufactured by the several families, is carried from thence to houses +appointed for that purpose, in which all things of a sort are laid by +themselves; and thither every father goes, and takes whatsoever he or his +family stand in need of, without either paying for it or leaving anything +in exchange. There is no reason for giving a denial to any person, since +there is such plenty of everything among them; and there is no danger of +a man's asking for more than he needs; they have no inducements to do +this, since they are sure they shall always be supplied: it is the fear +of want that makes any of the whole race of animals either greedy or +ravenous; but, besides fear, there is in man a pride that makes him fancy +it a particular glory to excel others in pomp and excess; but by the laws +of the Utopians, there is no room for this. Near these markets there are +others for all sorts of provisions, where there are not only herbs, +fruits, and bread, but also fish, fowl, and cattle. There are also, +without their towns, places appointed near some running water for killing +their beasts and for washing away their filth, which is done by their +slaves; for they suffer none of their citizens to kill their cattle, +because they think that pity and good-nature, which are among the best of +those affections that are born with us, are much impaired by the +butchering of animals; nor do they suffer anything that is foul or +unclean to be brought within their towns, lest the air should be infected +by ill-smells, which might prejudice their health. In every street there +are great halls, that lie at an equal distance from each other, +distinguished by particular names. The Syphogrants dwell in those that +are set over thirty families, fifteen lying on one side of it, and as +many on the other. In these halls they all meet and have their repasts; +the stewards of every one of them come to the market-place at an +appointed hour, and according to the number of those that belong to the +hall they carry home provisions. But they take more care of their sick +than of any others; these are lodged and provided for in public +hospitals. They have belonging to every town four hospitals, that are +built without their walls, and are so large that they may pass for little +towns; by this means, if they had ever such a number of sick persons, +they could lodge them conveniently, and at such a distance that such of +them as are sick of infectious diseases may be kept so far from the rest +that there can be no danger of contagion. The hospitals are furnished +and stored with all things that are convenient for the ease and recovery +of the sick; and those that are put in them are looked after with such +tender and watchful care, and are so constantly attended by their skilful +physicians, that as none is sent to them against their will, so there is +scarce one in a whole town that, if he should fall ill, would not choose +rather to go thither than lie sick at home. + +"After the steward of the hospitals has taken for the sick whatsoever the +physician prescribes, then the best things that are left in the market +are distributed equally among the halls in proportion to their numbers; +only, in the first place, they serve the Prince, the Chief Priest, the +Tranibors, the Ambassadors, and strangers, if there are any, which, +indeed, falls out but seldom, and for whom there are houses, well +furnished, particularly appointed for their reception when they come +among them. At the hours of dinner and supper the whole Syphogranty +being called together by sound of trumpet, they meet and eat together, +except only such as are in the hospitals or lie sick at home. Yet, after +the halls are served, no man is hindered to carry provisions home from +the market-place, for they know that none does that but for some good +reason; for though any that will may eat at home, yet none does it +willingly, since it is both ridiculous and foolish for any to give +themselves the trouble to make ready an ill dinner at home when there is +a much more plentiful one made ready for him so near hand. All the +uneasy and sordid services about these halls are performed by their +slaves; but the dressing and cooking their meat, and the ordering their +tables, belong only to the women, all those of every family taking it by +turns. They sit at three or more tables, according to their number; the +men sit towards the wall, and the women sit on the other side, that if +any of them should be taken suddenly ill, which is no uncommon case +amongst women with child, she may, without disturbing the rest, rise and +go to the nurses' room (who are there with the sucking children), where +there is always clean water at hand and cradles, in which they may lay +the young children if there is occasion for it, and a fire, that they may +shift and dress them before it. Every child is nursed by its own mother +if death or sickness does not intervene; and in that case the +Syphogrants' wives find out a nurse quickly, which is no hard matter, for +any one that can do it offers herself cheerfully; for as they are much +inclined to that piece of mercy, so the child whom they nurse considers +the nurse as its mother. All the children under five years old sit among +the nurses; the rest of the younger sort of both sexes, till they are fit +for marriage, either serve those that sit at table, or, if they are not +strong enough for that, stand by them in great silence and eat what is +given them; nor have they any other formality of dining. In the middle +of the first table, which stands across the upper end of the hall, sit +the Syphogrant and his wife, for that is the chief and most conspicuous +place; next to him sit two of the most ancient, for there go always four +to a mess. If there is a temple within the Syphogranty, the Priest and +his wife sit with the Syphogrant above all the rest; next them there is a +mixture of old and young, who are so placed that as the young are set +near others, so they are mixed with the more ancient; which, they say, +was appointed on this account: that the gravity of the old people, and +the reverence that is due to them, might restrain the younger from all +indecent words and gestures. Dishes are not served up to the whole table +at first, but the best are first set before the old, whose seats are +distinguished from the young, and, after them, all the rest are served +alike. The old men distribute to the younger any curious meats that +happen to be set before them, if there is not such an abundance of them +that the whole company may be served alike. + +"Thus old men are honoured with a particular respect, yet all the rest +fare as well as they. Both dinner and supper are begun with some lecture +of morality that is read to them; but it is so short that it is not +tedious nor uneasy to them to hear it. From hence the old men take +occasion to entertain those about them with some useful and pleasant +enlargements; but they do not engross the whole discourse so to +themselves during their meals that the younger may not put in for a +share; on the contrary, they engage them to talk, that so they may, in +that free way of conversation, find out the force of every one's spirit +and observe his temper. They despatch their dinners quickly, but sit +long at supper, because they go to work after the one, and are to sleep +after the other, during which they think the stomach carries on the +concoction more vigorously. They never sup without music, and there is +always fruit served up after meat; while they are at table some burn +perfumes and sprinkle about fragrant ointments and sweet waters--in +short, they want nothing that may cheer up their spirits; they give +themselves a large allowance that way, and indulge themselves in all such +pleasures as are attended with no inconvenience. Thus do those that are +in the towns live together; but in the country, where they live at a +great distance, every one eats at home, and no family wants any necessary +sort of provision, for it is from them that provisions are sent unto +those that live in the towns. + + + +OF THE TRAVELLING OF THE UTOPIANS + + +If any man has a mind to visit his friends that live in some other town, +or desires to travel and see the rest of the country, he obtains leave +very easily from the Syphogrant and Tranibors, when there is no +particular occasion for him at home. Such as travel carry with them a +passport from the Prince, which both certifies the licence that is +granted for travelling, and limits the time of their return. They are +furnished with a waggon and a slave, who drives the oxen and looks after +them; but, unless there are women in the company, the waggon is sent back +at the end of the journey as a needless encumbrance. While they are on +the road they carry no provisions with them, yet they want for nothing, +but are everywhere treated as if they were at home. If they stay in any +place longer than a night, every one follows his proper occupation, and +is very well used by those of his own trade; but if any man goes out of +the city to which he belongs without leave, and is found rambling without +a passport, he is severely treated, he is punished as a fugitive, and +sent home disgracefully; and, if he falls again into the like fault, is +condemned to slavery. If any man has a mind to travel only over the +precinct of his own city, he may freely do it, with his father's +permission and his wife's consent; but when he comes into any of the +country houses, if he expects to be entertained by them, he must labour +with them and conform to their rules; and if he does this, he may freely +go over the whole precinct, being then as useful to the city to which he +belongs as if he were still within it. Thus you see that there are no +idle persons among them, nor pretences of excusing any from labour. There +are no taverns, no ale-houses, nor stews among them, nor any other +occasions of corrupting each other, of getting into corners, or forming +themselves into parties; all men live in full view, so that all are +obliged both to perform their ordinary task and to employ themselves well +in their spare hours; and it is certain that a people thus ordered must +live in great abundance of all things, and these being equally +distributed among them, no man can want or be obliged to beg. + +"In their great council at Amaurot, to which there are three sent from +every town once a year, they examine what towns abound in provisions and +what are under any scarcity, that so the one may be furnished from the +other; and this is done freely, without any sort of exchange; for, +according to their plenty or scarcity, they supply or are supplied from +one another, so that indeed the whole island is, as it were, one family. +When they have thus taken care of their whole country, and laid up stores +for two years (which they do to prevent the ill consequences of an +unfavourable season), they order an exportation of the overplus, both of +corn, honey, wool, flax, wood, wax, tallow, leather, and cattle, which +they send out, commonly in great quantities, to other nations. They +order a seventh part of all these goods to be freely given to the poor of +the countries to which they send them, and sell the rest at moderate +rates; and by this exchange they not only bring back those few things +that they need at home (for, indeed, they scarce need anything but iron), +but likewise a great deal of gold and silver; and by their driving this +trade so long, it is not to be imagined how vast a treasure they have got +among them, so that now they do not much care whether they sell off their +merchandise for money in hand or upon trust. A great part of their +treasure is now in bonds; but in all their contracts no private man +stands bound, but the writing runs in the name of the town; and the towns +that owe them money raise it from those private hands that owe it to +them, lay it up in their public chamber, or enjoy the profit of it till +the Utopians call for it; and they choose rather to let the greatest part +of it lie in their hands, who make advantage by it, than to call for it +themselves; but if they see that any of their other neighbours stand more +in need of it, then they call it in and lend it to them. Whenever they +are engaged in war, which is the only occasion in which their treasure +can be usefully employed, they make use of it themselves; in great +extremities or sudden accidents they employ it in hiring foreign troops, +whom they more willingly expose to danger than their own people; they +give them great pay, knowing well that this will work even on their +enemies; that it will engage them either to betray their own side, or, at +least, to desert it; and that it is the best means of raising mutual +jealousies among them. For this end they have an incredible treasure; +but they do not keep it as a treasure, but in such a manner as I am +almost afraid to tell, lest you think it so extravagant as to be hardly +credible. This I have the more reason to apprehend because, if I had not +seen it myself, I could not have been easily persuaded to have believed +it upon any man's report. + +"It is certain that all things appear incredible to us in proportion as +they differ from known customs; but one who can judge aright will not +wonder to find that, since their constitution differs so much from ours, +their value of gold and silver should be measured by a very different +standard; for since they have no use for money among themselves, but keep +it as a provision against events which seldom happen, and between which +there are generally long intervening intervals, they value it no farther +than it deserves--that is, in proportion to its use. So that it is plain +they must prefer iron either to gold or silver, for men can no more live +without iron than without fire or water; but Nature has marked out no use +for the other metals so essential as not easily to be dispensed with. The +folly of men has enhanced the value of gold and silver because of their +scarcity; whereas, on the contrary, it is their opinion that Nature, as +an indulgent parent, has freely given us all the best things in great +abundance, such as water and earth, but has laid up and hid from us the +things that are vain and useless. + +"If these metals were laid up in any tower in the kingdom it would raise +a jealousy of the Prince and Senate, and give birth to that foolish +mistrust into which the people are apt to fall--a jealousy of their +intending to sacrifice the interest of the public to their own private +advantage. If they should work it into vessels, or any sort of plate, +they fear that the people might grow too fond of it, and so be unwilling +to let the plate be run down, if a war made it necessary, to employ it in +paying their soldiers. To prevent all these inconveniences they have +fallen upon an expedient which, as it agrees with their other policy, so +is it very different from ours, and will scarce gain belief among us who +value gold so much, and lay it up so carefully. They eat and drink out +of vessels of earth or glass, which make an agreeable appearance, though +formed of brittle materials; while they make their chamber-pots and close- +stools of gold and silver, and that not only in their public halls but in +their private houses. Of the same metals they likewise make chains and +fetters for their slaves, to some of which, as a badge of infamy, they +hang an earring of gold, and make others wear a chain or a coronet of the +same metal; and thus they take care by all possible means to render gold +and silver of no esteem; and from hence it is that while other nations +part with their gold and silver as unwillingly as if one tore out their +bowels, those of Utopia would look on their giving in all they possess of +those metals (when there were any use for them) but as the parting with a +trifle, or as we would esteem the loss of a penny! They find pearls on +their coasts, and diamonds and carbuncles on their rocks; they do not +look after them, but, if they find them by chance, they polish them, and +with them they adorn their children, who are delighted with them, and +glory in them during their childhood; but when they grow to years, and +see that none but children use such baubles, they of their own accord, +without being bid by their parents, lay them aside, and would be as much +ashamed to use them afterwards as children among us, when they come to +years, are of their puppets and other toys. + +"I never saw a clearer instance of the opposite impressions that +different customs make on people than I observed in the ambassadors of +the Anemolians, who came to Amaurot when I was there. As they came to +treat of affairs of great consequence, the deputies from several towns +met together to wait for their coming. The ambassadors of the nations +that lie near Utopia, knowing their customs, and that fine clothes are in +no esteem among them, that silk is despised, and gold is a badge of +infamy, used to come very modestly clothed; but the Anemolians, lying +more remote, and having had little commerce with them, understanding that +they were coarsely clothed, and all in the same manner, took it for +granted that they had none of those fine things among them of which they +made no use; and they, being a vainglorious rather than a wise people, +resolved to set themselves out with so much pomp that they should look +like gods, and strike the eyes of the poor Utopians with their splendour. +Thus three ambassadors made their entry with a hundred attendants, all +clad in garments of different colours, and the greater part in silk; the +ambassadors themselves, who were of the nobility of their country, were +in cloth-of-gold, and adorned with massy chains, earrings and rings of +gold; their caps were covered with bracelets set full of pearls and other +gems--in a word, they were set out with all those things that among the +Utopians were either the badges of slavery, the marks of infamy, or the +playthings of children. It was not unpleasant to see, on the one side, +how they looked big, when they compared their rich habits with the plain +clothes of the Utopians, who were come out in great numbers to see them +make their entry; and, on the other, to observe how much they were +mistaken in the impression which they hoped this pomp would have made on +them. It appeared so ridiculous a show to all that had never stirred out +of their country, and had not seen the customs of other nations, that +though they paid some reverence to those that were the most meanly clad, +as if they had been the ambassadors, yet when they saw the ambassadors +themselves so full of gold and chains, they looked upon them as slaves, +and forbore to treat them with reverence. You might have seen the +children who were grown big enough to despise their playthings, and who +had thrown away their jewels, call to their mothers, push them gently, +and cry out, 'See that great fool, that wears pearls and gems as if he +were yet a child!' while their mothers very innocently replied, 'Hold +your peace! this, I believe, is one of the ambassadors' fools.' Others +censured the fashion of their chains, and observed, 'That they were of no +use, for they were too slight to bind their slaves, who could easily +break them; and, besides, hung so loose about them that they thought it +easy to throw their away, and so get from them." But after the +ambassadors had stayed a day among them, and saw so vast a quantity of +gold in their houses (which was as much despised by them as it was +esteemed in other nations), and beheld more gold and silver in the chains +and fetters of one slave than all their ornaments amounted to, their +plumes fell, and they were ashamed of all that glory for which they had +formed valued themselves, and accordingly laid it aside--a resolution +that they immediately took when, on their engaging in some free discourse +with the Utopians, they discovered their sense of such things and their +other customs. The Utopians wonder how any man should be so much taken +with the glaring doubtful lustre of a jewel or a stone, that can look up +to a star or to the sun himself; or how any should value himself because +his cloth is made of a finer thread; for, how fine soever that thread may +be, it was once no better than the fleece of a sheep, and that sheep, was +a sheep still, for all its wearing it. They wonder much to hear that +gold, which in itself is so useless a thing, should be everywhere so much +esteemed that even man, for whom it was made, and by whom it has its +value, should yet be thought of less value than this metal; that a man of +lead, who has no more sense than a log of wood, and is as bad as he is +foolish, should have many wise and good men to serve him, only because he +has a great heap of that metal; and that if it should happen that by some +accident or trick of law (which, sometimes produces as great changes as +chance itself) all this wealth should pass from the master to the meanest +varlet of his whole family, he himself would very soon become one of his +servants, as if he were a thing that belonged to his wealth, and so were +bound to follow its fortune! But they much more admire and detest the +folly of those who, when they see a rich man, though they neither owe him +anything, nor are in any sort dependent on his bounty, yet, merely +because he is rich, give him little less than divine honours, even though +they know him to be so covetous and base-minded that, notwithstanding all +his wealth, he will not part with one farthing of it to them as long as +he lives! + +"These and such like notions have that people imbibed, partly from their +education, being bred in a country whose customs and laws are opposite to +all such foolish maxims, and partly from their learning and studies--for +though there are but few in any town that are so wholly excused from +labour as to give themselves entirely up to their studies (these being +only such persons as discover from their childhood an extraordinary +capacity and disposition for letters), yet their children and a great +part of the nation, both men and women, are taught to spend those hours +in which they are not obliged to work in reading; and this they do +through the whole progress of life. They have all their learning in +their own tongue, which is both a copious and pleasant language, and in +which a man can fully express his mind; it runs over a great tract of +many countries, but it is not equally pure in all places. They had never +so much as heard of the names of any of those philosophers that are so +famous in these parts of the world, before we went among them; and yet +they had made the same discoveries as the Greeks, both in music, logic, +arithmetic, and geometry. But as they are almost in everything equal to +the ancient philosophers, so they far exceed our modern logicians for +they have never yet fallen upon the barbarous niceties that our youth are +forced to learn in those trifling logical schools that are among us. They +are so far from minding chimeras and fantastical images made in the mind +that none of them could comprehend what we meant when we talked to them +of a man in the abstract as common to all men in particular (so that +though we spoke of him as a thing that we could point at with our +fingers, yet none of them could perceive him) and yet distinct from every +one, as if he were some monstrous Colossus or giant; yet, for all this +ignorance of these empty notions, they knew astronomy, and were perfectly +acquainted with the motions of the heavenly bodies; and have many +instruments, well contrived and divided, by which they very accurately +compute the course and positions of the sun, moon, and stars. But for +the cheat of divining by the stars, by their oppositions or conjunctions, +it has not so much as entered into their thoughts. They have a +particular sagacity, founded upon much observation, in judging of the +weather, by which they know when they may look for rain, wind, or other +alterations in the air; but as to the philosophy of these things, the +cause of the saltness of the sea, of its ebbing and flowing, and of the +original and nature both of the heavens and the earth, they dispute of +them partly as our ancient philosophers have done, and partly upon some +new hypothesis, in which, as they differ from them, so they do not in all +things agree among themselves. + +"As to moral philosophy, they have the same disputes among them as we +have here. They examine what are properly good, both for the body and +the mind; and whether any outward thing can be called truly _good_, or if +that term belong only to the endowments of the soul. They inquire, +likewise, into the nature of virtue and pleasure. But their chief +dispute is concerning the happiness of a man, and wherein it +consists--whether in some one thing or in a great many. They seem, +indeed, more inclinable to that opinion that places, if not the whole, +yet the chief part, of a man's happiness in pleasure; and, what may seem +more strange, they make use of arguments even from religion, +notwithstanding its severity and roughness, for the support of that +opinion so indulgent to pleasure; for they never dispute concerning +happiness without fetching some arguments from the principles of religion +as well as from natural reason, since without the former they reckon that +all our inquiries after happiness must be but conjectural and defective. + +"These are their religious principles:--That the soul of man is immortal, +and that God of His goodness has designed that it should be happy; and +that He has, therefore, appointed rewards for good and virtuous actions, +and punishments for vice, to be distributed after this life. Though +these principles of religion are conveyed down among them by tradition, +they think that even reason itself determines a man to believe and +acknowledge them; and freely confess that if these were taken away, no +man would be so insensible as not to seek after pleasure by all possible +means, lawful or unlawful, using only this caution--that a lesser +pleasure might not stand in the way of a greater, and that no pleasure +ought to be pursued that should draw a great deal of pain after it; for +they think it the maddest thing in the world to pursue virtue, that is a +sour and difficult thing, and not only to renounce the pleasures of life, +but willingly to undergo much pain and trouble, if a man has no prospect +of a reward. And what reward can there be for one that has passed his +whole life, not only without pleasure, but in pain, if there is nothing +to be expected after death? Yet they do not place happiness in all sorts +of pleasures, but only in those that in themselves are good and honest. +There is a party among them who place happiness in bare virtue; others +think that our natures are conducted by virtue to happiness, as that +which is the chief good of man. They define virtue thus--that it is a +living according to Nature, and think that we are made by God for that +end; they believe that a man then follows the dictates of Nature when he +pursues or avoids things according to the direction of reason. They say +that the first dictate of reason is the kindling in us a love and +reverence for the Divine Majesty, to whom we owe both all that we have +and, all that we can ever hope for. In the next place, reason directs us +to keep our minds as free from passion and as cheerful as we can, and +that we should consider ourselves as bound by the ties of good-nature and +humanity to use our utmost endeavours to help forward the happiness of +all other persons; for there never was any man such a morose and severe +pursuer of virtue, such an enemy to pleasure, that though he set hard +rules for men to undergo, much pain, many watchings, and other rigors, +yet did not at the same time advise them to do all they could in order to +relieve and ease the miserable, and who did not represent gentleness and +good-nature as amiable dispositions. And from thence they infer that if +a man ought to advance the welfare and comfort of the rest of mankind +(there being no virtue more proper and peculiar to our nature than to +ease the miseries of others, to free from trouble and anxiety, in +furnishing them with the comforts of life, in which pleasure consists) +Nature much more vigorously leads them to do all this for himself. A +life of pleasure is either a real evil, and in that case we ought not to +assist others in their pursuit of it, but, on the contrary, to keep them +from it all we can, as from that which is most hurtful and deadly; or if +it is a good thing, so that we not only may but ought to help others to +it, why, then, ought not a man to begin with himself? since no man can be +more bound to look after the good of another than after his own; for +Nature cannot direct us to be good and kind to others, and yet at the +same time to be unmerciful and cruel to ourselves. Thus as they define +virtue to be living according to Nature, so they imagine that Nature +prompts all people on to seek after pleasure as the end of all they do. +They also observe that in order to our supporting the pleasures of life, +Nature inclines us to enter into society; for there is no man so much +raised above the rest of mankind as to be the only favourite of Nature, +who, on the contrary, seems to have placed on a level all those that +belong to the same species. Upon this they infer that no man ought to +seek his own conveniences so eagerly as to prejudice others; and +therefore they think that not only all agreements between private persons +ought to be observed, but likewise that all those laws ought to be kept +which either a good prince has published in due form, or to which a +people that is neither oppressed with tyranny nor circumvented by fraud +has consented, for distributing those conveniences of life which afford +us all our pleasures. + +"They think it is an evidence of true wisdom for a man to pursue his own +advantage as far as the laws allow it, they account it piety to prefer +the public good to one's private concerns, but they think it unjust for a +man to seek for pleasure by snatching another man's pleasures from him; +and, on the contrary, they think it a sign of a gentle and good soul for +a man to dispense with his own advantage for the good of others, and that +by this means a good man finds as much pleasure one way as he parts with +another; for as he may expect the like from others when he may come to +need it, so, if that should fail him, yet the sense of a good action, and +the reflections that he makes on the love and gratitude of those whom he +has so obliged, gives the mind more pleasure than the body could have +found in that from which it had restrained itself. They are also +persuaded that God will make up the loss of those small pleasures with a +vast and endless joy, of which religion easily convinces a good soul. + +"Thus, upon an inquiry into the whole matter, they reckon that all our +actions, and even all our virtues, terminate in pleasure, as in our chief +end and greatest happiness; and they call every motion or state, either +of body or mind, in which Nature teaches us to delight, a pleasure. Thus +they cautiously limit pleasure only to those appetites to which Nature +leads us; for they say that Nature leads us only to those delights to +which reason, as well as sense, carries us, and by which we neither +injure any other person nor lose the possession of greater pleasures, and +of such as draw no troubles after them. But they look upon those +delights which men by a foolish, though common, mistake call pleasure, as +if they could change as easily the nature of things as the use of words, +as things that greatly obstruct their real happiness, instead of +advancing it, because they so entirely possess the minds of those that +are once captivated by them with a false notion of pleasure that there is +no room left for pleasures of a truer or purer kind. + +"There are many things that in themselves have nothing that is truly +delightful; on the contrary, they have a good deal of bitterness in them; +and yet, from our perverse appetites after forbidden objects, are not +only ranked among the pleasures, but are made even the greatest designs, +of life. Among those who pursue these sophisticated pleasures they +reckon such as I mentioned before, who think themselves really the better +for having fine clothes; in which they think they are doubly mistaken, +both in the opinion they have of their clothes, and in that they have of +themselves. For if you consider the use of clothes, why should a fine +thread be thought better than a coarse one? And yet these men, as if +they had some real advantages beyond others, and did not owe them wholly +to their mistakes, look big, seem to fancy themselves to be more +valuable, and imagine that a respect is due to them for the sake of a +rich garment, to which they would not have pretended if they had been +more meanly clothed, and even resent it as an affront if that respect is +not paid them. It is also a great folly to be taken with outward marks +of respect, which signify nothing; for what true or real pleasure can one +man find in another's standing bare or making legs to him? Will the +bending another man's knees give ease to yours? and will the head's being +bare cure the madness of yours? And yet it is wonderful to see how this +false notion of pleasure bewitches many who delight themselves with the +fancy of their nobility, and are pleased with this conceit--that they are +descended from ancestors who have been held for some successions rich, +and who have had great possessions; for this is all that makes nobility +at present. Yet they do not think themselves a whit the less noble, +though their immediate parents have left none of this wealth to them, or +though they themselves have squandered it away. The Utopians have no +better opinion of those who are much taken with gems and precious stones, +and who account it a degree of happiness next to a divine one if they can +purchase one that is very extraordinary, especially if it be of that sort +of stones that is then in greatest request, for the same sort is not at +all times universally of the same value, nor will men buy it unless it be +dismounted and taken out of the gold. The jeweller is then made to give +good security, and required solemnly to swear that the stone is true, +that, by such an exact caution, a false one might not be bought instead +of a true; though, if you were to examine it, your eye could find no +difference between the counterfeit and that which is true; so that they +are all one to you, as much as if you were blind. Or can it be thought +that they who heap up a useless mass of wealth, not for any use that it +is to bring them, but merely to please themselves with the contemplation +of it, enjoy any true pleasure in it? The delight they find is only a +false shadow of joy. Those are no better whose error is somewhat +different from the former, and who hide it out of their fear of losing +it; for what other name can fit the hiding it in the earth, or, rather, +the restoring it to it again, it being thus cut off from being useful +either to its owner or to the rest of mankind? And yet the owner, having +hid it carefully, is glad, because he thinks he is now sure of it. If it +should be stole, the owner, though he might live perhaps ten years after +the theft, of which he knew nothing, would find no difference between his +having or losing it, for both ways it was equally useless to him. + +"Among those foolish pursuers of pleasure they reckon all that delight in +hunting, in fowling, or gaming, of whose madness they have only heard, +for they have no such things among them. But they have asked us, 'What +sort of pleasure is it that men can find in throwing the dice?' (for if +there were any pleasure in it, they think the doing it so often should +give one a surfeit of it); 'and what pleasure can one find in hearing the +barking and howling of dogs, which seem rather odious than pleasant +sounds?' Nor can they comprehend the pleasure of seeing dogs run after a +hare, more than of seeing one dog run after another; for if the seeing +them run is that which gives the pleasure, you have the same +entertainment to the eye on both these occasions, since that is the same +in both cases. But if the pleasure lies in seeing the hare killed and +torn by the dogs, this ought rather to stir pity, that a weak, harmless, +and fearful hare should be devoured by strong, fierce, and cruel dogs. +Therefore all this business of hunting is, among the Utopians, turned +over to their butchers, and those, as has been already said, are all +slaves, and they look on hunting as one of the basest parts of a +butcher's work, for they account it both more profitable and more decent +to kill those beasts that are more necessary and useful to mankind, +whereas the killing and tearing of so small and miserable an animal can +only attract the huntsman with a false show of pleasure, from which he +can reap but small advantage. They look on the desire of the bloodshed, +even of beasts, as a mark of a mind that is already corrupted with +cruelty, or that at least, by too frequent returns of so brutal a +pleasure, must degenerate into it. + +"Thus though the rabble of mankind look upon these, and on innumerable +other things of the same nature, as pleasures, the Utopians, on the +contrary, observing that there is nothing in them truly pleasant, +conclude that they are not to be reckoned among pleasures; for though +these things may create some tickling in the senses (which seems to be a +true notion of pleasure), yet they imagine that this does not arise from +the thing itself, but from a depraved custom, which may so vitiate a +man's taste that bitter things may pass for sweet, as women with child +think pitch or tallow taste sweeter than honey; but as a man's sense, +when corrupted either by a disease or some ill habit, does not change the +nature of other things, so neither can it change the nature of pleasure. + +"They reckon up several sorts of pleasures, which they call true ones; +some belong to the body, and others to the mind. The pleasures of the +mind lie in knowledge, and in that delight which the contemplation of +truth carries with it; to which they add the joyful reflections on a well- +spent life, and the assured hopes of a future happiness. They divide the +pleasures of the body into two sorts--the one is that which gives our +senses some real delight, and is performed either by recruiting Nature +and supplying those parts which feed the internal heat of life by eating +and drinking, or when Nature is eased of any surcharge that oppresses it, +when we are relieved from sudden pain, or that which arises from +satisfying the appetite which Nature has wisely given to lead us to the +propagation of the species. There is another kind of pleasure that +arises neither from our receiving what the body requires, nor its being +relieved when overcharged, and yet, by a secret unseen virtue, affects +the senses, raises the passions, and strikes the mind with generous +impressions--this is, the pleasure that arises from music. Another kind +of bodily pleasure is that which results from an undisturbed and vigorous +constitution of body, when life and active spirits seem to actuate every +part. This lively health, when entirely free from all mixture of pain, +of itself gives an inward pleasure, independent of all external objects +of delight; and though this pleasure does not so powerfully affect us, +nor act so strongly on the senses as some of the others, yet it may be +esteemed as the greatest of all pleasures; and almost all the Utopians +reckon it the foundation and basis of all the other joys of life, since +this alone makes the state of life easy and desirable, and when this is +wanting, a man is really capable of no other pleasure. They look upon +freedom from pain, if it does not rise from perfect health, to be a state +of stupidity rather than of pleasure. This subject has been very +narrowly canvassed among them, and it has been debated whether a firm and +entire health could be called a pleasure or not. Some have thought that +there was no pleasure but what was 'excited' by some sensible motion in +the body. But this opinion has been long ago excluded from among them; +so that now they almost universally agree that health is the greatest of +all bodily pleasures; and that as there is a pain in sickness which is as +opposite in its nature to pleasure as sickness itself is to health, so +they hold that health is accompanied with pleasure. And if any should +say that sickness is not really pain, but that it only carries pain along +with it, they look upon that as a fetch of subtlety that does not much +alter the matter. It is all one, in their opinion, whether it be said +that health is in itself a pleasure, or that it begets a pleasure, as +fire gives heat, so it be granted that all those whose health is entire +have a true pleasure in the enjoyment of it. And they reason thus:--'What +is the pleasure of eating, but that a man's health, which had been +weakened, does, with the assistance of food, drive away hunger, and so +recruiting itself, recovers its former vigour? And being thus refreshed +it finds a pleasure in that conflict; and if the conflict is pleasure, +the victory must yet breed a greater pleasure, except we fancy that it +becomes stupid as soon as it has obtained that which it pursued, and so +neither knows nor rejoices in its own welfare.' If it is said that +health cannot be felt, they absolutely deny it; for what man is in +health, that does not perceive it when he is awake? Is there any man +that is so dull and stupid as not to acknowledge that he feels a delight +in health? And what is delight but another name for pleasure? + +"But, of all pleasures, they esteem those to be most valuable that lie in +the mind, the chief of which arise out of true virtue and the witness of +a good conscience. They account health the chief pleasure that belongs +to the body; for they think that the pleasure of eating and drinking, and +all the other delights of sense, are only so far desirable as they give +or maintain health; but they are not pleasant in themselves otherwise +than as they resist those impressions that our natural infirmities are +still making upon us. For as a wise man desires rather to avoid diseases +than to take physic, and to be freed from pain rather than to find ease +by remedies, so it is more desirable not to need this sort of pleasure +than to be obliged to indulge it. If any man imagines that there is a +real happiness in these enjoyments, he must then confess that he would be +the happiest of all men if he were to lead his life in perpetual hunger, +thirst, and itching, and, by consequence, in perpetual eating, drinking, +and scratching himself; which any one may easily see would be not only a +base, but a miserable, state of a life. These are, indeed, the lowest of +pleasures, and the least pure, for we can never relish them but when they +are mixed with the contrary pains. The pain of hunger must give us the +pleasure of eating, and here the pain out-balances the pleasure. And as +the pain is more vehement, so it lasts much longer; for as it begins +before the pleasure, so it does not cease but with the pleasure that +extinguishes it, and both expire together. They think, therefore, none +of those pleasures are to be valued any further than as they are +necessary; yet they rejoice in them, and with due gratitude acknowledge +the tenderness of the great Author of Nature, who has planted in us +appetites, by which those things that are necessary for our preservation +are likewise made pleasant to us. For how miserable a thing would life +be if those daily diseases of hunger and thirst were to be carried off by +such bitter drugs as we must use for those diseases that return seldomer +upon us! And thus these pleasant, as well as proper, gifts of Nature +maintain the strength and the sprightliness of our bodies. + +"They also entertain themselves with the other delights let in at their +eyes, their ears, and their nostrils as the pleasant relishes and +seasoning of life, which Nature seems to have marked out peculiarly for +man, since no other sort of animals contemplates the figure and beauty of +the universe, nor is delighted with smells any further than as they +distinguish meats by them; nor do they apprehend the concords or discords +of sound. Yet, in all pleasures whatsoever, they take care that a lesser +joy does not hinder a greater, and that pleasure may never breed pain, +which they think always follows dishonest pleasures. But they think it +madness for a man to wear out the beauty of his face or the force of his +natural strength, to corrupt the sprightliness of his body by sloth and +laziness, or to waste it by fasting; that it is madness to weaken the +strength of his constitution and reject the other delights of life, +unless by renouncing his own satisfaction he can either serve the public +or promote the happiness of others, for which he expects a greater +recompense from God. So that they look on such a course of life as the +mark of a mind that is both cruel to itself and ungrateful to the Author +of Nature, as if we would not be beholden to Him for His favours, and +therefore rejects all His blessings; as one who should afflict himself +for the empty shadow of virtue, or for no better end than to render +himself capable of bearing those misfortunes which possibly will never +happen. + +"This is their notion of virtue and of pleasure: they think that no man's +reason can carry him to a truer idea of them unless some discovery from +heaven should inspire him with sublimer notions. I have not now the +leisure to examine whether they think right or wrong in this matter; nor +do I judge it necessary, for I have only undertaken to give you an +account of their constitution, but not to defend all their principles. I +am sure that whatever may be said of their notions, there is not in the +whole world either a better people or a happier government. Their bodies +are vigorous and lively; and though they are but of a middle stature, and +have neither the fruitfullest soil nor the purest air in the world; yet +they fortify themselves so well, by their temperate course of life, +against the unhealthiness of their air, and by their industry they so +cultivate their soil, that there is nowhere to be seen a greater +increase, both of corn and cattle, nor are there anywhere healthier men +and freer from diseases; for one may there see reduced to practice not +only all the art that the husbandman employs in manuring and improving an +ill soil, but whole woods plucked up by the roots, and in other places +new ones planted, where there were none before. Their principal motive +for this is the convenience of carriage, that their timber may be either +near their towns or growing on the banks of the sea, or of some rivers, +so as to be floated to them; for it is a harder work to carry wood at any +distance over land than corn. The people are industrious, apt to learn, +as well as cheerful and pleasant, and none can endure more labour when it +is necessary; but, except in that case, they love their ease. They are +unwearied pursuers of knowledge; for when we had given them some hints of +the learning and discipline of the Greeks, concerning whom we only +instructed them (for we know that there was nothing among the Romans, +except their historians and their poets, that they would value much), it +was strange to see how eagerly they were set on learning that language: +we began to read a little of it to them, rather in compliance with their +importunity than out of any hopes of their reaping from it any great +advantage: but, after a very short trial, we found they made such +progress, that we saw our labour was like to be more successful than we +could have expected: they learned to write their characters and to +pronounce their language so exactly, had so quick an apprehension, they +remembered it so faithfully, and became so ready and correct in the use +of it, that it would have looked like a miracle if the greater part of +those whom we taught had not been men both of extraordinary capacity and +of a fit age for instruction: they were, for the greatest part, chosen +from among their learned men by their chief council, though some studied +it of their own accord. In three years' time they became masters of the +whole language, so that they read the best of the Greek authors very +exactly. I am, indeed, apt to think that they learned that language the +more easily from its having some relation to their own. I believe that +they were a colony of the Greeks; for though their language comes nearer +the Persian, yet they retain many names, both for their towns and +magistrates, that are of Greek derivation. I happened to carry a great +many books with me, instead of merchandise, when I sailed my fourth +voyage; for I was so far from thinking of soon coming back, that I rather +thought never to have returned at all, and I gave them all my books, +among which were many of Plato's and some of Aristotle's works: I had +also Theophrastus on Plants, which, to my great regret, was imperfect; +for having laid it carelessly by, while we were at sea, a monkey had +seized upon it, and in many places torn out the leaves. They have no +books of grammar but Lascares, for I did not carry Theodorus with me; nor +have they any dictionaries but Hesichius and Dioscerides. They esteem +Plutarch highly, and were much taken with Lucian's wit and with his +pleasant way of writing. As for the poets, they have Aristophanes, +Homer, Euripides, and Sophocles of Aldus's edition; and for historians, +Thucydides, Herodotus, and Herodian. One of my companions, Thricius +Apinatus, happened to carry with him some of Hippocrates's works and +Galen's Microtechne, which they hold in great estimation; for though +there is no nation in the world that needs physic so little as they do, +yet there is not any that honours it so much; they reckon the knowledge +of it one of the pleasantest and most profitable parts of philosophy, by +which, as they search into the secrets of nature, so they not only find +this study highly agreeable, but think that such inquiries are very +acceptable to the Author of nature; and imagine, that as He, like the +inventors of curious engines amongst mankind, has exposed this great +machine of the universe to the view of the only creatures capable of +contemplating it, so an exact and curious observer, who admires His +workmanship, is much more acceptable to Him than one of the herd, who, +like a beast incapable of reason, looks on this glorious scene with the +eyes of a dull and unconcerned spectator. + +"The minds of the Utopians, when fenced with a love for learning, are +very ingenious in discovering all such arts as are necessary to carry it +to perfection. Two things they owe to us, the manufacture of paper and +the art of printing; yet they are not so entirely indebted to us for +these discoveries but that a great part of the invention was their own. +We showed them some books printed by Aldus, we explained to them the way +of making paper and the mystery of printing; but, as we had never +practised these arts, we described them in a crude and superficial +manner. They seized the hints we gave them; and though at first they +could not arrive at perfection, yet by making many essays they at last +found out and corrected all their errors and conquered every difficulty. +Before this they only wrote on parchment, on reeds, or on the barks of +trees; but now they have established the manufactures of paper and set up +printing presses, so that, if they had but a good number of Greek +authors, they would be quickly supplied with many copies of them: at +present, though they have no more than those I have mentioned, yet, by +several impressions, they have multiplied them into many thousands. If +any man was to go among them that had some extraordinary talent, or that +by much travelling had observed the customs of many nations (which made +us to be so well received), he would receive a hearty welcome, for they +are very desirous to know the state of the whole world. Very few go +among them on the account of traffic; for what can a man carry to them +but iron, or gold, or silver? which merchants desire rather to export +than import to a strange country: and as for their exportation, they +think it better to manage that themselves than to leave it to foreigners, +for by this means, as they understand the state of the neighbouring +countries better, so they keep up the art of navigation which cannot be +maintained but by much practice. + + + +OF THEIR SLAVES, AND OF THEIR MARRIAGES + + +"They do not make slaves of prisoners of war, except those that are taken +in battle, nor of the sons of their slaves, nor of those of other +nations: the slaves among them are only such as are condemned to that +state of life for the commission of some crime, or, which is more common, +such as their merchants find condemned to die in those parts to which +they trade, whom they sometimes redeem at low rates, and in other places +have them for nothing. They are kept at perpetual labour, and are always +chained, but with this difference, that their own natives are treated +much worse than others: they are considered as more profligate than the +rest, and since they could not be restrained by the advantages of so +excellent an education, are judged worthy of harder usage. Another sort +of slaves are the poor of the neighbouring countries, who offer of their +own accord to come and serve them: they treat these better, and use them +in all other respects as well as their own countrymen, except their +imposing more labour upon them, which is no hard task to those that have +been accustomed to it; and if any of these have a mind to go back to +their own country, which, indeed, falls out but seldom, as they do not +force them to stay, so they do not send them away empty-handed. + +"I have already told you with what care they look after their sick, so +that nothing is left undone that can contribute either to their case or +health; and for those who are taken with fixed and incurable diseases, +they use all possible ways to cherish them and to make their lives as +comfortable as possible. They visit them often and take great pains to +make their time pass off easily; but when any is taken with a torturing +and lingering pain, so that there is no hope either of recovery or ease, +the priests and magistrates come and exhort them, that, since they are +now unable to go on with the business of life, are become a burden to +themselves and to all about them, and they have really out-lived +themselves, they should no longer nourish such a rooted distemper, but +choose rather to die since they cannot live but in much misery; being +assured that if they thus deliver themselves from torture, or are willing +that others should do it, they shall be happy after death: since, by +their acting thus, they lose none of the pleasures, but only the troubles +of life, they think they behave not only reasonably but in a manner +consistent with religion and piety; because they follow the advice given +them by their priests, who are the expounders of the will of God. Such +as are wrought on by these persuasions either starve themselves of their +own accord, or take opium, and by that means die without pain. But no +man is forced on this way of ending his life; and if they cannot be +persuaded to it, this does not induce them to fail in their attendance +and care of them: but as they believe that a voluntary death, when it is +chosen upon such an authority, is very honourable, so if any man takes +away his own life without the approbation of the priests and the senate, +they give him none of the honours of a decent funeral, but throw his body +into a ditch. + +"Their women are not married before eighteen nor their men before two-and- +twenty, and if any of them run into forbidden embraces before marriage +they are severely punished, and the privilege of marriage is denied them +unless they can obtain a special warrant from the Prince. Such disorders +cast a great reproach upon the master and mistress of the family in which +they happen, for it is supposed that they have failed in their duty. The +reason of punishing this so severely is, because they think that if they +were not strictly restrained from all vagrant appetites, very few would +engage in a state in which they venture the quiet of their whole lives, +by being confined to one person, and are obliged to endure all the +inconveniences with which it is accompanied. In choosing their wives +they use a method that would appear to us very absurd and ridiculous, but +it is constantly observed among them, and is accounted perfectly +consistent with wisdom. Before marriage some grave matron presents the +bride, naked, whether she is a virgin or a widow, to the bridegroom, and +after that some grave man presents the bridegroom, naked, to the bride. +We, indeed, both laughed at this, and condemned it as very indecent. But +they, on the other hand, wondered at the folly of the men of all other +nations, who, if they are but to buy a horse of a small value, are so +cautious that they will see every part of him, and take off both his +saddle and all his other tackle, that there may be no secret ulcer hid +under any of them, and that yet in the choice of a wife, on which depends +the happiness or unhappiness of the rest of his life, a man should +venture upon trust, and only see about a handsbreadth of the face, all +the rest of the body being covered, under which may lie hid what may be +contagious as well as loathsome. All men are not so wise as to choose a +woman only for her good qualities, and even wise men consider the body as +that which adds not a little to the mind, and it is certain there may be +some such deformity covered with clothes as may totally alienate a man +from his wife, when it is too late to part with her; if such a thing is +discovered after marriage a man has no remedy but patience; they, +therefore, think it is reasonable that there should be good provision +made against such mischievous frauds. + +"There was so much the more reason for them to make a regulation in this +matter, because they are the only people of those parts that neither +allow of polygamy nor of divorces, except in the case of adultery or +insufferable perverseness, for in these cases the Senate dissolves the +marriage and grants the injured person leave to marry again; but the +guilty are made infamous and are never allowed the privilege of a second +marriage. None are suffered to put away their wives against their wills, +from any great calamity that may have fallen on their persons, for they +look on it as the height of cruelty and treachery to abandon either of +the married persons when they need most the tender care of their consort, +and that chiefly in the case of old age, which, as it carries many +diseases along with it, so it is a disease of itself. But it frequently +falls out that when a married couple do not well agree, they, by mutual +consent, separate, and find out other persons with whom they hope they +may live more happily; yet this is not done without obtaining leave of +the Senate, which never admits of a divorce but upon a strict inquiry +made, both by the senators and their wives, into the grounds upon which +it is desired, and even when they are satisfied concerning the reasons of +it they go on but slowly, for they imagine that too great easiness in +granting leave for new marriages would very much shake the kindness of +married people. They punish severely those that defile the marriage bed; +if both parties are married they are divorced, and the injured persons +may marry one another, or whom they please, but the adulterer and the +adulteress are condemned to slavery, yet if either of the injured persons +cannot shake off the love of the married person they may live with them +still in that state, but they must follow them to that labour to which +the slaves are condemned, and sometimes the repentance of the condemned, +together with the unshaken kindness of the innocent and injured person, +has prevailed so far with the Prince that he has taken off the sentence; +but those that relapse after they are once pardoned are punished with +death. + +"Their law does not determine the punishment for other crimes, but that +is left to the Senate, to temper it according to the circumstances of the +fact. Husbands have power to correct their wives and parents to chastise +their children, unless the fault is so great that a public punishment is +thought necessary for striking terror into others. For the most part +slavery is the punishment even of the greatest crimes, for as that is no +less terrible to the criminals themselves than death, so they think the +preserving them in a state of servitude is more for the interest of the +commonwealth than killing them, since, as their labour is a greater +benefit to the public than their death could be, so the sight of their +misery is a more lasting terror to other men than that which would be +given by their death. If their slaves rebel, and will not bear their +yoke and submit to the labour that is enjoined them, they are treated as +wild beasts that cannot be kept in order, neither by a prison nor by +their chains, and are at last put to death. But those who bear their +punishment patiently, and are so much wrought on by that pressure that +lies so hard on them, that it appears they are really more troubled for +the crimes they have committed than for the miseries they suffer, are not +out of hope, but that, at last, either the Prince will, by his +prerogative, or the people, by their intercession, restore them again to +their liberty, or, at least, very much mitigate their slavery. He that +tempts a married woman to adultery is no less severely punished than he +that commits it, for they believe that a deliberate design to commit a +crime is equal to the fact itself, since its not taking effect does not +make the person that miscarried in his attempt at all the less guilty. + +"They take great pleasure in fools, and as it is thought a base and +unbecoming thing to use them ill, so they do not think it amiss for +people to divert themselves with their folly; and, in their opinion, this +is a great advantage to the fools themselves; for if men were so sullen +and severe as not at all to please themselves with their ridiculous +behaviour and foolish sayings, which is all that they can do to recommend +themselves to others, it could not be expected that they would be so well +provided for nor so tenderly used as they must otherwise be. If any man +should reproach another for his being misshaped or imperfect in any part +of his body, it would not at all be thought a reflection on the person so +treated, but it would be accounted scandalous in him that had upbraided +another with what he could not help. It is thought a sign of a sluggish +and sordid mind not to preserve carefully one's natural beauty; but it is +likewise infamous among them to use paint. They all see that no beauty +recommends a wife so much to her husband as the probity of her life and +her obedience; for as some few are caught and held only by beauty, so all +are attracted by the other excellences which charm all the world. + +"As they fright men from committing crimes by punishments, so they invite +them to the love of virtue by public honours; therefore they erect +statues to the memories of such worthy men as have deserved well of their +country, and set these in their market-places, both to perpetuate the +remembrance of their actions and to be an incitement to their posterity +to follow their example. + +"If any man aspires to any office he is sure never to compass it. They +all live easily together, for none of the magistrates are either insolent +or cruel to the people; they affect rather to be called fathers, and, by +being really so, they well deserve the name; and the people pay them all +the marks of honour the more freely because none are exacted from them. +The Prince himself has no distinction, either of garments or of a crown; +but is only distinguished by a sheaf of corn carried before him; as the +High Priest is also known by his being preceded by a person carrying a +wax light. + +"They have but few laws, and such is their constitution that they need +not many. They very much condemn other nations whose laws, together with +the commentaries on them, swell up to so many volumes; for they think it +an unreasonable thing to oblige men to obey a body of laws that are both +of such a bulk, and so dark as not to be read and understood by every one +of the subjects. + +"They have no lawyers among them, for they consider them as a sort of +people whose profession it is to disguise matters and to wrest the laws, +and, therefore, they think it is much better that every man should plead +his own cause, and trust it to the judge, as in other places the client +trusts it to a counsellor; by this means they both cut off many delays +and find out truth more certainly; for after the parties have laid open +the merits of the cause, without those artifices which lawyers are apt to +suggest, the judge examines the whole matter, and supports the simplicity +of such well-meaning persons, whom otherwise crafty men would be sure to +run down; and thus they avoid those evils which appear very remarkably +among all those nations that labour under a vast load of laws. Every one +of them is skilled in their law; for, as it is a very short study, so the +plainest meaning of which words are capable is always the sense of their +laws; and they argue thus: all laws are promulgated for this end, that +every man may know his duty; and, therefore, the plainest and most +obvious sense of the words is that which ought to be put upon them, since +a more refined exposition cannot be easily comprehended, and would only +serve to make the laws become useless to the greater part of mankind, and +especially to those who need most the direction of them; for it is all +one not to make a law at all or to couch it in such terms that, without a +quick apprehension and much study, a man cannot find out the true meaning +of it, since the generality of mankind are both so dull, and so much +employed in their several trades, that they have neither the leisure nor +the capacity requisite for such an inquiry. + +"Some of their neighbours, who are masters of their own liberties (having +long ago, by the assistance of the Utopians, shaken off the yoke of +tyranny, and being much taken with those virtues which they observe among +them), have come to desire that they would send magistrates to govern +them, some changing them every year, and others every five years; at the +end of their government they bring them back to Utopia, with great +expressions of honour and esteem, and carry away others to govern in +their stead. In this they seem to have fallen upon a very good expedient +for their own happiness and safety; for since the good or ill condition +of a nation depends so much upon their magistrates, they could not have +made a better choice than by pitching on men whom no advantages can bias; +for wealth is of no use to them, since they must so soon go back to their +own country, and they, being strangers among them, are not engaged in any +of their heats or animosities; and it is certain that when public +judicatories are swayed, either by avarice or partial affections, there +must follow a dissolution of justice, the chief sinew of society. + +"The Utopians call those nations that come and ask magistrates from them +Neighbours; but those to whom they have been of more particular service, +Friends; and as all other nations are perpetually either making leagues +or breaking them, they never enter into an alliance with any state. They +think leagues are useless things, and believe that if the common ties of +humanity do not knit men together, the faith of promises will have no +great effect; and they are the more confirmed in this by what they see +among the nations round about them, who are no strict observers of +leagues and treaties. We know how religiously they are observed in +Europe, more particularly where the Christian doctrine is received, among +whom they are sacred and inviolable! which is partly owing to the justice +and goodness of the princes themselves, and partly to the reverence they +pay to the popes, who, as they are the most religious observers of their +own promises, so they exhort all other princes to perform theirs, and, +when fainter methods do not prevail, they compel them to it by the +severity of the pastoral censure, and think that it would be the most +indecent thing possible if men who are particularly distinguished by the +title of 'The Faithful' should not religiously keep the faith of their +treaties. But in that new-found world, which is not more distant from us +in situation than the people are in their manners and course of life, +there is no trusting to leagues, even though they were made with all the +pomp of the most sacred ceremonies; on the contrary, they are on this +account the sooner broken, some slight pretence being found in the words +of the treaties, which are purposely couched in such ambiguous terms that +they can never be so strictly bound but they will always find some +loophole to escape at, and thus they break both their leagues and their +faith; and this is done with such impudence, that those very men who +value themselves on having suggested these expedients to their princes +would, with a haughty scorn, declaim against such craft; or, to speak +plainer, such fraud and deceit, if they found private men make use of it +in their bargains, and would readily say that they deserved to be hanged. + +"By this means it is that all sort of justice passes in the world for a +low-spirited and vulgar virtue, far below the dignity of royal +greatness--or at least there are set up two sorts of justice; the one is +mean and creeps on the ground, and, therefore, becomes none but the lower +part of mankind, and so must be kept in severely by many restraints, that +it may not break out beyond the bounds that are set to it; the other is +the peculiar virtue of princes, which, as it is more majestic than that +which becomes the rabble, so takes a freer compass, and thus lawful and +unlawful are only measured by pleasure and interest. These practices of +the princes that lie about Utopia, who make so little account of their +faith, seem to be the reasons that determine them to engage in no +confederacy. Perhaps they would change their mind if they lived among +us; but yet, though treaties were more religiously observed, they would +still dislike the custom of making them, since the world has taken up a +false maxim upon it, as if there were no tie of nature uniting one nation +to another, only separated perhaps by a mountain or a river, and that all +were born in a state of hostility, and so might lawfully do all that +mischief to their neighbours against which there is no provision made by +treaties; and that when treaties are made they do not cut off the enmity +or restrain the licence of preying upon each other, if, by the +unskilfulness of wording them, there are not effectual provisoes made +against them; they, on the other hand, judge that no man is to be +esteemed our enemy that has never injured us, and that the partnership of +human nature is instead of a league; and that kindness and good nature +unite men more effectually and with greater strength than any agreements +whatsoever, since thereby the engagements of men's hearts become stronger +than the bond and obligation of words. + + + +OF THEIR MILITARY DISCIPLINE + + +They detest war as a very brutal thing, and which, to the reproach of +human nature, is more practised by men than by any sort of beasts. They, +in opposition to the sentiments of almost all other nations, think that +there is nothing more inglorious than that glory that is gained by war; +and therefore, though they accustom themselves daily to military +exercises and the discipline of war, in which not only their men, but +their women likewise, are trained up, that, in cases of necessity, they +may not be quite useless, yet they do not rashly engage in war, unless it +be either to defend themselves or their friends from any unjust +aggressors, or, out of good nature or in compassion, assist an oppressed +nation in shaking off the yoke of tyranny. They, indeed, help their +friends not only in defensive but also in offensive wars; but they never +do that unless they had been consulted before the breach was made, and, +being satisfied with the grounds on which they went, they had found that +all demands of reparation were rejected, so that a war was unavoidable. +This they think to be not only just when one neighbour makes an inroad on +another by public order, and carries away the spoils, but when the +merchants of one country are oppressed in another, either under pretence +of some unjust laws, or by the perverse wresting of good ones. This they +count a juster cause of war than the other, because those injuries are +done under some colour of laws. This was the only ground of that war in +which they engaged with the Nephelogetes against the Aleopolitanes, a +little before our time; for the merchants of the former having, as they +thought, met with great injustice among the latter, which (whether it was +in itself right or wrong) drew on a terrible war, in which many of their +neighbours were engaged; and their keenness in carrying it on being +supported by their strength in maintaining it, it not only shook some +very flourishing states and very much afflicted others, but, after a +series of much mischief ended in the entire conquest and slavery of the +Aleopolitanes, who, though before the war they were in all respects much +superior to the Nephelogetes, were yet subdued; but, though the Utopians +had assisted them in the war, yet they pretended to no share of the +spoil. + +"But, though they so vigorously assist their friends in obtaining +reparation for the injuries they have received in affairs of this nature, +yet, if any such frauds were committed against themselves, provided no +violence was done to their persons, they would only, on their being +refused satisfaction, forbear trading with such a people. This is not +because they consider their neighbours more than their own citizens; but, +since their neighbours trade every one upon his own stock, fraud is a +more sensible injury to them than it is to the Utopians, among whom the +public, in such a case, only suffers, as they expect no thing in return +for the merchandise they export but that in which they so much abound, +and is of little use to them, the loss does not much affect them. They +think, therefore, it would be too severe to revenge a loss attended with +so little inconvenience, either to their lives or their subsistence, with +the death of many persons; but if any of their people are either killed +or wounded wrongfully, whether it be done by public authority, or only by +private men, as soon as they hear of it they send ambassadors, and demand +that the guilty persons may be delivered up to them, and if that is +denied, they declare war; but if it be complied with, the offenders are +condemned either to death or slavery. + +"They would be both troubled and ashamed of a bloody victory over their +enemies; and think it would be as foolish a purchase as to buy the most +valuable goods at too high a rate. And in no victory do they glory so +much as in that which is gained by dexterity and good conduct without +bloodshed. In such cases they appoint public triumphs, and erect +trophies to the honour of those who have succeeded; for then do they +reckon that a man acts suitably to his nature, when he conquers his enemy +in such a way as that no other creature but a man could be capable of, +and that is by the strength of his understanding. Bears, lions, boars, +wolves, and dogs, and all other animals, employ their bodily force one +against another, in which, as many of them are superior to men, both in +strength and fierceness, so they are all subdued by his reason and +understanding. + +"The only design of the Utopians in war is to obtain that by force which, +if it had been granted them in time, would have prevented the war; or, if +that cannot be done, to take so severe a revenge on those that have +injured them that they may be terrified from doing the like for the time +to come. By these ends they measure all their designs, and manage them +so, that it is visible that the appetite of fame or vainglory does not +work so much on there as a just care of their own security. + +"As soon as they declare war, they take care to have a great many +schedules, that are sealed with their common seal, affixed in the most +conspicuous places of their enemies' country. This is carried secretly, +and done in many places all at once. In these they promise great rewards +to such as shall kill the prince, and lesser in proportion to such as +shall kill any other persons who are those on whom, next to the prince +himself, they cast the chief balance of the war. And they double the sum +to him that, instead of killing the person so marked out, shall take him +alive, and put him in their hands. They offer not only indemnity, but +rewards, to such of the persons themselves that are so marked, if they +will act against their countrymen. By this means those that are named in +their schedules become not only distrustful of their fellow-citizens, but +are jealous of one another, and are much distracted by fear and danger; +for it has often fallen out that many of them, and even the prince +himself, have been betrayed, by those in whom they have trusted most; for +the rewards that the Utopians offer are so immeasurably great, that there +is no sort of crime to which men cannot be drawn by them. They consider +the risk that those run who undertake such services, and offer a +recompense proportioned to the danger--not only a vast deal of gold, but +great revenues in lands, that lie among other nations that are their +friends, where they may go and enjoy them very securely; and they observe +the promises they make of their kind most religiously. They very much +approve of this way of corrupting their enemies, though it appears to +others to be base and cruel; but they look on it as a wise course, to +make an end of what would be otherwise a long war, without so much as +hazarding one battle to decide it. They think it likewise an act of +mercy and love to mankind to prevent the great slaughter of those that +must otherwise be killed in the progress of the war, both on their own +side and on that of their enemies, by the death of a few that are most +guilty; and that in so doing they are kind even to their enemies, and +pity them no less than their own people, as knowing that the greater part +of them do not engage in the war of their own accord, but are driven into +it by the passions of their prince. + +"If this method does not succeed with them, then they sow seeds of +contention among their enemies, and animate the prince's brother, or some +of the nobility, to aspire to the crown. If they cannot disunite them by +domestic broils, then they engage their neighbours against them, and make +them set on foot some old pretensions, which are never wanting to princes +when they have occasion for them. These they plentifully supply with +money, though but very sparingly with any auxiliary troops; for they are +so tender of their own people that they would not willingly exchange one +of them, even with the prince of their enemies' country. + +"But as they keep their gold and silver only for such an occasion, so, +when that offers itself, they easily part with it; since it would be no +convenience to them, though they should reserve nothing of it to +themselves. For besides the wealth that they have among them at home, +they have a vast treasure abroad; many nations round about them being +deep in their debt: so that they hire soldiers from all places for +carrying on their wars; but chiefly from the Zapolets, who live five +hundred miles east of Utopia. They are a rude, wild, and fierce nation, +who delight in the woods and rocks, among which they were born and bred +up. They are hardened both against heat, cold, and labour, and know +nothing of the delicacies of life. They do not apply themselves to +agriculture, nor do they care either for their houses or their clothes: +cattle is all that they look after; and for the greatest part they live +either by hunting or upon rapine; and are made, as it were, only for war. +They watch all opportunities of engaging in it, and very readily embrace +such as are offered them. Great numbers of them will frequently go out, +and offer themselves for a very low pay, to serve any that will employ +them: they know none of the arts of life, but those that lead to the +taking it away; they serve those that hire them, both with much courage +and great fidelity; but will not engage to serve for any determined time, +and agree upon such terms, that the next day they may go over to the +enemies of those whom they serve if they offer them a greater +encouragement; and will, perhaps, return to them the day after that upon +a higher advance of their pay. There are few wars in which they make not +a considerable part of the armies of both sides: so it often falls out +that they who are related, and were hired in the same country, and so +have lived long and familiarly together, forgetting both their relations +and former friendship, kill one another upon no other consideration than +that of being hired to it for a little money by princes of different +interests; and such a regard have they for money that they are easily +wrought on by the difference of one penny a day to change sides. So +entirely does their avarice influence them; and yet this money, which +they value so highly, is of little use to them; for what they purchase +thus with their blood they quickly waste on luxury, which among them is +but of a poor and miserable form. + +"This nation serves the Utopians against all people whatsoever, for they +pay higher than any other. The Utopians hold this for a maxim, that as +they seek out the best sort of men for their own use at home, so they +make use of this worst sort of men for the consumption of war; and +therefore they hire them with the offers of vast rewards to expose +themselves to all sorts of hazards, out of which the greater part never +returns to claim their promises; yet they make them good most religiously +to such as escape. This animates them to adventure again, whenever there +is occasion for it; for the Utopians are not at all troubled how many of +these happen to be killed, and reckon it a service done to mankind if +they could be a means to deliver the world from such a lewd and vicious +sort of people, that seem to have run together, as to the drain of human +nature. Next to these, they are served in their wars with those upon +whose account they undertake them, and with the auxiliary troops of their +other friends, to whom they join a few of their own people, and send some +man of eminent and approved virtue to command in chief. There are two +sent with him, who, during his command, are but private men, but the +first is to succeed him if he should happen to be either killed or taken; +and, in case of the like misfortune to him, the third comes in his place; +and thus they provide against all events, that such accidents as may +befall their generals may not endanger their armies. When they draw out +troops of their own people, they take such out of every city as freely +offer themselves, for none are forced to go against their wills, since +they think that if any man is pressed that wants courage, he will not +only act faintly, but by his cowardice dishearten others. But if an +invasion is made on their country, they make use of such men, if they +have good bodies, though they are not brave; and either put them aboard +their ships, or place them on the walls of their towns, that being so +posted, they may find no opportunity of flying away; and thus either +shame, the heat of action, or the impossibility of flying, bears down +their cowardice; they often make a virtue of necessity, and behave +themselves well, because nothing else is left them. But as they force no +man to go into any foreign war against his will, so they do not hinder +those women who are willing to go along with their husbands; on the +contrary, they encourage and praise them, and they stand often next their +husbands in the front of the army. They also place together those who +are related, parents, and children, kindred, and those that are mutually +allied, near one another; that those whom nature has inspired with the +greatest zeal for assisting one another may be the nearest and readiest +to do it; and it is matter of great reproach if husband or wife survive +one another, or if a child survives his parent, and therefore when they +come to be engaged in action, they continue to fight to the last man, if +their enemies stand before them: and as they use all prudent methods to +avoid the endangering their own men, and if it is possible let all the +action and danger fall upon the troops that they hire, so if it becomes +necessary for themselves to engage, they then charge with as much courage +as they avoided it before with prudence: nor is it a fierce charge at +first, but it increases by degrees; and as they continue in action, they +grow more obstinate, and press harder upon the enemy, insomuch that they +will much sooner die than give ground; for the certainty that their +children will be well looked after when they are dead frees them from all +that anxiety concerning them which often masters men of great courage; +and thus they are animated by a noble and invincible resolution. Their +skill in military affairs increases their courage: and the wise +sentiments which, according to the laws of their country, are instilled +into them in their education, give additional vigour to their minds: for +as they do not undervalue life so as prodigally to throw it away, they +are not so indecently fond of it as to preserve it by base and unbecoming +methods. In the greatest heat of action the bravest of their youth, who +have devoted themselves to that service, single out the general of their +enemies, set on him either openly or by ambuscade; pursue him everywhere, +and when spent and wearied out, are relieved by others, who never give +over the pursuit, either attacking him with close weapons when they can +get near him, or with those which wound at a distance, when others get in +between them. So that, unless he secures himself by flight, they seldom +fail at last to kill or to take him prisoner. When they have obtained a +victory, they kill as few as possible, and are much more bent on taking +many prisoners than on killing those that fly before them. Nor do they +ever let their men so loose in the pursuit of their enemies as not to +retain an entire body still in order; so that if they have been forced to +engage the last of their battalions before they could gain the day, they +will rather let their enemies all escape than pursue them when their own +army is in disorder; remembering well what has often fallen out to +themselves, that when the main body of their army has been quite defeated +and broken, when their enemies, imagining the victory obtained, have let +themselves loose into an irregular pursuit, a few of them that lay for a +reserve, waiting a fit opportunity, have fallen on them in their chase, +and when straggling in disorder, and apprehensive of no danger, but +counting the day their own, have turned the whole action, and, wresting +out of their hands a victory that seemed certain and undoubted, while the +vanquished have suddenly become victorious. + +"It is hard to tell whether they are more dexterous in laying or avoiding +ambushes. They sometimes seem to fly when it is far from their thoughts; +and when they intend to give ground, they do it so that it is very hard +to find out their design. If they see they are ill posted, or are like +to be overpowered by numbers, they then either march off in the night +with great silence, or by some stratagem delude their enemies. If they +retire in the day-time, they do it in such order that it is no less +dangerous to fall upon them in a retreat than in a march. They fortify +their camps with a deep and large trench; and throw up the earth that is +dug out of it for a wall; nor do they employ only their slaves in this, +but the whole army works at it, except those that are then upon the +guard; so that when so many hands are at work, a great line and a strong +fortification is finished in so short a time that it is scarce credible. +Their armour is very strong for defence, and yet is not so heavy as to +make them uneasy in their marches; they can even swim with it. All that +are trained up to war practise swimming. Both horse and foot make great +use of arrows, and are very expert. They have no swords, but fight with +a pole-axe that is both sharp and heavy, by which they thrust or strike +down an enemy. They are very good at finding out warlike machines, and +disguise them so well that the enemy does not perceive them till he feels +the use of them; so that he cannot prepare such a defence as would render +them useless; the chief consideration had in the making them is that they +may be easily carried and managed. + +"If they agree to a truce, they observe it so religiously that no +provocations will make them break it. They never lay their enemies' +country waste nor burn their corn, and even in their marches they take +all possible care that neither horse nor foot may tread it down, for they +do not know but that they may have use for it themselves. They hurt no +man whom they find disarmed, unless he is a spy. When a town is +surrendered to them, they take it into their protection; and when they +carry a place by storm they never plunder it, but put those only to the +sword that oppose the rendering of it up, and make the rest of the +garrison slaves, but for the other inhabitants, they do them no hurt; and +if any of them had advised a surrender, they give them good rewards out +of the estates of those that they condemn, and distribute the rest among +their auxiliary troops, but they themselves take no share of the spoil. + +"When a war is ended, they do not oblige their friends to reimburse their +expenses; but they obtain them of the conquered, either in money, which +they keep for the next occasion, or in lands, out of which a constant +revenue is to be paid them; by many increases the revenue which they draw +out from several countries on such occasions is now risen to above +700,000 ducats a year. They send some of their own people to receive +these revenues, who have orders to live magnificently and like princes, +by which means they consume much of it upon the place; and either bring +over the rest to Utopia or lend it to that nation in which it lies. This +they most commonly do, unless some great occasion, which falls out but +very seldom, should oblige them to call for it all. It is out of these +lands that they assign rewards to such as they encourage to adventure on +desperate attempts. If any prince that engages in war with them is +making preparations for invading their country, they prevent him, and +make his country the seat of the war; for they do not willingly suffer +any war to break in upon their island; and if that should happen, they +would only defend themselves by their own people; but would not call for +auxiliary troops to their assistance. + + + +OF THE RELIGIONS OF THE UTOPIANS + + +"There are several sorts of religions, not only in different parts of the +island, but even in every town; some worshipping the sun, others the moon +or one of the planets. Some worship such men as have been eminent in +former times for virtue or glory, not only as ordinary deities, but as +the supreme god. Yet the greater and wiser sort of them worship none of +these, but adore one eternal, invisible, infinite, and incomprehensible +Deity; as a Being that is far above all our apprehensions, that is spread +over the whole universe, not by His bulk, but by His power and virtue; +Him they call the Father of All, and acknowledge that the beginnings, the +increase, the progress, the vicissitudes, and the end of all things come +only from Him; nor do they offer divine honours to any but to Him alone. +And, indeed, though they differ concerning other things, yet all agree in +this: that they think there is one Supreme Being that made and governs +the world, whom they call, in the language of their country, Mithras. +They differ in this: that one thinks the god whom he worships is this +Supreme Being, and another thinks that his idol is that god; but they all +agree in one principle, that whoever is this Supreme Being, He is also +that great essence to whose glory and majesty all honours are ascribed by +the consent of all nations. + +"By degrees they fall off from the various superstitions that are among +them, and grow up to that one religion that is the best and most in +request; and there is no doubt to be made, but that all the others had +vanished long ago, if some of those who advised them to lay aside their +superstitions had not met with some unhappy accidents, which, being +considered as inflicted by heaven, made them afraid that the god whose +worship had like to have been abandoned had interposed and revenged +themselves on those who despised their authority. + +"After they had heard from us an account of the doctrine, the course of +life, and the miracles of Christ, and of the wonderful constancy of so +many martyrs, whose blood, so willingly offered up by them, was the chief +occasion of spreading their religion over a vast number of nations, it is +not to be imagined how inclined they were to receive it. I shall not +determine whether this proceeded from any secret inspiration of God, or +whether it was because it seemed so favourable to that community of +goods, which is an opinion so particular as well as so dear to them; +since they perceived that Christ and His followers lived by that rule, +and that it was still kept up in some communities among the sincerest +sort of Christians. From whichsoever of these motives it might be, true +it is, that many of them came over to our religion, and were initiated +into it by baptism. But as two of our number were dead, so none of the +four that survived were in priests' orders, we, therefore, could only +baptise them, so that, to our great regret, they could not partake of the +other sacraments, that can only be administered by priests, but they are +instructed concerning them and long most vehemently for them. They have +had great disputes among themselves, whether one chosen by them to be a +priest would not be thereby qualified to do all the things that belong to +that character, even though he had no authority derived from the Pope, +and they seemed to be resolved to choose some for that employment, but +they had not done it when I left them. + +"Those among them that have not received our religion do not fright any +from it, and use none ill that goes over to it, so that all the while I +was there one man was only punished on this occasion. He being newly +baptised did, notwithstanding all that we could say to the contrary, +dispute publicly concerning the Christian religion, with more zeal than +discretion, and with so much heat, that he not only preferred our worship +to theirs, but condemned all their rites as profane, and cried out +against all that adhered to them as impious and sacrilegious persons, +that were to be damned to everlasting burnings. Upon his having +frequently preached in this manner he was seized, and after trial he was +condemned to banishment, not for having disparaged their religion, but +for his inflaming the people to sedition; for this is one of their most +ancient laws, that no man ought to be punished for his religion. At the +first constitution of their government, Utopus having understood that +before his coming among them the old inhabitants had been engaged in +great quarrels concerning religion, by which they were so divided among +themselves, that he found it an easy thing to conquer them, since, +instead of uniting their forces against him, every different party in +religion fought by themselves. After he had subdued them he made a law +that every man might be of what religion he pleased, and might endeavour +to draw others to it by the force of argument and by amicable and modest +ways, but without bitterness against those of other opinions; but that he +ought to use no other force but that of persuasion, and was neither to +mix with it reproaches nor violence; and such as did otherwise were to be +condemned to banishment or slavery. + +"This law was made by Utopus, not only for preserving the public peace, +which he saw suffered much by daily contentions and irreconcilable heats, +but because he thought the interest of religion itself required it. He +judged it not fit to determine anything rashly; and seemed to doubt +whether those different forms of religion might not all come from God, +who might inspire man in a different manner, and be pleased with this +variety; he therefore thought it indecent and foolish for any man to +threaten and terrify another to make him believe what did not appear to +him to be true. And supposing that only one religion was really true, +and the rest false, he imagined that the native force of truth would at +last break forth and shine bright, if supported only by the strength of +argument, and attended to with a gentle and unprejudiced mind; while, on +the other hand, if such debates were carried on with violence and +tumults, as the most wicked are always the most obstinate, so the best +and most holy religion might be choked with superstition, as corn is with +briars and thorns; he therefore left men wholly to their liberty, that +they might be free to believe as they should see cause; only he made a +solemn and severe law against such as should so far degenerate from the +dignity of human nature, as to think that our souls died with our bodies, +or that the world was governed by chance, without a wise overruling +Providence: for they all formerly believed that there was a state of +rewards and punishments to the good and bad after this life; and they now +look on those that think otherwise as scarce fit to be counted men, since +they degrade so noble a being as the soul, and reckon it no better than a +beast's: thus they are far from looking on such men as fit for human +society, or to be citizens of a well-ordered commonwealth; since a man of +such principles must needs, as oft as he dares do it, despise all their +laws and customs: for there is no doubt to be made, that a man who is +afraid of nothing but the law, and apprehends nothing after death, will +not scruple to break through all the laws of his country, either by fraud +or force, when by this means he may satisfy his appetites. They never +raise any that hold these maxims, either to honours or offices, nor +employ them in any public trust, but despise them, as men of base and +sordid minds. Yet they do not punish them, because they lay this down as +a maxim, that a man cannot make himself believe anything he pleases; nor +do they drive any to dissemble their thoughts by threatenings, so that +men are not tempted to lie or disguise their opinions; which being a sort +of fraud, is abhorred by the Utopians: they take care indeed to prevent +their disputing in defence of these opinions, especially before the +common people: but they suffer, and even encourage them to dispute +concerning them in private with their priest, and other grave men, being +confident that they will be cured of those mad opinions by having reason +laid before them. There are many among them that run far to the other +extreme, though it is neither thought an ill nor unreasonable opinion, +and therefore is not at all discouraged. They think that the souls of +beasts are immortal, though far inferior to the dignity of the human +soul, and not capable of so great a happiness. They are almost all of +them very firmly persuaded that good men will be infinitely happy in +another state: so that though they are compassionate to all that are +sick, yet they lament no man's death, except they see him loath to part +with life; for they look on this as a very ill presage, as if the soul, +conscious to itself of guilt, and quite hopeless, was afraid to leave the +body, from some secret hints of approaching misery. They think that such +a man's appearance before God cannot be acceptable to Him, who being +called on, does not go out cheerfully, but is backward and unwilling, and +is as it were dragged to it. They are struck with horror when they see +any die in this manner, and carry them out in silence and with sorrow, +and praying God that He would be merciful to the errors of the departed +soul, they lay the body in the ground: but when any die cheerfully, and +full of hope, they do not mourn for them, but sing hymns when they carry +out their bodies, and commending their souls very earnestly to God: their +whole behaviour is then rather grave than sad, they burn the body, and +set up a pillar where the pile was made, with an inscription to the +honour of the deceased. When they come from the funeral, they discourse +of his good life, and worthy actions, but speak of nothing oftener and +with more pleasure than of his serenity at the hour of death. They think +such respect paid to the memory of good men is both the greatest +incitement to engage others to follow their example, and the most +acceptable worship that can be offered them; for they believe that though +by the imperfection of human sight they are invisible to us, yet they are +present among us, and hear those discourses that pass concerning +themselves. They believe it inconsistent with the happiness of departed +souls not to be at liberty to be where they will: and do not imagine them +capable of the ingratitude of not desiring to see those friends with whom +they lived on earth in the strictest bonds of love and kindness: besides, +they are persuaded that good men, after death, have these affections; and +all other good dispositions increased rather than diminished, and +therefore conclude that they are still among the living, and observe all +they say or do. From hence they engage in all their affairs with the +greater confidence of success, as trusting to their protection; while +this opinion of the presence of their ancestors is a restraint that +prevents their engaging in ill designs. + +"They despise and laugh at auguries, and the other vain and superstitious +ways of divination, so much observed among other nations; but have great +reverence for such miracles as cannot flow from any of the powers of +nature, and look on them as effects and indications of the presence of +the Supreme Being, of which they say many instances have occurred among +them; and that sometimes their public prayers, which upon great and +dangerous occasions they have solemnly put up to God, with assured +confidence of being heard, have been answered in a miraculous manner. + +"They think the contemplating God in His works, and the adoring Him for +them, is a very acceptable piece of worship to Him. + +"There are many among them that upon a motive of religion neglect +learning, and apply themselves to no sort of study; nor do they allow +themselves any leisure time, but are perpetually employed, believing that +by the good things that a man does he secures to himself that happiness +that comes after death. Some of these visit the sick; others mend +highways, cleanse ditches, repair bridges, or dig turf, gravel, or stone. +Others fell and cleave timber, and bring wood, corn, and other +necessaries, on carts, into their towns; nor do these only serve the +public, but they serve even private men, more than the slaves themselves +do: for if there is anywhere a rough, hard, and sordid piece of work to +be done, from which many are frightened by the labour and loathsomeness +of it, if not the despair of accomplishing it, they cheerfully, and of +their own accord, take that to their share; and by that means, as they +ease others very much, so they afflict themselves, and spend their whole +life in hard labour: and yet they do not value themselves upon this, nor +lessen other people's credit to raise their own; but by their stooping to +such servile employments they are so far from being despised, that they +are so much the more esteemed by the whole nation. + +"Of these there are two sorts: some live unmarried and chaste, and +abstain from eating any sort of flesh; and thus weaning themselves from +all the pleasures of the present life, which they account hurtful, they +pursue, even by the hardest and painfullest methods possible, that +blessedness which they hope for hereafter; and the nearer they approach +to it, they are the more cheerful and earnest in their endeavours after +it. Another sort of them is less willing to put themselves to much toil, +and therefore prefer a married state to a single one; and as they do not +deny themselves the pleasure of it, so they think the begetting of +children is a debt which they owe to human nature, and to their country; +nor do they avoid any pleasure that does not hinder labour; and therefore +eat flesh so much the more willingly, as they find that by this means +they are the more able to work: the Utopians look upon these as the wiser +sect, but they esteem the others as the most holy. They would indeed +laugh at any man who, from the principles of reason, would prefer an +unmarried state to a married, or a life of labour to an easy life: but +they reverence and admire such as do it from the motives of religion. +There is nothing in which they are more cautious than in giving their +opinion positively concerning any sort of religion. The men that lead +those severe lives are called in the language of their country +Brutheskas, which answers to those we call Religious Orders. + +"Their priests are men of eminent piety, and therefore they are but few, +for there are only thirteen in every town, one for every temple; but when +they go to war, seven of these go out with their forces, and seven others +are chosen to supply their room in their absence; but these enter again +upon their employments when they return; and those who served in their +absence, attend upon the high priest, till vacancies fall by death; for +there is one set over the rest. They are chosen by the people as the +other magistrates are, by suffrages given in secret, for preventing of +factions: and when they are chosen, they are consecrated by the college +of priests. The care of all sacred things, the worship of God, and an +inspection into the manners of the people, are committed to them. It is +a reproach to a man to be sent for by any of them, or for them to speak +to him in secret, for that always gives some suspicion: all that is +incumbent on them is only to exhort and admonish the people; for the +power of correcting and punishing ill men belongs wholly to the Prince, +and to the other magistrates: the severest thing that the priest does is +the excluding those that are desperately wicked from joining in their +worship: there is not any sort of punishment more dreaded by them than +this, for as it loads them with infamy, so it fills them with secret +horrors, such is their reverence to their religion; nor will their bodies +be long exempted from their share of trouble; for if they do not very +quickly satisfy the priests of the truth of their repentance, they are +seized on by the Senate, and punished for their impiety. The education +of youth belongs to the priests, yet they do not take so much care of +instructing them in letters, as in forming their minds and manners +aright; they use all possible methods to infuse, very early, into the +tender and flexible minds of children, such opinions as are both good in +themselves and will be useful to their country, for when deep impressions +of these things are made at that age, they follow men through the whole +course of their lives, and conduce much to preserve the peace of the +government, which suffers by nothing more than by vices that rise out of +ill opinions. The wives of their priests are the most extraordinary +women of the whole country; sometimes the women themselves are made +priests, though that falls out but seldom, nor are any but ancient widows +chosen into that order. + +"None of the magistrates have greater honour paid them than is paid the +priests; and if they should happen to commit any crime, they would not be +questioned for it; their punishment is left to God, and to their own +consciences; for they do not think it lawful to lay hands on any man, how +wicked soever he is, that has been in a peculiar manner dedicated to God; +nor do they find any great inconvenience in this, both because they have +so few priests, and because these are chosen with much caution, so that +it must be a very unusual thing to find one who, merely out of regard to +his virtue, and for his being esteemed a singularly good man, was raised +up to so great a dignity, degenerate into corruption and vice; and if +such a thing should fall out, for man is a changeable creature, yet, +there being few priests, and these having no authority but what rises out +of the respect that is paid them, nothing of great consequence to the +public can proceed from the indemnity that the priests enjoy. + +"They have, indeed, very few of them, lest greater numbers sharing in the +same honour might make the dignity of that order, which they esteem so +highly, to sink in its reputation; they also think it difficult to find +out many of such an exalted pitch of goodness as to be equal to that +dignity, which demands the exercise of more than ordinary virtues. Nor +are the priests in greater veneration among them than they are among +their neighbouring nations, as you may imagine by that which I think +gives occasion for it. + +"When the Utopians engage in battle, the priests who accompany them to +the war, apparelled in their sacred vestments, kneel down during the +action (in a place not far from the field), and, lifting up their hands +to heaven, pray, first for peace, and then for victory to their own side, +and particularly that it may be gained without the effusion of much blood +on either side; and when the victory turns to their side, they run in +among their own men to restrain their fury; and if any of their enemies +see them or call to them, they are preserved by that means; and such as +can come so near them as to touch their garments have not only their +lives, but their fortunes secured to them; it is upon this account that +all the nations round about consider them so much, and treat them with +such reverence, that they have been often no less able to preserve their +own people from the fury of their enemies than to save their enemies from +their rage; for it has sometimes fallen out, that when their armies have +been in disorder and forced to fly, so that their enemies were running +upon the slaughter and spoil, the priests by interposing have separated +them from one another, and stopped the effusion of more blood; so that, +by their mediation, a peace has been concluded on very reasonable terms; +nor is there any nation about them so fierce, cruel, or barbarous, as not +to look upon their persons as sacred and inviolable. + +"The first and the last day of the month, and of the year, is a festival; +they measure their months by the course of the moon, and their years by +the course of the sun: the first days are called in their language the +Cynemernes, and the last the Trapemernes, which answers in our language, +to the festival that begins or ends the season. + +"They have magnificent temples, that are not only nobly built, but +extremely spacious, which is the more necessary as they have so few of +them; they are a little dark within, which proceeds not from any error in +the architecture, but is done with design; for their priests think that +too much light dissipates the thoughts, and that a more moderate degree +of it both recollects the mind and raises devotion. Though there are +many different forms of religion among them, yet all these, how various +soever, agree in the main point, which is the worshipping the Divine +Essence; and, therefore, there is nothing to be seen or heard in their +temples in which the several persuasions among them may not agree; for +every sect performs those rites that are peculiar to it in their private +houses, nor is there anything in the public worship that contradicts the +particular ways of those different sects. There are no images for God in +their temples, so that every one may represent Him to his thoughts +according to the way of his religion; nor do they call this one God by +any other name but that of Mithras, which is the common name by which +they all express the Divine Essence, whatsoever otherwise they think it +to be; nor are there any prayers among them but such as every one of them +may use without prejudice to his own opinion. + +"They meet in their temples on the evening of the festival that concludes +a season, and not having yet broke their fast, they thank God for their +good success during that year or month which is then at an end; and the +next day, being that which begins the new season, they meet early in +their temples, to pray for the happy progress of all their affairs during +that period upon which they then enter. In the festival which concludes +the period, before they go to the temple, both wives and children fall on +their knees before their husbands or parents and confess everything in +which they have either erred or failed in their duty, and beg pardon for +it. Thus all little discontents in families are removed, that they may +offer up their devotions with a pure and serene mind; for they hold it a +great impiety to enter upon them with disturbed thoughts, or with a +consciousness of their bearing hatred or anger in their hearts to any +person whatsoever; and think that they should become liable to severe +punishments if they presumed to offer sacrifices without cleansing their +hearts, and reconciling all their differences. In the temples the two +sexes are separated, the men go to the right hand, and the women to the +left; and the males and females all place themselves before the head and +master or mistress of the family to which they belong, so that those who +have the government of them at home may see their deportment in public. +And they intermingle them so, that the younger and the older may be set +by one another; for if the younger sort were all set together, they +would, perhaps, trifle away that time too much in which they ought to +beget in themselves that religious dread of the Supreme Being which is +the greatest and almost the only incitement to virtue. + +"They offer up no living creature in sacrifice, nor do they think it +suitable to the Divine Being, from whose bounty it is that these +creatures have derived their lives, to take pleasure in their deaths, or +the offering up their blood. They burn incense and other sweet odours, +and have a great number of wax lights during their worship, not out of +any imagination that such oblations can add anything to the divine nature +(which even prayers cannot do), but as it is a harmless and pure way of +worshipping God; so they think those sweet savours and lights, together +with some other ceremonies, by a secret and unaccountable virtue, elevate +men's souls, and inflame them with greater energy and cheerfulness during +the divine worship. + +"All the people appear in the temples in white garments; but the priest's +vestments are parti-coloured, and both the work and colours are +wonderful. They are made of no rich materials, for they are neither +embroidered nor set with precious stones; but are composed of the plumes +of several birds, laid together with so much art, and so neatly, that the +true value of them is far beyond the costliest materials. They say, that +in the ordering and placing those plumes some dark mysteries are +represented, which pass down among their priests in a secret tradition +concerning them; and that they are as hieroglyphics, putting them in mind +of the blessing that they have received from God, and of their duties, +both to Him and to their neighbours. As soon as the priest appears in +those ornaments, they all fall prostrate on the ground, with so much +reverence and so deep a silence, that such as look on cannot but be +struck with it, as if it were the effect of the appearance of a deity. +After they have been for some time in this posture, they all stand up, +upon a sign given by the priest, and sing hymns to the honour of God, +some musical instruments playing all the while. These are quite of +another form than those used among us; but, as many of them are much +sweeter than ours, so others are made use of by us. Yet in one thing +they very much exceed us: all their music, both vocal and instrumental, +is adapted to imitate and express the passions, and is so happily suited +to every occasion, that, whether the subject of the hymn be cheerful, or +formed to soothe or trouble the mind, or to express grief or remorse, the +music takes the impression of whatever is represented, affects and +kindles the passions, and works the sentiments deep into the hearts of +the hearers. When this is done, both priests and people offer up very +solemn prayers to God in a set form of words; and these are so composed, +that whatsoever is pronounced by the whole assembly may be likewise +applied by every man in particular to his own condition. In these they +acknowledge God to be the author and governor of the world, and the +fountain of all the good they receive, and therefore offer up to him +their thanksgiving; and, in particular, bless him for His goodness in +ordering it so, that they are born under the happiest government in the +world, and are of a religion which they hope is the truest of all others; +but, if they are mistaken, and if there is either a better government, or +a religion more acceptable to God, they implore His goodness to let them +know it, vowing that they resolve to follow him whithersoever he leads +them; but if their government is the best, and their religion the truest, +then they pray that He may fortify them in it, and bring all the world +both to the same rules of life, and to the same opinions concerning +Himself, unless, according to the unsearchableness of His mind, He is +pleased with a variety of religions. Then they pray that God may give +them an easy passage at last to Himself, not presuming to set limits to +Him, how early or late it should be; but, if it may be wished for without +derogating from His supreme authority, they desire to be quickly +delivered, and to be taken to Himself, though by the most terrible kind +of death, rather than to be detained long from seeing Him by the most +prosperous course of life. When this prayer is ended, they all fall down +again upon the ground; and, after a little while, they rise up, go home +to dinner, and spend the rest of the day in diversion or military +exercises. + +"Thus have I described to you, as particularly as I could, the +Constitution of that commonwealth, which I do not only think the best in +the world, but indeed the only commonwealth that truly deserves that +name. In all other places it is visible that, while people talk of a +commonwealth, every man only seeks his own wealth; but there, where no +man has any property, all men zealously pursue the good of the public, +and, indeed, it is no wonder to see men act so differently, for in other +commonwealths every man knows that, unless he provides for himself, how +flourishing soever the commonwealth may be, he must die of hunger, so +that he sees the necessity of preferring his own concerns to the public; +but in Utopia, where every man has a right to everything, they all know +that if care is taken to keep the public stores full no private man can +want anything; for among them there is no unequal distribution, so that +no man is poor, none in necessity, and though no man has anything, yet +they are all rich; for what can make a man so rich as to lead a serene +and cheerful life, free from anxieties; neither apprehending want +himself, nor vexed with the endless complaints of his wife? He is not +afraid of the misery of his children, nor is he contriving how to raise a +portion for his daughters; but is secure in this, that both he and his +wife, his children and grand-children, to as many generations as he can +fancy, will all live both plentifully and happily; since, among them, +there is no less care taken of those who were once engaged in labour, but +grow afterwards unable to follow it, than there is, elsewhere, of these +that continue still employed. I would gladly hear any man compare the +justice that is among them with that of all other nations; among whom, +may I perish, if I see anything that looks either like justice or equity; +for what justice is there in this: that a nobleman, a goldsmith, a +banker, or any other man, that either does nothing at all, or, at best, +is employed in things that are of no use to the public, should live in +great luxury and splendour upon what is so ill acquired, and a mean man, +a carter, a smith, or a ploughman, that works harder even than the beasts +themselves, and is employed in labours so necessary, that no commonwealth +could hold out a year without them, can only earn so poor a livelihood +and must lead so miserable a life, that the condition of the beasts is +much better than theirs? For as the beasts do not work so constantly, so +they feed almost as well, and with more pleasure, and have no anxiety +about what is to come, whilst these men are depressed by a barren and +fruitless employment, and tormented with the apprehensions of want in +their old age; since that which they get by their daily labour does but +maintain them at present, and is consumed as fast as it comes in, there +is no overplus left to lay up for old age. + +"Is not that government both unjust and ungrateful, that is so prodigal +of its favours to those that are called gentlemen, or goldsmiths, or such +others who are idle, or live either by flattery or by contriving the arts +of vain pleasure, and, on the other hand, takes no care of those of a +meaner sort, such as ploughmen, colliers, and smiths, without whom it +could not subsist? But after the public has reaped all the advantage of +their service, and they come to be oppressed with age, sickness, and +want, all their labours and the good they have done is forgotten, and all +the recompense given them is that they are left to die in great misery. +The richer sort are often endeavouring to bring the hire of labourers +lower, not only by their fraudulent practices, but by the laws which they +procure to be made to that effect, so that though it is a thing most +unjust in itself to give such small rewards to those who deserve so well +of the public, yet they have given those hardships the name and colour of +justice, by procuring laws to be made for regulating them. + +"Therefore I must say that, as I hope for mercy, I can have no other +notion of all the other governments that I see or know, than that they +are a conspiracy of the rich, who, on pretence of managing the public, +only pursue their private ends, and devise all the ways and arts they can +find out; first, that they may, without danger, preserve all that they +have so ill-acquired, and then, that they may engage the poor to toil and +labour for them at as low rates as possible, and oppress them as much as +they please; and if they can but prevail to get these contrivances +established by the show of public authority, which is considered as the +representative of the whole people, then they are accounted laws; yet +these wicked men, after they have, by a most insatiable covetousness, +divided that among themselves with which all the rest might have been +well supplied, are far from that happiness that is enjoyed among the +Utopians; for the use as well as the desire of money being extinguished, +much anxiety and great occasions of mischief is cut off with it, and who +does not see that the frauds, thefts, robberies, quarrels, tumults, +contentions, seditions, murders, treacheries, and witchcrafts, which are, +indeed, rather punished than restrained by the seventies of law, would +all fall off, if money were not any more valued by the world? Men's +fears, solicitudes, cares, labours, and watchings would all perish in the +same moment with the value of money; even poverty itself, for the relief +of which money seems most necessary, would fall. But, in order to the +apprehending this aright, take one instance:-- + +"Consider any year, that has been so unfruitful that many thousands have +died of hunger; and yet if, at the end of that year, a survey was made of +the granaries of all the rich men that have hoarded up the corn, it would +be found that there was enough among them to have prevented all that +consumption of men that perished in misery; and that, if it had been +distributed among them, none would have felt the terrible effects of that +scarcity: so easy a thing would it be to supply all the necessities of +life, if that blessed thing called money, which is pretended to be +invented for procuring them was not really the only thing that obstructed +their being procured! + +"I do not doubt but rich men are sensible of this, and that they well +know how much a greater happiness it is to want nothing necessary, than +to abound in many superfluities; and to be rescued out of so much misery, +than to abound with so much wealth: and I cannot think but the sense of +every man's interest, added to the authority of Christ's commands, who, +as He was infinitely wise, knew what was best, and was not less good in +discovering it to us, would have drawn all the world over to the laws of +the Utopians, if pride, that plague of human nature, that source of so +much misery, did not hinder it; for this vice does not measure happiness +so much by its own conveniences, as by the miseries of others; and would +not be satisfied with being thought a goddess, if none were left that +were miserable, over whom she might insult. Pride thinks its own +happiness shines the brighter, by comparing it with the misfortunes of +other persons; that by displaying its own wealth they may feel their +poverty the more sensibly. This is that infernal serpent that creeps +into the breasts of mortals, and possesses them too much to be easily +drawn out; and, therefore, I am glad that the Utopians have fallen upon +this form of government, in which I wish that all the world could be so +wise as to imitate them; for they have, indeed, laid down such a scheme +and foundation of policy, that as men live happily under it, so it is +like to be of great continuance; for they having rooted out of the minds +of their people all the seeds, both of ambition and faction, there is no +danger of any commotions at home; which alone has been the ruin of many +states that seemed otherwise to be well secured; but as long as they live +in peace at home, and are governed by such good laws, the envy of all +their neighbouring princes, who have often, though in vain, attempted +their ruin, will never be able to put their state into any commotion or +disorder." + +When Raphael had thus made an end of speaking, though many things +occurred to me, both concerning the manners and laws of that people, that +seemed very absurd, as well in their way of making war, as in their +notions of religion and divine matters--together with several other +particulars, but chiefly what seemed the foundation of all the rest, +their living in common, without the use of money, by which all nobility, +magnificence, splendour, and majesty, which, according to the common +opinion, are the true ornaments of a nation, would be quite taken +away--yet since I perceived that Raphael was weary, and was not sure +whether he could easily bear contradiction, remembering that he had taken +notice of some, who seemed to think they were bound in honour to support +the credit of their own wisdom, by finding out something to censure in +all other men's inventions, besides their own, I only commended their +Constitution, and the account he had given of it in general; and so, +taking him by the hand, carried him to supper, and told him I would find +out some other time for examining this subject more particularly, and for +discoursing more copiously upon it. And, indeed, I shall be glad to +embrace an opportunity of doing it. In the meanwhile, though it must be +confessed that he is both a very learned man and a person who has +obtained a great knowledge of the world, I cannot perfectly agree to +everything he has related. However, there are many things in the +commonwealth of Utopia that I rather wish, than hope, to see followed in +our governments. + + + +***END OF THE PROJECT GUTENBERG EBOOK UTOPIA*** + + +******* This file should be named 2130.txt or 2130.zip ******* + + +This and all associated files of various formats will be found in: +http://www.gutenberg.org/dirs/2/1/3/2130 + + + +Updated editions will replace the previous one--the old editions +will be renamed. + +Creating the works from public domain print editions means that no +one owns a United States copyright in these works, so the Foundation +(and you!) can copy and distribute it in the United States without +permission and without paying copyright royalties. Special rules, +set forth in the General Terms of Use part of this license, apply to +copying and distributing Project Gutenberg-tm electronic works to +protect the PROJECT GUTENBERG-tm concept and trademark. Project +Gutenberg is a registered trademark, and may not be used if you +charge for the eBooks, unless you receive specific permission. If you +do not charge anything for copies of this eBook, complying with the +rules is very easy. You may use this eBook for nearly any purpose +such as creation of derivative works, reports, performances and +research. They may be modified and printed and given away--you may do +practically ANYTHING with public domain eBooks. Redistribution is +subject to the trademark license, especially commercial +redistribution. + + + +*** START: FULL LICENSE *** + +THE FULL PROJECT GUTENBERG LICENSE +PLEASE READ THIS BEFORE YOU DISTRIBUTE OR USE THIS WORK + +To protect the Project Gutenberg-tm mission of promoting the free +distribution of electronic works, by using or distributing this work +(or any other work associated in any way with the phrase "Project +Gutenberg"), you agree to comply with all the terms of the Full Project +Gutenberg-tm License (available with this file or online at +http://gutenberg.net/license). + + +Section 1. General Terms of Use and Redistributing Project Gutenberg-tm +electronic works + +1.A. By reading or using any part of this Project Gutenberg-tm +electronic work, you indicate that you have read, understand, agree to +and accept all the terms of this license and intellectual property +(trademark/copyright) agreement. If you do not agree to abide by all +the terms of this agreement, you must cease using and return or destroy +all copies of Project Gutenberg-tm electronic works in your possession. +If you paid a fee for obtaining a copy of or access to a Project +Gutenberg-tm electronic work and you do not agree to be bound by the +terms of this agreement, you may obtain a refund from the person or +entity to whom you paid the fee as set forth in paragraph 1.E.8. + +1.B. "Project Gutenberg" is a registered trademark. It may only be +used on or associated in any way with an electronic work by people who +agree to be bound by the terms of this agreement. There are a few +things that you can do with most Project Gutenberg-tm electronic works +even without complying with the full terms of this agreement. See +paragraph 1.C below. There are a lot of things you can do with Project +Gutenberg-tm electronic works if you follow the terms of this agreement +and help preserve free future access to Project Gutenberg-tm electronic +works. See paragraph 1.E below. + +1.C. The Project Gutenberg Literary Archive Foundation ("the Foundation" +or PGLAF), owns a compilation copyright in the collection of Project +Gutenberg-tm electronic works. Nearly all the individual works in the +collection are in the public domain in the United States. If an +individual work is in the public domain in the United States and you are +located in the United States, we do not claim a right to prevent you from +copying, distributing, performing, displaying or creating derivative +works based on the work as long as all references to Project Gutenberg +are removed. Of course, we hope that you will support the Project +Gutenberg-tm mission of promoting free access to electronic works by +freely sharing Project Gutenberg-tm works in compliance with the terms of +this agreement for keeping the Project Gutenberg-tm name associated with +the work. You can easily comply with the terms of this agreement by +keeping this work in the same format with its attached full Project +Gutenberg-tm License when you share it without charge with others. + +1.D. The copyright laws of the place where you are located also govern +what you can do with this work. Copyright laws in most countries are in +a constant state of change. If you are outside the United States, check +the laws of your country in addition to the terms of this agreement +before downloading, copying, displaying, performing, distributing or +creating derivative works based on this work or any other Project +Gutenberg-tm work. The Foundation makes no representations concerning +the copyright status of any work in any country outside the United +States. + +1.E. Unless you have removed all references to Project Gutenberg: + +1.E.1. The following sentence, with active links to, or other immediate +access to, the full Project Gutenberg-tm License must appear prominently +whenever any copy of a Project Gutenberg-tm work (any work on which the +phrase "Project Gutenberg" appears, or with which the phrase "Project +Gutenberg" is associated) is accessed, displayed, performed, viewed, +copied or distributed: + +This eBook is for the use of anyone anywhere at no cost and with +almost no restrictions whatsoever. You may copy it, give it away or +re-use it under the terms of the Project Gutenberg License included +with this eBook or online at www.gutenberg.net + +1.E.2. If an individual Project Gutenberg-tm electronic work is derived +from the public domain (does not contain a notice indicating that it is +posted with permission of the copyright holder), the work can be copied +and distributed to anyone in the United States without paying any fees +or charges. If you are redistributing or providing access to a work +with the phrase "Project Gutenberg" associated with or appearing on the +work, you must comply either with the requirements of paragraphs 1.E.1 +through 1.E.7 or obtain permission for the use of the work and the +Project Gutenberg-tm trademark as set forth in paragraphs 1.E.8 or +1.E.9. + +1.E.3. If an individual Project Gutenberg-tm electronic work is posted +with the permission of the copyright holder, your use and distribution +must comply with both paragraphs 1.E.1 through 1.E.7 and any additional +terms imposed by the copyright holder. Additional terms will be linked +to the Project Gutenberg-tm License for all works posted with the +permission of the copyright holder found at the beginning of this work. + +1.E.4. Do not unlink or detach or remove the full Project Gutenberg-tm +License terms from this work, or any files containing a part of this +work or any other work associated with Project Gutenberg-tm. + +1.E.5. Do not copy, display, perform, distribute or redistribute this +electronic work, or any part of this electronic work, without +prominently displaying the sentence set forth in paragraph 1.E.1 with +active links or immediate access to the full terms of the Project +Gutenberg-tm License. + +1.E.6. You may convert to and distribute this work in any binary, +compressed, marked up, nonproprietary or proprietary form, including any +word processing or hypertext form. However, if you provide access to or +distribute copies of a Project Gutenberg-tm work in a format other than +"Plain Vanilla ASCII" or other format used in the official version +posted on the official Project Gutenberg-tm web site (www.gutenberg.net), +you must, at no additional cost, fee or expense to the user, provide a +copy, a means of exporting a copy, or a means of obtaining a copy upon +request, of the work in its original "Plain Vanilla ASCII" or other +form. Any alternate format must include the full Project Gutenberg-tm +License as specified in paragraph 1.E.1. + +1.E.7. Do not charge a fee for access to, viewing, displaying, +performing, copying or distributing any Project Gutenberg-tm works +unless you comply with paragraph 1.E.8 or 1.E.9. + +1.E.8. You may charge a reasonable fee for copies of or providing +access to or distributing Project Gutenberg-tm electronic works provided +that + +- You pay a royalty fee of 20% of the gross profits you derive from + the use of Project Gutenberg-tm works calculated using the method + you already use to calculate your applicable taxes. The fee is + owed to the owner of the Project Gutenberg-tm trademark, but he + has agreed to donate royalties under this paragraph to the + Project Gutenberg Literary Archive Foundation. Royalty payments + must be paid within 60 days following each date on which you + prepare (or are legally required to prepare) your periodic tax + returns. Royalty payments should be clearly marked as such and + sent to the Project Gutenberg Literary Archive Foundation at the + address specified in Section 4, "Information about donations to + the Project Gutenberg Literary Archive Foundation." + +- You provide a full refund of any money paid by a user who notifies + you in writing (or by e-mail) within 30 days of receipt that s/he + does not agree to the terms of the full Project Gutenberg-tm + License. You must require such a user to return or + destroy all copies of the works possessed in a physical medium + and discontinue all use of and all access to other copies of + Project Gutenberg-tm works. + +- You provide, in accordance with paragraph 1.F.3, a full refund of any + money paid for a work or a replacement copy, if a defect in the + electronic work is discovered and reported to you within 90 days + of receipt of the work. + +- You comply with all other terms of this agreement for free + distribution of Project Gutenberg-tm works. + +1.E.9. If you wish to charge a fee or distribute a Project Gutenberg-tm +electronic work or group of works on different terms than are set +forth in this agreement, you must obtain permission in writing from +both the Project Gutenberg Literary Archive Foundation and Michael +Hart, the owner of the Project Gutenberg-tm trademark. Contact the +Foundation as set forth in Section 3 below. + +1.F. + +1.F.1. Project Gutenberg volunteers and employees expend considerable +effort to identify, do copyright research on, transcribe and proofread +public domain works in creating the Project Gutenberg-tm +collection. Despite these efforts, Project Gutenberg-tm electronic +works, and the medium on which they may be stored, may contain +"Defects," such as, but not limited to, incomplete, inaccurate or +corrupt data, transcription errors, a copyright or other intellectual +property infringement, a defective or damaged disk or other medium, a +computer virus, or computer codes that damage or cannot be read by +your equipment. + +1.F.2. LIMITED WARRANTY, DISCLAIMER OF DAMAGES - Except for the "Right +of Replacement or Refund" described in paragraph 1.F.3, the Project +Gutenberg Literary Archive Foundation, the owner of the Project +Gutenberg-tm trademark, and any other party distributing a Project +Gutenberg-tm electronic work under this agreement, disclaim all +liability to you for damages, costs and expenses, including legal +fees. YOU AGREE THAT YOU HAVE NO REMEDIES FOR NEGLIGENCE, STRICT +LIABILITY, BREACH OF WARRANTY OR BREACH OF CONTRACT EXCEPT THOSE +PROVIDED IN PARAGRAPH F3. YOU AGREE THAT THE FOUNDATION, THE +TRADEMARK OWNER, AND ANY DISTRIBUTOR UNDER THIS AGREEMENT WILL NOT BE +LIABLE TO YOU FOR ACTUAL, DIRECT, INDIRECT, CONSEQUENTIAL, PUNITIVE OR +INCIDENTAL DAMAGES EVEN IF YOU GIVE NOTICE OF THE POSSIBILITY OF SUCH +DAMAGE. + +1.F.3. LIMITED RIGHT OF REPLACEMENT OR REFUND - If you discover a +defect in this electronic work within 90 days of receiving it, you can +receive a refund of the money (if any) you paid for it by sending a +written explanation to the person you received the work from. If you +received the work on a physical medium, you must return the medium with +your written explanation. The person or entity that provided you with +the defective work may elect to provide a replacement copy in lieu of a +refund. If you received the work electronically, the person or entity +providing it to you may choose to give you a second opportunity to +receive the work electronically in lieu of a refund. If the second copy +is also defective, you may demand a refund in writing without further +opportunities to fix the problem. + +1.F.4. Except for the limited right of replacement or refund set forth +in paragraph 1.F.3, this work is provided to you 'AS-IS', WITH NO OTHER +WARRANTIES OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO +WARRANTIES OF MERCHANTIBILITY OR FITNESS FOR ANY PURPOSE. + +1.F.5. Some states do not allow disclaimers of certain implied +warranties or the exclusion or limitation of certain types of damages. +If any disclaimer or limitation set forth in this agreement violates the +law of the state applicable to this agreement, the agreement shall be +interpreted to make the maximum disclaimer or limitation permitted by +the applicable state law. The invalidity or unenforceability of any +provision of this agreement shall not void the remaining provisions. + +1.F.6. INDEMNITY - You agree to indemnify and hold the Foundation, the +trademark owner, any agent or employee of the Foundation, anyone +providing copies of Project Gutenberg-tm electronic works in accordance +with this agreement, and any volunteers associated with the production, +promotion and distribution of Project Gutenberg-tm electronic works, +harmless from all liability, costs and expenses, including legal fees, +that arise directly or indirectly from any of the following which you do +or cause to occur: (a) distribution of this or any Project Gutenberg-tm +work, (b) alteration, modification, or additions or deletions to any +Project Gutenberg-tm work, and (c) any Defect you cause. + + +Section 2. Information about the Mission of Project Gutenberg-tm + +Project Gutenberg-tm is synonymous with the free distribution of +electronic works in formats readable by the widest variety of computers +including obsolete, old, middle-aged and new computers. It exists +because of the efforts of hundreds of volunteers and donations from +people in all walks of life. + +Volunteers and financial support to provide volunteers with the +assistance they need, is critical to reaching Project Gutenberg-tm's +goals and ensuring that the Project Gutenberg-tm collection will +remain freely available for generations to come. In 2001, the Project +Gutenberg Literary Archive Foundation was created to provide a secure +and permanent future for Project Gutenberg-tm and future generations. +To learn more about the Project Gutenberg Literary Archive Foundation +and how your efforts and donations can help, see Sections 3 and 4 +and the Foundation web page at http://www.gutenberg.net/fundraising/pglaf. + + +Section 3. Information about the Project Gutenberg Literary Archive +Foundation + +The Project Gutenberg Literary Archive Foundation is a non profit +501(c)(3) educational corporation organized under the laws of the +state of Mississippi and granted tax exempt status by the Internal +Revenue Service. The Foundation's EIN or federal tax identification +number is 64-6221541. Contributions to the Project Gutenberg +Literary Archive Foundation are tax deductible to the full extent +permitted by U.S. federal laws and your state's laws. + +The Foundation's principal office is located at 4557 Melan Dr. S. +Fairbanks, AK, 99712., but its volunteers and employees are scattered +throughout numerous locations. Its business office is located at +809 North 1500 West, Salt Lake City, UT 84116, (801) 596-1887, email +business@pglaf.org. Email contact links and up to date contact +information can be found at the Foundation's web site and official +page at http://www.gutenberg.net/about/contact + +For additional contact information: + Dr. Gregory B. Newby + Chief Executive and Director + gbnewby@pglaf.org + +Section 4. Information about Donations to the Project Gutenberg +Literary Archive Foundation + +Project Gutenberg-tm depends upon and cannot survive without wide +spread public support and donations to carry out its mission of +increasing the number of public domain and licensed works that can be +freely distributed in machine readable form accessible by the widest +array of equipment including outdated equipment. Many small donations +($1 to $5,000) are particularly important to maintaining tax exempt +status with the IRS. + +The Foundation is committed to complying with the laws regulating +charities and charitable donations in all 50 states of the United +States. Compliance requirements are not uniform and it takes a +considerable effort, much paperwork and many fees to meet and keep up +with these requirements. We do not solicit donations in locations +where we have not received written confirmation of compliance. To +SEND DONATIONS or determine the status of compliance for any +particular state visit http://www.gutenberg.net/fundraising/donate + +While we cannot and do not solicit contributions from states where we +have not met the solicitation requirements, we know of no prohibition +against accepting unsolicited donations from donors in such states who +approach us with offers to donate. + +International donations are gratefully accepted, but we cannot make +any statements concerning tax treatment of donations received from +outside the United States. U.S. laws alone swamp our small staff. + +Please check the Project Gutenberg Web pages for current donation +methods and addresses. Donations are accepted in a number of other +ways including including checks, online payments and credit card +donations. To donate, please visit: +http://www.gutenberg.net/fundraising/donate + + +Section 5. General Information About Project Gutenberg-tm electronic +works. + +Professor Michael S. Hart is the originator of the Project Gutenberg-tm +concept of a library of electronic works that could be freely shared +with anyone. For thirty years, he produced and distributed Project +Gutenberg-tm eBooks with only a loose network of volunteer support. + +Project Gutenberg-tm eBooks are often created from several printed +editions, all of which are confirmed as Public Domain in the U.S. +unless a copyright notice is included. Thus, we do not necessarily +keep eBooks in compliance with any particular paper edition. + +Most people start at our Web site which has the main PG search facility: + + http://www.gutenberg.net + +This Web site includes information about Project Gutenberg-tm, +including how to make donations to the Project Gutenberg Literary +Archive Foundation, how to help produce our new eBooks, and how to +subscribe to our email newsletter to hear about new eBooks. diff --git a/tests/Examples/ConcatMap.hs b/tests/Examples/ConcatMap.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/ConcatMap.hs @@ -0,0 +1,8 @@ +module M where +import Char + +import Data.List.Stream as L + +foo :: [Char] -> [Char] +foo xs = (L.concatMap (L.replicate 10000)) ( map toUpper xs) + diff --git a/tests/Examples/Enum.hs b/tests/Examples/Enum.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/Enum.hs @@ -0,0 +1,9 @@ + +import Data.List.Stream +import Prelude hiding (map,sum,head) +import System.Environment + +main = do + n <- getArgs >>= readIO . head + print (sum (map (+1) [1..(n::Int)])) -- 1 fusion site. + print (sum (map (+1) [1..(10::Int)])) -- 2 fusion site. diff --git a/tests/Examples/Sum.hs b/tests/Examples/Sum.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/Sum.hs @@ -0,0 +1,4 @@ +import Data.List + +main = print . sum . map read . lines =<< getContents + diff --git a/tests/Examples/SumReplicate.hs b/tests/Examples/SumReplicate.hs new file mode 100644 --- /dev/null +++ b/tests/Examples/SumReplicate.hs @@ -0,0 +1,6 @@ +module FuseTest where + +import Data.List.Stream as L + +foo :: Int -> Int +foo n = L.sum (L.replicate n 1) diff --git a/tests/FuseTest.hs b/tests/FuseTest.hs new file mode 100644 --- /dev/null +++ b/tests/FuseTest.hs @@ -0,0 +1,6 @@ +module FuseTest where + +import Data.List.Stream as L + +foo :: Int -> Int +foo n = L.sum (L.replicate n 1) diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,90 @@ + +GHC_FLAGS=-cpp -DEXTERNAL_PACKAGE -i.. -O2 -fglasgow-exts -fbang-patterns +#GHC_FLAGS="-hide-package arrows-0.2" +GHC=ghc + +# run everything! +all :: internal list stream strictness list-compiled stream-compiled internal-compiled strictness-compiled + +# --------------------------------------------------------------- +# testing + +list :: + runghc $(GHC_FLAGS) Properties/ListVsSpec.hs + runghc $(GHC_FLAGS) Properties/ListVsBase.hs +stream :: + runghc $(GHC_FLAGS) Properties/StreamListVsSpec.hs + runghc $(GHC_FLAGS) Properties/StreamListVsBase.hs + runghc $(GHC_FLAGS) Properties/StreamVsSpecStream.hs +internal :: + runghc $(GHC_FLAGS) Properties/Internal.hs +strictness :: + runghc $(GHC_FLAGS) Strictness/ListVsSpec.hs + runghc $(GHC_FLAGS) Strictness/ListVsBase.hs + runghc $(GHC_FLAGS) Strictness/BaseVsSpec.hs + runghc $(GHC_FLAGS) Strictness/StreamListVsList.hs + +list-compiled :: + ghc $(GHC_FLAGS) --make -frules-off -o lp Properties/ListVsSpec.hs + ghc $(GHC_FLAGS) --make -frules-off -o lp2 Properties/ListVsBase.hs + time ./lp + time ./lp2 +stream-compiled :: + ghc $(GHC_FLAGS) --make -frules-off -o sp Properties/StreamListVsSpec.hs + ghc $(GHC_FLAGS) --make -frules-off -o sp2 Properties/StreamListVsBase.hs + ghc $(GHC_FLAGS) --make -frules-off -o sp3 Properties/StreamVsSpecStream.hs + time ./sp + time ./sp2 + time ./sp3 +internal-compiled :: + ghc $(GHC_FLAGS) --make -frules-off -o ip Properties/Internal.hs + time ./ip +strictness-compiled :: + ghc $(GHC_FLAGS) --make -frules-off -o strp Strictness/ListVsSpec.hs + ghc $(GHC_FLAGS) --make -frules-off -o strp2 Strictness/ListVsBase.hs + ghc $(GHC_FLAGS) --make -frules-off -o strp3 Strictness/BaseVsSpec.hs + ghc $(GHC_FLAGS) --make -frules-off -o strp4 Strictness/StreamListVsList.hs + time ./strp + time ./strp2 + time ./strp3 + time ./strp4 + +# --------------------------------------------------------------- +# benchmarking + +bench :: + $(GHC) $(GHC_FLAGS) --make Bench/ListVsBase.hs -o bench + $(GHC) $(GHC_FLAGS) --make Bench/StreamVsList.hs -o bench2 + ./bench + ./bench2 + +fusetest :: compiled + $(GHC) $(GHC_FLAGS) -c -no-recomp -ddump-simpl-stats \ + FuseTest.hs + +compiled :: ../Data/Stream.hs ../Data/List/Stream.hs \ + Bench/Utils.hs Properties/Utils.hs Strictness/Utils.hs \ + Spec/List.hs Spec/ListExts.hs Spec/PreludeList.hs \ + Properties/Monomorphic/Base.hs \ + Properties/Monomorphic/List.hs \ + Properties/Monomorphic/Spec.hs \ + Properties/Monomorphic/SpecStream.hs \ + Properties/Monomorphic/Stream.hs \ + Properties/Monomorphic/StreamList.hs \ + Strictness/Monomorphic/Base.hs \ + Strictness/Monomorphic/List.hs \ + Strictness/Monomorphic/Spec.hs \ + Strictness/Monomorphic/StreamList.hs + $(GHC) $(GHC_FLAGS) --make $^ + +Bench/bigdata : + cat Bench/data Bench/data Bench/data Bench/data Bench/data > Bench/bigdata + +# --------------------------------------------------------------- +# cleaning + +clean : + rm -f *.hi *.o ../Data/*.o ../Data/*.hi ../Data/List/*.o ../Data/List/*.hi + rm -f Spec/*.o Spec/*.hi Bench/*.o Bench/*.hi + rm -f Properties/*.o Properties/*.hi Strictness/*.o Strictness/*.hi + rm -f bench bench2 lp lp2 sp sp2 sp3 ip strp strp2 strp3 diff --git a/tests/Properties/Internal.hs b/tests/Properties/Internal.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Internal.hs @@ -0,0 +1,358 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +-- +-- Test the new list implementation for internal properties +-- +import Prelude (($),(.),(&&),(||),(+),Int,(==),Bool(..),not,flip,uncurry) + +import Properties.Utils +import System.IO + +import Data.Maybe +import qualified Data.List.Stream as T + +------------------------------------------------------------------------ +-- * Basic interface + +-- map fusion +prop_mapmap = (\(f :: B -> C) + (g :: A -> B) + (xs) -> T.map f . T.map g $ xs) `eq3` + + (\f g xs -> T.map (f.g) $ xs) + +prop_maprepeat n = (\(f :: A -> B) + (x :: A) -> T.map f (T.take n $ T.repeat x)) `eq2` (\f x -> T.take n $ T.repeat (f x)) + +prop_mapreplicate n = (\(f :: A -> B) + (x :: A) -> T.map f (T.replicate n x)) `eq2` (\f x -> T.replicate n (f x)) + +------------------------------------------------------------------------ +-- * List transformations + +prop_reverse = T.foldl (flip (:)) [] `eq1` (\(x :: [A]) -> T.reverse x) + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +------------------------------------------------------------------------ +-- ** Special folds + +prop_concatfoldr = (\(xs :: [[A]]) -> T.concat xs) `eq1` (T.foldr (T.++) []) + +prop_concatmap = (\(f :: A -> [B]) (xs :: [A]) -> T.concatMap f xs) `eq2` + (\f -> T.concat . T.map f) + +prop_and = (T.foldr (&&) True) `eq1` T.and +prop_or = (T.foldr (||) False) `eq1` T.or +prop_sum = (T.foldl (+) 0) `eq1` (T.sum :: [Int] -> Int) + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +-- (a -> b -> a) -> a -> [b] -> [a] +prop_scanlfold = (\(f :: A -> B -> A) + (z :: A) + (xs::[B]) -> + T.last (T.scanl f z xs)) `eq3` + (\f z xs -> + T.foldl f z xs) + +-- (a -> b -> a) -> a -> [b] -> [a] +prop_scanrfold = (\(f :: A -> B -> B) + (z :: B) + (xs::[A]) -> + T.head (T.scanr f z xs)) `eq3` + (\f z xs -> + T.foldr f z xs) + +------------------------------------------------------------------------ +-- ** Accumulating maps + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_replicate = T.replicate `eq2` (\n (x :: A) -> T.take n (T.repeat x)) + +------------------------------------------------------------------------ +-- ** Unfolding + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_break_span = T.break `eq2` (\(p :: A -> Bool) -> T.span (not . p)) + +------------------------------------------------------------------------ +-- * Predicates + +{- +-- +-- not true, has to take the minimum of the two, not the first only. +-- +prop_isPrefixOfzip = (\(xs:: [A]) ys -> + (T.isPrefixOf xs ys)) `eq2` + (\xs ys -> + (T.all (uncurry (==)) (T.zip xs ys))) +-} + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_filterfilter = (\(p :: A -> Bool) + (q :: A -> Bool) + (s :: [A] ) -> + T.filter p (T.filter q s)) `eq3` + (\p q s -> + T.filter (\x -> q x && p x) s) + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_findIndexfilter = (\p (xs ::[A]) -> + T.findIndex p xs) `eq2` + (\p xs -> + listToMaybe [ n | (n,x) <- T.zip [0..] xs, p x ]) + +prop_elemIndexfilter = (\x (xs ::[A]) -> + T.elemIndex x xs) `eq2` + (\x xs -> + listToMaybe [ n | (n,a) <- T.zip [0..] xs, a==x ]) + +prop_elemfindIndex = (\x (xs ::[A]) -> + T.findIndex (==x) xs) `eq2` + (\x xs -> + T.elemIndex x xs) + +prop_filterelemIndices = (\a (xs :: [A]) -> + T.length (T.filter (==a) xs)) `eq2` + (\a xs -> + T.length (T.elemIndices a xs)) + +prop_filterfindIndices = (\p (xs :: [A]) -> + T.length (T.filter p xs)) `eq2` + (\p xs -> + T.length (T.findIndices p xs)) + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +prop_unlinesconcat = T.unlines `eqnotnull1` (\xs -> T.concat (T.intersperse "\n" xs) T.++ "\n") +prop_unlinesconcatMap = T.unlines `eq1` (\xs -> T.concatMap (T.++ "\n") xs) + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +prop_nubsort = (\(xs :: [OrdA]) -> T.sort . T.nub $ xs ) `eq1` + (\xs -> T.map T.head . T.group . T.sort $ xs) + +------------------------------------------------------------------------ +-- ** Ordered lists + +prop_headsort = (T.head . T.sort) `eqnotnull1` (\x -> T.minimum (x :: [OrdA])) +prop_lastsort = (T.last . T.sort) `eqnotnull1` (\x -> T.maximum (x :: [OrdA])) + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +prop_nubsortby = (\f g (xs :: [OrdA]) -> T.sortBy f . T.nubBy g $ xs ) `eq3` + (\f g xs -> T.map T.head . T.groupBy g . T.sortBy f $ xs) + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + + runTests "Basic interface" opts + [ run prop_mapmap + , run prop_maprepeat + , run prop_mapreplicate + ] + + runTests "List transformations" opts + [ run prop_reverse + ] + +{- + runTests "Reducing lists (folds)" opts + [ + ] +-} + + runTests "Special folds" opts + [ run prop_concatfoldr + , run prop_concatmap + , run prop_and + , run prop_or + , run prop_sum + ] + + runTests "Scans" opts + [ run prop_scanlfold + , run prop_scanrfold + ] + +{- + runTests "Accumulating maps" opts + [ + ] +-} + + runTests "Infinite lists" opts + [ run prop_replicate + ] + +{- + runTests "Unfolding" opts + [ + ] +-} + + runTests "Extracting sublists" opts + [ run prop_break_span + ] + +{- + runTests "Predicates" opts + [ run prop_isPrefixOfzip + ] +-} + +{- + runTests "Searching by equality" opts + [ + ] +-} + + runTests "Searching by a predicate" opts + [ run prop_filterfilter + ] + + runTests "Indexing lists" opts + [ run prop_filterelemIndices + , run prop_filterfindIndices + , run prop_findIndexfilter + , run prop_elemIndexfilter + , run prop_elemfindIndex + ] + +{- + runTests "Zipping" opts + [ + ] +-} + +{- + runTests "Unzipping" opts + [ + ] +-} + + runTests "Functions on strings" opts + [ run prop_unlinesconcat + , run prop_unlinesconcatMap + ] + + runTests "\"Set\" operations" opts + [ run prop_nubsort + ] + + runTests "Ordered lists" opts + [ run prop_headsort + , run prop_lastsort + ] + + + runTests "Eq style \"By\" operations" opts + [ run prop_nubsortby -- same issue as prop_sortBy in ListProperties + ] +{- + runTests "Ord style \"By\" operations" opts + [ + ] + + runTests "The \"generic\" operations" opts + [ + ] +-} + +------------------------------------------------------------------------ + +{- + runTests "Searching by equality" opts + [ + ] +-} + + runTests "Searching by a predicate" opts + [ run prop_filterfilter + ] + + runTests "Indexing lists" opts + [ run prop_filterelemIndices + , run prop_filterfindIndices + , run prop_findIndexfilter + , run prop_elemIndexfilter + , run prop_elemfindIndex + ] + +{- + runTests "Zipping" opts + [ + ] +-} + +{- + runTests "Unzipping" opts + [ + ] +-} + + runTests "Functions on strings" opts + [ run prop_unlinesconcat + , run prop_unlinesconcatMap + ] + + runTests "\"Set\" operations" opts + [ run prop_nubsort + ] + + runTests "Ordered lists" opts + [ run prop_headsort + , run prop_lastsort + ] + + + runTests "Eq style \"By\" operations" opts + [ run prop_nubsortby -- same issue as prop_sortBy in ListProperties + ] +{- + runTests "Ord style \"By\" operations" opts + [ + ] + + runTests "The \"generic\" operations" opts + [ + ] +-} + +------------------------------------------------------------------------ diff --git a/tests/Properties/ListVsBase.hs b/tests/Properties/ListVsBase.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ListVsBase.hs @@ -0,0 +1,402 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +-- +-- Test the new list implementation against Data.List. +-- + +import Properties.Utils +import System.IO + +import qualified Properties.Monomorphic.List as Test -- our implementation +import qualified Properties.Monomorphic.Base as Spec -- current Data.List + +-- +-- Data.List.Stream <=> Data.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_append = (Test.++) `eq2` (Spec.++) +prop_head = Test.head `eqnotnull1` Spec.head +prop_last = Test.last `eqnotnull1` Spec.last +prop_tail = Test.tail `eqnotnull1` Spec.tail +prop_init = Test.init `eqnotnull1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +prop_intercalate = Test.intercalate `eq2` Spec.intercalate +prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' +prop_foldl1 = Test.foldl1 `eqnotnull2` Spec.foldl1 +prop_foldl1' = Test.foldl1' `eqnotnull2` Spec.foldl1' +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eqnotnull2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eqnotnull1` Spec.maximum +prop_minimum = Test.minimum `eqnotnull1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +prop_scanr = Test.scanr `eq3` Spec.scanr +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 + +------------------------------------------------------------------------ +-- ** Accumulating maps + +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eq2` Spec.replicate +prop_cycle = \x -> not (null x) ==> + (Test.cycle `eqfinite1` Spec.cycle) x + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +prop_notElem = Test.notElem `eq2` Spec.notElem +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +prop_partition = Test.partition `eq2` Spec.partition + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = \xs n -> n >= 0 && n < length xs ==> + ((Test.!!) `eq2` (Spec.!!)) xs n +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +prop_zip3 = Test.zip3 `eq3` Spec.zip3 +prop_zip4 = Test.zip4 `eq4` Spec.zip4 +prop_zip5 = Test.zip5 `eq5` Spec.zip5 +prop_zip6 = Test.zip6 `eq6` Spec.zip6 +prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip +prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +prop_lines = Test.lines `eq1` Spec.lines +prop_words = Test.words `eq1` Spec.words +prop_unlines = Test.unlines `eq1` Spec.unlines +prop_unwords = Test.unwords `eq1` Spec.unwords + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect + +------------------------------------------------------------------------ +-- ** Ordered lists + +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +prop_sortBy = Test.sortBy `eq2` Spec.sortBy +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eqnotnull2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eqnotnull2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = \i -> i >= I 0 ==> + (Test.genericTake `eq2` Spec.genericTake) i +prop_genericDrop = \i -> i >= I 0 ==> + (Test.genericDrop `eq2` Spec.genericDrop) i +prop_genericSplitAt = \i -> i >= I 0 ==> + (Test.genericSplitAt `eq2` Spec.genericSplitAt) i +prop_genericIndex = \xs i -> i >= I 0 && i < Spec.genericLength xs ==> + (Test.genericIndex `eq2` Spec.genericIndex) xs i +prop_genericReplicate = \i -> i >= I 0 ==> + (Test.genericReplicate `eq2` Spec.genericReplicate) i + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing: Data.List.Stream <=> Data.List" + putStrLn "=======================================\n" + + runTests "Basic interface" opts + [run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map + ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate + ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [run prop_concat + ,run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 + ,run prop_scanr + ,run prop_scanr1 + ] + + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails + ] + + runTests "Predicates" opts + [run prop_isPrefixOf + ,run prop_isSuffixOf + ,run prop_isInfixOf + ] + + runTests "Searching by equality" opts + [run prop_elem + ,run prop_notElem + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter + ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndex + ,run prop_findIndices + ] + + runTests "Zipping" opts + [run prop_zip + ,run prop_zip3 + ,run prop_zip4 + ,run prop_zip5 + ,run prop_zip6 + ,run prop_zip7 + ,run prop_zipWith + ,run prop_zipWith3 + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 + ] + + runTests "Unzipping" opts + [run prop_unzip + ,run prop_unzip3 + ,run prop_unzip4 + ,run prop_unzip5 + ,run prop_unzip6 + ,run prop_unzip7 + ] + + runTests "Functions on strings" opts + [run prop_lines + ,run prop_words + ,run prop_unlines + ,run prop_unwords + ] + + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] + + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] + + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] + + runTests "Ord style \"By\" operations" opts + [run prop_sortBy -- note issue here. + ,run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericSplitAt + ,run prop_genericIndex + ,run prop_genericReplicate + ] diff --git a/tests/Properties/ListVsSpec.hs b/tests/Properties/ListVsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/ListVsSpec.hs @@ -0,0 +1,402 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +-- +-- Test the new list implementation against h98 lists. +-- + +import Properties.Utils +import System.IO + +import qualified Properties.Monomorphic.List as Test -- our implementation +import qualified Properties.Monomorphic.Spec as Spec -- H98 spec + +-- +-- Data.List.Stream <=> Spec.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_append = (Test.++) `eq2` (Spec.++) +prop_head = Test.head `eqnotnull1` Spec.head +prop_last = Test.last `eqnotnull1` Spec.last +prop_tail = Test.tail `eqnotnull1` Spec.tail +prop_init = Test.init `eqnotnull1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +prop_intercalate = Test.intercalate `eq2` Spec.intercalate +prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' +prop_foldl1 = Test.foldl1 `eqnotnull2` Spec.foldl1 +prop_foldl1' = Test.foldl1' `eqnotnull2` Spec.foldl1' +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eqnotnull2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eqnotnull1` Spec.maximum +prop_minimum = Test.minimum `eqnotnull1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +prop_scanr = Test.scanr `eq3` Spec.scanr +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 + +------------------------------------------------------------------------ +-- ** Accumulating maps + +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eq2` Spec.replicate +prop_cycle = \x -> not (null x) ==> + (Test.cycle `eqfinite1` Spec.cycle) x + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +prop_notElem = Test.notElem `eq2` Spec.notElem +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +prop_partition = Test.partition `eq2` Spec.partition + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = \xs n -> n >= 0 && n < length xs ==> + ((Test.!!) `eq2` (Spec.!!)) xs n +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +prop_zip3 = Test.zip3 `eq3` Spec.zip3 +prop_zip4 = Test.zip4 `eq4` Spec.zip4 +prop_zip5 = Test.zip5 `eq5` Spec.zip5 +prop_zip6 = Test.zip6 `eq6` Spec.zip6 +prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip +prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +prop_lines = Test.lines `eq1` Spec.lines +prop_words = Test.words `eq1` Spec.words +prop_unlines = Test.unlines `eq1` Spec.unlines +prop_unwords = Test.unwords `eq1` Spec.unwords + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect + +------------------------------------------------------------------------ +-- ** Ordered lists + +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +prop_sortBy = Test.sortBy `eq2` Spec.sortBy +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eqnotnull2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eqnotnull2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = \i -> i >= I 0 ==> + (Test.genericTake `eq2` Spec.genericTake) i +prop_genericDrop = \i -> i >= I 0 ==> + (Test.genericDrop `eq2` Spec.genericDrop) i +prop_genericSplitAt = \i -> i >= I 0 ==> + (Test.genericSplitAt `eq2` Spec.genericSplitAt) i +prop_genericIndex = \xs i -> i >= I 0 && i < Spec.genericLength xs ==> + (Test.genericIndex `eq2` Spec.genericIndex) xs i +prop_genericReplicate = \i -> i >= I 0 ==> + (Test.genericReplicate `eq2` Spec.genericReplicate) i + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing: Data.List.Stream <=> Spec.List" + putStrLn "=======================================\n" + + runTests "Basic interface" opts + [run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map + ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate + ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [run prop_concat + ,run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 + ,run prop_scanr + ,run prop_scanr1 + ] + + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails + ] + + runTests "Predicates" opts + [run prop_isPrefixOf + ,run prop_isSuffixOf + ,run prop_isInfixOf + ] + + runTests "Searching by equality" opts + [run prop_elem + ,run prop_notElem + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter + ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndex + ,run prop_findIndices + ] + + runTests "Zipping" opts + [run prop_zip + ,run prop_zip3 + ,run prop_zip4 + ,run prop_zip5 + ,run prop_zip6 + ,run prop_zip7 + ,run prop_zipWith + ,run prop_zipWith3 + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 + ] + + runTests "Unzipping" opts + [run prop_unzip + ,run prop_unzip3 + ,run prop_unzip4 + ,run prop_unzip5 + ,run prop_unzip6 + ,run prop_unzip7 + ] + + runTests "Functions on strings" opts + [run prop_lines + ,run prop_words + ,run prop_unlines + ,run prop_unwords + ] + + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] + + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] + + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] + + runTests "Ord style \"By\" operations" opts + [run prop_sortBy -- note issue here. + ,run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericSplitAt + ,run prop_genericIndex + ,run prop_genericReplicate + ] diff --git a/tests/Properties/Monomorphic/Base.hs b/tests/Properties/Monomorphic/Base.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/Base.hs @@ -0,0 +1,321 @@ +-- +-- The Data.List api +-- +module Properties.Monomorphic.Base where + +import Properties.Utils + +import qualified Data.List as Spec + +-- * Basic interface +(++) :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +unzip :: [(A, B)] -> ([A], [B]) +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) + +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] + + + +-- * Basic interface +(++) = (Spec.++) +head = Spec.head +last = Spec.last +tail = Spec.tail +init = Spec.init +null = Spec.null +length = Spec.length + +-- * List transformations +map = Spec.map +reverse = Spec.reverse +intersperse = Spec.intersperse + +-- intercalate = -- Spec.intercalate +intercalate xs xss = Spec.concat (Spec.intersperse xs xss) + +transpose = Spec.transpose + +-- * Reducing lists (folds) +foldl = Spec.foldl +foldl' = Spec.foldl' +foldl1 = Spec.foldl1 +foldl1' = Spec.foldl1' +foldr = Spec.foldr +foldr1 = Spec.foldr1 + +-- ** Special folds +concat = Spec.concat +concatMap = Spec.concatMap +and = Spec.and +or = Spec.or +any = Spec.any +all = Spec.all +sum = Spec.sum +product = Spec.product +maximum = Spec.maximum +minimum = Spec.minimum + +-- * Building lists +-- ** Scans +scanl = Spec.scanl +scanl1 = Spec.scanl1 +scanr = Spec.scanr +scanr1 = Spec.scanr1 + +-- ** Accumulating maps +mapAccumL = Spec.mapAccumL +mapAccumR = Spec.mapAccumR + +-- ** Infinite lists +iterate = Spec.iterate +repeat = Spec.repeat +replicate = Spec.replicate +cycle = Spec.cycle + +-- ** Unfolding +unfoldr = Spec.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = Spec.take +drop = Spec.drop +splitAt = Spec.splitAt +takeWhile = Spec.takeWhile +dropWhile = Spec.dropWhile +span = Spec.span +break = Spec.break +group = Spec.group +inits = Spec.inits +tails = Spec.tails + +-- * Predicates +isPrefixOf = Spec.isPrefixOf +isSuffixOf = Spec.isSuffixOf +isInfixOf = Spec.isInfixOf + +-- * Searching lists +-- ** Searching by equality +elem = Spec.elem +notElem = Spec.notElem +lookup = Spec.lookup + +-- ** Searching with a predicate +find = Spec.find +filter = Spec.filter +partition = Spec.partition + +-- * Indexing lists +(!!) = (Spec.!!) +elemIndex = Spec.elemIndex +elemIndices = Spec.elemIndices +findIndex = Spec.findIndex +findIndices = Spec.findIndices + +-- * Zipping and unzipping lists +zip = Spec.zip +zip3 = Spec.zip3 +zip4 = Spec.zip4 +zip5 = Spec.zip5 +zip6 = Spec.zip6 +zip7 = Spec.zip7 +zipWith = Spec.zipWith +zipWith3 = Spec.zipWith3 +zipWith4 = Spec.zipWith4 +zipWith5 = Spec.zipWith5 +zipWith6 = Spec.zipWith6 +zipWith7 = Spec.zipWith7 +unzip = Spec.unzip +unzip3 = Spec.unzip3 +unzip4 = Spec.unzip4 +unzip5 = Spec.unzip5 +unzip6 = Spec.unzip6 +unzip7 = Spec.unzip7 + +-- * Special lists +-- ** Functions on strings +lines = Spec.lines +words = Spec.words +unlines = Spec.unlines +unwords = Spec.unwords + +-- ** \"Set\" operations +nub = Spec.nub +delete = Spec.delete +(\\) = (Spec.\\) +union = Spec.union +intersect = Spec.intersect + +-- ** Ordered lists +sort = Spec.sort +insert = Spec.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Spec.nubBy +deleteBy = Spec.deleteBy +deleteFirstsBy = Spec.deleteFirstsBy +unionBy = Spec.unionBy +intersectBy = Spec.intersectBy +groupBy = Spec.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = Spec.sortBy +insertBy = Spec.insertBy +maximumBy = Spec.maximumBy +minimumBy = Spec.minimumBy + +-- * The \"generic\" operations +genericLength = Spec.genericLength +genericTake = Spec.genericTake +genericDrop = Spec.genericDrop +genericSplitAt = Spec.genericSplitAt +genericIndex = Spec.genericIndex +genericReplicate = Spec.genericReplicate diff --git a/tests/Properties/Monomorphic/List.hs b/tests/Properties/Monomorphic/List.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/List.hs @@ -0,0 +1,319 @@ +module Properties.Monomorphic.List where + +-- +-- just test the List api +-- + +import Properties.Utils + +import qualified Data.List.Stream as List + +-- * Basic interface +(++) :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +unzip :: [(A, B)] -> ([A], [B]) +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) + +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] + + + +-- * Basic interface +(++) = (List.++) +head = List.head +last = List.last +tail = List.tail +init = List.init +null = List.null +length = List.length + +-- * List transformations +map = List.map +reverse = List.reverse +intersperse = List.intersperse +intercalate = List.intercalate +transpose = List.transpose + +-- * Reducing lists (folds) +foldl = List.foldl +foldl' = List.foldl' +foldl1 = List.foldl1 +foldl1' = List.foldl1' +foldr = List.foldr +foldr1 = List.foldr1 + +-- ** Special folds +concat = List.concat +concatMap = List.concatMap +and = List.and +or = List.or +any = List.any +all = List.all +sum = List.sum +product = List.product +maximum = List.maximum +minimum = List.minimum + +-- * Building lists +-- ** Scans +scanl = List.scanl +scanl1 = List.scanl1 +scanr = List.scanr +scanr1 = List.scanr1 + +-- ** Accumulating maps +mapAccumL = List.mapAccumL +mapAccumR = List.mapAccumR + +-- ** Infinite lists +iterate = List.iterate +repeat = List.repeat +replicate = List.replicate +cycle = List.cycle + +-- ** Unfolding +unfoldr = List.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = List.take +drop = List.drop +splitAt = List.splitAt +takeWhile = List.takeWhile +dropWhile = List.dropWhile +span = List.span +break = List.break +group = List.group +inits = List.inits +tails = List.tails + +-- * Predicates +isPrefixOf = List.isPrefixOf +isSuffixOf = List.isSuffixOf +isInfixOf = List.isInfixOf + +-- * Searching lists +-- ** Searching by equality +elem = List.elem +notElem = List.notElem +lookup = List.lookup + +-- ** Searching with a predicate +find = List.find +filter = List.filter +partition = List.partition + +-- * Indexing lists +(!!) = (List.!!) +elemIndex = List.elemIndex +elemIndices = List.elemIndices +findIndex = List.findIndex +findIndices = List.findIndices + +-- * Zipping and unzipping lists +zip = List.zip +zip3 = List.zip3 +zip4 = List.zip4 +zip5 = List.zip5 +zip6 = List.zip6 +zip7 = List.zip7 +zipWith = List.zipWith +zipWith3 = List.zipWith3 +zipWith4 = List.zipWith4 +zipWith5 = List.zipWith5 +zipWith6 = List.zipWith6 +zipWith7 = List.zipWith7 +unzip = List.unzip +unzip3 = List.unzip3 +unzip4 = List.unzip4 +unzip5 = List.unzip5 +unzip6 = List.unzip6 +unzip7 = List.unzip7 + +-- * Special lists +-- ** Functions on strings +lines = List.lines +words = List.words +unlines = List.unlines +unwords = List.unwords + +-- ** \"Set\" operations +nub = List.nub +delete = List.delete +(\\) = (List.\\) +union = List.union +intersect = List.intersect + +-- ** Ordered lists +sort = List.sort +insert = List.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = List.nubBy +deleteBy = List.deleteBy +deleteFirstsBy = List.deleteFirstsBy +unionBy = List.unionBy +intersectBy = List.intersectBy +groupBy = List.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = List.sortBy +insertBy = List.insertBy +maximumBy = List.maximumBy +minimumBy = List.minimumBy + +-- * The \"generic\" operations +genericLength = List.genericLength +genericTake = List.genericTake +genericDrop = List.genericDrop +genericSplitAt = List.genericSplitAt +genericIndex = List.genericIndex +genericReplicate = List.genericReplicate diff --git a/tests/Properties/Monomorphic/Spec.hs b/tests/Properties/Monomorphic/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/Spec.hs @@ -0,0 +1,316 @@ +module Properties.Monomorphic.Spec where + +import Properties.Utils + +import qualified Spec.List as Spec +import qualified Spec.ListExts as Spec + +-- * Basic interface +(++) :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +unzip :: [(A, B)] -> ([A], [B]) +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) + +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] + + + +-- * Basic interface +(++) = (Spec.++) +head = Spec.head +last = Spec.last +tail = Spec.tail +init = Spec.init +null = Spec.null +length = Spec.length + +-- * List transformations +map = Spec.map +reverse = Spec.reverse +intersperse = Spec.intersperse +intercalate = Spec.intercalate +transpose = Spec.transpose + +-- * Reducing lists (folds) +foldl = Spec.foldl +foldl' = Spec.foldl' +foldl1 = Spec.foldl1 +foldl1' = Spec.foldl1' +foldr = Spec.foldr +foldr1 = Spec.foldr1 + +-- ** Special folds +concat = Spec.concat +concatMap = Spec.concatMap +and = Spec.and +or = Spec.or +any = Spec.any +all = Spec.all +sum = Spec.sum +product = Spec.product +maximum = Spec.maximum +minimum = Spec.minimum + +-- * Building lists +-- ** Scans +scanl = Spec.scanl +scanl1 = Spec.scanl1 +scanr = Spec.scanr +scanr1 = Spec.scanr1 + +-- ** Accumulating maps +mapAccumL = Spec.mapAccumL +mapAccumR = Spec.mapAccumR + +-- ** Infinite lists +iterate = Spec.iterate +repeat = Spec.repeat +replicate = Spec.replicate +cycle = Spec.cycle + +-- ** Unfolding +unfoldr = Spec.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = Spec.take +drop = Spec.drop +splitAt = Spec.splitAt +takeWhile = Spec.takeWhile +dropWhile = Spec.dropWhile +span = Spec.span +break = Spec.break +group = Spec.group +inits = Spec.inits +tails = Spec.tails + +-- * Predicates +isPrefixOf = Spec.isPrefixOf +isSuffixOf = Spec.isSuffixOf +isInfixOf = Spec.isInfixOf + +-- * Searching lists +-- ** Searching by equality +elem = Spec.elem +notElem = Spec.notElem +lookup = Spec.lookup + +-- ** Searching with a predicate +find = Spec.find +filter = Spec.filter +partition = Spec.partition + +-- * Indexing lists +(!!) = (Spec.!!) +elemIndex = Spec.elemIndex +elemIndices = Spec.elemIndices +findIndex = Spec.findIndex +findIndices = Spec.findIndices + +-- * Zipping and unzipping lists +zip = Spec.zip +zip3 = Spec.zip3 +zip4 = Spec.zip4 +zip5 = Spec.zip5 +zip6 = Spec.zip6 +zip7 = Spec.zip7 +zipWith = Spec.zipWith +zipWith3 = Spec.zipWith3 +zipWith4 = Spec.zipWith4 +zipWith5 = Spec.zipWith5 +zipWith6 = Spec.zipWith6 +zipWith7 = Spec.zipWith7 +unzip = Spec.unzip +unzip3 = Spec.unzip3 +unzip4 = Spec.unzip4 +unzip5 = Spec.unzip5 +unzip6 = Spec.unzip6 +unzip7 = Spec.unzip7 + +-- * Special lists +-- ** Functions on strings +lines = Spec.lines +words = Spec.words +unlines = Spec.unlines +unwords = Spec.unwords + +-- ** \"Set\" operations +nub = Spec.nub +delete = Spec.delete +(\\) = (Spec.\\) +union = Spec.union +intersect = Spec.intersect + +-- ** Ordered lists +sort = Spec.sort +insert = Spec.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Spec.nubBy +deleteBy = Spec.deleteBy +deleteFirstsBy = Spec.deleteFirstsBy +unionBy = Spec.unionBy +intersectBy = Spec.intersectBy +groupBy = Spec.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = Spec.sortBy +insertBy = Spec.insertBy +maximumBy = Spec.maximumBy +minimumBy = Spec.minimumBy + +-- * The \"generic\" operations +genericLength = Spec.genericLength +genericTake = Spec.genericTake +genericDrop = Spec.genericDrop +genericSplitAt = Spec.genericSplitAt +genericIndex = Spec.genericIndex +genericReplicate = Spec.genericReplicate diff --git a/tests/Properties/Monomorphic/SpecStream.hs b/tests/Properties/Monomorphic/SpecStream.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/SpecStream.hs @@ -0,0 +1,335 @@ +-- Haskell98 list spec wrapped in a stream interface so we can compare it to +-- the stream implementation and test using streams that contain Skips. + +module Properties.Monomorphic.SpecStream where + +import Properties.Utils + +import qualified Spec.List as Spec +import qualified Spec.ListExts as Spec +import Data.Stream as Stream (Stream, stream, unstream) + +-- * Basic interface +cons :: A -> Stream A -> Stream A +snoc :: Stream A -> A -> Stream A +(++) :: Stream A -> Stream A -> Stream A +head :: Stream A -> A +last :: Stream A -> A +tail :: Stream A -> Stream A +init :: Stream A -> Stream A +null :: Stream A -> Bool +length :: Stream A -> Int + +-- * List transformations +map :: (A -> B) -> Stream A -> Stream B +reverse :: Stream A -> Stream A +intersperse :: A -> Stream A -> Stream A +intercalate :: Stream A -> Stream (Stream A) -> Stream A +transpose :: Stream (Stream A) -> Stream (Stream A) + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> Stream A -> B +foldl' :: (B -> A -> B) -> B -> Stream A -> B +foldl1 :: (A -> A -> A) -> Stream A -> A +foldl1' :: (A -> A -> A) -> Stream A -> A +foldr :: (A -> B -> B) -> B -> Stream A -> B +foldr1 :: (A -> A -> A) -> Stream A -> A + +-- ** Special folds +concat :: Stream (Stream A) -> Stream A +concatMap :: (A -> Stream B) -> Stream A -> Stream B +and :: Stream Bool -> Bool +or :: Stream Bool -> Bool +any :: (A -> Bool) -> Stream A -> Bool +all :: (A -> Bool) -> Stream A -> Bool +sum :: Stream N -> N +product :: Stream N -> N +maximum :: Stream OrdA -> OrdA +minimum :: Stream OrdA -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> Stream B -> Stream A +scanl1 :: (A -> A -> A) -> Stream A -> Stream A +scanr :: (A -> B -> B) -> B -> Stream A -> Stream B +scanr1 :: (A -> A -> A) -> Stream A -> Stream A + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> Stream A -> (C, Stream B) +mapAccumR :: (C -> A -> (C, B)) -> C -> Stream A -> (C, Stream B) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> Stream A +repeat :: A -> Stream A +replicate :: Int -> A -> Stream A +cycle :: Stream A -> Stream A + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> Stream A + +-- * Sublists +-- ** Extracting sublists +take :: Int -> Stream A -> Stream A +drop :: Int -> Stream A -> Stream A +splitAt :: Int -> Stream A -> ([A], [A]) +takeWhile :: (A -> Bool) -> Stream A -> Stream A +dropWhile :: (A -> Bool) -> Stream A -> Stream A +span :: (A -> Bool) -> Stream A -> ([A], [A]) +break :: (A -> Bool) -> Stream A -> ([A], [A]) +group :: Stream A -> Stream (Stream A) +inits :: Stream A -> Stream (Stream A) +tails :: Stream A -> Stream (Stream A) + +-- * Predicates +isPrefixOf :: Stream A -> Stream A -> Bool +isSuffixOf :: Stream A -> Stream A -> Bool +isInfixOf :: Stream A -> Stream A -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> Stream A -> Bool +notElem :: A -> Stream A -> Bool +lookup :: A -> Stream (A, B) -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> Stream A -> Maybe A +filter :: (A -> Bool) -> Stream A -> Stream A +partition :: (A -> Bool) -> Stream A -> ([A], [A]) + +-- * Indexing lists +(!!) :: Stream A -> Int -> A +elemIndex :: A -> Stream A -> Maybe Int +elemIndices :: A -> Stream A -> Stream Int +findIndex :: (A -> Bool) -> Stream A -> Maybe Int +findIndices :: (A -> Bool) -> Stream A -> Stream Int + +-- * Zipping and unzipping lists +zip :: Stream A -> Stream B -> Stream (A, B) +zip3 :: Stream A -> Stream B -> Stream C -> Stream (A, B, C) +zip4 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream (A, B, C, D) +zip5 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream (A, B, C, D, E) +zip6 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream (A, B, C, D, E, F) +zip7 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream G -> Stream (A, B, C, D, E, F, G) +zipWith :: (A -> B -> C) -> Stream A -> Stream B -> Stream C +zipWith3 :: (A -> B -> C -> D) -> Stream A -> Stream B -> Stream C -> Stream D +zipWith4 :: (A -> B -> C -> D -> E) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E +zipWith5 :: (A -> B -> C -> D -> E -> F) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream G +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream G -> Stream H +unzip :: Stream (A, B) -> ([A], [B]) +unzip3 :: Stream (A, B, C) -> (Stream A, Stream B, Stream C) +unzip4 :: Stream (A, B, C, D) -> (Stream A, Stream B, Stream C, Stream D) +unzip5 :: Stream (A, B, C, D, E) -> (Stream A, Stream B, Stream C, Stream D, Stream E) +unzip6 :: Stream (A, B, C, D, E, F) -> (Stream A, Stream B, Stream C, Stream D, Stream E, Stream F) +unzip7 :: Stream (A, B, C, D, E, F, G) -> (Stream A, Stream B, Stream C, Stream D, Stream E, Stream F, Stream G) + +-- * Special lists +-- ** Functions on strings +lines :: Stream Char -> Stream String +words :: Stream Char -> Stream String +unlines :: Stream String -> Stream Char +unwords :: Stream String -> Stream Char + +-- ** \"Set\" operations +nub :: Stream A -> Stream A +delete :: A -> Stream A -> Stream A +(\\) :: Stream A -> Stream A -> Stream A +union :: Stream A -> Stream A -> Stream A +intersect :: Stream A -> Stream A -> Stream A + +-- ** Ordered lists +sort :: Stream OrdA -> Stream OrdA +insert :: OrdA -> Stream OrdA -> Stream OrdA + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> Stream A -> Stream A +deleteBy :: (A -> A -> Bool) -> A -> Stream A -> Stream A +deleteFirstsBy :: (A -> A -> Bool) -> Stream A -> Stream A -> Stream A +unionBy :: (A -> A -> Bool) -> Stream A -> Stream A -> Stream A +intersectBy :: (A -> A -> Bool) -> Stream A -> Stream A -> Stream A +groupBy :: (A -> A -> Bool) -> Stream A -> Stream (Stream A) + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> Stream A -> Stream A +insertBy :: (A -> A -> Ordering) -> A -> Stream A -> Stream A +maximumBy :: (A -> A -> Ordering) -> Stream A -> A +minimumBy :: (A -> A -> Ordering) -> Stream A -> A + +-- * The \"generic\" operations +genericLength :: Stream A -> I +genericTake :: I -> Stream A -> Stream A +genericDrop :: I -> Stream A -> Stream A +genericSplitAt :: I -> Stream A -> ([A], [A]) +genericIndex :: Stream A -> I -> A +genericReplicate :: I -> A -> Stream A + + +s :: [a] -> Stream a +s = Stream.stream + +u :: Stream a -> [a] +u = Stream.unstream + +ss :: [[a]] -> Stream (Stream a) +ss = s . Spec.map s + +uu :: Stream (Stream a) -> [[a]] +uu = Spec.map u . u + +-- * Basic interface +cons = \x xs -> s $ (:) x (u xs) +snoc = \xs x -> s $ (u xs) Spec.++ [x] +(++) = \xs ys -> s $ (Spec.++) (u xs) (u ys) +head = \xs -> Spec.head (u xs) +last = \xs -> Spec.last (u xs) +tail = \xs -> s $ Spec.tail (u xs) +init = \xs -> s $ Spec.init (u xs) +null = \xs -> Spec.null (u xs) +length = \xs -> Spec.length (u xs) + +-- * List transformations +map = \f xs -> s $ Spec.map f (u xs) +reverse = \ xs -> s $ Spec.reverse (u xs) +intersperse = \x xs -> s $ Spec.intersperse x (u xs) +intercalate = \ xs xss -> s $ Spec.intercalate (u xs) (uu xss) +transpose = \ xss -> ss $ Spec.transpose (uu xss) + +-- * Reducing lists (folds) +foldl = \f z xs -> Spec.foldl f z (u xs) +foldl' = \f z xs -> Spec.foldl' f z (u xs) +foldl1 = \f xs -> Spec.foldl1 f (u xs) +foldl1' = \f xs -> Spec.foldl1' f (u xs) +foldr = \f z xs -> Spec.foldr f z (u xs) +foldr1 = \f xs -> Spec.foldr1 f (u xs) + +-- ** Special folds +concat = \ xss -> s $ Spec.concat (uu xss) +concatMap = \f xs -> s $ Spec.concatMap (u . f) (u xs) +and = \ xs -> Spec.and (u xs) +or = \ xs -> Spec.or (u xs) +any = \f xs -> Spec.any f (u xs) +all = \f xs -> Spec.all f (u xs) +sum = \ xs -> Spec.sum (u xs) +product = \ xs -> Spec.product (u xs) +maximum = \ xs -> Spec.maximum (u xs) +minimum = \ xs -> Spec.minimum (u xs) + +-- * Building lists +-- ** Scans +scanl = \f z xs -> s $ Spec.scanl f z (u xs) +scanl1 = \f xs -> s $ Spec.scanl1 f (u xs) +scanr = \f z xs -> s $ Spec.scanr f z (u xs) +scanr1 = \f xs -> s $ Spec.scanr1 f (u xs) + +-- ** Accumulating maps +mapAccumL = \f z xs -> (\(a,b)->(a,s b)) $ Spec.mapAccumL f z (u xs) +mapAccumR = \f z xs -> (\(a,b)->(a,s b)) $ Spec.mapAccumR f z (u xs) + +-- ** Infinite lists +iterate = \f x -> s $ Spec.iterate f x +repeat = \ x -> s $ Spec.repeat x +replicate = \n x -> s $ Spec.replicate n x +cycle = \ xs -> s $ Spec.cycle (u xs) + +-- ** Unfolding +unfoldr = \f x -> s $ Spec.unfoldr f x + +-- * Sublists +-- ** Extracting sublists +take = \n xs -> s $ Spec.take n (u xs) +drop = \n xs -> s $ Spec.drop n (u xs) +splitAt = \n xs -> Spec.splitAt n (u xs) +takeWhile = \f xs -> s $ Spec.takeWhile f (u xs) +dropWhile = \f xs -> s $ Spec.dropWhile f (u xs) +span = \f xs -> Spec.span f (u xs) +break = \f xs -> Spec.break f (u xs) +group = \ xs -> ss $ Spec.group (u xs) +inits = \ xs -> ss $ Spec.inits (u xs) +tails = \ xs -> ss $ Spec.tails (u xs) + +-- * Predicates +isPrefixOf = \xs ys -> Spec.isPrefixOf (u xs) (u ys) +isSuffixOf = \xs ys -> Spec.isSuffixOf (u xs) (u ys) +isInfixOf = \xs ys -> Spec.isInfixOf (u xs) (u ys) + +-- * Searching lists +-- ** Searching by equality +elem = \x xs -> Spec.elem x (u xs) +notElem = \x xs -> Spec.notElem x (u xs) +lookup = \x xs -> Spec.lookup x (u xs) + +-- ** Searching with a predicate +find = \f xs -> Spec.find f (u xs) +filter = \f xs -> s $ Spec.filter f (u xs) +partition = \f xs -> Spec.partition f (u xs) + +-- * Indexing lists +(!!) = \xs n -> (Spec.!!) (u xs) n +elemIndex = \x xs -> Spec.elemIndex x (u xs) +elemIndices = \x xs -> s $ Spec.elemIndices x (u xs) +findIndex = \f xs -> Spec.findIndex f (u xs) +findIndices = \f xs -> s $ Spec.findIndices f (u xs) + +-- * Zipping and unzipping lists +zip = \a b -> s $ Spec.zip (u a) (u b) +zip3 = \a b c -> s $ Spec.zip3 (u a) (u b) (u c) +zip4 = \a b c d -> s $ Spec.zip4 (u a) (u b) (u c) (u d) +zip5 = \a b c d e -> s $ Spec.zip5 (u a) (u b) (u c) (u d) (u e) +zip6 = \a b c d e f -> s $ Spec.zip6 (u a) (u b) (u c) (u d) (u e) (u f) +zip7 = \a b c d e f g -> s $ Spec.zip7 (u a) (u b) (u c) (u d) (u e) (u f) (u g) +zipWith = \h a b -> s $ Spec.zipWith h (u a) (u b) +zipWith3 = \h a b c -> s $ Spec.zipWith3 h (u a) (u b) (u c) +zipWith4 = \h a b c d -> s $ Spec.zipWith4 h (u a) (u b) (u c) (u d) +zipWith5 = \h a b c d e -> s $ Spec.zipWith5 h (u a) (u b) (u c) (u d) (u e) +zipWith6 = \h a b c d e f -> s $ Spec.zipWith6 h (u a) (u b) (u c) (u d) (u e) (u f) +zipWith7 = \h a b c d e f g -> s $ Spec.zipWith7 h (u a) (u b) (u c) (u d) (u e) (u f) (u g) +unzip = \xs -> {-(\(a,b)->(s a,s b)) $-} Spec.unzip (u xs) +unzip3 = \xs -> (\(a,b,c)->(s a,s b,s c)) $ Spec.unzip3 (u xs) +unzip4 = \xs -> (\(a,b,c,d)->(s a,s b,s c,s d)) $ Spec.unzip4 (u xs) +unzip5 = \xs -> (\(a,b,c,d,e)->(s a,s b,s c,s d,s e)) $ Spec.unzip5 (u xs) +unzip6 = \xs -> (\(a,b,c,d,e,f)->(s a,s b,s c,s d,s e,s f)) $ Spec.unzip6 (u xs) +unzip7 = \xs -> (\(a,b,c,d,e,f,g)->(s a,s b,s c,s d,s e,s f,s g)) $ Spec.unzip7 (u xs) + +-- * Special lists +-- ** Functions on strings +lines = \x -> s $ Spec.lines (u x) +words = \x -> s $ Spec.words (u x) +unlines = \x -> s $ Spec.unlines (u x) +unwords = \x -> s $ Spec.unwords (u x) + +-- ** \"Set\" operations +nub = \ xs -> s $ Spec.nub (u xs) +delete = \x xs -> s $ Spec.delete x (u xs) +(\\) = \ xs ys -> s $ (Spec.\\) (u xs) (u ys) +union = \ xs ys -> s $ Spec.union (u xs) (u ys) +intersect = \ xs ys -> s $ Spec.intersect (u xs) (u ys) + +-- ** Ordered lists +sort = \ xs -> s $ Spec.sort (u xs) +insert = \x xs -> s $ Spec.insert x (u xs) + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = \f xs -> s $ Spec.nubBy f (u xs) +deleteBy = \f x xs -> s $ Spec.deleteBy f x (u xs) +deleteFirstsBy = \f xs ys -> s $ Spec.deleteFirstsBy f (u xs) (u ys) +unionBy = \f xs ys -> s $ Spec.unionBy f (u xs) (u ys) +intersectBy = \f xs ys -> s $ Spec.intersectBy f (u xs) (u ys) +groupBy = \f xs -> ss $ Spec.groupBy f (u xs) + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = \f xs -> s $ Spec.sortBy f (u xs) +insertBy = \f x xs -> s $ Spec.insertBy f x (u xs) +maximumBy = \f xs -> Spec.maximumBy f (u xs) +minimumBy = \f xs -> Spec.minimumBy f (u xs) + +-- * The \"generic\" operations +genericLength = \ xs -> Spec.genericLength (u xs) +genericTake = \n xs -> s $ Spec.genericTake n (u xs) +genericDrop = \n xs -> s $ Spec.genericDrop n (u xs) +genericSplitAt = \n xs -> Spec.genericSplitAt n (u xs) +genericIndex = \xs n -> Spec.genericIndex (u xs) n +genericReplicate = \n x -> s $ Spec.genericReplicate n x diff --git a/tests/Properties/Monomorphic/Stream.hs b/tests/Properties/Monomorphic/Stream.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/Stream.hs @@ -0,0 +1,362 @@ +-- +-- raw stream interface, no list wrappers +-- +-- These specify the versions used when fusion occurs. +-- +-- So we can check our stream implementations, which are only used when +-- fusion happens, are correct. +-- + +module Properties.Monomorphic.Stream where + +import Prelude +import qualified Prelude + +import Properties.Utils + +import qualified Data.Stream as Stream +import Data.Stream (Stream) + + +-- * Basic interface +cons :: A -> Stream A -> Stream A +snoc :: Stream A -> A -> Stream A +append :: Stream A -> Stream A -> Stream A +head :: Stream A -> A +last :: Stream A -> A +tail :: Stream A -> Stream A +init :: Stream A -> Stream A +null :: Stream A -> Bool +length :: Stream A -> Int + +-- * List transformations +map :: (A -> B) -> Stream A -> Stream B +--reverse :: Stream A -> Stream A +intersperse :: A -> Stream A -> Stream A +--intercalate :: Stream A -> Stream (Stream A) -> Stream A +--transpose :: Stream (Stream A) -> Stream (Stream A) + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> Stream A -> B +foldl' :: (B -> A -> B) -> B -> Stream A -> B +foldl1 :: (A -> A -> A) -> Stream A -> A +foldl1' :: (A -> A -> A) -> Stream A -> A +foldr :: (A -> B -> B) -> B -> Stream A -> B +foldr1 :: (A -> A -> A) -> Stream A -> A + +-- ** Special folds +-- concat :: Stream (Stream A) -> Stream A +concatMap :: (A -> Stream B) -> Stream A -> Stream B +and :: Stream Bool -> Bool +or :: Stream Bool -> Bool +any :: (A -> Bool) -> Stream A -> Bool +all :: (A -> Bool) -> Stream A -> Bool +sum :: Stream N -> N +product :: Stream N -> N +maximum :: Stream OrdA -> OrdA +minimum :: Stream OrdA -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> Stream B -> Stream A +scanl1 :: (A -> A -> A) -> Stream A -> Stream A +--scanr :: (A -> B -> B) -> B -> Stream A -> Stream B +--scanr1 :: (A -> A -> A) -> Stream A -> Stream A + +-- ** Accumulating maps +--mapAccumL :: (C -> A -> (C, B)) -> C -> Stream A -> (C, Stream B) +--mapAccumR :: (C -> A -> (C, B)) -> C -> Stream A -> (C, Stream B) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> Stream A +repeat :: A -> Stream A +replicate :: Int -> A -> Stream A +cycle :: Stream A -> Stream A + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> Stream A + +-- * Sublists +-- ** Extracting sublists +take :: Int -> Stream A -> Stream A +drop :: Int -> Stream A -> Stream A +splitAt :: Int -> Stream A -> ([A], [A]) +takeWhile :: (A -> Bool) -> Stream A -> Stream A +dropWhile :: (A -> Bool) -> Stream A -> Stream A +--span :: (A -> Bool) -> Stream A -> (Stream A, Stream A) +--break :: (A -> Bool) -> Stream A -> (Stream A, Stream A) +--group :: Stream A -> Stream (Stream A) +--inits :: Stream A -> Stream (Stream A) +--tails :: Stream A -> Stream (Stream A) + +-- * Predicates +isPrefixOf :: Stream A -> Stream A -> Bool +--isSuffixOf :: Stream A -> Stream A -> Bool +--isInfixOf :: Stream A -> Stream A -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> Stream A -> Bool +--notElem :: A -> Stream A -> Bool +lookup :: A -> Stream (A, B) -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> Stream A -> Maybe A +filter :: (A -> Bool) -> Stream A -> Stream A +--partition :: (A -> Bool) -> Stream A -> (Stream A, Stream A) + +-- * Indexing lists +(!!) :: Stream A -> Int -> A +elemIndex :: A -> Stream A -> Maybe Int +findIndex :: (A -> Bool) -> Stream A -> Maybe Int +elemIndices :: A -> Stream A -> Stream Int +findIndices :: (A -> Bool) -> Stream A -> Stream Int + +-- * Zipping and unzipping lists +zip :: Stream A -> Stream B -> Stream (A, B) +zip3 :: Stream A -> Stream B -> Stream C -> Stream (A, B, C) + +--zip4 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream (A, B, C, D) +--zip5 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream (A, B, C, D, E) +--zip6 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream (A, B, C, D, E, F) +--zip7 :: Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream G -> Stream (A, B, C, D, E, F, G) + +zipWith :: (A -> B -> C) -> Stream A -> Stream B -> Stream C +zipWith3 :: (A -> B -> C -> D) -> Stream A -> Stream B -> Stream C -> Stream D + +--zipWith4 :: (A -> B -> C -> D -> E) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E +--zipWith5 :: (A -> B -> C -> D -> E -> F) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F +--zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream G +--zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> Stream A -> Stream B -> Stream C -> Stream D -> Stream E -> Stream F -> Stream G -> Stream H + +unzip :: Stream (A, B) -> ([A], [B]) + +{- +--unzip3 :: Stream (A, B, C) -> (Stream A, Stream B, Stream C) +--unzip4 :: Stream (A, B, C, D) -> (Stream A, Stream B, Stream C, Stream D) +--unzip5 :: Stream (A, B, C, D, E) -> (Stream A, Stream B, Stream C, Stream D, Stream E) +--unzip6 :: Stream (A, B, C, D, E, F) -> (Stream A, Stream B, Stream C, Stream D, Stream E, Stream F) +--unzip7 :: Stream (A, B, C, D, E, F, G) -> (Stream A, Stream B, Stream C, Stream D, Stream E, Stream F, Stream G) +-} + +-- * Special lists +-- ** Functions on strings +--lines :: Stream Char -> Stream [Char] + + +--words :: String -> Stream String +--unlines :: Stream String -> String +--unwords :: Stream String -> String + +-- ** \"Set\" operations +--nub :: Stream A -> Stream A +--delete :: A -> Stream A -> Stream A +--(\\) :: Stream A -> Stream A -> Stream A +--union :: Stream A -> Stream A -> Stream A +--intersect :: Stream A -> Stream A -> Stream A + +-- ** Ordered lists +--sort :: Stream OrdA -> Stream OrdA +--insert :: OrdA -> Stream OrdA -> Stream OrdA + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +--nubBy :: (A -> A -> Bool) -> Stream A -> Stream A +--deleteBy :: (A -> A -> Bool) -> A -> Stream A -> Stream A +--deleteFirstsBy :: (A -> A -> Bool) -> Stream A -> Stream A -> Stream A +--unionBy :: (A -> A -> Bool) -> Stream A -> Stream A -> Stream A +--intersectBy :: (A -> A -> Bool) -> Stream A -> Stream A -> Stream A +--groupBy :: (A -> A -> Bool) -> Stream A -> Stream (Stream A) + +-- *** User-supplied comparison (replacing an Ord context) +--sortBy :: (A -> A -> Ordering) -> Stream A -> Stream A + +insertBy :: (A -> A -> Ordering) -> A -> Stream A -> Stream A +maximumBy :: (A -> A -> Ordering) -> Stream A -> A +minimumBy :: (A -> A -> Ordering) -> Stream A -> A + +-- * The \"generic\" operations + +genericLength :: Stream A -> I +genericTake :: I -> Stream A -> Stream A +genericDrop :: I -> Stream A -> Stream A +genericSplitAt :: I -> Stream A -> ([A], [A]) +genericIndex :: Stream A -> I -> A + +--genericReplicate :: I -> A -> Stream A + +-- * Basic interface +cons = Stream.cons +snoc = Stream.snoc +append = Stream.append +head = Stream.head +last = Stream.last +tail = Stream.tail +init = Stream.init +null = Stream.null +length = Stream.length + + +-- * List transformations +map = Stream.map +--reverse = Stream.reverse +intersperse = Stream.intersperse +--intercalate = Stream.intercalate +--transpose = Stream.transpose + +-- * Reducing lists (folds) +foldl = Stream.foldl +foldl' = Stream.foldl' +foldl1 = Stream.foldl1 +foldl1' = Stream.foldl1' +foldr = Stream.foldr +foldr1 = Stream.foldr1 + +-- ** Special folds +-- concat = Stream.concat +concatMap = Stream.concatMap +and = Stream.and +or = Stream.or +any = Stream.any +all = Stream.all +sum = Stream.sum +product = Stream.product +maximum = Stream.maximum +minimum = Stream.minimum + +-- * Building lists +-- ** Scans +scanl = \f z xs -> Stream.scanl f z (Stream.snoc xs bottom) + where + bottom :: a + bottom = error "bottom" + +scanl1 = \f xs -> Stream.scanl1 f (Stream.snoc xs bottom) + where + bottom :: a + bottom = error "bottom" + +{- +scanr = Stream.scanr +scanr1 = Stream.scanr1 + +-- ** Accumulating maps +mapAccumL = Stream.mapAccumL +mapAccumR = Stream.mapAccumR +-} +-- ** Infinite lists +iterate = Stream.iterate +repeat = Stream.repeat +replicate = Stream.replicate +cycle = Stream.cycle + +-- ** Unfolding +unfoldr = Stream.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = Stream.take +drop = Stream.drop +splitAt = Stream.splitAt +takeWhile = Stream.takeWhile +dropWhile = Stream.dropWhile +{- +span = Stream.span +break = Stream.break +group = Stream.group +inits = Stream.inits +tails = Stream.tails +-} + +-- * Predicates +isPrefixOf = Stream.isPrefixOf +{- +isSuffixOf = Stream.isSuffixOf +isInfixOf = Stream.isInfixOf +-} +-- * Searching lists +-- ** Searching by equality +elem = Stream.elem +--notElem = Stream.notElem +lookup = Stream.lookup + +-- ** Searching with a predicate +find = Stream.find +filter = Stream.filter +--partition = Stream.partition + +-- * Indexing lists +(!!) = Stream.index +findIndex = Stream.findIndex +elemIndex = Stream.elemIndex +elemIndices = Stream.elemIndices +findIndices = Stream.findIndices + +-- * Zipping and unzipping lists +zip = Stream.zip +zip3 = Stream.zip3 +--zip4 = Stream.zip4 +--zip5 = Stream.zip5 +--zip6 = Stream.zip6 +--zip7 = Stream.zip7 +zipWith = Stream.zipWith +zipWith3 = Stream.zipWith3 +--zipWith4 = Stream.zipWith4 +--zipWith5 = Stream.zipWith5 +--zipWith6 = Stream.zipWith6 +--zipWith7 = Stream.zipWith7 +unzip = Stream.unzip +--unzip3 = Stream.unzip3 +--unzip4 = Stream.unzip4 +--unzip5 = Stream.unzip5 +--unzip6 = Stream.unzip6 +--unzip7 = Stream.unzip7 + +-- * Special lists +-- ** Functions on strings + +{- +lines = Stream.lines +words = Stream.words +unlines = Stream.unlines +unwords = Stream.unwords + +-- ** \"Set\" operations +nub = Stream.nub +delete = Stream.delete +(\\) = (Stream.\\) +union = Stream.union +intersect = Stream.intersect + +-- ** Ordered lists +sort = Stream.sort +insert = Stream.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Stream.nubBy +deleteBy = Stream.deleteBy +deleteFirstsBy = Stream.deleteFirstsBy +unionBy = Stream.unionBy +intersectBy = Stream.intersectBy +groupBy = Stream.groupBy +-} + +-- *** User-supplied comparison (replacing an Ord context) +insertBy = Stream.insertBy +{- +sortBy = Stream.sortBy +-} + +maximumBy = Stream.maximumBy +minimumBy = Stream.minimumBy + +-- * The \"generic\" operations +genericLength = Stream.genericLength +genericTake = Stream.genericTake +genericDrop = Stream.genericDrop +genericIndex = Stream.genericIndex +genericSplitAt = Stream.genericSplitAt +--genericReplicate = Stream.genericReplicate diff --git a/tests/Properties/Monomorphic/StreamList.hs b/tests/Properties/Monomorphic/StreamList.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Monomorphic/StreamList.hs @@ -0,0 +1,385 @@ +-- +-- list like wrappers for abstract streams +-- +-- These specify the versions used when fusion occurs. +-- +-- So we can check our stream implementations, which are only used when +-- fusion happens, are correct. +-- + +module Properties.Monomorphic.StreamList where + +import Prelude +import qualified Prelude +import Properties.Utils + +import qualified Data.Stream as Stream + +-- * Basic interface +cons :: A -> [A] -> [A] +snoc :: [A] -> A -> [A] +append :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +--reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +--transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +--concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] + +{- +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +-} + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] + +{- +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] +-} + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +{- +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool +-} + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +--notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +--partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +findIndex :: (A -> Bool) -> [A] -> Maybe Int +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +{- +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +-} + +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +{- +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +-} + +unzip :: [(A, B)] -> ([A], [B]) +{- +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) +-} + +-- * Special lists +-- ** Functions on strings +unlines :: [String] -> String +-- lines :: String -> [String] +{- +words :: String -> [String] +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] +-} + +-- *** User-supplied comparison (replacing an Ord context) +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +{- +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +-} +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericIndex :: [A] -> I -> A +genericSplitAt :: I -> [A] -> ([A], [A]) +genericReplicate :: I -> A -> [A] + +s = Stream.stream +u = Stream.unstream + +-- * Basic interface +cons = \x xs -> u $ Stream.cons x (s xs) +snoc = \xs x -> u $ Stream.snoc (s xs) x +append = \xs ys -> u $ Stream.append (s xs) (s ys) +head = \xs -> Stream.head (s xs) +last = \xs -> Stream.last (s xs) +tail = \xs -> u $ Stream.tail (s xs) +init = \xs -> u $ Stream.init (s xs) +null = \xs -> Stream.null (s xs) +length = \xs -> Stream.length (s xs) + + +-- * List transformations +map = \f xs -> u $ Stream.map f (s xs) +--reverse = Stream.reverse +intersperse = \sep xs -> u $ Stream.intersperse sep (s xs) +intercalate = \sep xs -> u $ Stream.concatMap s (Stream.intersperse sep(s xs)) + +--transpose = Stream.transpose + +-- * Reducing lists (folds) +foldl = \f z xs -> Stream.foldl f z (s xs) +foldl' = \f z xs -> Stream.foldl' f z (s xs) +foldl1 = \f xs -> Stream.foldl1 f (s xs) +foldl1' = \f xs -> Stream.foldl1' f (s xs) +foldr = \f z xs -> Stream.foldr f z (s xs) +foldr1 = \f xs -> Stream.foldr1 f (s xs) + +-- ** Special folds +-- concat = \ xs -> Stream.concat xs +concatMap = \f xs -> u $ Stream.concatMap (s . f) (s xs) +and = \ xs -> Stream.and (s xs) +or = \ xs -> Stream.or (s xs) +any = \f xs -> Stream.any f (s xs) +all = \f xs -> Stream.all f (s xs) +sum = \ xs -> Stream.sum (s xs) +product = \ xs -> Stream.product (s xs) +maximum = \ xs -> Stream.maximum (s xs) +minimum = \ xs -> Stream.minimum (s xs) + +-- * Building lists +-- ** Scans +scanl = \f z xs -> u (Stream.scanl f z (Stream.snoc (s xs) bottom)) + where + bottom :: a + bottom = error "StreamProperties.bottom" + +scanl1 = \f xs -> u (Stream.scanl1 f (Stream.snoc (s xs) bottom)) + where + bottom :: a + bottom = error "StreamProperties.bottom" + +{- +scanr = \f z xs -> u (Stream.scanr f z (Stream.cons bottom (s xs))) + where + bottom :: a + bottom = error "StreamProperties.bottom" +-} + +{- +scanr1 = Stream.scanr1 + +-- ** Accumulating maps +mapAccumL = Stream.mapAccumL +mapAccumR = Stream.mapAccumR +-} +-- ** Infinite lists +iterate = \f x -> u $ Stream.iterate f x +repeat = \ x -> u $ Stream.repeat x +replicate = \n x -> u $ Stream.replicate n x +cycle = \ xs -> u $ Stream.cycle (s xs) + +-- ** Unfolding +unfoldr = \f x -> u $ Stream.unfoldr f x + +-- * Sublists +-- ** Extracting sublists +take = \n xs -> u $ Stream.take n (s xs) +drop = \n xs -> u $ Stream.drop n (s xs) +splitAt = \n xs -> Stream.splitAt n (s xs) +takeWhile = \f xs -> u $ Stream.takeWhile f (s xs) +dropWhile = \f xs -> u $ Stream.dropWhile f (s xs) +{- +span = Stream.span +break = Stream.break +group = Stream.group +inits = Stream.inits +tails = Stream.tails +-} + +-- * Predicates +isPrefixOf = \xs ys -> Stream.isPrefixOf (s xs) (s ys) +{- +isSuffixOf = Stream.isSuffixOf +isInfixOf = Stream.isInfixOf +-} +-- * Searching lists +-- ** Searching by equality +elem = \key xs -> Stream.elem key (s xs) +--notElem = Stream.notElem +lookup = \key xs -> Stream.lookup key (s xs) + +-- ** Searching with a predicate +find = \p xs -> Stream.find p (s xs) +filter = \p xs -> u $ Stream.filter p (s xs) +--partition = Stream.partition + +-- * Indexing lists +(!!) = \xs -> Stream.index (s xs) +findIndex = \f xs -> Stream.findIndex f (s xs) +elemIndex = \x xs -> Stream.elemIndex x (s xs) +elemIndices = \x xs -> u (Stream.elemIndices x (s xs)) +findIndices = \p xs -> u (Stream.findIndices p (s xs)) + + +-- * Zipping and unzipping lists +zip = \xs ys -> u (Stream.zip (s xs) (s ys)) +zip3 = \xs ys zs -> u (Stream.zip3 (s xs) (s ys) (s zs)) + +zipWith = \f xs ys -> u (Stream.zipWith f (s xs) (s ys)) +zipWith3 = \f xs ys zs -> u (Stream.zipWith3 f (s xs) (s ys) (s zs)) + +unzip = Stream.unzip . s + +{- +zip4 = Stream.zip4 +zip5 = Stream.zip5 +zip6 = Stream.zip6 +zip7 = Stream.zip7 +zipWith4 = Stream.zipWith4 +zipWith5 = Stream.zipWith5 +zipWith6 = Stream.zipWith6 +zipWith7 = Stream.zipWith7 +unzip3 = Stream.unzip3 +unzip4 = Stream.unzip4 +unzip5 = Stream.unzip5 +unzip6 = Stream.unzip6 +unzip7 = Stream.unzip7 +-} + +-- * Special lists +-- ** Functions on strings +unlines = \xs -> u (Stream.concatMap (\x -> Stream.snoc (s x) '\n') (s xs)) +-- lines = \xs -> u (Stream.lines (s xs)) + +{- +words = Stream.words +unwords = Stream.unwords + +-- ** \"Set\" operations +nub = Stream.nub +delete = Stream.delete +(\\) = (Stream.\\) +union = Stream.union +intersect = Stream.intersect + +-- ** Ordered lists +sort = Stream.sort +insert = Stream.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Stream.nubBy +deleteBy = Stream.deleteBy +deleteFirstsBy = Stream.deleteFirstsBy +unionBy = Stream.unionBy +intersectBy = Stream.intersectBy +groupBy = Stream.groupBy +-} + +-- *** User-supplied comparison (replacing an Ord context) +{- +sortBy = Stream.sortBy +-} +insertBy = \cmp x xs -> u $ Stream.insertBy cmp x (s xs) + +maximumBy = \cmp xs -> Stream.maximumBy cmp (s xs) +minimumBy = \cmp xs -> Stream.minimumBy cmp (s xs) + +-- * The \"generic\" operations +genericLength = \xs -> Stream.genericLength (s xs) +genericTake = \n xs -> u $ Stream.genericTake n (s xs) +genericDrop = \n xs -> u $ Stream.genericDrop n (s xs) +genericIndex = \xs n -> Stream.genericIndex (s xs) n +genericSplitAt = \n xs -> Stream.genericSplitAt n (s xs) +genericReplicate = \n x -> genericTake n (Prelude.repeat x) + diff --git a/tests/Properties/StreamListVsBase.hs b/tests/Properties/StreamListVsBase.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/StreamListVsBase.hs @@ -0,0 +1,459 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import System.IO +import Properties.Utils + +import qualified Properties.Monomorphic.StreamList as Test -- stream functions +import qualified Properties.Monomorphic.Base as Spec -- Data.List + +-- +-- Data.Stream <=> Data.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_cons = Test.cons `eq2` (:) +prop_snoc = Test.snoc `eq2` (\xs x -> xs Spec.++ [x]) +prop_append = Test.append `eq2` (Spec.++) +prop_head = Test.head `eqnotnull1` Spec.head +prop_last = Test.last `eqnotnull1` Spec.last +prop_tail = Test.tail `eqnotnull1` Spec.tail +prop_init = Test.init `eqnotnull1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +-- prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +prop_intercalate = Test.intercalate `eq2` Spec.intercalate +-- prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' + +prop_foldl1 = Test.foldl1 `eqnotnull2` Spec.foldl1 -- n.b. +prop_foldl1' = Test.foldl1' `eqnotnull2` Spec.foldl1' -- n.b. + +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eqnotnull2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +-- prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eqnotnull1` Spec.maximum +prop_minimum = Test.minimum `eqnotnull1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +-- prop_scanr = Test.scanr `eq3` Spec.scanr + +{- +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 +-} + +------------------------------------------------------------------------ +-- ** Accumulating maps + +{- +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR +-} + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eq2` Spec.replicate +prop_cycle = \x -> not (null x) ==> + (Test.cycle `eqfinite1` Spec.cycle) x + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile + +{- +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails +-} + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +{- +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf +-} + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +-- prop_notElem = Test.notElem `eq2` Spec.notElem -- no specific implementation +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +-- prop_partition = Test.partition `eq2` Spec.partition + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = \xs n -> n >= 0 && n < length xs ==> + ((Test.!!) `eq2` (Spec.!!)) xs n +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +prop_zip3 = Test.zip3 `eq3` Spec.zip3 + +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 + +{- +prop_zip4 = Test.zip4 `eq4` Spec.zip4 +prop_zip5 = Test.zip5 `eq5` Spec.zip5 +prop_zip6 = Test.zip6 `eq6` Spec.zip6 +prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 +-} + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip + +{- +prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 +-} + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings +prop_unlines = Test.unlines `eq1` Spec.unlines +-- prop_lines = Test.lines `eq1` Spec.lines + +{- +prop_words = Test.words `eq1` Spec.words +prop_unwords = Test.unwords `eq1` Spec.unwords +-} + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +{- +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect +-} + +------------------------------------------------------------------------ +-- ** Ordered lists + +{- +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert +-} + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +{- +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy +-} + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +{- +prop_sortBy = Test.sortBy `eq2` Spec.sortBy +-} +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eqnotnull2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eqnotnull2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = \i -> i >= I 0 ==> + (Test.genericTake `eq2` Spec.genericTake) i +prop_genericDrop = \i -> i >= I 0 ==> + (Test.genericDrop `eq2` Spec.genericDrop) i +prop_genericIndex = \xs i -> i >= I 0 && i < Spec.genericLength xs ==> + (Test.genericIndex `eq2` Spec.genericIndex) xs i +prop_genericSplitAt = \i -> i >= I 0 ==> + (Test.genericSplitAt `eq2` Spec.genericSplitAt) i +prop_genericReplicate = \i -> i >= I 0 ==> + (Test.genericReplicate `eq2` Spec.genericReplicate) i + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing: Data.Stream <=> Data.List" + putStrLn "==================================\n" + + runTests "Basic interface" opts + [run prop_cons + ,run prop_snoc + ,run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map +-- ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate +-- ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldr + + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [ +-- run prop_concat, + run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 +{- + ,run prop_scanr + ,run prop_scanr1 +-} + ] + +{- + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] +-} + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + +{- + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails +-} + ] + + runTests "Predicates" opts + [run prop_isPrefixOf +{- + ,run prop_isSuffixOf + ,run prop_isInfixOf +-} + ] + + runTests "Searching by equality" opts + [run prop_elem +-- ,run prop_notElem-- no specific implementation + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter +-- ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_findIndex + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndices + ] + + runTests "Zipping" opts + [ + run prop_zip + ,run prop_zip3 +{- + ,run prop_zip4 + ,run prop_zip5 + ,run prop_zip6 + ,run prop_zip7 +-} + ,run prop_zipWith + ,run prop_zipWith3 +{- + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 +-} + ] + + runTests "Unzipping" opts + [run prop_unzip +{- + ,run prop_unzip3 + ,run prop_unzip4 + ,run prop_unzip5 + ,run prop_unzip6 + ,run prop_unzip7 +-} + ] + + runTests "Functions on strings" opts + [run prop_unlines +{- + ,run prop_lines + ,run prop_words + ,run prop_unwords +-} + ] + +{- + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] +-} + +{- + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] +-} + +{- + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] +-} + + runTests "Ord style \"By\" operations" opts +{- + run prop_sortBy -- note issue here. +-} + [run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericIndex + ,run prop_genericSplitAt + ,run prop_genericReplicate + ] diff --git a/tests/Properties/StreamListVsSpec.hs b/tests/Properties/StreamListVsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/StreamListVsSpec.hs @@ -0,0 +1,463 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import System.IO +import Properties.Utils + +import qualified Properties.Monomorphic.StreamList as Test -- stream functions +import qualified Properties.Monomorphic.Spec as Spec -- H98 + +-- +-- Data.Stream <=> Spec.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_cons = Test.cons `eq2` (:) +prop_snoc = Test.snoc `eq2` (\xs x -> xs Spec.++ [x]) +prop_append = Test.append `eq2` (Spec.++) +prop_head = Test.head `eqnotnull1` Spec.head +prop_last = Test.last `eqnotnull1` Spec.last +prop_tail = Test.tail `eqnotnull1` Spec.tail +prop_init = Test.init `eqnotnull1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +-- prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +prop_intercalate = Test.intercalate `eq2` Spec.intercalate +-- prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' + +prop_foldl1 = Test.foldl1 `eqnotnull2` Spec.foldl1 -- n.b. +prop_foldl1' = Test.foldl1' `eqnotnull2` Spec.foldl1' -- n.b. + +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eqnotnull2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +-- prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eqnotnull1` Spec.maximum +prop_minimum = Test.minimum `eqnotnull1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +-- prop_scanr = Test.scanr `eq3` Spec.scanr + +{- +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 +-} + +------------------------------------------------------------------------ +-- ** Accumulating maps + +{- +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR +-} + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eq2` Spec.replicate +prop_cycle = \x -> not (null x) ==> + (Test.cycle `eqfinite1` Spec.cycle) x + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile + +{- +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails +-} + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +{- +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf +-} + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +-- prop_notElem = Test.notElem `eq2` Spec.notElem -- no specific implementation +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +-- prop_partition = Test.partition `eq2` Spec.partition + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = \xs n -> n >= 0 && n < length xs ==> + ((Test.!!) `eq2` (Spec.!!)) xs n +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +prop_zip3 = Test.zip3 `eq3` Spec.zip3 + +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 + +{- +prop_zip4 = Test.zip4 `eq4` Spec.zip4 +prop_zip5 = Test.zip5 `eq5` Spec.zip5 +prop_zip6 = Test.zip6 `eq6` Spec.zip6 +prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 +-} + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip + +{- +prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 +-} + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings +prop_unlines = Test.unlines `eq1` Spec.unlines +-- prop_lines = Test.lines `eq1` Spec.lines + +{- +prop_words = Test.words `eq1` Spec.words +prop_unwords = Test.unwords `eq1` Spec.unwords +-} + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +{- +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect +-} + +------------------------------------------------------------------------ +-- ** Ordered lists + +{- +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert +-} + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +{- +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy +-} + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +{- +prop_sortBy = Test.sortBy `eq2` Spec.sortBy +-} +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eqnotnull2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eqnotnull2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = \i -> i >= I 0 ==> + (Test.genericTake `eq2` Spec.genericTake) i +prop_genericDrop = \i -> i >= I 0 ==> + (Test.genericDrop `eq2` Spec.genericDrop) i +prop_genericIndex = \xs i -> i >= I 0 && i < Spec.genericLength xs ==> + (Test.genericIndex `eq2` Spec.genericIndex) xs i +prop_genericSplitAt = \i -> i >= I 0 ==> + (Test.genericSplitAt `eq2` Spec.genericSplitAt) i +prop_genericReplicate = \i -> i >= I 0 ==> + (Test.genericReplicate `eq2` Spec.genericReplicate) i + +------------------------------------------------------------------------ + +{-# RULES +"main/error" main = error "RULES are on!" + #-} + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing: Data.Stream <=> Spec.List" + putStrLn "==================================\n" + + runTests "Basic interface" opts + [run prop_cons + ,run prop_snoc + ,run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map +-- ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate +-- ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldr + + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [ +-- run prop_concat, + run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 +{- + ,run prop_scanr + ,run prop_scanr1 +-} + ] + +{- + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] +-} + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + +{- + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails +-} + ] + + runTests "Predicates" opts + [run prop_isPrefixOf +{- + ,run prop_isSuffixOf + ,run prop_isInfixOf +-} + ] + + runTests "Searching by equality" opts + [run prop_elem +-- ,run prop_notElem-- no specific implementation + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter +-- ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_findIndex + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndices + ] + + runTests "Zipping" opts + [ + run prop_zip + ,run prop_zip3 +{- + ,run prop_zip4 + ,run prop_zip5 + ,run prop_zip6 + ,run prop_zip7 +-} + ,run prop_zipWith + ,run prop_zipWith3 +{- + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 +-} + ] + + runTests "Unzipping" opts + [run prop_unzip +{- + ,run prop_unzip3 + ,run prop_unzip4 + ,run prop_unzip5 + ,run prop_unzip6 + ,run prop_unzip7 +-} + ] + + runTests "Functions on strings" opts + [run prop_unlines +{- + ,run prop_lines + ,run prop_words + ,run prop_unwords +-} + ] + +{- + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] +-} + +{- + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] +-} + +{- + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] +-} + + runTests "Ord style \"By\" operations" opts +{- + run prop_sortBy -- note issue here. +-} + [run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericIndex + ,run prop_genericSplitAt + ,run prop_genericReplicate + ] diff --git a/tests/Properties/StreamVsSpecStream.hs b/tests/Properties/StreamVsSpecStream.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/StreamVsSpecStream.hs @@ -0,0 +1,475 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import System.IO +import Properties.Utils hiding (eqnotnull1, eqnotnull2, eqnotnull3 + ,eqfinite1, eqfinite2, eqfinite1) + +import qualified Properties.Monomorphic.Stream as Test -- stream functions +import qualified Properties.Monomorphic.SpecStream as Spec -- H98 + +import qualified Data.Stream as Stream (Stream(Stream), Step(..), null, take, length) + +-- +-- Data.Stream <=> Spec.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_cons = Test.cons `eq2` Spec.cons +prop_snoc = Test.snoc `eq2` Spec.snoc +prop_append = Test.append `eq2` (Spec.++) +prop_head = Test.head `eqnotnull1` Spec.head +prop_last = Test.last `eqnotnull1` Spec.last +prop_tail = Test.tail `eqnotnull1` Spec.tail +prop_init = Test.init `eqnotnull1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +-- prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +-- prop_intercalate = Test.intercalate `eq2` Spec.intercalate +-- prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' + +prop_foldl1 = Test.foldl1 `eqnotnull2` Spec.foldl1 -- n.b. +prop_foldl1' = Test.foldl1' `eqnotnull2` Spec.foldl1' -- n.b. + +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eqnotnull2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +-- prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eqnotnull1` Spec.maximum +prop_minimum = Test.minimum `eqnotnull1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 + +{- +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 +prop_scanr = Test.scanr `eq3` Spec.scanr +-} + +------------------------------------------------------------------------ +-- ** Accumulating maps + +{- +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR +-} + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eq2` Spec.replicate +prop_cycle = \x -> not (Stream.null x) ==> + (Test.cycle `eqfinite1` Spec.cycle) x + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile + +{- +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails +-} + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +{- +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf +-} + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +-- prop_notElem = Test.notElem `eq2` Spec.notElem -- no specific implementation +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +-- prop_partition = Test.partition `eq2` Spec.partition + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = \xs n -> n >= 0 && n < Stream.length xs ==> + ((Test.!!) `eq2` (Spec.!!)) xs n +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +prop_zip3 = Test.zip3 `eq3` Spec.zip3 + +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 + +{- +prop_zip4 = Test.zip4 `eq4` Spec.zip4 +prop_zip5 = Test.zip5 `eq5` Spec.zip5 +prop_zip6 = Test.zip6 `eq6` Spec.zip6 +prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 +-} + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip + +{- +prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 +-} + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +-- hmm? +{- +prop_lines = Test.lines `eq1` Spec.lines +prop_words = Test.words `eq1` Spec.words +prop_unlines = Test.unlines `eq1` Spec.unlines +prop_unwords = Test.unwords `eq1` Spec.unwords +-} + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +{- +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect +-} + +------------------------------------------------------------------------ +-- ** Ordered lists + +{- +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert +-} + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +{- +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy +-} + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +{- +prop_sortBy = Test.sortBy `eq2` Spec.sortBy +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +-} +prop_maximumBy = Test.maximumBy `eqnotnull2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eqnotnull2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = \i -> i >= I 0 ==> + (Test.genericTake `eq2` Spec.genericTake) i +prop_genericDrop = \i -> i >= I 0 ==> + (Test.genericDrop `eq2` Spec.genericDrop) i +prop_genericIndex = \xs i -> i >= I 0 && i < Spec.genericLength xs ==> + (Test.genericIndex `eq2` Spec.genericIndex) xs i +prop_genericSplitAt = \i -> i >= I 0 ==> + (Test.genericSplitAt `eq2` Spec.genericSplitAt) i +--prop_genericReplicate = \i -> i >= I 0 ==> +-- (Test.genericReplicate `eq2` Spec.genericReplicate) i + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing: Data.Stream <=> Spec.List" + putStrLn "==================================\n" + + runTests "Basic interface" opts + [run prop_cons + ,run prop_snoc + ,run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map +-- ,run prop_reverse + ,run prop_intersperse +-- ,run prop_intercalate +-- ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldr + + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [ +-- run prop_concat, + run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 +{- +-- ,run prop_scanr + ,run prop_scanr1 +-} + ] + +{- + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] +-} + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + +{- + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails +-} + ] + + runTests "Predicates" opts + [run prop_isPrefixOf +{- + ,run prop_isSuffixOf + ,run prop_isInfixOf +-} + ] + + runTests "Searching by equality" opts + [run prop_elem +-- ,run prop_notElem-- no specific implementation + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter +-- ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_findIndex + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndices + ] + + runTests "Zipping" opts + [ + run prop_zip + ,run prop_zip3 +{- + ,run prop_zip4 + ,run prop_zip5 + ,run prop_zip6 + ,run prop_zip7 +-} + ,run prop_zipWith + ,run prop_zipWith3 +{- + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 +-} + ] + + runTests "Unzipping" opts + [run prop_unzip +{- + ,run prop_unzip3 + ,run prop_unzip4 + ,run prop_unzip5 + ,run prop_unzip6 + ,run prop_unzip7 +-} + ] + + runTests "Functions on strings" opts + [ +{- + run prop_unlines + ,run prop_lines + ,run prop_words + ,run prop_unwords +-} + ] + +{- + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] +-} + +{- + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] +-} + +{- + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] +-} + + runTests "Ord style \"By\" operations" opts + [ +{- + run prop_sortBy -- note issue here. + ,run prop_insertBy +-} + run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericIndex + ,run prop_genericSplitAt +-- ,run prop_genericReplicate + ] + +------------------------------------------------------------------------ + +eqnotnull1 f g = \x -> (not (Stream.null x)) ==> eq1 f g x +eqnotnull2 f g = \x y -> (not (Stream.null y)) ==> eq2 f g x y +eqnotnull3 f g = \x y z -> (not (Stream.null z)) ==> eq3 f g x y z + +eqfinite1 f g = \x -> forAll arbitrary $ \n -> Stream.take n (f x) == Stream.take n (g x) +eqfinite2 f g = \x y -> forAll arbitrary $ \n -> Stream.take n (f x y) == Stream.take n (g x y) +eqfinite3 f g = \x y z -> forAll arbitrary $ \n -> Stream.take n (f x y z) == Stream.take n (g x y z) diff --git a/tests/Properties/Utils.hs b/tests/Properties/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Utils.hs @@ -0,0 +1,162 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +module Properties.Utils ( + module Properties.Utils, + module Test.QuickCheck, + module Test.QuickCheck.Batch, + ) where + +import Test.QuickCheck +import Test.QuickCheck.Batch +import Text.Show.Functions + +import Control.Monad (liftM,liftM5) + +import qualified Data.Stream as S + +opts = TestOptions { + no_of_tests = 200, + length_of_tests = 0, + debug_tests = False + } + +eq1 :: (Eq a) => (t -> a) -> (t -> a) -> t -> Property +eq2 :: (Eq a) => (t -> t1 -> a) -> (t -> t1 -> a) -> t -> t1 -> Property +eq3 :: (Eq a) => (t -> t1 -> t2 -> a) + -> (t -> t1 -> t2 -> a) + -> t -> t1 -> t2 -> Property +eq4 :: (Eq a) => (t -> t1 -> t2 -> t3 -> a) + -> (t -> t1 -> t2 -> t3 -> a) + -> t -> t1 -> t2 -> t3 -> Property +eq5 :: (Eq a) => (t -> t1 -> t2 -> t3 -> t4 -> a) + -> (t -> t1 -> t2 -> t3 -> t4 -> a) + -> t -> t1 -> t2 -> t3 -> t4 -> Property +eq6 :: (Eq a) => (t -> t1 -> t2 -> t3 -> t4 -> t5 -> a) + -> (t -> t1 -> t2 -> t3 -> t4 -> t5 -> a) + -> t -> t1 -> t2 -> t3 -> t4 -> t5 -> Property +eq7 :: (Eq a) => (t -> t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> a) + -> (t -> t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> a) + -> t -> t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> Property +eq8 :: (Eq a) => (t -> t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> t7 -> a) + -> (t -> t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> t7 -> a) + -> t -> t1 -> t2 -> t3 -> t4 -> t5 -> t6 -> t7 -> Property + +eq1 f g = \x -> property $ f x == g x +eq2 f g = \x y -> property $ f x y == g x y +eq3 f g = \x y z -> property $ f x y z == g x y z +eq4 f g = \x y z a -> property $ f x y z a == g x y z a +eq5 f g = \x y z a b -> property $ f x y z a b == g x y z a b +eq6 f g = \x y z a b c -> property $ f x y z a b c == g x y z a b c +eq7 f g = \x y z a b c d -> property $ f x y z a b c d == g x y z a b c d +eq8 f g = \x y z a b c d e -> property $ f x y z a b c d e == g x y z a b c d e + +eqnotnull1 :: (Eq a1) => ([a] -> a1) -> ([a] -> a1) -> [a] -> Property +eqnotnull2 :: (Eq a1) => (t -> [a] -> a1) + -> (t -> [a] -> a1) -> t -> [a] -> Property +eqnotnull3 :: (Eq a1) => (t -> t1 -> [a] -> a1) + -> (t -> t1 -> [a] -> a1) -> t -> t1 -> [a] -> Property + +eqnotnull1 f g = \x -> (not (null x)) ==> eq1 f g x +eqnotnull2 f g = \x y -> (not (null y)) ==> eq2 f g x y +eqnotnull3 f g = \x y z -> (not (null z)) ==> eq3 f g x y z + +eqfinite1 f g = \x -> forAll arbitrary $ \n -> Prelude.take n (f x) == Prelude.take n (g x) +eqfinite2 f g = \x y -> forAll arbitrary $ \n -> Prelude.take n (f x y) == Prelude.take n (g x y) +eqfinite3 f g = \x y z -> forAll arbitrary $ \n -> Prelude.take n (f x y z) == Prelude.take n (g x y z) + + +newtype A = A Int deriving (Eq, Show, Arbitrary) +newtype B = B Int deriving (Eq, Show, Arbitrary) +newtype C = C Int deriving (Eq, Show, Arbitrary) +type D = A +type E = B +type F = C +type G = A +type H = B + +newtype OrdA = OrdA Int deriving (Eq, Ord, Show, Arbitrary) + +newtype N = N Int deriving (Eq, Ord, Num, Show, Arbitrary) +newtype I = I Int deriving (Eq, Ord, Num, Enum, Real, Integral, Show, Arbitrary) + +instance Arbitrary Char where + arbitrary = elements ([' ', '\n', '\0'] ++ ['a'..'h']) + coarbitrary c = variant (fromEnum c `rem` 4) + +instance Arbitrary Ordering where + arbitrary = elements [LT, EQ, GT] + coarbitrary LT = variant 0 + coarbitrary EQ = variant 1 + coarbitrary GT = variant 2 + +{- +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = frequency [ (1, return Nothing) + , (3, liftM Just arbitrary) ] + coarbitrary Nothing = variant 0 + coarbitrary (Just a) = variant 1 . coarbitrary a + -} + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) + => Arbitrary (a, b, c, d ,e ) + where + arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary + coarbitrary (a, b, c, d, e) = + coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) + => Arbitrary (a, b, c, d, e, f) + where + arbitrary = liftM6 (,,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary + coarbitrary (a, b, c, d, e, f) = + coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e . coarbitrary f + +liftM6 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m r +liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) } + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f, Arbitrary g) + => Arbitrary (a, b, c, d, e, f, g) + where + arbitrary = liftM7 (,,,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary arbitrary + coarbitrary (a, b, c, d, e, f, g) = + coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d . coarbitrary e . coarbitrary f . coarbitrary g + +liftM7 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m r +liftM7 f m1 m2 m3 m4 m5 m6 m7 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7 ; return (f x1 x2 x3 x4 x5 x6 x7) } + + +------------------------------------------------------------------------ +-- Arbitrary instance for Stream + +{- +instance (Arbitrary a, Arbitrary s) => Arbitrary (S.Step a s) where + arbitrary = do x <- arbitrary + a <- arbitrary + s <- arbitrary + return $ case x of + LT -> S.Yield a s + EQ -> S.Skip s + GT -> S.Done + coarbitrary = error "No coarbitrary for Step a s" +-} + +-- existential state type +instance (Arbitrary a) => Arbitrary (S.Stream a) where + coarbitrary = error "No coarbitrary for Streams" + arbitrary = do xs <- arbitrary :: Gen [a] + skips <- arbitrary :: Gen [Bool] -- random Skips + return (stream' (zip xs skips)) + where + -- | Construct an abstract stream from a list, with Steps in it. + stream' :: [(a,Bool)] -> S.Stream a + stream' xs0 = S.Stream next (S.L xs0) + where + next (S.L []) = S.Done + next (S.L ((x,True ):xs)) = S.Yield x (S.L xs) + next (S.L ((_,False):xs)) = S.Skip (S.L xs) + +instance Show a => Show (S.Stream a) where + show = show . S.unstream + +instance Eq a => Eq (S.Stream a) where + xs == ys = S.unstream xs == S.unstream ys diff --git a/tests/Spec/List.hs b/tests/Spec/List.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/List.hs @@ -0,0 +1,289 @@ +-- Taken from the Haskell 98 Report: +-- http://haskell.org/onlinereport/ + +-- Modifications to make it compile: +-- changed module name +-- limited import list from the real Prelude +-- copied listToMaybe from the Maybe module + +module Spec.List ( + elemIndex, elemIndices, + find, findIndex, findIndices, + nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy, + union, unionBy, intersect, intersectBy, + intersperse, transpose, partition, group, groupBy, + inits, tails, isPrefixOf, isSuffixOf, + mapAccumL, mapAccumR, + sort, sortBy, insert, insertBy, maximumBy, minimumBy, + genericLength, genericTake, genericDrop, + genericSplitAt, genericIndex, genericReplicate, + zip4, zip5, zip6, zip7, + zipWith4, zipWith5, zipWith6, zipWith7, + unzip4, unzip5, unzip6, unzip7, unfoldr, + + -- ...and what the Prelude exports + -- []((:), []), -- This is built-in syntax + map, (++), concat, filter, + head, last, tail, init, null, length, (!!), + foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1, + iterate, repeat, replicate, cycle, + take, drop, splitAt, takeWhile, dropWhile, span, break, + lines, words, unlines, unwords, reverse, and, or, + any, all, elem, notElem, lookup, + sum, product, maximum, minimum, concatMap, + zip, zip3, zipWith, zipWith3, unzip, unzip3 + ) where + +import Prelude (Int, Integer, Integral, Num(..), Eq(..), Ord(..), Ordering(..), + Bool(..), (&&), (||), not, Maybe(..), String, + (.), error, seq, otherwise, flip) +import Spec.PreludeList + +infix 5 \\ -- for cpp + +-- copied from the Maybe module + +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:_) = Just a + + + +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x ==) + +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x ==) + +find :: (a -> Bool) -> [a] -> Maybe a +find p = listToMaybe . filter p + +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p = listToMaybe . findIndices p + +findIndices :: (a -> Bool) -> [a] -> [Int] +findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ] + +nub :: Eq a => [a] -> [a] +nub = nubBy (==) + +nubBy :: (a -> a -> Bool) -> [a] -> [a] +nubBy eq [] = [] +nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs) + +delete :: Eq a => a -> [a] -> [a] +delete = deleteBy (==) + +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteBy eq x [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +(\\) :: Eq a => [a] -> [a] -> [a] +(\\) = foldl (flip delete) + +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) + +union :: Eq a => [a] -> [a] -> [a] +union = unionBy (==) + +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy eq xs ys = xs ++ deleteFirstsBy eq (nubBy eq ys) xs + +intersect :: Eq a => [a] -> [a] -> [a] +intersect = intersectBy (==) + +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] + +intersperse :: a -> [a] -> [a] +intersperse sep [] = [] +intersperse sep [x] = [x] +intersperse sep (x:xs) = x : sep : intersperse sep xs + +-- transpose is lazy in both rows and columns, +-- and works for non-rectangular 'matrices' +-- For example, transpose [[1,2],[3,4,5],[]] = [[1,3],[2,4],[5]] +-- Note that [h | (h:t) <- xss] is not the same as (map head xss) +-- because the former discards empty sublists inside xss +transpose :: [[a]] -> [[a]] +transpose [] = [] +transpose ([] : xss) = transpose xss +transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : + transpose (xs : [t | (h:t) <- xss]) + +partition :: (a -> Bool) -> [a] -> ([a],[a]) +partition p xs = (filter p xs, filter (not . p) xs) + +-- group splits its list argument into a list of lists of equal, adjacent +-- elements. e.g., +-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"] +group :: Eq a => [a] -> [[a]] +group = groupBy (==) + +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy eq [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs + where (ys,zs) = span (eq x) xs + +-- inits xs returns the list of initial segments of xs, shortest first. +-- e.g., inits "abc" == ["","a","ab","abc"] +inits :: [a] -> [[a]] +inits [] = [[]] +inits (x:xs) = [[]] ++ map (x:) (inits xs) + +-- tails xs returns the list of all final segments of xs, longest first. +-- e.g., tails "abc" == ["abc", "bc", "c",""] +tails :: [a] -> [[a]] +tails [] = [[]] +tails xxs@(_:xs) = xxs : tails xs + +isPrefixOf :: Eq a => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (x:xs) (y:ys) = x == y && isPrefixOf xs ys + +isSuffixOf :: Eq a => [a] -> [a] -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y + +mapAccumL :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccumL f s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +mapAccumR :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccumR f s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs + +unfoldr :: (b -> Maybe (a,b)) -> b -> [a] +unfoldr f b = case f b of + Nothing -> [] + Just (a,b) -> a : unfoldr f b + +sort :: (Ord a) => [a] -> [a] +sort = sortBy compare + +sortBy :: (a -> a -> Ordering) -> [a] -> [a] +sortBy cmp = foldr (insertBy cmp) [] + +insert :: (Ord a) => a -> [a] -> [a] +insert = insertBy compare + +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy cmp x [] = [x] +insertBy cmp x ys@(y:ys') + = case cmp x y of + GT -> y : insertBy cmp x ys' + _ -> x : ys + +maximumBy :: (a -> a -> Ordering) -> [a] -> a +maximumBy cmp [] = error "List.maximumBy: empty list" +maximumBy cmp xs = foldl1 max xs + where + max x y = case cmp x y of + GT -> x + _ -> y + +minimumBy :: (a -> a -> Ordering) -> [a] -> a +minimumBy cmp [] = error "List.minimumBy: empty list" +minimumBy cmp xs = foldl1 min xs + where + min x y = case cmp x y of + GT -> y + _ -> x + +genericLength :: (Integral a) => [b] -> a +genericLength [] = 0 +genericLength (x:xs) = 1 + genericLength xs + +genericTake :: (Integral a) => a -> [b] -> [b] +genericTake _ [] = [] +genericTake 0 _ = [] +genericTake n (x:xs) + | n > 0 = x : genericTake (n-1) xs + | otherwise = error "List.genericTake: negative argument" + +genericDrop :: (Integral a) => a -> [b] -> [b] +genericDrop 0 xs = xs +genericDrop _ [] = [] +genericDrop n (_:xs) + | n > 0 = genericDrop (n-1) xs + | otherwise = error "List.genericDrop: negative argument" + +genericSplitAt :: (Integral a) => a -> [b] -> ([b],[b]) +genericSplitAt 0 xs = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) + | n > 0 = (x:xs',xs'') + | otherwise = error "List.genericSplitAt: negative argument" + where (xs',xs'') = genericSplitAt (n-1) xs + +genericIndex :: (Integral a) => [b] -> a -> b +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = error "List.genericIndex: negative argument" +genericIndex _ _ = error "List.genericIndex: index too large" + +genericReplicate :: (Integral a) => a -> b -> [b] +genericReplicate n x = genericTake n (repeat x) + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (,,,) + +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (,,,,) + +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [(a,b,c,d,e,f)] +zip6 = zipWith6 (,,,,,) + +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [g] -> [(a,b,c,d,e,f,g)] +zip7 = zipWith7 (,,,,,,) + +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] + +zipWith5 :: (a->b->c->d->e->f) -> + [a]->[b]->[c]->[d]->[e]->[f] +zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] + +zipWith6 :: (a->b->c->d->e->f->g) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g] +zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] + +zipWith7 :: (a->b->c->d->e->f->g->h) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] +zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +zipWith7 _ _ _ _ _ _ _ _ = [] + +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) + +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) + +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) + +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) diff --git a/tests/Spec/ListExts.hs b/tests/Spec/ListExts.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/ListExts.hs @@ -0,0 +1,33 @@ +-- Spececifications of things in Data.List but not in the H98 List module + + +module Spec.ListExts ( + foldl', + foldl1', + + intercalate, + + isInfixOf, + ) where + +import Prelude (Int, Integer, Integral, Num(..), Eq(..), Ord(..), Ordering(..), + Bool(..), (&&), (||), not, Maybe(..), String, + (.), error, seq, otherwise, flip) +import Spec.List + +foldl' :: (a -> b -> a) -> a -> [b] -> a +foldl' f z [] = z +foldl' f z (x:xs) = let z' = f z x in z' `seq` foldl f z' xs + + +foldl1' :: (a -> a -> a) -> [a] -> a +foldl1' f (x:xs) = foldl' f x xs +foldl1' _ [] = error "Prelude.foldl1: empty list" + + +isInfixOf :: Eq a => [a] -> [a] -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + + +intercalate :: [a] -> [[a]] -> [a] +intercalate xs xss = concat (intersperse xs xss) diff --git a/tests/Spec/PreludeList.hs b/tests/Spec/PreludeList.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/PreludeList.hs @@ -0,0 +1,358 @@ +-- Taken from the Haskell 98 Report: +-- http://haskell.org/onlinereport/ + +-- Modifications to make it compile: +-- changed module name +-- limited import list from the real Prelude + +module Spec.PreludeList ( + map, (++), filter, concat, concatMap, + head, last, tail, init, null, length, (!!), + foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1, + iterate, repeat, replicate, cycle, + take, drop, splitAt, takeWhile, dropWhile, span, break, + lines, words, unlines, unwords, reverse, and, or, + any, all, elem, notElem, lookup, + sum, product, maximum, minimum, + zip, zip3, zipWith, zipWith3, unzip, unzip3) + where + +import Prelude (Int, Integer, Integral, Num(..), Eq(..), Ord(..), Ordering(..), + Bool(..), (&&), (||), not, Maybe(..), String, + (.), error, seq, otherwise, flip) +import qualified Char(isSpace) + +infixl 9 !! +infixr 5 ++ +infix 4 `elem`, `notElem` + +-- Map and append + +map :: (a -> b) -> [a] -> [b] +map f [] = [] +map f (x:xs) = f x : map f xs + + +(++) :: [a] -> [a] -> [a] +[] ++ ys = ys +(x:xs) ++ ys = x : (xs ++ ys) + + +filter :: (a -> Bool) -> [a] -> [a] +filter p [] = [] +filter p (x:xs) | p x = x : filter p xs + | otherwise = filter p xs + + +concat :: [[a]] -> [a] +concat xss = foldr (++) [] xss + + +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = concat . map f + +-- head and tail extract the first element and remaining elements, +-- respectively, of a list, which must be non-empty. last and init +-- are the dual functions working from the end of a finite list, +-- rather than the beginning. + + +head :: [a] -> a +head (x:_) = x +head [] = error "Prelude.head: empty list" + + +tail :: [a] -> [a] +tail (_:xs) = xs +tail [] = error "Prelude.tail: empty list" + + +last :: [a] -> a +last [x] = x +last (_:xs) = last xs +last [] = error "Prelude.last: empty list" + + +init :: [a] -> [a] +init [x] = [] +init (x:xs) = x : init xs +init [] = error "Prelude.init: empty list" + + +null :: [a] -> Bool +null [] = True +null (_:_) = False + +-- length returns the length of a finite list as an Int. + +length :: [a] -> Int +length [] = 0 +length (_:l) = 1 + length l + +-- List index (subscript) operator, 0-origin + +(!!) :: [a] -> Int -> a +xs !! n | n < 0 = error "Prelude.!!: negative index" +[] !! _ = error "Prelude.!!: index too large" +(x:_) !! 0 = x +(_:xs) !! n = xs !! (n-1) + +-- foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a list, reduces the list using +-- the binary operator, from left to right: +-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- foldl1 is a variant that has no starting value argument, and thus must +-- be applied to non-empty lists. scanl is similar to foldl, but returns +-- a list of successive reduced values from the left: +-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- Note that last (scanl f z xs) == foldl f z xs. +-- scanl1 is similar, again without the starting element: +-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] + + +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z [] = z +foldl f z (x:xs) = foldl f (f z x) xs + + +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs +foldl1 _ [] = error "Prelude.foldl1: empty list" + + +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q xs = q : (case xs of + [] -> [] + x:xs -> scanl f (f q x) xs) + + +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs +scanl1 _ [] = [] + +-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the +-- above functions. + + +foldr :: (a -> b -> b) -> b -> [a] -> b +foldr f z [] = z +foldr f z (x:xs) = f x (foldr f z xs) + + +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 f [x] = x +foldr1 f (x:xs) = f x (foldr1 f xs) +foldr1 _ [] = error "Prelude.foldr1: empty list" + + +scanr :: (a -> b -> b) -> b -> [a] -> [b] +scanr f q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs + + +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 f [] = [] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs + +-- iterate f x returns an infinite list of repeated applications of f to x: +-- iterate f x == [x, f x, f (f x), ...] + +iterate :: (a -> a) -> a -> [a] +iterate f x = x : iterate f (f x) + +-- repeat x is an infinite list, with x the value of every element. + +repeat :: a -> [a] +repeat x = xs where xs = x:xs + +-- replicate n x is a list of length n with x the value of every element + +replicate :: Int -> a -> [a] +replicate n x = take n (repeat x) + +-- cycle ties a finite list into a circular one, or equivalently, +-- the infinite repetition of the original list. It is the identity +-- on infinite lists. + + +cycle :: [a] -> [a] +cycle [] = error "Prelude.cycle: empty list" +cycle xs = xs' where xs' = xs ++ xs' + +-- take n, applied to a list xs, returns the prefix of xs of length n, +-- or xs itself if n > length xs. drop n xs returns the suffix of xs +-- after the first n elements, or [] if n > length xs. splitAt n xs +-- is equivalent to (take n xs, drop n xs). + + +take :: Int -> [a] -> [a] +take n _ | n <= 0 = [] +take _ [] = [] +take n (x:xs) = x : take (n-1) xs + + +drop :: Int -> [a] -> [a] +drop n xs | n <= 0 = xs +drop _ [] = [] +drop n (_:xs) = drop (n-1) xs + + +splitAt :: Int -> [a] -> ([a],[a]) +splitAt n xs = (take n xs, drop n xs) + +-- takeWhile, applied to a predicate p and a list xs, returns the longest +-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs +-- returns the remaining suffix. span p xs is equivalent to +-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. + + +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile p [] = [] +takeWhile p (x:xs) + | p x = x : takeWhile p xs + | otherwise = [] + + +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile p [] = [] +dropWhile p xs@(x:xs') + | p x = dropWhile p xs' + | otherwise = xs + + +span, break :: (a -> Bool) -> [a] -> ([a],[a]) +span p [] = ([],[]) +span p xs@(x:xs') + | p x = (x:ys,zs) + | otherwise = ([],xs) + where (ys,zs) = span p xs' + +break p = span (not . p) + +-- lines breaks a string up into a list of strings at newline characters. +-- The resulting strings do not contain newlines. Similary, words +-- breaks a string up into a list of words, which were delimited by +-- white space. unlines and unwords are the inverse operations. +-- unlines joins lines with terminating newlines, and unwords joins +-- words with separating spaces. + + +lines :: String -> [String] +lines "" = [] +lines s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines s'' + + +words :: String -> [String] +words s = case dropWhile Char.isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = break Char.isSpace s' + + +unlines :: [String] -> String +unlines = concatMap (++ "\n") + + +unwords :: [String] -> String +unwords [] = "" +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws + +-- reverse xs returns the elements of xs in reverse order. xs must be finite. + +reverse :: [a] -> [a] +reverse = foldl (flip (:)) [] + +-- and returns the conjunction of a Boolean list. For the result to be +-- True, the list must be finite; False, however, results from a False +-- value at a finite index of a finite or infinite list. or is the +-- disjunctive dual of and. + +and, or :: [Bool] -> Bool +and = foldr (&&) True +or = foldr (||) False + +-- Applied to a predicate and a list, any determines if any element +-- of the list satisfies the predicate. Similarly, for all. + +any, all :: (a -> Bool) -> [a] -> Bool +any p = or . map p +all p = and . map p + +-- elem is the list membership predicate, usually written in infix form, +-- e.g., x `elem` xs. notElem is the negation. + +elem, notElem :: (Eq a) => a -> [a] -> Bool +elem x = any (== x) +notElem x = all (/= x) + +-- lookup key assocs looks up a key in an association list. + +lookup :: (Eq a) => a -> [(a,b)] -> Maybe b +lookup key [] = Nothing +lookup key ((x,y):xys) + | key == x = Just y + | otherwise = lookup key xys + +-- sum and product compute the sum or product of a finite list of numbers. + +sum, product :: (Num a) => [a] -> a +sum = foldl (+) 0 +product = foldl (*) 1 + +-- maximum and minimum return the maximum or minimum value from a list, +-- which must be non-empty, finite, and of an ordered type. + +maximum, minimum :: (Ord a) => [a] -> a +maximum [] = error "Prelude.maximum: empty list" +maximum xs = foldl1 max xs + +minimum [] = error "Prelude.minimum: empty list" +minimum xs = foldl1 min xs + +-- zip takes two lists and returns a list of corresponding pairs. If one +-- input list is short, excess elements of the longer list are discarded. +-- zip3 takes three lists and returns a list of triples. Zips for larger +-- tuples are in the List library + + +zip :: [a] -> [b] -> [(a,b)] +zip = zipWith (,) + + +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 = zipWith3 (,,) + +-- The zipWith family generalises the zip family by zipping with the +-- function given as the first argument, instead of a tupling function. +-- For example, zipWith (+) is applied to two lists to produce the list +-- of corresponding sums. + + +zipWith :: (a->b->c) -> [a]->[b]->[c] +zipWith z (a:as) (b:bs) + = z a b : zipWith z as bs +zipWith _ _ _ = [] + + +zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith3 z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3 z as bs cs +zipWith3 _ _ _ _ = [] + + +-- unzip transforms a list of pairs into a pair of lists. + + +unzip :: [(a,b)] -> ([a],[b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) + + +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) + ([],[],[]) diff --git a/tests/Strictness/BaseVsSpec.hs b/tests/Strictness/BaseVsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/BaseVsSpec.hs @@ -0,0 +1,391 @@ + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import Prelude hiding (null) +import Strictness.Utils +import System.IO + +import qualified Strictness.Monomorphic.Base as Test -- base implementation +import qualified Strictness.Monomorphic.Spec as Spec -- H98 spec + +-- +-- Data.List <=> Spec.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_append = (Test.++) `eq2` (Spec.++) +prop_head = Test.head `eq1` Spec.head +prop_last = Test.last `eq1` Spec.last +prop_tail = Test.tail `eq1` Spec.tail +prop_init = Test.init `eq1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +prop_intercalate = Test.intercalate `eq2` Spec.intercalate +prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' +prop_foldl1 = Test.foldl1 `eq2` Spec.foldl1 +prop_foldl1' = Test.foldl1' `eq2` Spec.foldl1' +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eq2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eq1` Spec.maximum +prop_minimum = Test.minimum `eq1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +prop_scanr = Test.scanr `eq3` Spec.scanr +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 + +------------------------------------------------------------------------ +-- ** Accumulating maps + +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eqfinite2` Spec.replicate +prop_cycle = Test.cycle `eqfinite1` Spec.cycle + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt -- base is stricter than the spec +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +prop_notElem = Test.notElem `eq2` Spec.notElem +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +prop_partition = Test.partition `eq2` Spec.partition -- base is stricter than the spec + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = (Test.!!) `eq2` (Spec.!!) +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +--prop_zip3 = Test.zip3 `eq3` Spec.zip3 +--prop_zip4 = Test.zip4 `eq4` Spec.zip4 +--prop_zip5 = Test.zip5 `eq5` Spec.zip5 +--prop_zip6 = Test.zip6 `eq6` Spec.zip6 +--prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip +--prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +--prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +--prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +--prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +--prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +prop_lines = Test.lines `eq1` Spec.lines +prop_words = Test.words `eq1` Spec.words +prop_unlines = Test.unlines `eq1` Spec.unlines +prop_unwords = Test.unwords `eq1` Spec.unwords + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect + +------------------------------------------------------------------------ +-- ** Ordered lists + +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +prop_sortBy = Test.sortBy `eq2` Spec.sortBy --need to generate total orders +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eq2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eq2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = Test.genericTake `eq2` Spec.genericTake -- we disagree with the spec +prop_genericDrop = Test.genericDrop `eq2` Spec.genericDrop +prop_genericSplitAt = Test.genericSplitAt `eq2` Spec.genericSplitAt +prop_genericIndex = Test.genericIndex `eq2` Spec.genericIndex +prop_genericReplicate = Test.genericReplicate `eqfinite2` Spec.genericReplicate + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing Data.List <=> Spec.List" + putStrLn "===============================\n" + + runTests "Basic interface" opts + [run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map + ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate + ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [run prop_concat + ,run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 + ,run prop_scanr + ,run prop_scanr1 + ] + + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails + ] + + runTests "Predicates" opts + [run prop_isPrefixOf + ,run prop_isSuffixOf + ,run prop_isInfixOf + ] + + runTests "Searching by equality" opts + [run prop_elem + ,run prop_notElem + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter + ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndex + ,run prop_findIndices + ] + + runTests "Zipping" opts { testDepth = 6, maxTests = 100000 } + [run prop_zip +-- ,run prop_zip3 +-- ,run prop_zip4 +-- ,run prop_zip5 +-- ,run prop_zip6 +-- ,run prop_zip7 + ,run prop_zipWith + ,run prop_zipWith3 + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 + ] + + runTests "Unzipping" opts + [run prop_unzip +-- ,run prop_unzip3 +-- ,run prop_unzip4 +-- ,run prop_unzip5 +-- ,run prop_unzip6 +-- ,run prop_unzip7 + ] + + runTests "Functions on strings" opts + [run prop_lines + ,run prop_words + ,run prop_unlines + ,run prop_unwords + ] + + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] + + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] + + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] + + runTests "Ord style \"By\" operations" opts + [run prop_sortBy -- note issue here. + ,run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericSplitAt + ,run prop_genericIndex + ,run prop_genericReplicate + ] diff --git a/tests/Strictness/ListVsBase.hs b/tests/Strictness/ListVsBase.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/ListVsBase.hs @@ -0,0 +1,400 @@ + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import Prelude hiding (null) +import Strictness.Utils +import System.IO + +import qualified Strictness.Monomorphic.List as Test -- our implementation +import qualified Strictness.Monomorphic.Base as Spec -- base implementation + +-- +-- Data.List.Stream <=> Data.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_append = (Test.++) `eq2` (Spec.++) +prop_head = Test.head `eq1` Spec.head +prop_last = Test.last `eq1` Spec.last +prop_tail = Test.tail `eq1` Spec.tail +prop_init = Test.init `eq1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `refines2` Spec.intersperse +prop_intercalate = Test.intercalate `refines2` Spec.intercalate +prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' -- we're stricter than the 'spec' +prop_foldl1 = Test.foldl1 `eq2` Spec.foldl1 +prop_foldl1' = Test.foldl1' `eq2` Spec.foldl1' -- we're stricter than the 'spec' +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eq2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eq1` Spec.maximum +prop_minimum = Test.minimum `eq1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +prop_scanr = Test.scanr `eq3` Spec.scanr +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 + +------------------------------------------------------------------------ +-- ** Accumulating maps + +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eqfinite2` Spec.replicate +prop_cycle = Test.cycle `eqfinite1` Spec.cycle + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt -- we're stricter than the spec +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +prop_notElem = Test.notElem `eq2` Spec.notElem +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +prop_partition = Test.partition `eq2` Spec.partition -- we're stricter than the spec + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = (Test.!!) `eq2` (Spec.!!) +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +--prop_zip3 = Test.zip3 `eq3` Spec.zip3 +--prop_zip4 = Test.zip4 `eq4` Spec.zip4 +--prop_zip5 = Test.zip5 `eq5` Spec.zip5 +--prop_zip6 = Test.zip6 `eq6` Spec.zip6 +--prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip +--prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +--prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +--prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +--prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +--prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +prop_lines = Test.lines `eq1` Spec.lines +prop_words = Test.words `eq1` Spec.words +prop_unlines = Test.unlines `eq1` Spec.unlines +prop_unwords = Test.unwords `refines1` Spec.unwords + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect + +------------------------------------------------------------------------ +-- ** Ordered lists + +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +prop_sortBy = Test.sortBy `eq2` Spec.sortBy --need to generate total orders +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eq2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eq2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = Test.genericTake `eq2` Spec.genericTake -- we disagree with the spec +prop_genericDrop = Test.genericDrop `eq2` Spec.genericDrop +prop_genericSplitAt = Test.genericSplitAt `eq2` Spec.genericSplitAt +prop_genericIndex = Test.genericIndex `eq2` Spec.genericIndex +prop_genericReplicate = Test.genericReplicate `eqfinite2` Spec.genericReplicate + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing Data.List.Stream <=> Data.List" + putStrLn "======================================\n" + + runTests "Basic interface" opts + [run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map + ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate + ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [run prop_concat + ,run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 + ,run prop_scanr + ,run prop_scanr1 + ] + + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails + ] + + runTests "Predicates" opts + [run prop_isPrefixOf + ,run prop_isSuffixOf + ,run prop_isInfixOf + ] + + runTests "Searching by equality" opts + [run prop_elem + ,run prop_notElem + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter + ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndex + ,run prop_findIndices + ] + + runTests "Zipping" opts { testDepth = 6, maxTests = 100000 } + [run prop_zip +-- ,run prop_zip3 +-- ,run prop_zip4 +-- ,run prop_zip5 +-- ,run prop_zip6 +-- ,run prop_zip7 + ,run prop_zipWith + ,run prop_zipWith3 + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 + ] + + runTests "Unzipping" opts + [run prop_unzip +-- ,run prop_unzip3 +-- ,run prop_unzip4 +-- ,run prop_unzip5 +-- ,run prop_unzip6 +-- ,run prop_unzip7 + ] + + runTests "Functions on strings" opts + [run prop_lines + ,run prop_words + ,run prop_unlines + ,run prop_unwords + ] + + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] + + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] + + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] + + runTests "Ord style \"By\" operations" opts + [run prop_sortBy -- note issue here. + ,run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericSplitAt + ,run prop_genericIndex + ,run prop_genericReplicate + ] +{- +run :: Testable a => a -> Int -> IO () +run = flip depthCheck + +runTests :: String -> [Int -> IO ()] -> IO () +runTests name tests = do + putStrLn name + mapM_ ($ 6) tests +-} diff --git a/tests/Strictness/ListVsSpec.hs b/tests/Strictness/ListVsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/ListVsSpec.hs @@ -0,0 +1,400 @@ + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import Prelude hiding (null) +import Strictness.Utils +import System.IO + +import qualified Strictness.Monomorphic.List as Test -- our implementation +import qualified Strictness.Monomorphic.Spec as Spec -- H98 spec + +-- +-- Data.List.Stream <=> Spec.List +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_append = (Test.++) `eq2` (Spec.++) +prop_head = Test.head `eq1` Spec.head +prop_last = Test.last `eq1` Spec.last +prop_tail = Test.tail `eq1` Spec.tail +prop_init = Test.init `eq1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `refines2` Spec.intersperse +prop_intercalate = Test.intercalate `refines2` Spec.intercalate +prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' -- we're stricter than the 'spec' +prop_foldl1 = Test.foldl1 `eq2` Spec.foldl1 +prop_foldl1' = Test.foldl1' `eq2` Spec.foldl1' -- we're stricter than the 'spec' +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eq2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eq1` Spec.maximum +prop_minimum = Test.minimum `eq1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +prop_scanr = Test.scanr `eq3` Spec.scanr +prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 + +------------------------------------------------------------------------ +-- ** Accumulating maps + +prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eqfinite2` Spec.replicate +prop_cycle = Test.cycle `eqfinite1` Spec.cycle + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt -- we're stricter than the spec +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile +prop_span = Test.span `eq2` Spec.span +prop_break = Test.break `eq2` Spec.break +prop_group = Test.group `eq1` Spec.group +prop_inits = Test.inits `eq1` Spec.inits +prop_tails = Test.tails `eq1` Spec.tails + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +prop_notElem = Test.notElem `eq2` Spec.notElem +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +prop_partition = Test.partition `eq2` Spec.partition -- we're stricter than the spec + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = (Test.!!) `eq2` (Spec.!!) +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +--prop_zip3 = Test.zip3 `eq3` Spec.zip3 +--prop_zip4 = Test.zip4 `eq4` Spec.zip4 +--prop_zip5 = Test.zip5 `eq5` Spec.zip5 +--prop_zip6 = Test.zip6 `eq6` Spec.zip6 +--prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip +--prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +--prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +--prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +--prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +--prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +prop_lines = Test.lines `eq1` Spec.lines +prop_words = Test.words `eq1` Spec.words +prop_unlines = Test.unlines `eq1` Spec.unlines +prop_unwords = Test.unwords `refines1` Spec.unwords + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +prop_nub = Test.nub `eq1` Spec.nub +prop_delete = Test.delete `eq2` Spec.delete +prop_difference = (Test.\\) `eq2` (Spec.\\) +prop_union = Test.union `eq2` Spec.union +prop_intersect = Test.intersect `eq2` Spec.intersect + +------------------------------------------------------------------------ +-- ** Ordered lists + +prop_sort = Test.sort `eq1` Spec.sort +prop_insert = Test.insert `eq2` Spec.insert + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +prop_nubBy = Test.nubBy `eq2` Spec.nubBy +prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +prop_unionBy = Test.unionBy `eq3` Spec.unionBy +prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +prop_groupBy = Test.groupBy `eq2` Spec.groupBy + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +prop_sortBy = Test.sortBy `eq2` Spec.sortBy --need to generate total orders +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eq2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eq2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = Test.genericTake `eq2` Spec.genericTake -- we disagree with the spec +prop_genericDrop = Test.genericDrop `eq2` Spec.genericDrop +prop_genericSplitAt = Test.genericSplitAt `eq2` Spec.genericSplitAt +prop_genericIndex = Test.genericIndex `eq2` Spec.genericIndex +prop_genericReplicate = Test.genericReplicate `eqfinite2` Spec.genericReplicate + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing Data.List.Stream <=> Spec.List" + putStrLn "======================================\n" + + runTests "Basic interface" opts + [run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map + ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate + ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [run prop_concat + ,run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 + ,run prop_scanr + ,run prop_scanr1 + ] + + runTests "Accumulating maps" opts + [run prop_mapAccumL + ,run prop_mapAccumR + ] + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile + ,run prop_span + ,run prop_break + ,run prop_group + ,run prop_inits + ,run prop_tails + ] + + runTests "Predicates" opts + [run prop_isPrefixOf + ,run prop_isSuffixOf + ,run prop_isInfixOf + ] + + runTests "Searching by equality" opts + [run prop_elem + ,run prop_notElem + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter + ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndex + ,run prop_findIndices + ] + + runTests "Zipping" opts { testDepth = 6, maxTests = 100000 } + [run prop_zip +-- ,run prop_zip3 +-- ,run prop_zip4 +-- ,run prop_zip5 +-- ,run prop_zip6 +-- ,run prop_zip7 + ,run prop_zipWith + ,run prop_zipWith3 + ,run prop_zipWith4 + ,run prop_zipWith5 + ,run prop_zipWith6 + ,run prop_zipWith7 + ] + + runTests "Unzipping" opts + [run prop_unzip +-- ,run prop_unzip3 +-- ,run prop_unzip4 +-- ,run prop_unzip5 +-- ,run prop_unzip6 +-- ,run prop_unzip7 + ] + + runTests "Functions on strings" opts + [run prop_lines + ,run prop_words + ,run prop_unlines + ,run prop_unwords + ] + + runTests "\"Set\" operations" opts + [run prop_nub + ,run prop_delete + ,run prop_difference + ,run prop_union + ,run prop_intersect + ] + + runTests "Ordered lists" opts + [run prop_sort + ,run prop_insert + ] + + runTests "Eq style \"By\" operations" opts + [run prop_nubBy + ,run prop_deleteBy + ,run prop_deleteFirstsBy + ,run prop_unionBy + ,run prop_intersectBy + ,run prop_groupBy + ] + + runTests "Ord style \"By\" operations" opts + [run prop_sortBy -- note issue here. + ,run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericSplitAt + ,run prop_genericIndex + ,run prop_genericReplicate + ] +{- +run :: Testable a => a -> Int -> IO () +run = flip depthCheck + +runTests :: String -> [Int -> IO ()] -> IO () +runTests name tests = do + putStrLn name + mapM_ ($ 6) tests +-} diff --git a/tests/Strictness/Monomorphic/Base.hs b/tests/Strictness/Monomorphic/Base.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/Monomorphic/Base.hs @@ -0,0 +1,321 @@ +-- +-- The Data.List api +-- +module Strictness.Monomorphic.Base where + +import Strictness.Utils + +import qualified Data.List as Spec + +-- * Basic interface +(++) :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +unzip :: [(A, B)] -> ([A], [B]) +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) + +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] + + + +-- * Basic interface +(++) = (Spec.++) +head = Spec.head +last = Spec.last +tail = Spec.tail +init = Spec.init +null = Spec.null +length = Spec.length + +-- * List transformations +map = Spec.map +reverse = Spec.reverse +intersperse = Spec.intersperse + +-- intercalate = -- Spec.intercalate +intercalate xs xss = Spec.concat (Spec.intersperse xs xss) + +transpose = Spec.transpose + +-- * Reducing lists (folds) +foldl = Spec.foldl +foldl' = Spec.foldl' +foldl1 = Spec.foldl1 +foldl1' = Spec.foldl1' +foldr = Spec.foldr +foldr1 = Spec.foldr1 + +-- ** Special folds +concat = Spec.concat +concatMap = Spec.concatMap +and = Spec.and +or = Spec.or +any = Spec.any +all = Spec.all +sum = Spec.sum +product = Spec.product +maximum = Spec.maximum +minimum = Spec.minimum + +-- * Building lists +-- ** Scans +scanl = Spec.scanl +scanl1 = Spec.scanl1 +scanr = Spec.scanr +scanr1 = Spec.scanr1 + +-- ** Accumulating maps +mapAccumL = Spec.mapAccumL +mapAccumR = Spec.mapAccumR + +-- ** Infinite lists +iterate = Spec.iterate +repeat = Spec.repeat +replicate = Spec.replicate +cycle = Spec.cycle + +-- ** Unfolding +unfoldr = Spec.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = Spec.take +drop = Spec.drop +splitAt = Spec.splitAt +takeWhile = Spec.takeWhile +dropWhile = Spec.dropWhile +span = Spec.span +break = Spec.break +group = Spec.group +inits = Spec.inits +tails = Spec.tails + +-- * Predicates +isPrefixOf = Spec.isPrefixOf +isSuffixOf = Spec.isSuffixOf +isInfixOf = Spec.isInfixOf + +-- * Searching lists +-- ** Searching by equality +elem = Spec.elem +notElem = Spec.notElem +lookup = Spec.lookup + +-- ** Searching with a predicate +find = Spec.find +filter = Spec.filter +partition = Spec.partition + +-- * Indexing lists +(!!) = (Spec.!!) +elemIndex = Spec.elemIndex +elemIndices = Spec.elemIndices +findIndex = Spec.findIndex +findIndices = Spec.findIndices + +-- * Zipping and unzipping lists +zip = Spec.zip +zip3 = Spec.zip3 +zip4 = Spec.zip4 +zip5 = Spec.zip5 +zip6 = Spec.zip6 +zip7 = Spec.zip7 +zipWith = Spec.zipWith +zipWith3 = Spec.zipWith3 +zipWith4 = Spec.zipWith4 +zipWith5 = Spec.zipWith5 +zipWith6 = Spec.zipWith6 +zipWith7 = Spec.zipWith7 +unzip = Spec.unzip +unzip3 = Spec.unzip3 +unzip4 = Spec.unzip4 +unzip5 = Spec.unzip5 +unzip6 = Spec.unzip6 +unzip7 = Spec.unzip7 + +-- * Special lists +-- ** Functions on strings +lines = Spec.lines +words = Spec.words +unlines = Spec.unlines +unwords = Spec.unwords + +-- ** \"Set\" operations +nub = Spec.nub +delete = Spec.delete +(\\) = (Spec.\\) +union = Spec.union +intersect = Spec.intersect + +-- ** Ordered lists +sort = Spec.sort +insert = Spec.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Spec.nubBy +deleteBy = Spec.deleteBy +deleteFirstsBy = Spec.deleteFirstsBy +unionBy = Spec.unionBy +intersectBy = Spec.intersectBy +groupBy = Spec.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = Spec.sortBy +insertBy = Spec.insertBy +maximumBy = Spec.maximumBy +minimumBy = Spec.minimumBy + +-- * The \"generic\" operations +genericLength = Spec.genericLength +genericTake = Spec.genericTake +genericDrop = Spec.genericDrop +genericSplitAt = Spec.genericSplitAt +genericIndex = Spec.genericIndex +genericReplicate = Spec.genericReplicate diff --git a/tests/Strictness/Monomorphic/List.hs b/tests/Strictness/Monomorphic/List.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/Monomorphic/List.hs @@ -0,0 +1,319 @@ +module Strictness.Monomorphic.List where + +-- +-- just test the List api +-- + +import Strictness.Utils + +import qualified Data.List.Stream as List + +-- * Basic interface +(++) :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +unzip :: [(A, B)] -> ([A], [B]) +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) + +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] --fixme: need to use Bool domain for order +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] + + + +-- * Basic interface +(++) = (List.++) +head = List.head +last = List.last +tail = List.tail +init = List.init +null = List.null +length = List.length + +-- * List transformations +map = List.map +reverse = List.reverse +intersperse = List.intersperse +intercalate = List.intercalate +transpose = List.transpose + +-- * Reducing lists (folds) +foldl = List.foldl +foldl' = List.foldl' +foldl1 = List.foldl1 +foldl1' = List.foldl1' +foldr = List.foldr +foldr1 = List.foldr1 + +-- ** Special folds +concat = List.concat +concatMap = List.concatMap +and = List.and +or = List.or +any = List.any +all = List.all +sum = List.sum +product = List.product +maximum = List.maximum +minimum = List.minimum + +-- * Building lists +-- ** Scans +scanl = List.scanl +scanl1 = List.scanl1 +scanr = List.scanr +scanr1 = List.scanr1 + +-- ** Accumulating maps +mapAccumL = List.mapAccumL +mapAccumR = List.mapAccumR + +-- ** Infinite lists +iterate = List.iterate +repeat = List.repeat +replicate = List.replicate +cycle = List.cycle + +-- ** Unfolding +unfoldr = List.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = List.take +drop = List.drop +splitAt = List.splitAt +takeWhile = List.takeWhile +dropWhile = List.dropWhile +span = List.span +break = List.break +group = List.group +inits = List.inits +tails = List.tails + +-- * Predicates +isPrefixOf = List.isPrefixOf +isSuffixOf = List.isSuffixOf +isInfixOf = List.isInfixOf + +-- * Searching lists +-- ** Searching by equality +elem = List.elem +notElem = List.notElem +lookup = List.lookup + +-- ** Searching with a predicate +find = List.find +filter = List.filter +partition = List.partition + +-- * Indexing lists +(!!) = (List.!!) +elemIndex = List.elemIndex +elemIndices = List.elemIndices +findIndex = List.findIndex +findIndices = List.findIndices + +-- * Zipping and unzipping lists +zip = List.zip +zip3 = List.zip3 +zip4 = List.zip4 +zip5 = List.zip5 +zip6 = List.zip6 +zip7 = List.zip7 +zipWith = List.zipWith +zipWith3 = List.zipWith3 +zipWith4 = List.zipWith4 +zipWith5 = List.zipWith5 +zipWith6 = List.zipWith6 +zipWith7 = List.zipWith7 +unzip = List.unzip +unzip3 = List.unzip3 +unzip4 = List.unzip4 +unzip5 = List.unzip5 +unzip6 = List.unzip6 +unzip7 = List.unzip7 + +-- * Special lists +-- ** Functions on strings +lines = List.lines +words = List.words +unlines = List.unlines +unwords = List.unwords + +-- ** \"Set\" operations +nub = List.nub +delete = List.delete +(\\) = (List.\\) +union = List.union +intersect = List.intersect + +-- ** Ordered lists +sort = List.sort +insert = List.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = List.nubBy +deleteBy = List.deleteBy +deleteFirstsBy = List.deleteFirstsBy +unionBy = List.unionBy +intersectBy = List.intersectBy +groupBy = List.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = List.sortBy +insertBy = List.insertBy +maximumBy = List.maximumBy +minimumBy = List.minimumBy + +-- * The \"generic\" operations +genericLength = List.genericLength +genericTake = List.genericTake +genericDrop = List.genericDrop +genericSplitAt = List.genericSplitAt +genericIndex = List.genericIndex +genericReplicate = List.genericReplicate diff --git a/tests/Strictness/Monomorphic/Spec.hs b/tests/Strictness/Monomorphic/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/Monomorphic/Spec.hs @@ -0,0 +1,321 @@ +module Strictness.Monomorphic.Spec where + +-- +-- just test the List api +-- + +import Strictness.Utils + +import qualified Spec.List as Spec +import qualified Spec.ListExts as Spec + + +-- * Basic interface +(++) :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndex :: (A -> Bool) -> [A] -> Maybe Int +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +unzip :: [(A, B)] -> ([A], [B]) +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) + +-- * Special lists +-- ** Functions on strings +lines :: String -> [String] +words :: String -> [String] +unlines :: [String] -> String +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] + +-- *** User-supplied comparison (replacing an Ord context) +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericSplitAt :: I -> [A] -> ([A], [A]) +genericIndex :: [A] -> I -> A +genericReplicate :: I -> A -> [A] + + + +-- * Basic interface +(++) = (Spec.++) +head = Spec.head +last = Spec.last +tail = Spec.tail +init = Spec.init +null = Spec.null +length = Spec.length + +-- * List transformations +map = Spec.map +reverse = Spec.reverse +intersperse = Spec.intersperse +intercalate = Spec.intercalate +transpose = Spec.transpose + +-- * Reducing lists (folds) +foldl = Spec.foldl +foldl' = Spec.foldl' +foldl1 = Spec.foldl1 +foldl1' = Spec.foldl1' +foldr = Spec.foldr +foldr1 = Spec.foldr1 + +-- ** Special folds +concat = Spec.concat +concatMap = Spec.concatMap +and = Spec.and +or = Spec.or +any = Spec.any +all = Spec.all +sum = Spec.sum +product = Spec.product +maximum = Spec.maximum +minimum = Spec.minimum + +-- * Building lists +-- ** Scans +scanl = Spec.scanl +scanl1 = Spec.scanl1 +scanr = Spec.scanr +scanr1 = Spec.scanr1 + +-- ** Accumulating maps +mapAccumL = Spec.mapAccumL +mapAccumR = Spec.mapAccumR + +-- ** Infinite lists +iterate = Spec.iterate +repeat = Spec.repeat +replicate = Spec.replicate +cycle = Spec.cycle + +-- ** Unfolding +unfoldr = Spec.unfoldr + +-- * Sublists +-- ** Extracting sublists +take = Spec.take +drop = Spec.drop +splitAt = Spec.splitAt +takeWhile = Spec.takeWhile +dropWhile = Spec.dropWhile +span = Spec.span +break = Spec.break +group = Spec.group +inits = Spec.inits +tails = Spec.tails + +-- * Predicates +isPrefixOf = Spec.isPrefixOf +isSuffixOf = Spec.isSuffixOf +isInfixOf = Spec.isInfixOf + +-- * Searching lists +-- ** Searching by equality +elem = Spec.elem +notElem = Spec.notElem +lookup = Spec.lookup + +-- ** Searching with a predicate +find = Spec.find +filter = Spec.filter +partition = Spec.partition + +-- * Indexing lists +(!!) = (Spec.!!) +elemIndex = Spec.elemIndex +elemIndices = Spec.elemIndices +findIndex = Spec.findIndex +findIndices = Spec.findIndices + +-- * Zipping and unzipping lists +zip = Spec.zip +zip3 = Spec.zip3 +zip4 = Spec.zip4 +zip5 = Spec.zip5 +zip6 = Spec.zip6 +zip7 = Spec.zip7 +zipWith = Spec.zipWith +zipWith3 = Spec.zipWith3 +zipWith4 = Spec.zipWith4 +zipWith5 = Spec.zipWith5 +zipWith6 = Spec.zipWith6 +zipWith7 = Spec.zipWith7 +unzip = Spec.unzip +unzip3 = Spec.unzip3 +unzip4 = Spec.unzip4 +unzip5 = Spec.unzip5 +unzip6 = Spec.unzip6 +unzip7 = Spec.unzip7 + +-- * Special lists +-- ** Functions on strings +lines = Spec.lines +words = Spec.words +unlines = Spec.unlines +unwords = Spec.unwords + +-- ** \"Set\" operations +nub = Spec.nub +delete = Spec.delete +(\\) = (Spec.\\) +union = Spec.union +intersect = Spec.intersect + +-- ** Ordered lists +sort = Spec.sort +insert = Spec.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Spec.nubBy +deleteBy = Spec.deleteBy +deleteFirstsBy = Spec.deleteFirstsBy +unionBy = Spec.unionBy +intersectBy = Spec.intersectBy +groupBy = Spec.groupBy + +-- *** User-supplied comparison (replacing an Ord context) +sortBy = Spec.sortBy +insertBy = Spec.insertBy +maximumBy = Spec.maximumBy +minimumBy = Spec.minimumBy + +-- * The \"generic\" operations +genericLength = Spec.genericLength +genericTake = Spec.genericTake +genericDrop = Spec.genericDrop +genericSplitAt = Spec.genericSplitAt +genericIndex = Spec.genericIndex +genericReplicate = Spec.genericReplicate diff --git a/tests/Strictness/Monomorphic/StreamList.hs b/tests/Strictness/Monomorphic/StreamList.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/Monomorphic/StreamList.hs @@ -0,0 +1,385 @@ +-- +-- list like wrappers for abstract streams +-- +-- These specify the versions used when fusion occurs. +-- +-- So we can check our stream implementations, which are only used when +-- fusion happens, are correct. +-- + +module Strictness.Monomorphic.StreamList where + +import Strictness.Utils + +import qualified Data.Stream as Stream + +-- * Basic interface +cons :: A -> [A] -> [A] +snoc :: [A] -> A -> [A] +append :: [A] -> [A] -> [A] +head :: [A] -> A +last :: [A] -> A +tail :: [A] -> [A] +init :: [A] -> [A] +null :: [A] -> Bool +length :: [A] -> Int + + +-- * List transformations +map :: (A -> B) -> [A] -> [B] +--reverse :: [A] -> [A] +intersperse :: A -> [A] -> [A] +intercalate :: [A] -> [[A]] -> [A] +--transpose :: [[A]] -> [[A]] + +-- * Reducing lists (folds) +foldl :: (B -> A -> B) -> B -> [A] -> B +foldl' :: (B -> A -> B) -> B -> [A] -> B +foldl1 :: (A -> A -> A) -> [A] -> A +foldl1' :: (A -> A -> A) -> [A] -> A +foldr :: (A -> B -> B) -> B -> [A] -> B +foldr1 :: (A -> A -> A) -> [A] -> A + +-- ** Special folds +concat :: [[A]] -> [A] +concatMap :: (A -> [B]) -> [A] -> [B] +and :: [Bool] -> Bool +or :: [Bool] -> Bool +any :: (A -> Bool) -> [A] -> Bool +all :: (A -> Bool) -> [A] -> Bool +sum :: [N] -> N +product :: [N] -> N +maximum :: [OrdA] -> OrdA +minimum :: [OrdA] -> OrdA + +-- * Building lists +-- ** Scans +scanl :: (A -> B -> A) -> A -> [B] -> [A] +scanl1 :: (A -> A -> A) -> [A] -> [A] + +{- +scanr :: (A -> B -> B) -> B -> [A] -> [B] +scanr1 :: (A -> A -> A) -> [A] -> [A] + +-- ** Accumulating maps +mapAccumL :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +mapAccumR :: (C -> A -> (C, B)) -> C -> [A] -> (C, [B]) +-} + +-- ** Infinite lists +iterate :: (A -> A) -> A -> [A] +repeat :: A -> [A] +replicate :: Int -> A -> [A] +cycle :: [A] -> [A] + +-- ** Unfolding +unfoldr :: (B -> Maybe (A, B)) -> B -> [A] + +-- * Sublists +-- ** Extracting sublists +take :: Int -> [A] -> [A] +drop :: Int -> [A] -> [A] +splitAt :: Int -> [A] -> ([A], [A]) +takeWhile :: (A -> Bool) -> [A] -> [A] +dropWhile :: (A -> Bool) -> [A] -> [A] + +{- +span :: (A -> Bool) -> [A] -> ([A], [A]) +break :: (A -> Bool) -> [A] -> ([A], [A]) +group :: [A] -> [[A]] +inits :: [A] -> [[A]] +tails :: [A] -> [[A]] +-} + +-- * Predicates +isPrefixOf :: [A] -> [A] -> Bool +{- +isSuffixOf :: [A] -> [A] -> Bool +isInfixOf :: [A] -> [A] -> Bool +-} + +-- * Searching lists +-- ** Searching by equality +elem :: A -> [A] -> Bool +--notElem :: A -> [A] -> Bool +lookup :: A -> [(A, B)] -> Maybe B + +-- ** Searching with A predicate +find :: (A -> Bool) -> [A] -> Maybe A +filter :: (A -> Bool) -> [A] -> [A] +--partition :: (A -> Bool) -> [A] -> ([A], [A]) + +-- * Indexing lists +(!!) :: [A] -> Int -> A +findIndex :: (A -> Bool) -> [A] -> Maybe Int +elemIndex :: A -> [A] -> Maybe Int +elemIndices :: A -> [A] -> [Int] +findIndices :: (A -> Bool) -> [A] -> [Int] + +-- * Zipping and unzipping lists +zip :: [A] -> [B] -> [(A, B)] +zip3 :: [A] -> [B] -> [C] -> [(A, B, C)] +{- +zip4 :: [A] -> [B] -> [C] -> [D] -> [(A, B, C, D)] +zip5 :: [A] -> [B] -> [C] -> [D] -> [E] -> [(A, B, C, D, E)] +zip6 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [(A, B, C, D, E, F)] +zip7 :: [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [(A, B, C, D, E, F, G)] +-} + +zipWith :: (A -> B -> C) -> [A] -> [B] -> [C] +zipWith3 :: (A -> B -> C -> D) -> [A] -> [B] -> [C] -> [D] +{- +zipWith4 :: (A -> B -> C -> D -> E) -> [A] -> [B] -> [C] -> [D] -> [E] +zipWith5 :: (A -> B -> C -> D -> E -> F) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] +zipWith6 :: (A -> B -> C -> D -> E -> F -> G) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] +zipWith7 :: (A -> B -> C -> D -> E -> F -> G -> H) -> [A] -> [B] -> [C] -> [D] -> [E] -> [F] -> [G] -> [H] +-} + +unzip :: [(A, B)] -> ([A], [B]) +{- +unzip3 :: [(A, B, C)] -> ([A], [B], [C]) +unzip4 :: [(A, B, C, D)] -> ([A], [B], [C], [D]) +unzip5 :: [(A, B, C, D, E)] -> ([A], [B], [C], [D], [E]) +unzip6 :: [(A, B, C, D, E, F)] -> ([A], [B], [C], [D], [E], [F]) +unzip7 :: [(A, B, C, D, E, F, G)] -> ([A], [B], [C], [D], [E], [F], [G]) +-} + +-- * Special lists +-- ** Functions on strings +--unlines :: [String] -> String +--lines :: String -> [String] +{- +words :: String -> [String] +unwords :: [String] -> String + +-- ** \"Set\" operations +nub :: [A] -> [A] +delete :: A -> [A] -> [A] +(\\) :: [A] -> [A] -> [A] +union :: [A] -> [A] -> [A] +intersect :: [A] -> [A] -> [A] + +-- ** Ordered lists +sort :: [OrdA] -> [OrdA] +insert :: OrdA -> [OrdA] -> [OrdA] + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy :: (A -> A -> Bool) -> [A] -> [A] +deleteBy :: (A -> A -> Bool) -> A -> [A] -> [A] +deleteFirstsBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +unionBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +intersectBy :: (A -> A -> Bool) -> [A] -> [A] -> [A] +groupBy :: (A -> A -> Bool) -> [A] -> [[A]] +-} + +-- *** User-supplied comparison (replacing an Ord context) +insertBy :: (A -> A -> Ordering) -> A -> [A] -> [A] +{- +sortBy :: (A -> A -> Ordering) -> [A] -> [A] +-} +maximumBy :: (A -> A -> Ordering) -> [A] -> A +minimumBy :: (A -> A -> Ordering) -> [A] -> A + +-- * The \"generic\" operations +genericLength :: [A] -> I +genericTake :: I -> [A] -> [A] +genericDrop :: I -> [A] -> [A] +genericIndex :: [A] -> I -> A +genericSplitAt :: I -> [A] -> ([A], [A]) +genericReplicate :: I -> A -> [A] + +s = Stream.stream +u = Stream.unstream + +-- * Basic interface +cons = \x xs -> u $ Stream.cons x (s xs) +snoc = \xs x -> u $ Stream.snoc (s xs) x +append = \xs ys -> u $ Stream.append (s xs) (s ys) +head = \xs -> Stream.head (s xs) +last = \xs -> Stream.last (s xs) +tail = \xs -> u $ Stream.tail (s xs) +init = \xs -> u $ Stream.init (s xs) +null = \xs -> Stream.null (s xs) +length = \xs -> Stream.length (s xs) + + +-- * List transformations +map = \f xs -> u $ Stream.map f (s xs) +--reverse = Stream.reverse +intersperse = \sep xs -> u $ Stream.intersperse sep (s xs) +intercalate = \sep xs -> Stream.concat (Stream.intersperse sep(s xs)) + +--transpose = Stream.transpose + +-- * Reducing lists (folds) +foldl = \f z xs -> Stream.foldl f z (s xs) +foldl' = \f z xs -> Stream.foldl' f z (s xs) +foldl1 = \f xs -> Stream.foldl1 f (s xs) +foldl1' = \f xs -> Stream.foldl1' f (s xs) +foldr = \f z xs -> Stream.foldr f z (s xs) +foldr1 = \f xs -> Stream.foldr1 f (s xs) + +-- ** Special folds +concat = \ xs -> Stream.concat (s xs) +concatMap = \f xs -> u $ Stream.concatMap (s . f) (s xs) +and = \ xs -> Stream.and (s xs) +or = \ xs -> Stream.or (s xs) +any = \f xs -> Stream.any f (s xs) +all = \f xs -> Stream.all f (s xs) +sum = \ xs -> Stream.sum (s xs) +product = \ xs -> Stream.product (s xs) +maximum = \ xs -> Stream.maximum (s xs) +minimum = \ xs -> Stream.minimum (s xs) + +-- * Building lists +-- ** Scans +scanl = \f z xs -> u (Stream.scanl f z (Stream.snoc (s xs) bottom)) + where + bottom :: a + bottom = error "StreamProperties.bottom" + +scanl1 = \f xs -> u (Stream.scanl1 f (Stream.snoc (s xs) bottom)) + where + bottom :: a + bottom = error "StreamProperties.bottom" + +{- +scanr = \f z xs -> u (Stream.scanr f z (Stream.cons bottom (s xs))) + where + bottom :: a + bottom = error "StreamProperties.bottom" +-} + +{- +scanr1 = Stream.scanr1 + +-- ** Accumulating maps +mapAccumL = Stream.mapAccumL +mapAccumR = Stream.mapAccumR +-} +-- ** Infinite lists +iterate = \f x -> u $ Stream.iterate f x +repeat = \ x -> u $ Stream.repeat x +replicate = \n x -> u $ Stream.replicate n x +cycle = \ xs -> u $ Stream.cycle (s xs) + +-- ** Unfolding +unfoldr = \f x -> u $ Stream.unfoldr f x + +-- * Sublists +-- ** Extracting sublists +take = \n xs -> u $ Stream.take n (s xs) +drop = \n xs -> u $ Stream.drop n (s xs) +splitAt = \n xs -> Stream.splitAt n (s xs) +takeWhile = \f xs -> u $ Stream.takeWhile f (s xs) +dropWhile = \f xs -> u $ Stream.dropWhile f (s xs) +{- +span = Stream.span +break = Stream.break +group = Stream.group +inits = Stream.inits +tails = Stream.tails +-} + +-- * Predicates +isPrefixOf = \xs ys -> Stream.isPrefixOf (s xs) (s ys) +{- +isSuffixOf = Stream.isSuffixOf +isInfixOf = Stream.isInfixOf +-} +-- * Searching lists +-- ** Searching by equality +elem = \key xs -> Stream.elem key (s xs) +--notElem = Stream.notElem +lookup = \key xs -> Stream.lookup key (s xs) + +-- ** Searching with a predicate +find = \p xs -> Stream.find p (s xs) +filter = \p xs -> u $ Stream.filter p (s xs) +--partition = Stream.partition + +-- * Indexing lists +(!!) = \xs -> Stream.index (s xs) +findIndex = \f xs -> Stream.findIndex f (s xs) +elemIndex = \x xs -> Stream.elemIndex x (s xs) +elemIndices = \x xs -> u (Stream.elemIndices x (s xs)) +findIndices = \p xs -> u (Stream.findIndices p (s xs)) + + +-- * Zipping and unzipping lists +zip = \xs ys -> u (Stream.zip (s xs) (s ys)) +zip3 = \xs ys zs -> u (Stream.zip3 (s xs) (s ys) (s zs)) +zip4 = \xs ys zs as -> u (Stream.zip4 (s xs) (s ys) (s zs) (s as)) + +zipWith = \f xs ys -> u (Stream.zipWith f (s xs) (s ys)) +zipWith3 = \f xs ys zs -> u (Stream.zipWith3 f (s xs) (s ys) (s zs)) +zipWith4 = \f xs ys zs as -> u (Stream.zipWith4 f (s xs) (s ys) (s zs) (s as)) + +unzip = Stream.unzip . s + +{- +zip4 = Stream.zip4 +zip5 = Stream.zip5 +zip6 = Stream.zip6 +zip7 = Stream.zip7 +zipWith4 = Stream.zipWith4 +zipWith5 = Stream.zipWith5 +zipWith6 = Stream.zipWith6 +zipWith7 = Stream.zipWith7 +unzip3 = Stream.unzip3 +unzip4 = Stream.unzip4 +unzip5 = Stream.unzip5 +unzip6 = Stream.unzip6 +unzip7 = Stream.unzip7 +-} + +-- * Special lists +-- ** Functions on strings +--unlines = \xs -> u (Stream.concatMap (\x -> Stream.snoc (s x) '\n') (s xs)) +--lines = \xs -> u (Stream.lines (s xs)) + +{- +words = Stream.words +unwords = Stream.unwords + +-- ** \"Set\" operations +nub = Stream.nub +delete = Stream.delete +(\\) = (Stream.\\) +union = Stream.union +intersect = Stream.intersect + +-- ** Ordered lists +sort = Stream.sort +insert = Stream.insert + +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) +nubBy = Stream.nubBy +deleteBy = Stream.deleteBy +deleteFirstsBy = Stream.deleteFirstsBy +unionBy = Stream.unionBy +intersectBy = Stream.intersectBy +groupBy = Stream.groupBy +-} + +-- *** User-supplied comparison (replacing an Ord context) +{- +sortBy = Stream.sortBy +-} +insertBy = \cmp x xs -> u $ Stream.insertBy cmp x (s xs) + +maximumBy = \cmp xs -> Stream.maximumBy cmp (s xs) +minimumBy = \cmp xs -> Stream.minimumBy cmp (s xs) + +-- * The \"generic\" operations +genericLength = \xs -> Stream.genericLength (s xs) +genericTake = \n xs -> u $ Stream.genericTake n (s xs) +genericDrop = \n xs -> u $ Stream.genericDrop n (s xs) +genericIndex = \xs n -> Stream.genericIndex (s xs) n +genericSplitAt = \n xs -> Stream.genericSplitAt n (s xs) +genericReplicate = \n x -> genericTake n (Prelude.repeat x) + diff --git a/tests/Strictness/StreamListVsList.hs b/tests/Strictness/StreamListVsList.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/StreamListVsList.hs @@ -0,0 +1,391 @@ + +-- +-- Must have rules off, otherwise the fusion rules will replace the rhs +-- with the lhs, and we only end up testing lhs == lhs +-- + +import Prelude hiding (null) +import Strictness.Utils +import System.IO + +import qualified Strictness.Monomorphic.StreamList as Test -- our stream implementation +import qualified Strictness.Monomorphic.List as Spec -- our list implementation + +-- +-- Data.Stream <=> Data.List.Stream +-- + +------------------------------------------------------------------------ +-- * Basic interface + +prop_append = Test.append `eq2` (Spec.++) +prop_head = Test.head `eq1` Spec.head +prop_last = Test.last `eq1` Spec.last +prop_tail = Test.tail `eq1` Spec.tail +prop_init = Test.init `eq1` Spec.init +prop_null = Test.null `eq1` Spec.null +prop_length = Test.length `eq1` Spec.length + +------------------------------------------------------------------------ +-- * List transformations + +prop_map = Test.map `eq2` Spec.map +--prop_reverse = Test.reverse `eq1` Spec.reverse +prop_intersperse = Test.intersperse `eq2` Spec.intersperse +prop_intercalate = Test.intercalate `eq2` Spec.intercalate +--prop_transpose = Test.transpose `eq1` Spec.transpose + +------------------------------------------------------------------------ +-- * Reducing lists (folds) + +prop_foldl = Test.foldl `eq3` Spec.foldl +prop_foldl' = Test.foldl' `eq3` Spec.foldl' +prop_foldl1 = Test.foldl1 `eq2` Spec.foldl1 +prop_foldl1' = Test.foldl1' `eq2` Spec.foldl1' +prop_foldr = Test.foldr `eq3` Spec.foldr +prop_foldr1 = Test.foldr1 `eq2` Spec.foldr1 + +------------------------------------------------------------------------ +-- ** Special folds + +prop_concat = Test.concat `eq1` Spec.concat +prop_concatMap = Test.concatMap `eq2` Spec.concatMap +prop_and = Test.and `eq1` Spec.and +prop_or = Test.or `eq1` Spec.or +prop_any = Test.any `eq2` Spec.any +prop_all = Test.all `eq2` Spec.all +prop_sum = Test.sum `eq1` Spec.sum +prop_product = Test.product `eq1` Spec.product +prop_maximum = Test.maximum `eq1` Spec.maximum +prop_minimum = Test.minimum `eq1` Spec.minimum + +------------------------------------------------------------------------ +-- * Building lists +-- ** Scans + +prop_scanl = Test.scanl `eq3` Spec.scanl +prop_scanl1 = Test.scanl1 `eq2` Spec.scanl1 +--prop_scanr = Test.scanr `eq3` Spec.scanr +--prop_scanr1 = Test.scanr1 `eq2` Spec.scanr1 + +------------------------------------------------------------------------ +-- ** Accumulating maps + +--prop_mapAccumL = Test.mapAccumL `eq3` Spec.mapAccumL +--prop_mapAccumR = Test.mapAccumR `eq3` Spec.mapAccumR + +------------------------------------------------------------------------ +-- ** Infinite lists + +prop_iterate = Test.iterate `eqfinite2` Spec.iterate +prop_repeat = Test.repeat `eqfinite1` Spec.repeat +prop_replicate = Test.replicate `eqfinite2` Spec.replicate +prop_cycle = Test.cycle `eqfinite1` Spec.cycle + +------------------------------------------------------------------------ +-- ** Unfolding + +prop_unfoldr = Test.unfoldr `eqfinite2` Spec.unfoldr + +------------------------------------------------------------------------ +-- * Sublists +-- ** Extracting sublists + +prop_take = Test.take `eq2` Spec.take +prop_drop = Test.drop `eq2` Spec.drop +prop_splitAt = Test.splitAt `eq2` Spec.splitAt +prop_takeWhile = Test.takeWhile `eq2` Spec.takeWhile +prop_dropWhile = Test.dropWhile `eq2` Spec.dropWhile +--prop_span = Test.span `eq2` Spec.span +--prop_break = Test.break `eq2` Spec.break +--prop_group = Test.group `eq1` Spec.group +--prop_inits = Test.inits `eq1` Spec.inits +--prop_tails = Test.tails `eq1` Spec.tails + +------------------------------------------------------------------------ +-- * Predicates + +prop_isPrefixOf = Test.isPrefixOf `eq2` Spec.isPrefixOf +--prop_isSuffixOf = Test.isSuffixOf `eq2` Spec.isSuffixOf +--prop_isInfixOf = Test.isInfixOf `eq2` Spec.isInfixOf + +------------------------------------------------------------------------ +-- * Searching lists +-- ** Searching by equality + +prop_elem = Test.elem `eq2` Spec.elem +--prop_notElem = Test.notElem `eq2` Spec.notElem +prop_lookup = Test.lookup `eq2` Spec.lookup + +------------------------------------------------------------------------ +-- ** Searching with a predicate + +prop_find = Test.find `eq2` Spec.find +prop_filter = Test.filter `eq2` Spec.filter +--prop_partition = Test.partition `eq2` Spec.partition + +------------------------------------------------------------------------ +-- * Indexing lists + +prop_index = (Test.!!) `eq2` (Spec.!!) +prop_elemIndex = Test.elemIndex `eq2` Spec.elemIndex +prop_elemIndices = Test.elemIndices `eq2` Spec.elemIndices +prop_findIndex = Test.findIndex `eq2` Spec.findIndex +prop_findIndices = Test.findIndices `eq2` Spec.findIndices + +------------------------------------------------------------------------ +-- * Zipping and unzipping lists + +prop_zip = Test.zip `eq2` Spec.zip +prop_zip3 = Test.zip3 `eq3` Spec.zip3 +prop_zip4 = Test.zip4 `eq4` Spec.zip4 +--prop_zip5 = Test.zip5 `eq5` Spec.zip5 +--prop_zip6 = Test.zip6 `eq6` Spec.zip6 +--prop_zip7 = Test.zip7 `eq7` Spec.zip7 +prop_zipWith = Test.zipWith `eq3` Spec.zipWith +prop_zipWith3 = Test.zipWith3 `eq4` Spec.zipWith3 +prop_zipWith4 = Test.zipWith4 `eq5` Spec.zipWith4 +--prop_zipWith5 = Test.zipWith5 `eq6` Spec.zipWith5 +--prop_zipWith6 = Test.zipWith6 `eq7` Spec.zipWith6 +--prop_zipWith7 = Test.zipWith7 `eq8` Spec.zipWith7 + +------------------------------------------------------------------------ + +prop_unzip = Test.unzip `eq1` Spec.unzip +--prop_unzip3 = Test.unzip3 `eq1` Spec.unzip3 +--prop_unzip4 = Test.unzip4 `eq1` Spec.unzip4 +--prop_unzip5 = Test.unzip5 `eq1` Spec.unzip5 +--prop_unzip6 = Test.unzip6 `eq1` Spec.unzip6 +--prop_unzip7 = Test.unzip7 `eq1` Spec.unzip7 + +------------------------------------------------------------------------ +-- * Special lists +-- ** Functions on strings + +--prop_lines = Test.lines `eq1` Spec.lines +--prop_words = Test.words `eq1` Spec.words +--prop_unlines = Test.unlines `eq1` Spec.unlines +--prop_unwords = Test.unwords `eq1` Spec.unwords + +------------------------------------------------------------------------ +-- ** \"Set\" operations + +--prop_nub = Test.nub `eq1` Spec.nub +--prop_delete = Test.delete `eq2` Spec.delete +--prop_difference = (Test.\\) `eq2` (Spec.\\) +--prop_union = Test.union `eq2` Spec.union +--prop_intersect = Test.intersect `eq2` Spec.intersect + +------------------------------------------------------------------------ +-- ** Ordered lists + +--prop_sort = Test.sort `eq1` Spec.sort +--prop_insert = Test.insert `eq2` Spec.insert + +------------------------------------------------------------------------ +-- * Generalized functions +-- ** The \"By\" operations +-- *** User-supplied equality (replacing an Eq context) + +--prop_nubBy = Test.nubBy `eq2` Spec.nubBy +--prop_deleteBy = Test.deleteBy `eq3` Spec.deleteBy +--prop_deleteFirstsBy = Test.deleteFirstsBy `eq3` Spec.deleteFirstsBy +--prop_unionBy = Test.unionBy `eq3` Spec.unionBy +--prop_intersectBy = Test.intersectBy `eq3` Spec.intersectBy +--prop_groupBy = Test.groupBy `eq2` Spec.groupBy + +------------------------------------------------------------------------ +-- *** User-supplied comparison (replacing an Ord context) + +--prop_sortBy = Test.sortBy `eq2` Spec.sortBy --need to generate total orders +prop_insertBy = Test.insertBy `eq3` Spec.insertBy +prop_maximumBy = Test.maximumBy `eq2` Spec.maximumBy +prop_minimumBy = Test.minimumBy `eq2` Spec.minimumBy + +------------------------------------------------------------------------ +-- * The \"generic\" operations + +prop_genericLength = Test.genericLength `eq1` Spec.genericLength +prop_genericTake = Test.genericTake `eq2` Spec.genericTake +prop_genericDrop = Test.genericDrop `eq2` Spec.genericDrop +prop_genericSplitAt = Test.genericSplitAt `eq2` Spec.genericSplitAt +prop_genericIndex = Test.genericIndex `eq2` Spec.genericIndex +prop_genericReplicate = Test.genericReplicate `eqfinite2` Spec.genericReplicate + +------------------------------------------------------------------------ + +main = do + hSetBuffering stdout NoBuffering + putStrLn "Testing Data.Stream <=> Data.List.Stream" + putStrLn "========================================\n" + + runTests "Basic interface" opts + [run prop_append + ,run prop_head + ,run prop_last + ,run prop_tail + ,run prop_init + ,run prop_null + ,run prop_length + ] + + runTests "List transformations" opts + [run prop_map +-- ,run prop_reverse + ,run prop_intersperse + ,run prop_intercalate +-- ,run prop_transpose + ] + + runTests "Reducing lists (folds)" opts + [run prop_foldl + ,run prop_foldl' + ,run prop_foldl1 + ,run prop_foldl1' + ,run prop_foldr + ,run prop_foldr1 + ] + + runTests "Special folds" opts + [run prop_concat + ,run prop_concatMap + ,run prop_and + ,run prop_or + ,run prop_any + ,run prop_all + ,run prop_sum + ,run prop_product + ,run prop_maximum + ,run prop_minimum + ] + + runTests "Scans" opts + [run prop_scanl + ,run prop_scanl1 +-- ,run prop_scanr +-- ,run prop_scanr1 + ] + + runTests "Accumulating maps" opts + [--run prop_mapAccumL +-- ,run prop_mapAccumR + ] + + runTests "Infinite lists" opts + [run prop_iterate + ,run prop_repeat + ,run prop_replicate + ,run prop_cycle + ] + + runTests "Unfolding" opts + [run prop_unfoldr + ] + + runTests "Extracting sublists" opts + [run prop_take + ,run prop_drop + ,run prop_splitAt + ,run prop_takeWhile + ,run prop_dropWhile +-- ,run prop_span +-- ,run prop_break +-- ,run prop_group +-- ,run prop_inits +-- ,run prop_tails + ] + + runTests "Predicates" opts + [run prop_isPrefixOf +-- ,run prop_isSuffixOf +-- ,run prop_isInfixOf + ] + + runTests "Searching by equality" opts + [run prop_elem +-- ,run prop_notElem + ,run prop_lookup + ] + + runTests "Searching by a predicate" opts + [run prop_find + ,run prop_filter +-- ,run prop_partition + ] + + runTests "Indexing lists" opts + [run prop_index + ,run prop_elemIndex + ,run prop_elemIndices + ,run prop_findIndex + ,run prop_findIndices + ] + + runTests "Zipping" opts { testDepth = 6, maxTests = 100000 } + [run prop_zip + ,run prop_zip3 + ,run prop_zip4 +-- ,run prop_zip5 +-- ,run prop_zip6 +-- ,run prop_zip7 + ,run prop_zipWith + ,run prop_zipWith3 + ,run prop_zipWith4 +-- ,run prop_zipWith5 +-- ,run prop_zipWith6 +-- ,run prop_zipWith7 + ] + + runTests "Unzipping" opts + [run prop_unzip +-- ,run prop_unzip3 +-- ,run prop_unzip4 +-- ,run prop_unzip5 +-- ,run prop_unzip6 +-- ,run prop_unzip7 + ] + +-- runTests "Functions on strings" opts +-- [run prop_lines +-- ,run prop_words +-- ,run prop_unlines +-- ,run prop_unwords +-- ] + + runTests "\"Set\" operations" opts + [--run prop_nub + --,run prop_delete + --,run prop_difference + --,run prop_union + --,run prop_intersect + ] + + runTests "Ordered lists" opts + [--run prop_sort +-- ,run prop_insert + ] + + runTests "Eq style \"By\" operations" opts + [--run prop_nubBy +-- ,run prop_deleteBy +-- ,run prop_deleteFirstsBy +-- ,run prop_unionBy +-- ,run prop_intersectBy +-- ,run prop_groupBy + ] + + runTests "Ord style \"By\" operations" opts + [--run prop_sortBy -- note issue here. + run prop_insertBy + ,run prop_maximumBy + ,run prop_minimumBy + ] + + runTests "The \"generic\" operations" opts + [run prop_genericLength + ,run prop_genericTake + ,run prop_genericDrop + ,run prop_genericSplitAt + ,run prop_genericIndex + ,run prop_genericReplicate + ] diff --git a/tests/Strictness/Utils.hs b/tests/Strictness/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness/Utils.hs @@ -0,0 +1,74 @@ +module Strictness.Utils ( + module Strictness.Utils, + module Test.SmallCheck.Partial + ) where + +import Prelude hiding (null) +import qualified Prelude + +import Test.SmallCheck.Partial hiding (PositiveIntegral(N)) +import Test.ChasingBottoms +import Data.Generics + +-- some types to use when testing at polymorphic values + +newtype A = A () deriving (Eq, Show, Serial, Typeable, Data) +newtype B = B () deriving (Eq, Show, Serial, Typeable, Data) +newtype C = C () deriving (Eq, Show, Serial, Typeable, Data) + +type D = A +type E = B +type F = C +type G = A +type H = B + +newtype OrdA = OrdA Bool deriving (Eq, Ord, Show, Serial, Typeable, Data) + +newtype N = N Int deriving (Eq, Ord, Show, Serial, Typeable, Data) +newtype I = I Int deriving (Eq, Ord, Enum, Real, Integral, Show, Serial, Typeable, Data) + +-- to catch cases where we rely on associativity or comutativity of +-- (+) or (*)... make them neither! Mwahahaha :-) + +instance Num N where + N x + N y = N (2 * x + y) + N x * N y = N (2 * x + y + 1) + fromInteger = N . fromInteger + negate (N n) = N (negate n) + abs (N n) = N (abs n) + signum (N n) = N (signum n) + +instance Num I where + I x + I y = I (2 * x + y) + I x * I y = I (2 * x + y + 1) + fromInteger = I . fromInteger + negate (I i) = I (negate i) + abs (I i) = I (abs i) + signum (I i) = I (signum i) + + +eq1 f g = \x -> f x ==! g x +eq2 f g = \x y -> f x y ==! g x y +eq3 f g = \x y z -> f x y z ==! g x y z +eq4 f g = \x y z a -> f x y z a ==! g x y z a +eq5 f g = \x y z a b -> f x y z a b ==! g x y z a b +eq6 f g = \x y z a b c -> f x y z a b c ==! g x y z a b c +eq7 f g = \x y z a b c d -> f x y z a b c d ==! g x y z a b c d +eq8 f g = \x y z a b c d e -> f x y z a b c d e ==! g x y z a b c d e + +eqfinite1 f g = \x -> semanticEq limit (f x) (g x) +eqfinite2 f g = \x y -> semanticEq limit (f x y) (g x y) + +limit = Tweak { approxDepth = Just 1000, timeOutLimit = Nothing } + + +refines1 f g = \x -> f x >=! g x +refines2 f g = \x y -> f x y >=! g x y +refines3 f g = \x y z -> f x y z >=! g x y z +refines4 f g = \x y z a -> f x y z a >=! g x y z a +refines5 f g = \x y z a b -> f x y z a b >=! g x y z a b +refines6 f g = \x y z a b c -> f x y z a b c >=! g x y z a b c +refines7 f g = \x y z a b c d -> f x y z a b c d >=! g x y z a b c d +refines8 f g = \x y z a b c d e -> f x y z a b c d e >=! g x y z a b c d e + +opts = TestOptions 8 10000 diff --git a/tests/Test/SmallCheck/Partial.hs b/tests/Test/SmallCheck/Partial.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SmallCheck/Partial.hs @@ -0,0 +1,527 @@ +{-# OPTIONS_GHC -fallow-incoherent-instances -fallow-undecidable-instances #-} + +--------------------------------------------------------------------- +-- SmallCheck: another lightweight testing library. +-- Colin Runciman, August 2006 +-- Version 0.2 (November 2006) +-- +-- After QuickCheck, by Koen Claessen and John Hughes (2000-2004). +--------------------------------------------------------------------- + +module Test.SmallCheck.Partial ( + smallCheck, smallCheckI, depthCheck, test, + Property, Testable, + forAll, forAllElem, + exists, existsDeeperBy, thereExists, thereExistsElem, + (==>), + Series, Serial(..), + (\/), (><), two, three, four, + cons0, cons1, cons2, cons3, cons4, + alts0, alts1, alts2, alts3, alts4, + PositiveIntegral(..), Nat, Natural, + depth, inc, dec, + + run, runTests, TestOptions(..) + ) where + +import List (intersperse) +import Monad (when) +import IO (stdout, hFlush) +import Foreign (unsafePerformIO) -- used only for Testable (IO a) + +import qualified Test.ChasingBottoms as Bottoms + +------------------ ----------------- + +-- Series arguments should be interpreted as a depth bound (>=0) +-- Series results should have finite length + +type Series a = Int -> [a] + +-- sum +infixr 7 \/ +(\/) :: Series a -> Series a -> Series a +(s1 \/ s2) 0 = bottom : [] +(s1 \/ s2) d = bottom : s1 (d-1) ++ s2 (d-1) + +-- product +infixr 8 >< +(><) :: Series a -> Series b -> Series (a,b) +(s1 >< s2) 0 = bottom : [] +(s1 >< s2) d = bottom : [(x,y) | x <- s1 (d-1), y <- s2 (d-1)] + + +------------------- ------------------ + +-- enumerated data values should be finite and fully defined +-- enumerated functional values should be total and strict + +bottom :: a +bottom = error "_|_" + +-- bounds: +-- for data values, the depth of nested constructor applications +-- for functional values, both the depth of nested case analysis +-- and the depth of results + +class Serial a where + series :: Series a + coseries :: Serial b => Series (a->b) + +instance Serial () where + series d = take (d+1) [bottom, ()] + coseries d = [ \() -> b + | b <- series d ] + +instance Serial Int where + series d = seq 0 + where seq n | n > d = [] + seq n@0 = bottom : seq (n+1) + seq n@1 = 0 : seq (n+1) + seq n = -(n-1) : (n-1) : seq (n+1) + coseries d = [ \i -> if i > 0 then f (N (i - 1)) + else if i < 0 then g (N (abs i - 1)) + else z + | z <- alts0 d, f <- alts1 d, g <- alts1 d ] + +instance Serial Integer where + series d = [ toInteger (i :: Int) + | i <- series d ] + coseries d = [ f . (fromInteger :: Integer->Int) + | f <- series d ] + +newtype PositiveIntegral a = N a + +instance Show a => Show (PositiveIntegral a) where + show (N i) = show i + +instance (Integral a, Serial a) => Serial (PositiveIntegral a) where + series d = map N [0..d'] + where + d' = fromInteger (toInteger d) + coseries d = [ \(N i) -> if i > 0 then f (N (i - 1)) + else z + | z <- alts0 d, f <- alts1 d ] + +type Nat = PositiveIntegral Int +type Natural = PositiveIntegral Integer + +instance Serial Float where + series d = [ encodeFloat sig exp + | (sig,exp) <- series d, + odd sig || sig==0 && exp==0 ] + coseries d = [ f . decodeFloat + | f <- series d ] + +instance Serial Double where + series d = [ frac (x :: Float) + | x <- series d ] + coseries d = [ f . (frac :: Double->Float) + | f <- series d ] + +frac :: (Real a, Fractional a, Real b, Fractional b) => a -> b +frac = fromRational . toRational + +instance Serial Char where + series d = take (d+1) " \nab\0cd,ef" + coseries d = [ \c -> f (N (fromEnum c - fromEnum 'a')) + | f <- series d ] + +instance (Serial a, Serial b) => + Serial (a,b) where + series = series >< series + coseries = map uncurry . coseries + +instance (Serial a, Serial b, Serial c) => + Serial (a,b,c) where + series = \d -> bottom + : [ (x,y,z) + | x <- series (d-1) + , y <- series (d-1) + , z <- series (d-1)] + coseries = map uncurry3 . coseries + +instance (Serial a, Serial b, Serial c, Serial d) => + Serial (a,b,c,d) where + series = \d -> bottom + : [ (x,y,z,a) + | x <- series (d-1) + , y <- series (d-1) + , z <- series (d-1) + , a <- series (d-1)] + coseries = map uncurry4 . coseries + +uncurry3 :: (a->b->c->d) -> ((a,b,c)->d) +uncurry3 f (x,y,z) = f x y z + +uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e) +uncurry4 f (w,x,y,z) = f w x y z + +two :: Series a -> Series (a,a) +two s = s >< s + +three :: Series a -> Series (a,a,a) +three s = \d -> [(x,y,z) | (x,(y,z)) <- (s >< s >< s) d] + +four :: Series a -> Series (a,a,a,a) +four s = \d -> [(w,x,y,z) | (w,(x,(y,z))) <- (s >< s >< s >< s) d] + +cons0 :: + a -> Series a +cons0 c _ = [c] + +cons1 :: Serial a => + (a->b) -> Series b +cons1 c d = [c z | d > 0, z <- series (d-1)] + +cons2 :: (Serial a, Serial b) => + (a->b->c) -> Series c +cons2 c d = [c y z | d > 0, y <- series (d-1), z <- series (d-1)] + +cons3 :: (Serial a, Serial b, Serial c) => + (a->b->c->d) -> Series d +cons3 c d = [c x y z | d > 0, (x,y,z) <- series (d-1)] + +cons4 :: (Serial a, Serial b, Serial c, Serial d) => + (a->b->c->d->e) -> Series e +cons4 c d = [c w x y z | d > 0, (w,x,y,z) <- series (d-1)] + +alts0 :: Serial a => + Series a +alts0 d = series d + +alts1 :: (Serial a, Serial b) => + Series (a->b) +alts1 d = if d > 0 then series (dec d) + else [\_ -> x | x <- series d] + +alts2 :: (Serial a, Serial b, Serial c) => + Series (a->b->c) +alts2 d = if d > 0 then series (dec d) + else [\_ _ -> x | x <- series d] + +alts3 :: (Serial a, Serial b, Serial c, Serial d) => + Series (a->b->c->d) +alts3 d = if d > 0 then series (dec d) + else [\_ _ _ -> x | x <- series d] + +alts4 :: (Serial a, Serial b, Serial c, Serial d, Serial e) => + Series (a->b->c->d->e) +alts4 d = if d > 0 then series (dec d) + else [\_ _ _ _ -> x | x <- series d] + +instance Serial Bool where + series = cons0 False \/ cons0 True + coseries d = [ \x -> if x then b1 else b2 + | b1 <- series d, b2 <- series d ] + +instance Serial Ordering where + series = cons0 EQ \/ cons0 LT \/ cons0 GT + coseries d = [ \m -> case m of + LT -> x + EQ -> y + GT -> z + | x <- alts0 d , + y <- alts0 d , + z <- alts0 d ] + +instance Serial a => Serial (Maybe a) where + series = cons0 Nothing \/ cons1 Just + coseries d = [ \m -> case m of + Nothing -> z + Just x -> f x + | z <- alts0 d , + f <- alts1 d ] + +instance (Serial a, Serial b) => Serial (Either a b) where + series = cons1 Left \/ cons1 Right + coseries d = [ \e -> case e of + Left x -> f x + Right y -> g y + | f <- alts1 d , + g <- alts1 d ] + +instance Serial a => Serial [a] where + series = cons0 [] \/ cons2 (:) + coseries d = [ \xs -> case xs of + [] -> y + (x:xs') -> f x xs' + | y <- alts0 d , + f <- alts2 d ] + +-- Warning: the coseries instance here may generate duplicates. +instance (Serial a, Serial b) => Serial (a->b) where + series 0 = bottom : [] + series (d+1) = bottom : [ \_ -> x | x <- series d ] ++ tail (coseries d) + coseries d = [ \f -> g [f x | x <- series d] + | g <- series d ] + +-- For customising the depth measure. Use with care! + +depth :: Int -> Int -> Int +depth d d' | d >= 0 = d'+1-d + | otherwise = error "SmallCheck.depth: argument < 0" + +dec :: Int -> Int +dec d | d > 0 = d-1 + | otherwise = error "SmallCheck.dec: argument <= 0" + +inc :: Int -> Int +inc d = d+1 +{- +-- show the extension of a function (in part, bounded both by +-- the number and depth of arguments) +instance (Serial a, Show a, Show b) => Show (a->b) where + show f = + if maxarheight == 1 + && sumarwidth + length ars * length "->;" < widthLimit then + "{"++( + concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars] + )++"}" + else + concat $ [a++"->\n"++indent r | (a,r) <- ars] + where + ars = take lengthLimit [ (show x, show (f x)) + | x <- series depthLimit ] + maxarheight = maximum [ max (height a) (height r) + | (a,r) <- ars ] + sumarwidth = sum [ length a + length r + | (a,r) <- ars] + indent = unlines . map (" "++) . lines + height = length . lines + (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Int) +-} +instance (Serial a, Bottoms.ApproxShow a, Bottoms.ApproxShow b) => Show (a->b) where + show f + | Bottoms.isBottom f = "_|_" + | otherwise = + if maxarheight == 1 + && sumarwidth + length ars * length "->;" < widthLimit then + "{"++( + concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars] + )++"}" + else + concat $ [a++"->\n"++indent r | (a,r) <- ars] + where + ars = take lengthLimit [ (Bottoms.approxShow 1000 x, Bottoms.approxShow 1000 (f x)) + | x <- series depthLimit ] + maxarheight = maximum [ max (height a) (height r) + | (a,r) <- ars ] + sumarwidth = sum [ length a + length r + | (a,r) <- ars] + indent = unlines . map (" "++) . lines + height = length . lines + (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Int) + + +---------------- ------------------ + +-- adapted from QuickCheck originals: here results come in lists, +-- properties have depth arguments, stamps (for classifying random +-- tests) are omitted, existentials are introduced + +newtype PR = Prop [Result] + +data Result = Result {ok :: Maybe Bool, arguments :: [String]} + +nothing :: Result +nothing = Result {ok = Nothing, arguments = []} + +result :: Result -> PR +result res = Prop [res] + +newtype Property = Property (Int -> PR) + +class Testable a where + property :: a -> Int -> PR + +instance Testable Bool where + property b _ = Prop [Result (Just b) []] + +instance Testable PR where + property prop _ = prop + +instance (Serial a, Bottoms.ApproxShow a, Testable b) => Testable (a->b) where + property f = f' where Property f' = forAll series f + +instance Testable Property where + property (Property f) d = f d + +-- For testing properties involving IO. Unsafe, so use with care! +instance Testable a => Testable (IO a) where + property = property . unsafePerformIO + +evaluate :: Testable a => a -> Series Result +evaluate x d = rs where Prop rs = property x d + +forAll :: (Bottoms.ApproxShow a, Testable b) => Series a -> (a->b) -> Property +forAll xs f = Property $ \d -> Prop $ + [ r{arguments = Bottoms.approxShow 1000 x : arguments r} + | x <- xs d, r <- evaluate (f x) d ] + +forAllElem :: (Bottoms.ApproxShow a, Testable b) => [a] -> (a->b) -> Property +forAllElem xs = forAll (const xs) + +thereExists :: Testable b => Series a -> (a->b) -> Property +thereExists xs f = Property $ \d -> Prop $ + [ Result + ( Just $ or [ all pass (evaluate (f x) d) + | x <- xs d ] ) + [] ] + where + pass (Result Nothing _) = True + pass (Result (Just b) _) = b + +thereExistsElem :: Testable b => [a] -> (a->b) -> Property +thereExistsElem xs = thereExists (const xs) + +exists :: (Serial a, Testable b) => + (a->b) -> Property +exists = thereExists series + +existsDeeperBy :: (Serial a, Testable b) => + (Int->Int) -> (a->b) -> Property +existsDeeperBy f = thereExists (series . f) + +infixr 0 ==> + +(==>) :: Testable a => Bool -> a -> Property +True ==> x = Property (property x) +False ==> x = Property (const (result nothing)) + +--------------------- ---------------------- + +-- similar in spirit to QuickCheck but with iterative deepening + +test :: Testable a => a -> IO () +test = smallCheckI + +-- test for values of depths 0..d stopping when a property +-- fails or when it has been checked for all these values +smallCheck :: Testable a => Int -> a -> IO () +smallCheck d = iterCheck 0 (Just d) + +-- interactive variant, asking the user whether testing should +-- continue/go deeper after a failure/completed iteration +smallCheckI :: Testable a => a -> IO () +smallCheckI = iterCheck 0 Nothing + +depthCheck :: Testable a => Int -> a -> IO () +depthCheck d = iterCheck d (Just d) + +iterCheck :: Testable a => Int -> Maybe Int -> a -> IO () +iterCheck dFrom mdTo t = iter dFrom + where + iter d = do + putStrLn ("Depth "++show d++":") + let Prop results = property t d + ok <- check (mdTo==Nothing) 0 0 True results + maybe (whenUserWishes " Deeper" () $ iter (d+1)) + (\dTo -> when (ok && d < dTo) $ iter (d+1)) + mdTo + +check :: Bool -> Int -> Int -> Bool -> [Result] -> IO Bool +check i n x ok rs | null rs = do + putStr (" Completed "++show n++" test(s)") + putStrLn (if ok then " without failure." else ".") + when (x > 0) $ + putStrLn (" But "++show x++" did not meet ==> condition.") + return ok +check i n x ok (Result Nothing _ : rs) = do + progressReport i n x + check i (n+1) (x+1) ok rs +check i n x f (Result (Just True) _ : rs) = do + progressReport i n x + check i (n+1) x f rs +check i n x f (Result (Just False) args : rs) = do + putStrLn (" Failed test no. "++show (n+1)++". Test values follow.") + mapM_ (putStrLn . (" "++)) args + ( if i then + whenUserWishes " Continue" False $ check i (n+1) x False rs + else + return False ) + +whenUserWishes :: String -> a -> IO a -> IO a +whenUserWishes wish x action = do + putStr (wish++"? ") + hFlush stdout + reply <- getLine + ( if (null reply || reply=="y") then action + else return x ) + +progressReport :: Bool -> Int -> Int -> IO () +progressReport i n x | n >= x = do + when i $ ( putStr (n' ++ replicate (length n') '\b') >> + hFlush stdout ) + where + n' = show n + + +run :: Testable a => a -> Property +run p = Property (property p) + +data TestResult = TestOk Int + | TestExhausted Int + | TestFailed Int [String] + +data TestOptions = TestOptions { + testDepth :: Int, + maxTests :: Int + } + +runTest :: TestOptions -> Property -> TestResult +runTest TestOptions { testDepth = depth, maxTests = max } p = + let Prop results = property p depth + in check 0 results + + where check n _ | n >= max = TestExhausted n + check n [] = TestOk n + check n (Result Nothing _ : rs) = check (n+1) rs + check n (Result (Just True ) _ : rs) = check (n+1) rs + check n (Result (Just False) args : rs) = TestFailed n args + + +runTests :: String -> TestOptions -> [Property] -> IO () +runTests name opts props = + + do putStr (rjustify 25 name ++ " : ") + failures <- tr 1 props [] 0 + mapM fa (reverse failures) + return () + where + rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s + + tr n [] xs c = do + putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n") + return xs + tr n (prop:props) failures c = + case runTest opts prop of + TestOk m + -> do { putStr "." ; + tr (n+1) props failures (c+m) } + TestExhausted m + -> do { putStr "?" ; + tr (n+1) props failures (c+m) } + TestFailed m args + -> do { putStr "#" ; + tr (n+1) props ((args,n,m):failures) c } + + fa :: ([String],Int,Int) -> IO () + fa (f,n,m) = + do putStr "\n" + putStr (" ** test " + ++ show (n :: Int) + ++ " of " + ++ name + ++ " failed (after " ++ show m ++ " steps) with the binding(s)\n") + sequence_ [putStr (" ** " ++ v ++ "\n") + | v <- f ] + putStr "\n" + + +------------------------------------------------------------------------ +-- +-- foldl' +-- lines too strict +-- structure of domain, insert bottoms in correct position. +--