diff --git a/Data/StorableVector.hs b/Data/StorableVector.hs --- a/Data/StorableVector.hs +++ b/Data/StorableVector.hs @@ -16,7 +16,7 @@ -- Stability : experimental -- Portability : portable, requires ffi and cpp -- Tested with : GHC 6.4.1 and Hugs March 2005 --- +-- -- -- | A time and space-efficient implementation of vectors using @@ -181,9 +181,9 @@ import Control.Exception (assert, bracket, ) -import Foreign.ForeignPtr -import Foreign.Marshal.Array -import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr, ) +import Foreign.Marshal.Array (advancePtr, copyArray, ) +import Foreign.Ptr (Ptr, minusPtr, ) import Foreign.Storable (Storable(..)) import Data.Monoid (Monoid, mempty, mappend, mconcat, ) @@ -192,15 +192,8 @@ hGetBuf, hPutBuf, Handle, IOMode(..), ) -#if !defined(__GLASGOW_HASKELL__) import System.IO.Unsafe -#endif - -#if defined(__GLASGOW_HASKELL__) - -import GHC.IOBase - -#endif +-- import GHC.IOBase -- ----------------------------------------------------------------------------- -- @@ -244,7 +237,7 @@ singleton c = unsafeCreate 1 $ \p -> poke p c {-# INLINE singleton #-} --- | /O(n)/ Convert a '[a]' into a 'Vector a'. +-- | /O(n)/ Convert a '[a]' into a 'Vector a'. -- pack :: (Storable a) => [a] -> Vector a pack str = unsafeCreate (P.length str) $ \p -> go p str @@ -315,7 +308,7 @@ -- | /O(n)/ Append an element to the end of a 'Vector' snoc :: (Storable a) => Vector a -> a -> Vector a snoc (SV x s l) c = unsafeCreate (l+1) $ \p -> withForeignPtr x $ \f -> do - copyArray (castPtr p) (f `advancePtr` s) l + copyArray p (f `advancePtr` s) l pokeElemOff p l c {-# INLINE snoc #-} @@ -378,8 +371,8 @@ -- | /O(n)/ 'reverse' @xs@ efficiently returns the elements of @xs@ in reverse order. reverse :: (Storable a) => Vector a -> Vector a -reverse (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> - sequence_ [peekElemOff (f `plusPtr` s) i >>= pokeElemOff p (l - i - 1) +reverse (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> + sequence_ [peekElemOff (f `advancePtr` s) i >>= pokeElemOff p (l - i - 1) | i <- [0 .. l - 1]] -- | /O(n)/ The 'intersperse' function takes a element and a @@ -428,7 +421,7 @@ -- | 'foldl1' is a variant of 'foldl' that has no starting value -- argument, and thus must be applied to non-empty 'Vector's. --- This function is subject to array fusion. +-- This function is subject to array fusion. -- An exception will be thrown in the case of an empty 'Vector'. foldl1 :: (Storable a) => (a -> a -> a) -> Vector a -> a foldl1 f = @@ -654,11 +647,11 @@ | w <= 0 = empty | otherwise = fst $ unfoldrN w (const $ return (c, ())) () --- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' --- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a --- 'Vector' from a seed value. The function takes the element and --- returns 'Nothing' if it is done producing the 'Vector or returns --- 'Just' @(a,b)@, in which case, @a@ is the next element in the 'Vector', +-- | /O(n)/, where /n/ is the length of the result. The 'unfoldr' +-- function is analogous to the List \'unfoldr\'. 'unfoldr' builds a +-- 'Vector' from a seed value. The function takes the element and +-- returns 'Nothing' if it is done producing the 'Vector or returns +-- 'Just' @(a,b)@, in which case, @a@ is the next element in the 'Vector', -- and @b@ is the seed value for further production. -- -- Examples: @@ -762,7 +755,7 @@ {-# INLINE break #-} -- | 'breakEnd' behaves like 'break' but from the end of the 'Vector' --- +-- -- breakEnd p == spanEnd (not.p) breakEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) breakEnd p ps = splitAt (findFromEndUntil p ps) ps @@ -781,8 +774,8 @@ -- and -- -- > spanEnd (not . isSpace) ps --- > == --- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) +-- > == +-- > let (x,y) = span (not.isSpace) (reverse ps) in (reverse y, reverse x) -- spanEnd :: (Storable a) => (a -> Bool) -> Vector a -> (Vector a, Vector a) spanEnd p ps = splitAt (findFromEndUntil (not.p) ps) ps @@ -812,12 +805,12 @@ -- > split '\n' "a\nb\nd\ne" == ["a","b","d","e"] -- > split 'a' "aXaXaXa" == ["","X","X","X"] -- > split 'x' "x" == ["",""] --- +-- -- and -- -- > join [c] . split c == id -- > split == splitWith . (==) --- +-- -- As for all splitting functions in this library, this function does -- not copy the substrings, it just constructs new 'Vector's that -- are slices of the original. @@ -828,7 +821,7 @@ -- | Like 'splitWith', except that sequences of adjacent separators are -- treated as a single separator. eg. --- +-- -- > tokens (=='a') "aabbaca" == ["bb","c"] -- tokens :: (Storable a) => (a -> Bool) -> Vector a -> [Vector a] @@ -843,7 +836,7 @@ -- > 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. It is about 40% faster than +-- supply their own equality test. It is about 40% faster than -- /groupBy (==)/ group :: (Storable a, Eq a) => Vector a -> [Vector a] group xs = @@ -885,7 +878,7 @@ -- | /O(n)/ The 'elemIndex' function returns the index of the first -- element in the given 'Vector' which is equal to the query --- element, or 'Nothing' if there is no such element. +-- element, or 'Nothing' if there is no such element. -- This implementation uses memchr(3). elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int elemIndex c (SV x s l) = inlinePerformIO $ withForeignPtr x $ \p -> go p (s + l) 0 @@ -904,7 +897,7 @@ -- element, or 'Nothing' if there is no such element. The following -- holds: -- --- > elemIndexEnd c xs == +-- > elemIndexEnd c xs == -- > (-) (length xs - 1) `fmap` elemIndex c (reverse xs) -- elemIndexEnd :: (Storable a, Eq a) => a -> Vector a -> Maybe Int @@ -934,7 +927,7 @@ ps' {-# INLINE elemIndices #-} --- | count returns the number of times its argument appears in the 'Vector' +-- | count returns the number of times its argument appears in the 'Vector' -- -- > count = length . elemIndices -- @@ -944,7 +937,7 @@ {-# INLINE count #-} -- | The 'findIndex' function takes a predicate and a 'Vector' and --- returns the index of the first element in the 'Vector' +-- returns the index of the first element in the 'Vector' -- satisfying the predicate. findIndex :: (Storable a) => (a -> Bool) -> Vector a -> Maybe Int findIndex k (SV x s l) = inlinePerformIO $ withForeignPtr x $ \f -> go (f `advancePtr` s) 0 @@ -1004,14 +997,14 @@ filter :: (Storable a) => (a -> Bool) -> Vector a -> Vector a filter k ps@(SV x s l) | null ps = ps - | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> + | otherwise = unsafePerformIO $ createAndTrim l $ \p -> withForeignPtr x $ \f -> let STRICT3(go) go end i j | i == end = return j | otherwise = do w <- peekElemOff f i if k w then do - pokeElemOff p j w + pokeElemOff p j w go end (i+1) (j + 1) else go end (i+1) j @@ -1039,7 +1032,7 @@ -- | /O(n)/ The 'isSuffixOf' function takes two 'Vector's and returns 'True' -- iff the first is a suffix of the second. --- +-- -- The following holds: -- -- > isSuffixOf x y == reverse x `isPrefixOf` reverse y @@ -1065,9 +1058,9 @@ -- | '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 'Vector's to produce the list of --- corresponding sums. -zipWith :: (Storable a, Storable b, Storable c) - => (a -> b -> c) -> Vector a -> Vector b -> Vector c +-- corresponding sums. +zipWith :: (Storable a, Storable b, Storable c) => + (a -> b -> c) -> Vector a -> Vector b -> Vector c zipWith f ps0 qs0 = fst $ unfoldrN (min (length ps0) (length qs0)) @@ -1104,10 +1097,10 @@ -- --------------------------------------------------------------------- -- Low level constructors --- | /O(n)/ Make a copy of the 'Vector' with its own storage. +-- | /O(n)/ Make a copy of the 'Vector' with its own storage. -- This is mainly useful to allow the rest of the data pointed -- to by the 'Vector' to be garbage collected, for example --- if a large string has been read in, and only a small part of it +-- if a large string has been read in, and only a small part of it -- is needed in the rest of the program. copy :: (Storable a) => Vector a -> Vector a copy (SV x s l) = unsafeCreate l $ \p -> withForeignPtr x $ \f -> diff --git a/Data/StorableVector/Base.hs b/Data/StorableVector/Base.hs --- a/Data/StorableVector/Base.hs +++ b/Data/StorableVector/Base.hs @@ -43,26 +43,20 @@ ) where import Foreign.Ptr (Ptr) -import Foreign.ForeignPtr +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) import Foreign.Marshal.Array (advancePtr, copyArray) -import Foreign.Storable (Storable(..)) +import Foreign.Storable (Storable(peekElemOff)) +import Data.StorableVector.Memory (mallocForeignPtrArray, ) + import Control.Exception (assert) #if defined(__GLASGOW_HASKELL__) -import qualified Foreign.Concurrent as FC (newForeignPtr) - import Data.Generics (Data(..), Typeable(..)) -import GHC.Ptr (Ptr(..)) import GHC.Base (realWorld#) -import GHC.IOBase - -#if defined(__GLASGOW_HASKELL__) && !defined(SLOW_FOREIGN_PTR) -import GHC.ForeignPtr (mallocPlainForeignPtrBytes) -#endif +import GHC.IOBase (IO(IO), unsafePerformIO, ) #else -import Data.Char (chr) import System.IO.Unsafe (unsafePerformIO) #endif @@ -158,6 +152,7 @@ fromForeignPtr fp l = SV fp 0 l -- | /O(1)/ Deconstruct a ForeignPtr from a Vector +toForeignPtr :: Vector a -> (ForeignPtr a, Int, Int) toForeignPtr (SV ps s l) = (ps, s, l) -- | A way of creating Vectors outside the IO monad. The @Int@ @@ -171,11 +166,7 @@ -- | Wrapper of mallocForeignPtrArray. create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a) create l f = do -#if defined(SLOW_FOREIGN_PTR) || !defined(__GLASGOW_HASKELL__) fp <- mallocForeignPtrArray l -#else - fp <- mallocPlainForeignPtrArray l -#endif withForeignPtr fp $ \p -> f p return $! SV fp 0 l @@ -189,11 +180,7 @@ -- createAndTrim :: (Storable a) => Int -> (Ptr a -> IO Int) -> IO (Vector a) createAndTrim l f = do -#if defined(SLOW_FOREIGN_PTR) || !defined(__GLASGOW_HASKELL__) fp <- mallocForeignPtrArray l -#else - fp <- mallocPlainForeignPtrArray l -#endif withForeignPtr fp $ \p -> do l' <- f p if assert (l' <= l) $ l' >= l @@ -204,11 +191,7 @@ -> (Ptr a -> IO (Int, Int, b)) -> IO (Vector a, b) createAndTrim' l f = do -#if defined(SLOW_FOREIGN_PTR) || !defined(__GLASGOW_HASKELL__) fp <- mallocForeignPtrArray l -#else - fp <- mallocPlainForeignPtrArray l -#endif withForeignPtr fp $ \p -> do (off, l', res) <- f p if assert (l' <= l) $ l' >= l diff --git a/slow-foreign-ptr/Data/StorableVector/Memory.hs b/slow-foreign-ptr/Data/StorableVector/Memory.hs new file mode 100644 --- /dev/null +++ b/slow-foreign-ptr/Data/StorableVector/Memory.hs @@ -0,0 +1,9 @@ +module Data.StorableVector.Memory where + +import Foreign.Storable (Storable) +import qualified Foreign.ForeignPtr as F + + +{-# INLINE mallocForeignPtrArray #-} +mallocForeignPtrArray :: Storable a => Int -> IO (F.ForeignPtr a) +mallocForeignPtrArray = F.mallocForeignPtrArray diff --git a/storablevector.cabal b/storablevector.cabal --- a/storablevector.cabal +++ b/storablevector.cabal @@ -1,5 +1,5 @@ Name: storablevector -Version: 0.1.2 +Version: 0.1.2.2 Category: Data Synopsis: Fast, packed, strict storable arrays with a list interface like ByteString Description: @@ -11,16 +11,19 @@ Maintainer: Henning Thielemann Homepage: http://darcs.haskell.org/storablevector Package-URL: http://code.haskell.org/~sjanssen/storablevector -Build-Depends: base Build-Type: Simple Tested-With: GHC==6.4.1, GHC==6.8.2 Cabal-Version: >=1.2 - Flag splitBase description: Choose the new smaller, split-up base package. +Flag buildTests + description: Build test executables + default: False + Library + Build-Depends: mtl >= 1 && <2 If flag(splitBase) Build-Depends: base >= 3 Else @@ -28,23 +31,40 @@ Extensions: CPP, ForeignFunctionInterface GHC-Options: -Wall -funbox-strict-fields - CPP-Options: -DSLOW_FOREIGN_PTR + Hs-Source-Dirs: ., slow-foreign-ptr - Exposed-modules: + Exposed-Modules: Data.StorableVector Data.StorableVector.Base + Other-Modules: + Data.StorableVector.Memory + Executable test GHC-Options: -Wall -funbox-strict-fields - CPP-Options: -DSLOW_FOREIGN_PTR + Hs-Source-Dirs: ., slow-foreign-ptr, tests Main-Is: tests.hs Other-Modules: QuickCheckUtils, Instances Build-Depends: bytestring >= 0.9 && < 0.10, QuickCheck >= 1 && < 2 Extensions: CPP, ForeignFunctionInterface If flag(splitBase) - Hs-Source-Dirs: ., tests, tests-2 + Hs-Source-Dirs: tests-2 Build-Depends: base >= 3, random >= 1.0 && < 1.1 Else - Hs-Source-Dirs: ., tests, tests-1 + Hs-Source-Dirs: tests-1 Build-Depends: base >= 1.0 && < 2 + if !flag(buildTests) + buildable: False + +Executable speedtest + GHC-Options: -Wall -funbox-strict-fields + Main-Is: SpeedTestLazy.hs + Extensions: CPP, ForeignFunctionInterface + Hs-Source-Dirs: ., slow-foreign-ptr, speedtest + If flag(splitBase) + Build-Depends: base >= 3 + Else + Build-Depends: base >= 1.0 && < 2 + if !flag(buildTests) + buildable: False diff --git a/tests-1/Instances.hs b/tests-1/Instances.hs deleted file mode 100644 --- a/tests-1/Instances.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Instances where - - -instance Functor ((->) r) where - fmap = (.) - -instance Monad ((->) r) where - return = const - f >>= k = \ r -> k (f r) r - -instance Functor ((,) a) where - fmap f (x,y) = (x, f y) - diff --git a/tests-2/Instances.hs b/tests-2/Instances.hs deleted file mode 100644 --- a/tests-2/Instances.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Instances where diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs deleted file mode 100644 --- a/tests/QuickCheckUtils.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# OPTIONS_GHC -O -fglasgow-exts #-} --- --- Uses multi-param type classes --- -module QuickCheckUtils where - -import Instances () - -import Test.QuickCheck --- import Test.QuickCheck (Arbitrary(arbitrary, coarbitrary), variant, choose, sized, (==>), Property, ) -import Text.Show.Functions () -import System.Random (RandomGen, StdGen, Random, newStdGen, split, randomR, random, ) - -import Control.Monad (liftM2) -import Data.Char (ord) -import Data.Word (Word8) -import Data.Int (Int64) -import System.IO (hFlush, stdout, ) - -import qualified Data.ByteString as P -import qualified Data.StorableVector as V -import qualified Data.List as List - -import qualified Data.ByteString.Char8 as PC - --- Enable this to get verbose test output. Including the actual tests. -debug = False - -mytest :: Testable a => a -> Int -> IO () -mytest a n = mycheck defaultConfig - { configMaxTest=n - , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a - -mycheck :: Testable a => Config -> a -> IO () -mycheck config a = - do rnd <- newStdGen - mytests config (evaluate a) rnd 0 0 [] - -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () -mytests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = do done "OK," ntest stamps - | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps - | otherwise = - do putStr (configEvery config ntest (arguments result)) >> hFlush stdout - case ok result of - Nothing -> - mytests config gen rnd1 ntest (nfail+1) stamps - Just True -> - mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - putStr ( "Falsifiable after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) >> hFlush stdout - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 - -done :: String -> Int -> [[String]] -> IO () -done mesg ntest stamps = - do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) - where - table = display - . map entry - . reverse - . List.sort - . map pairLength - . List.group - . List.sort - . filter (not . null) - $ stamps - - display [] = ".\n" - display [x] = " (" ++ x ++ ").\n" - display xs = ".\n" ++ unlines (map (++ ".") xs) - - pairLength xss@(xs:_) = (length xss, xs) - entry (n, xs) = percentage n ntest - ++ " " - ++ concat (List.intersperse ", " xs) - - percentage n m = show ((100 * n) `div` m) ++ "%" - ------------------------------------------------------------------------- - -instance Arbitrary Char where - arbitrary = choose ('a', 'i') - coarbitrary c = variant (ord c `rem` 4) - -instance Arbitrary Word8 where - arbitrary = choose (97, 105) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4)) - -instance Arbitrary Int64 where - arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n) - coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1)) - -{- -instance Arbitrary Char where - arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too - coarbitrary c = variant (ord c `rem` 16) - -instance Arbitrary Word8 where - arbitrary = choose (minBound, maxBound) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16)) --} - -instance Random Word8 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -instance Random Int64 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) -integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, - fromIntegral b :: Integer) g of - (x,g) -> (fromIntegral x, g) - -instance Arbitrary V where - arbitrary = V.pack `fmap` arbitrary - coarbitrary s = coarbitrary (V.unpack s) - -instance Arbitrary P.ByteString where - arbitrary = P.pack `fmap` arbitrary - coarbitrary s = coarbitrary (P.unpack s) - - ------------------------------------------------------------------------- --- --- We're doing two forms of testing here. Firstly, model based testing. --- For our Lazy and strict bytestring types, we have model types: --- --- i.e. Lazy == Byte --- \\ // --- List --- --- That is, the Lazy type can be modeled by functions in both the Byte --- and List type. For each of the 3 models, we have a set of tests that --- check those types match. --- --- The Model class connects a type and its model type, via a conversion --- function. --- --- -class Model a b where - model :: a -> b -- get the abstract value from a concrete value - --- --- Connecting our Lazy and Strict types to their models. We also check --- the data invariant on Lazy types. --- --- These instances represent the arrows in the above diagram --- -instance Model P [W] where model = P.unpack -instance Model P [Char] where model = PC.unpack -instance Model V [W] where model = V.unpack -instance Model V P where model = P.pack . V.unpack - --- Types are trivially modeled by themselves -instance Model Bool Bool where model = id -instance Model Int Int where model = id -instance Model Int64 Int64 where model = id -instance Model Int64 Int where model = fromIntegral -instance Model Word8 Word8 where model = id -instance Model Ordering Ordering where model = id -instance Model Char Char where model = id - --- More structured types are modeled recursively, using the NatTrans class from Gofer. -class (Functor f, Functor g) => NatTrans f g where - eta :: f a -> g a - --- The transformation of the same type is identity -instance NatTrans [] [] where eta = id -instance NatTrans Maybe Maybe where eta = id -instance NatTrans ((->) X) ((->) X) where eta = id -instance NatTrans ((->) W) ((->) W) where eta = id -instance NatTrans ((->) Char) ((->) Char) where eta = id - --- We have a transformation of pairs, if the pairs are in Model -instance Model f g => NatTrans ((,) f) ((,) g) where eta (f,a) = (model f, a) - --- And finally, we can take any (m a) to (n b), if we can Model m n, and a b -instance (NatTrans m n, Model a b) => Model (m a) (n b) where model x = fmap model (eta x) - ------------------------------------------------------------------------- - --- Some short hand. -type X = Int -type W = Word8 -type P = P.ByteString -type V = V.Vector Word8 - ------------------------------------------------------------------------- --- --- These comparison functions handle wrapping and equality. --- --- A single class for these would be nice, but note that they differe in --- the number of arguments, and those argument types, so we'd need HList --- tricks. See here: http://okmij.org/ftp/Haskell/vararg-fn.lhs --- - -eq1 f g = \a -> - model (f a) == g (model a) -eq2 f g = \a b -> - model (f a b) == g (model a) (model b) -eq3 f g = \a b c -> - model (f a b c) == g (model a) (model b) (model c) -eq4 f g = \a b c d -> - model (f a b c d) == g (model a) (model b) (model c) (model d) -eq5 f g = \a b c d e -> - model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e) - --- --- And for functions that take non-null input --- -eqnotnull1 f g = \x -> (not (isNull x)) ==> eq1 f g x -eqnotnull2 f g = \x y -> (not (isNull y)) ==> eq2 f g x y -eqnotnull3 f g = \x y z -> (not (isNull z)) ==> eq3 f g x y z - -class IsNull t where isNull :: t -> Bool -instance IsNull P.ByteString where isNull = P.null -instance IsNull V where isNull = V.null - -instance Show V where - show = show . V.unpack diff --git a/tests/tests.hs b/tests/tests.hs deleted file mode 100644 --- a/tests/tests.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# OPTIONS_GHC -O #-} -import qualified Data.StorableVector as V -import qualified Data.ByteString as P -import QuickCheckUtils - (V, W, X, P, mytest, - eq1, eq2, eq3, eqnotnull1, eqnotnull2, eqnotnull3, ) -import Text.Printf (printf) -import System.Environment (getArgs) - --- --- Data.StorableVector <=> ByteString --- - -prop_concatVP = (V.concat :: [V] -> V) `eq1` P.concat -prop_nullVP = (V.null :: V -> Bool) `eq1` P.null -prop_reverseVP = (V.reverse :: V -> V) `eq1` P.reverse -prop_transposeVP = (V.transpose :: [V] -> [V]) `eq1` P.transpose -prop_groupVP = (V.group :: V -> [V]) `eq1` P.group -prop_initsVP = (V.inits :: V -> [V]) `eq1` P.inits -prop_tailsVP = (V.tails :: V -> [V]) `eq1` P.tails -prop_allVP = (V.all :: (W -> Bool) -> V -> Bool) `eq2` P.all -prop_anyVP = (V.any :: (W -> Bool) -> V -> Bool) `eq2` P.any -prop_appendVP = (V.append :: V -> V -> V) `eq2` P.append -prop_breakVP = (V.break :: (W -> Bool) -> V -> (V, V)) `eq2` P.break -prop_concatMapVP = (V.concatMap :: (W -> V) -> V -> V) `eq2` P.concatMap -prop_consVP = (V.cons :: W -> V -> V) `eq2` P.cons -prop_countVP = (V.count :: W -> V -> X) `eq2` P.count -prop_dropVP = (V.drop :: X -> V -> V) `eq2` P.drop -prop_dropWhileVP = (V.dropWhile :: (W -> Bool) -> V -> V) `eq2` P.dropWhile -prop_filterVP = (V.filter :: (W -> Bool) -> V -> V) `eq2` P.filter -prop_findVP = (V.find :: (W -> Bool) -> V -> Maybe W) `eq2` P.find -prop_findIndexVP = (V.findIndex :: (W -> Bool) -> V -> Maybe X) `eq2` P.findIndex -prop_findIndicesVP = (V.findIndices :: (W -> Bool) -> V -> [X]) `eq2` P.findIndices -prop_isPrefixOfVP = (V.isPrefixOf :: V -> V -> Bool) `eq2` P.isPrefixOf -prop_mapVP = (V.map :: (W -> W) -> V -> V) `eq2` P.map -prop_replicateVP = (V.replicate :: X -> W -> V) `eq2` P.replicate -prop_snocVP = (V.snoc :: V -> W -> V) `eq2` P.snoc -prop_spanVP = (V.span :: (W -> Bool) -> V -> (V, V)) `eq2` P.span -prop_splitVP = (V.split :: W -> V -> [V]) `eq2` P.split -prop_splitAtVP = (V.splitAt :: X -> V -> (V, V)) `eq2` P.splitAt -prop_takeVP = (V.take :: X -> V -> V) `eq2` P.take -prop_takeWhileVP = (V.takeWhile :: (W -> Bool) -> V -> V) `eq2` P.takeWhile -prop_elemVP = (V.elem :: W -> V -> Bool) `eq2` P.elem -prop_notElemVP = (V.notElem :: W -> V -> Bool) `eq2` P.notElem -prop_elemIndexVP = (V.elemIndex :: W -> V -> Maybe X) `eq2` P.elemIndex -prop_elemIndicesVP = (V.elemIndices :: W -> V -> [X])`eq2` P.elemIndices -prop_lengthVP = (V.length :: V -> X) `eq1` P.length - -prop_headVP = (V.head :: V -> W) `eqnotnull1` P.head -prop_initVP = (V.init :: V -> V) `eqnotnull1` P.init -prop_lastVP = (V.last :: V -> W) `eqnotnull1` P.last -prop_maximumVP = (V.maximum :: V -> W) `eqnotnull1` P.maximum -prop_minimumVP = (V.minimum :: V -> W) `eqnotnull1` P.minimum -prop_tailVP = (V.tail :: V -> V) `eqnotnull1` P.tail -prop_foldl1VP = (V.foldl1 :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldl1 -prop_foldl1VP' = (V.foldl1' :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldl1' -prop_foldr1VP = (V.foldr1 :: (W -> W -> W) -> V -> W) `eqnotnull2` P.foldr1 -prop_scanlVP = (V.scanl :: (W -> W -> W) -> W -> V -> V) `eqnotnull3` P.scanl -prop_scanrVP = (V.scanr :: (W -> W -> W) -> W -> V -> V) `eqnotnull3` P.scanr - -prop_eqVP = eq2 - ((==) :: V -> V -> Bool) - ((==) :: P -> P -> Bool) -prop_foldlVP = eq3 - (V.foldl :: (X -> W -> X) -> X -> V -> X) - (P.foldl :: (X -> W -> X) -> X -> P -> X) -prop_foldlVP' = eq3 - (V.foldl' :: (X -> W -> X) -> X -> V -> X) - (P.foldl' :: (X -> W -> X) -> X -> P -> X) -prop_foldrVP = eq3 - (V.foldr :: (W -> X -> X) -> X -> V -> X) - (P.foldr :: (W -> X -> X) -> X -> P -> X) -prop_mapAccumLVP = eq3 - (V.mapAccumL :: (X -> W -> (X,W)) -> X -> V -> (X, V)) - (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) -prop_mapAccumRVP = eq3 - (V.mapAccumR :: (X -> W -> (X,W)) -> X -> V -> (X, V)) - (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P)) -prop_zipWithVP = eq3 - (V.zipWith :: (W -> W -> W) -> V -> V -> V) --- (P.zipWith :: (W -> W -> W) -> P -> P -> P) - (\f x y -> P.pack (P.zipWith f x y) :: P) - -prop_unfoldrVP = eq3 - ((\n f a -> V.take (fromIntegral n) $ - V.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> V) - ((\n f a -> fst $ - P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) - ------------------------------------------------------------------------- --- StorableVector <=> ByteString - -vp_tests = - [("all", mytest prop_allVP) - ,("any", mytest prop_anyVP) - ,("append", mytest prop_appendVP) - ,("concat", mytest prop_concatVP) - ,("cons", mytest prop_consVP) - ,("eq", mytest prop_eqVP) - ,("filter", mytest prop_filterVP) - ,("find", mytest prop_findVP) - ,("findIndex", mytest prop_findIndexVP) - ,("findIndices", mytest prop_findIndicesVP) - ,("foldl", mytest prop_foldlVP) - ,("foldl'", mytest prop_foldlVP') - ,("foldl1", mytest prop_foldl1VP) - ,("foldl1'", mytest prop_foldl1VP') - ,("foldr", mytest prop_foldrVP) - ,("foldr1", mytest prop_foldr1VP) - ,("mapAccumL", mytest prop_mapAccumLVP) - ,("mapAccumR", mytest prop_mapAccumRVP) - ,("zipWith", mytest prop_zipWithVP) - -- ,("unfoldr", mytest prop_unfoldrVP) - ,("head", mytest prop_headVP) - ,("init", mytest prop_initVP) - ,("isPrefixOf", mytest prop_isPrefixOfVP) - ,("last", mytest prop_lastVP) - ,("length", mytest prop_lengthVP) - ,("map", mytest prop_mapVP) - ,("maximum ", mytest prop_maximumVP) - ,("minimum" , mytest prop_minimumVP) - ,("null", mytest prop_nullVP) - ,("reverse", mytest prop_reverseVP) - ,("snoc", mytest prop_snocVP) - ,("tail", mytest prop_tailVP) - ,("scanl", mytest prop_scanlVP) - ,("scanr", mytest prop_scanrVP) - ,("transpose", mytest prop_transposeVP) - ,("replicate", mytest prop_replicateVP) - ,("take", mytest prop_takeVP) - ,("drop", mytest prop_dropVP) - ,("splitAt", mytest prop_splitAtVP) - ,("takeWhile", mytest prop_takeWhileVP) - ,("dropWhile", mytest prop_dropWhileVP) - ,("break", mytest prop_breakVP) - ,("span", mytest prop_spanVP) - ,("split", mytest prop_splitVP) - ,("count", mytest prop_countVP) - ,("group", mytest prop_groupVP) - ,("inits", mytest prop_initsVP) - ,("tails", mytest prop_tailsVP) - ,("elem", mytest prop_elemVP) - ,("notElem", mytest prop_notElemVP) - ,("elemIndex", mytest prop_elemIndexVP) - ,("elemIndices", mytest prop_elemIndicesVP) - ,("concatMap", mytest prop_concatMapVP) - ] - ------------------------------------------------------------------------- --- The entry point - -main = run vp_tests - -run :: [(String, Int -> IO ())] -> IO () -run tests = do - x <- getArgs - let n = if null x then 100 else read . head $ x - mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests