diff --git a/Data/Vector.hs b/Data/Vector.hs --- a/Data/Vector.hs +++ b/Data/Vector.hs @@ -119,7 +119,7 @@ takeWhile, dropWhile, -- ** Partitioning - partition, unstablePartition, span, break, + partition, unstablePartition, partitionWith, span, break, -- ** Searching elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, @@ -164,12 +164,17 @@ freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy ) where -import qualified Data.Vector.Generic as G -import Data.Vector.Mutable ( MVector(..) ) -import Data.Primitive.Array +import Data.Vector.Mutable ( MVector(..) ) +import Data.Primitive.Array import qualified Data.Vector.Fusion.Bundle as Bundle +import qualified Data.Vector.Generic as G -import Control.DeepSeq ( NFData, rnf ) +import Control.DeepSeq ( NFData(rnf) +#if MIN_VERSION_deepseq(1,4,3) + , NFData1(liftRnf) +#endif + ) + import Control.Monad ( MonadPlus(..), liftM, ap ) import Control.Monad.ST ( ST ) import Control.Monad.Primitive @@ -219,12 +224,19 @@ {-# UNPACK #-} !(Array a) deriving ( Typeable ) +liftRnfV :: (a -> ()) -> Vector a -> () +liftRnfV elemRnf = foldl' (\_ -> elemRnf) () + instance NFData a => NFData (Vector a) where - rnf (Vector i n arr) = rnfAll i - where - rnfAll ix | ix < n = rnf (indexArray arr ix) `seq` rnfAll (ix+1) - | otherwise = () + rnf = liftRnfV rnf + {-# INLINEABLE rnf #-} +#if MIN_VERSION_deepseq(1,4,3) +instance NFData1 Vector where + liftRnf = liftRnfV + {-# INLINEABLE liftRnf #-} +#endif + instance Show a => Show (Vector a) where showsPrec = G.showsPrec @@ -251,9 +263,9 @@ instance Data a => Data (Vector a) where gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Vector" + toConstr _ = G.mkVecConstr "Data.Vector.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Vector" dataCast1 = G.dataCast type instance G.Mutable Vector = MVector @@ -340,6 +352,7 @@ {-# INLINE (>>=) #-} (>>=) = flip concatMap + #if !(MIN_VERSION_base(4,13,0)) {-# INLINE fail #-} fail = Fail.fail -- == \ _str -> empty @@ -697,7 +710,7 @@ -- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the -- generator function to the already constructed part of the vector. -- --- > constructN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructN 3 f = let a = f <> ; b = f ; c = f in -- constructN :: Int -> (Vector a -> a) -> Vector a {-# INLINE constructN #-} @@ -707,7 +720,7 @@ -- repeatedly applying the generator function to the already constructed part -- of the vector. -- --- > constructrN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructrN 3 f = let a = f <> ; b = f ; c = f in -- constructrN :: Int -> (Vector a -> a) -> Vector a {-# INLINE constructrN #-} @@ -1249,6 +1262,13 @@ unstablePartition :: (a -> Bool) -> Vector a -> (Vector a, Vector a) {-# INLINE unstablePartition #-} unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector in two parts, the first one containing the +-- @Right@ elements and the second containing the @Left@ elements. +-- The relative order of the elements is preserved. +partitionWith :: (a -> Either b c) -> Vector a -> (Vector b, Vector c) +{-# INLINE partitionWith #-} +partitionWith = G.partitionWith -- | /O(n)/ Split the vector into the longest prefix of elements that satisfy -- the predicate and the rest without copying. diff --git a/Data/Vector/Fusion/Bundle/Monadic.hs b/Data/Vector/Fusion/Bundle/Monadic.hs --- a/Data/Vector/Fusion/Bundle/Monadic.hs +++ b/Data/Vector/Fusion/Bundle/Monadic.hs @@ -269,7 +269,7 @@ -- | The first @n@ elements take :: Monad m => Int -> Bundle m v a -> Bundle m v a {-# INLINE_FUSED take #-} -take n Bundle{sElems = s, sSize = sz} = fromStream (S.take n s) (smaller (Exact n) sz) +take n Bundle{sElems = s, sSize = sz} = fromStream (S.take n s) (smallerThan n sz) -- | All but the first @n@ elements drop :: Monad m => Int -> Bundle m v a -> Bundle m v a @@ -426,7 +426,15 @@ -- | Check if two 'Bundle's are equal eqBy :: (Monad m) => (a -> b -> Bool) -> Bundle m v a -> Bundle m v b -> m Bool {-# INLINE_FUSED eqBy #-} -eqBy eq x y = S.eqBy eq (sElems x) (sElems y) +eqBy eq x y + | sizesAreDifferent (sSize x) (sSize y) = return False + | otherwise = S.eqBy eq (sElems x) (sElems y) + where + sizesAreDifferent :: Size -> Size -> Bool + sizesAreDifferent (Exact a) (Exact b) = a /= b + sizesAreDifferent (Exact a) (Max b) = a > b + sizesAreDifferent (Max a) (Exact b) = a < b + sizesAreDifferent _ _ = False -- | Lexicographically compare two 'Bundle's cmpBy :: (Monad m) => (a -> b -> Ordering) -> Bundle m v a -> Bundle m v b -> m Ordering @@ -758,13 +766,15 @@ -- FIXME: add "too large" test for Int enumFromTo_small :: (Integral a, Monad m) => a -> a -> Bundle m v a {-# INLINE_FUSED enumFromTo_small #-} -enumFromTo_small x y = x `seq` y `seq` fromStream (Stream step x) (Exact n) +enumFromTo_small x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact n) where n = delay_inline max (fromIntegral y - fromIntegral x + 1) 0 {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -808,7 +818,7 @@ enumFromTo_int :: forall m v. Monad m => Int -> Int -> Bundle m v Int {-# INLINE_FUSED enumFromTo_int #-} -enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) +enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y)) where {-# INLINE [0] len #-} len :: Int -> Int -> Int @@ -820,12 +830,14 @@ n = v-u+1 {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Bundle m v a {-# INLINE_FUSED enumFromTo_intlike #-} -enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) +enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y)) where {-# INLINE [0] len #-} len u v | u > v = 0 @@ -836,8 +848,10 @@ n = v-u+1 {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -860,7 +874,7 @@ enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Bundle m v a {-# INLINE_FUSED enumFromTo_big_word #-} -enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) +enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y)) where {-# INLINE [0] len #-} len u v | u > v = 0 @@ -871,8 +885,10 @@ n = v-u {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -901,7 +917,7 @@ -- FIXME: the "too large" test is totally wrong enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Bundle m v a {-# INLINE_FUSED enumFromTo_big_int #-} -enumFromTo_big_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) +enumFromTo_big_int x y = x `seq` y `seq` fromStream (Stream step (Just x)) (Exact (len x y)) where {-# INLINE [0] len #-} len u v | u > v = 0 @@ -912,8 +928,10 @@ n = v-u+1 {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -952,7 +970,7 @@ enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Bundle m v a {-# INLINE_FUSED enumFromTo_double #-} -enumFromTo_double n m = n `seq` m `seq` fromStream (Stream step n) (Max (len n lim)) +enumFromTo_double n m = n `seq` m `seq` fromStream (Stream step ini) (Max (len n lim)) where lim = m + 1/2 -- important to float out @@ -966,8 +984,23 @@ l = truncate (y-x)+2 {-# INLINE_INNER step #-} +-- GHC changed definition of Enum for Double in GHC8.6 so we have to +-- accomodate both definitions in order to preserve validity of +-- rewrite rule +-- +-- ISSUE: https://gitlab.haskell.org/ghc/ghc/issues/15081 +-- COMMIT: https://gitlab.haskell.org/ghc/ghc/commit/4ffaf4b67773af4c72d92bb8b6c87b1a7d34ac0f +#if MIN_VERSION_base(4,12,0) + ini = 0 + step x | x' <= lim = return $ Yield x' (x+1) + | otherwise = return $ Done + where + x' = x + n +#else + ini = n step x | x <= lim = return $ Yield x (x+1) | otherwise = return $ Done +#endif {-# RULES diff --git a/Data/Vector/Fusion/Bundle/Size.hs b/Data/Vector/Fusion/Bundle/Size.hs --- a/Data/Vector/Fusion/Bundle/Size.hs +++ b/Data/Vector/Fusion/Bundle/Size.hs @@ -11,7 +11,7 @@ -- module Data.Vector.Fusion.Bundle.Size ( - Size(..), clampedSubtract, smaller, larger, toMax, upperBound, lowerBound + Size(..), clampedSubtract, smaller, smallerThan, larger, toMax, upperBound, lowerBound ) where import Data.Vector.Fusion.Util ( delay_inline ) @@ -90,6 +90,14 @@ smaller Unknown (Exact n) = Max n smaller Unknown (Max n) = Max n smaller Unknown Unknown = Unknown + +-- | Select a safe smaller than known size. +smallerThan :: Int -> Size -> Size +{-# INLINE smallerThan #-} +smallerThan m (Exact n) = Exact (delay_inline min m n) +smallerThan m (Max n) = Max (delay_inline min m n) +smallerThan _ Unknown = Unknown + -- | Maximum of two size hints larger :: Size -> Size -> Size diff --git a/Data/Vector/Fusion/Stream/Monadic.hs b/Data/Vector/Fusion/Stream/Monadic.hs --- a/Data/Vector/Fusion/Stream/Monadic.hs +++ b/Data/Vector/Fusion/Stream/Monadic.hs @@ -1325,11 +1325,13 @@ -- FIXME: add "too large" test for Int enumFromTo_small :: (Integral a, Monad m) => a -> a -> Stream m a {-# INLINE_FUSED enumFromTo_small #-} -enumFromTo_small x y = x `seq` y `seq` Stream step x +enumFromTo_small x y = x `seq` y `seq` Stream step (Just x) where {-# INLINE_INNER step #-} - step w | w <= y = return $ Yield w (w+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -1373,7 +1375,7 @@ enumFromTo_int :: forall m. Monad m => Int -> Int -> Stream m Int {-# INLINE_FUSED enumFromTo_int #-} -enumFromTo_int x y = x `seq` y `seq` Stream step x +enumFromTo_int x y = x `seq` y `seq` Stream step (Just x) where -- {-# INLINE [0] len #-} -- len :: Int -> Int -> Int @@ -1385,16 +1387,21 @@ -- n = v-u+1 {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done + enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Stream m a {-# INLINE_FUSED enumFromTo_intlike #-} -enumFromTo_intlike x y = x `seq` y `seq` Stream step x +enumFromTo_intlike x y = x `seq` y `seq` Stream step (Just x) where {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -1415,11 +1422,13 @@ enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Stream m a {-# INLINE_FUSED enumFromTo_big_word #-} -enumFromTo_big_word x y = x `seq` y `seq` Stream step x +enumFromTo_big_word x y = x `seq` y `seq` Stream step (Just x) where {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -1449,11 +1458,13 @@ -- FIXME: the "too large" test is totally wrong enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Stream m a {-# INLINE_FUSED enumFromTo_big_int #-} -enumFromTo_big_int x y = x `seq` y `seq` Stream step x +enumFromTo_big_int x y = x `seq` y `seq` Stream step (Just x) where {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done + step Nothing = return $ Done + step (Just z) | z == y = return $ Yield z Nothing + | z < y = return $ Yield z (Just (z+1)) + | otherwise = return $ Done {-# RULES @@ -1489,13 +1500,27 @@ enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Stream m a {-# INLINE_FUSED enumFromTo_double #-} -enumFromTo_double n m = n `seq` m `seq` Stream step n +enumFromTo_double n m = n `seq` m `seq` Stream step ini where lim = m + 1/2 -- important to float out - {-# INLINE_INNER step #-} +-- GHC changed definition of Enum for Double in GHC8.6 so we have to +-- accomodate both definitions in order to preserve validity of +-- rewrite rule +-- +-- ISSUE: https://gitlab.haskell.org/ghc/ghc/issues/15081 +-- COMMIT: https://gitlab.haskell.org/ghc/ghc/commit/4ffaf4b67773af4c72d92bb8b6c87b1a7d34ac0f +#if MIN_VERSION_base(4,12,0) + ini = 0 + step x | x' <= lim = return $ Yield x' (x+1) + | otherwise = return $ Done + where + x' = x + n +#else + ini = n step x | x <= lim = return $ Yield x (x+1) | otherwise = return $ Done +#endif {-# RULES diff --git a/Data/Vector/Generic.hs b/Data/Vector/Generic.hs --- a/Data/Vector/Generic.hs +++ b/Data/Vector/Generic.hs @@ -102,7 +102,7 @@ takeWhile, dropWhile, -- ** Partitioning - partition, unstablePartition, span, break, + partition, partitionWith, unstablePartition, span, break, -- ** Searching elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, @@ -165,7 +165,7 @@ liftShowsPrec, liftReadsPrec, -- ** @Data@ and @Typeable@ - gfoldl, dataCast, mkType + gfoldl, gunfold, dataCast, mkVecType, mkVecConstr ) where import Data.Vector.Generic.Base @@ -211,14 +211,8 @@ #include "vector.h" -import Data.Data ( Data, DataType ) -#if MIN_VERSION_base(4,2,0) -import Data.Data ( mkNoRepType ) -#else -import Data.Data ( mkNorepType ) -mkNoRepType :: String -> DataType -mkNoRepType = mkNorepType -#endif +import Data.Data ( Data, DataType, Constr, Fixity(Prefix), + mkDataType, mkConstr, constrIndex ) import qualified Data.Traversable as T (Traversable(mapM)) @@ -472,11 +466,13 @@ {-# INLINE unsafeDrop #-} unsafeDrop n v = unsafeSlice n (length v - n) v -{-# RULES -"slice/new [Vector]" forall i n p. - slice i n (new p) = new (New.slice i n p) +-- Turned off due to: https://github.com/haskell/vector/issues/257 +-- "slice/new [Vector]" forall i n p. +-- slice i n (new p) = new (New.slice i n p) +{-# RULES + "init/new [Vector]" forall p. init (new p) = new (New.init p) @@ -573,7 +569,7 @@ -- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the -- generator function to the already constructed part of the vector. -- --- > constructN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructN 3 f = let a = f <> ; b = f ; c = f in -- constructN :: forall v a. Vector v a => Int -> (v a -> a) -> v a {-# INLINE constructN #-} @@ -602,7 +598,7 @@ -- repeatedly applying the generator function to the already constructed part -- of the vector. -- --- > constructrN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructrN 3 f = let a = f <> ; b = f ; c = f in -- constructrN :: forall v a. Vector v a => Int -> (v a -> a) -> v a {-# INLINE constructrN #-} @@ -1375,6 +1371,19 @@ v2 <- unsafeFreeze mv2 return (v1,v2)) +partitionWith :: (Vector v a, Vector v b, Vector v c) => (a -> Either b c) -> v a -> (v b, v c) +{-# INLINE partitionWith #-} +partitionWith f = partition_with_stream f . stream + +partition_with_stream :: (Vector v a, Vector v b, Vector v c) => (a -> Either b c) -> Bundle u a -> (v b, v c) +{-# INLINE_FUSED partition_with_stream #-} +partition_with_stream f s = s `seq` runST ( + do + (mv1,mv2) <- M.partitionWithBundle f s + v1 <- unsafeFreeze mv1 + v2 <- unsafeFreeze mv2 + return (v1,v2)) + -- | /O(n)/ Split the vector in two parts, the first one containing those -- elements that satisfy the predicate and the second one those that don't. -- The order of the elements is not preserved but the operation is often @@ -2192,9 +2201,21 @@ {-# INLINE gfoldl #-} gfoldl f z v = z fromList `f` toList v -mkType :: String -> DataType -{-# INLINE mkType #-} -mkType = mkNoRepType +mkVecConstr :: String -> Constr +{-# INLINE mkVecConstr #-} +mkVecConstr name = mkConstr (mkVecType name) "fromList" [] Prefix + +mkVecType :: String -> DataType +{-# INLINE mkVecType #-} +mkVecType name = mkDataType name [mkVecConstr name] + +gunfold :: (Vector v a, Data a) + => (forall b r. Data b => c (b -> r) -> c r) + -> (forall r. r -> c r) + -> Constr -> c (v a) +gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" #if __GLASGOW_HASKELL__ >= 707 dataCast :: (Vector v a, Data a, Typeable v, Typeable t) diff --git a/Data/Vector/Generic/Mutable.hs b/Data/Vector/Generic/Mutable.hs --- a/Data/Vector/Generic/Mutable.hs +++ b/Data/Vector/Generic/Mutable.hs @@ -56,7 +56,8 @@ transform, transformR, fill, fillR, unsafeAccum, accum, unsafeUpdate, update, reverse, - unstablePartition, unstablePartitionBundle, partitionBundle + unstablePartition, unstablePartitionBundle, partitionBundle, + partitionWithBundle ) where import Data.Vector.Generic.Mutable.Base @@ -507,8 +508,13 @@ -- Extracting subvectors -- --------------------- --- | Yield a part of the mutable vector without copying it. -slice :: MVector v a => Int -> Int -> v s a -> v s a +-- | Yield a part of the mutable vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: MVector v a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> v s a + -> v s a {-# INLINE slice #-} slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v) $ unsafeSlice i n v @@ -710,7 +716,7 @@ $ BOUNDS_CHECK(checkIndex) "swap" j (length v) $ unsafeSwap v i j --- | Replace the element at the give position and return the old element. +-- | Replace the element at the given position and return the old element. exchange :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> a -> m a {-# INLINE exchange #-} exchange v i x = BOUNDS_CHECK(checkIndex) "exchange" i (length v) @@ -748,7 +754,7 @@ unsafeWrite v i y unsafeWrite v j x --- | Replace the element at the give position and return the old element. No +-- | Replace the element at the given position and return the old element. No -- bounds checks are performed. unsafeExchange :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> a -> m a @@ -787,7 +793,9 @@ -- copied to a temporary vector and then the temporary vector was copied -- to the target vector. move :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> v (PrimState m) a -> m () + => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () {-# INLINE move #-} move dst src = BOUNDS_CHECK(check) "move" "length mismatch" (length dst == length src) @@ -997,6 +1005,60 @@ v2' <- unsafeAppend1 v2 i2 x return (v1, i1, v2', i2+1) + +partitionWithBundle :: (PrimMonad m, MVector v a, MVector v b, MVector v c) + => (a -> Either b c) -> Bundle u a -> m (v (PrimState m) b, v (PrimState m) c) +{-# INLINE partitionWithBundle #-} +partitionWithBundle f s + = case upperBound (Bundle.size s) of + Just n -> partitionWithMax f s n + Nothing -> partitionWithUnknown f s + +partitionWithMax :: (PrimMonad m, MVector v a, MVector v b, MVector v c) + => (a -> Either b c) -> Bundle u a -> Int -> m (v (PrimState m) b, v (PrimState m) c) +{-# INLINE partitionWithMax #-} +partitionWithMax f s n + = do + v1 <- unsafeNew n + v2 <- unsafeNew n + let {-# INLINE_INNER put #-} + put (i1, i2) x = case f x of + Left b -> do + unsafeWrite v1 i1 b + return (i1+1, i2) + Right c -> do + unsafeWrite v2 i2 c + return (i1, i2+1) + (n1, n2) <- Bundle.foldM' put (0, 0) s + INTERNAL_CHECK(checkSlice) "partitionEithersMax" 0 n1 (length v1) + $ INTERNAL_CHECK(checkSlice) "partitionEithersMax" 0 n2 (length v2) + $ return (unsafeSlice 0 n1 v1, unsafeSlice 0 n2 v2) + +partitionWithUnknown :: forall m v u a b c. + (PrimMonad m, MVector v a, MVector v b, MVector v c) + => (a -> Either b c) -> Bundle u a -> m (v (PrimState m) b, v (PrimState m) c) +{-# INLINE partitionWithUnknown #-} +partitionWithUnknown f s + = do + v1 <- unsafeNew 0 + v2 <- unsafeNew 0 + (v1', n1, v2', n2) <- Bundle.foldM' put (v1, 0, v2, 0) s + INTERNAL_CHECK(checkSlice) "partitionEithersUnknown" 0 n1 (length v1') + $ INTERNAL_CHECK(checkSlice) "partitionEithersUnknown" 0 n2 (length v2') + $ return (unsafeSlice 0 n1 v1', unsafeSlice 0 n2 v2') + where + put :: (v (PrimState m) b, Int, v (PrimState m) c, Int) + -> a + -> m (v (PrimState m) b, Int, v (PrimState m) c, Int) + {-# INLINE_INNER put #-} + put (v1, i1, v2, i2) x = case f x of + Left b -> do + v1' <- unsafeAppend1 v1 i1 b + return (v1', i1+1, v2, i2) + Right c -> do + v2' <- unsafeAppend1 v2 i2 c + return (v1, i1, v2', i2+1) + {- http://en.wikipedia.org/wiki/Permutation#Algorithms_to_generate_permutations @@ -1011,7 +1073,7 @@ -} -- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation +-- Returns False when input is the last permutation nextPermutation :: (PrimMonad m,Ord e,MVector v e) => v (PrimState m) e -> m Bool nextPermutation v | dim < 2 = return False diff --git a/Data/Vector/Internal/Check.hs b/Data/Vector/Internal/Check.hs --- a/Data/Vector/Internal/Check.hs +++ b/Data/Vector/Internal/Check.hs @@ -148,5 +148,5 @@ {-# INLINE checkSlice #-} checkSlice file line kind loc i m n x = check file line kind loc (checkSlice_msg i m n) - (i >= 0 && m >= 0 && i+m <= n) x + (i >= 0 && m >= 0 && m <= n - i) x diff --git a/Data/Vector/Mutable.hs b/Data/Vector/Mutable.hs --- a/Data/Vector/Mutable.hs +++ b/Data/Vector/Mutable.hs @@ -62,6 +62,8 @@ #include "vector.h" + + -- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). data MVector s a = MVector {-# UNPACK #-} !Int {-# UNPACK #-} !Int @@ -185,7 +187,7 @@ in go 0 uninitialised :: a -uninitialised = error "Data.Vector.Mutable: uninitialised element" +uninitialised = error "Data.Vector.Mutable: uninitialised element. If you are trying to compact a vector, use the 'force' function to remove uninitialised elements from the underlying array." -- Length information -- ------------------ @@ -203,8 +205,12 @@ -- Extracting subvectors -- --------------------- --- | Yield a part of the mutable vector without copying it. -slice :: Int -> Int -> MVector s a -> MVector s a +-- | Yield a part of the mutable vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> MVector s a + -> MVector s a {-# INLINE slice #-} slice = G.slice @@ -371,8 +377,9 @@ -- | Copy a vector. The two vectors must have the same length and may not -- overlap. -copy :: PrimMonad m - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () +copy :: PrimMonad m => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () {-# INLINE copy #-} copy = G.copy @@ -391,8 +398,9 @@ -- Otherwise, the copying is performed as if the source vector were -- copied to a temporary vector and then the temporary vector was copied -- to the target vector. -move :: PrimMonad m - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () +move :: PrimMonad m => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () {-# INLINE move #-} move = G.move @@ -410,7 +418,7 @@ unsafeMove = G.unsafeMove -- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation +-- Returns False when input is the last permutation nextPermutation :: (PrimMonad m,Ord e) => MVector (PrimState m) e -> m Bool {-# INLINE nextPermutation #-} nextPermutation = G.nextPermutation diff --git a/Data/Vector/Primitive.hs b/Data/Vector/Primitive.hs --- a/Data/Vector/Primitive.hs +++ b/Data/Vector/Primitive.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables, Rank2Types #-} + -- | -- Module : Data.Vector.Primitive -- Copyright : (c) Roman Leshchinskiy 2008-2010 @@ -98,7 +99,7 @@ takeWhile, dropWhile, -- ** Partitioning - partition, unstablePartition, span, break, + partition, unstablePartition, partitionWith, span, break, -- ** Searching elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, @@ -143,7 +144,11 @@ import Data.Primitive.ByteArray import Data.Primitive ( Prim, sizeOf ) -import Control.DeepSeq ( NFData(rnf) ) +import Control.DeepSeq ( NFData(rnf) +#if MIN_VERSION_deepseq(1,4,3) + , NFData1(liftRnf) +#endif + ) import Control.Monad ( liftM ) import Control.Monad.ST ( ST ) @@ -177,6 +182,7 @@ import qualified GHC.Exts as Exts #endif + -- | Unboxed vectors of primitive types data Vector a = Vector {-# UNPACK #-} !Int {-# UNPACK #-} !Int @@ -186,6 +192,11 @@ instance NFData (Vector a) where rnf (Vector _ _ _) = () +#if MIN_VERSION_deepseq(1,4,3) +instance NFData1 Vector where + liftRnf _ (Vector _ _ _) = () +#endif + instance (Show a, Prim a) => Show (Vector a) where showsPrec = G.showsPrec @@ -195,9 +206,9 @@ instance (Data a, Prim a) => Data (Vector a) where gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Primitive.Vector" + toConstr _ = G.mkVecConstr "Data.Vector.Primitive.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Primitive.Vector" dataCast1 = G.dataCast @@ -536,7 +547,7 @@ -- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the -- generator function to the already constructed part of the vector. -- --- > constructN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructN 3 f = let a = f <> ; b = f ; c = f in -- constructN :: Prim a => Int -> (Vector a -> a) -> Vector a {-# INLINE constructN #-} @@ -546,7 +557,7 @@ -- repeatedly applying the generator function to the already constructed part -- of the vector. -- --- > constructrN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructrN 3 f = let a = f <> ; b = f ; c = f in -- constructrN :: Prim a => Int -> (Vector a -> a) -> Vector a {-# INLINE constructrN #-} @@ -978,6 +989,13 @@ unstablePartition :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) {-# INLINE unstablePartition #-} unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector in two parts, the first one containing the +-- @Right@ elements and the second containing the @Left@ elements. +-- The relative order of the elements is preserved. +partitionWith :: (Prim a, Prim b, Prim c) => (a -> Either b c) -> Vector a -> (Vector b, Vector c) +{-# INLINE partitionWith #-} +partitionWith = G.partitionWith -- | /O(n)/ Split the vector into the longest prefix of elements that satisfy -- the predicate and the rest without copying. diff --git a/Data/Vector/Primitive/Mutable.hs b/Data/Vector/Primitive/Mutable.hs --- a/Data/Vector/Primitive/Mutable.hs +++ b/Data/Vector/Primitive/Mutable.hs @@ -57,7 +57,11 @@ import Control.Monad.Primitive import Control.Monad ( liftM ) -import Control.DeepSeq ( NFData(rnf) ) +import Control.DeepSeq ( NFData(rnf) +#if MIN_VERSION_deepseq(1,4,3) + , NFData1(liftRnf) +#endif + ) import Prelude hiding ( length, null, replicate, reverse, map, read, take, drop, splitAt, init, tail ) @@ -80,6 +84,11 @@ instance NFData (MVector s a) where rnf (MVector _ _ _) = () +#if MIN_VERSION_deepseq(1,4,3) +instance NFData1 (MVector s) where + liftRnf _ (MVector _ _ _) = () +#endif + instance Prim a => G.MVector MVector a where basicLength (MVector _ n _) = n basicUnsafeSlice j m (MVector i _ arr) @@ -145,8 +154,13 @@ -- Extracting subvectors -- --------------------- --- | Yield a part of the mutable vector without copying it. -slice :: Prim a => Int -> Int -> MVector s a -> MVector s a +-- | Yield a part of the mutable vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Prim a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> MVector s a + -> MVector s a {-# INLINE slice #-} slice = G.slice @@ -341,7 +355,9 @@ -- copied to a temporary vector and then the temporary vector was copied -- to the target vector. move :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () {-# INLINE move #-} move = G.move @@ -360,7 +376,7 @@ unsafeMove = G.unsafeMove -- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation +-- Returns False when input is the last permutation nextPermutation :: (PrimMonad m,Ord e,Prim e) => MVector (PrimState m) e -> m Bool {-# INLINE nextPermutation #-} nextPermutation = G.nextPermutation diff --git a/Data/Vector/Storable.hs b/Data/Vector/Storable.hs --- a/Data/Vector/Storable.hs +++ b/Data/Vector/Storable.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, Rank2Types, ScopedTypeVariables #-} + -- | -- Module : Data.Vector.Storable -- Copyright : (c) Roman Leshchinskiy 2009-2010 @@ -95,7 +96,7 @@ takeWhile, dropWhile, -- ** Partitioning - partition, unstablePartition, span, break, + partition, unstablePartition, partitionWith, span, break, -- ** Searching elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, @@ -149,7 +150,11 @@ import Foreign.Ptr import Foreign.Marshal.Array ( advancePtr, copyArray ) -import Control.DeepSeq ( NFData(rnf) ) +import Control.DeepSeq ( NFData(rnf) +#if MIN_VERSION_deepseq(1,4,3) + , NFData1(liftRnf) +#endif + ) import Control.Monad.ST ( ST ) import Control.Monad.Primitive @@ -186,6 +191,8 @@ #define NOT_VECTOR_MODULE #include "vector.h" + + -- | 'Storable'-based vectors data Vector a = Vector {-# UNPACK #-} !Int {-# UNPACK #-} !(ForeignPtr a) @@ -194,6 +201,11 @@ instance NFData (Vector a) where rnf (Vector _ _) = () +#if MIN_VERSION_deepseq(1,4,3) +instance NFData1 Vector where + liftRnf _ (Vector _ _) = () +#endif + instance (Show a, Storable a) => Show (Vector a) where showsPrec = G.showsPrec @@ -203,11 +215,12 @@ instance (Data a, Storable a) => Data (Vector a) where gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Storable.Vector" + toConstr _ = G.mkVecConstr "Data.Vector.Storable.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Storable.Vector" dataCast1 = G.dataCast + type instance G.Mutable Vector = MVector instance Storable a => G.Vector Vector a where @@ -546,7 +559,7 @@ -- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the -- generator function to the already constructed part of the vector. -- --- > constructN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructN 3 f = let a = f <> ; b = f ; c = f in -- constructN :: Storable a => Int -> (Vector a -> a) -> Vector a {-# INLINE constructN #-} @@ -556,7 +569,7 @@ -- repeatedly applying the generator function to the already constructed part -- of the vector. -- --- > constructrN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructrN 3 f = let a = f <> ; b = f ; c = f in -- constructrN :: Storable a => Int -> (Vector a -> a) -> Vector a {-# INLINE constructrN #-} @@ -989,6 +1002,13 @@ {-# INLINE unstablePartition #-} unstablePartition = G.unstablePartition +-- | /O(n)/ Split the vector in two parts, the first one containing the +-- @Right@ elements and the second containing the @Left@ elements. +-- The relative order of the elements is preserved. +partitionWith :: (Storable a, Storable b, Storable c) => (a -> Either b c) -> Vector a -> (Vector b, Vector c) +{-# INLINE partitionWith #-} +partitionWith = G.partitionWith + -- | /O(n)/ Split the vector into the longest prefix of elements that satisfy -- the predicate and the rest without copying. span :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) @@ -1389,7 +1409,6 @@ unsafeCast (Vector n fp) = Vector ((n * sizeOf (undefined :: a)) `div` sizeOf (undefined :: b)) (castForeignPtr fp) - -- Conversions - Mutable vectors -- ----------------------------- diff --git a/Data/Vector/Storable/Internal.hs b/Data/Vector/Storable/Internal.hs --- a/Data/Vector/Storable/Internal.hs +++ b/Data/Vector/Storable/Internal.hs @@ -14,7 +14,8 @@ getPtr, setPtr, updPtr ) where - +import Foreign.ForeignPtr () +import Foreign.Ptr () import GHC.ForeignPtr ( ForeignPtr(..) ) import GHC.Ptr ( Ptr(..) ) diff --git a/Data/Vector/Storable/Mutable.hs b/Data/Vector/Storable/Mutable.hs --- a/Data/Vector/Storable/Mutable.hs +++ b/Data/Vector/Storable/Mutable.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MagicHash, MultiParamTypeClasses, ScopedTypeVariables #-} + + -- | -- Module : Data.Vector.Storable.Mutable -- Copyright : (c) Roman Leshchinskiy 2009-2010 @@ -51,13 +53,18 @@ -- * Unsafe conversions unsafeCast, + -- * Raw pointers unsafeFromForeignPtr, unsafeFromForeignPtr0, unsafeToForeignPtr, unsafeToForeignPtr0, unsafeWith ) where -import Control.DeepSeq ( NFData(rnf) ) +import Control.DeepSeq ( NFData(rnf) +#if MIN_VERSION_deepseq(1,4,3) + , NFData1(liftRnf) +#endif + ) import qualified Data.Vector.Generic.Mutable as G import Data.Vector.Storable.Internal @@ -76,7 +83,7 @@ import GHC.Base ( Int(..) ) -import Foreign.Ptr +import Foreign.Ptr (castPtr,plusPtr) import Foreign.Marshal.Array ( advancePtr, copyArray, moveArray ) import Control.Monad.Primitive @@ -91,10 +98,13 @@ import Data.Typeable ( Typeable ) + -- Data.Vector.Internal.Check is not needed #define NOT_VECTOR_MODULE #include "vector.h" + + -- | Mutable 'Storable'-based vectors data MVector s a = MVector {-# UNPACK #-} !Int {-# UNPACK #-} !(ForeignPtr a) @@ -106,6 +116,11 @@ instance NFData (MVector s a) where rnf (MVector _ _) = () +#if MIN_VERSION_deepseq(1,4,3) +instance NFData1 (MVector s) where + liftRnf _ (MVector _ _) = () +#endif + instance Storable a => G.MVector MVector a where {-# INLINE basicLength #-} basicLength (MVector n _) = n @@ -130,7 +145,7 @@ fp <- mallocVector n return $ MVector n fp where - size = sizeOf (undefined :: a) + size = sizeOf (undefined :: a) `max` 1 mx = maxBound `quot` size :: Int {-# INLINE basicInitialize #-} @@ -201,8 +216,7 @@ poke ptr x -- we dont equate storable and prim reps, so we need to write to a slot -- in storable - -- then read it back as a prim type - -- then use prim memset + -- then read it back as a prim w<- peakPrimPtr_vector ((castPtr ptr) :: Ptr b) 0 memsetPrimPtr_vector ((castPtr ptr) `plusPtr` sizeOf x ) (n-1) w @@ -210,8 +224,7 @@ {- AFTER primitive 0.7 is pretty old, move to using setPtr. which is really -a confusing misnomer for whats often called memset (initialize an array with a -default value) +a confusing misnomer for whats often called memset (intialize ) -} -- Fill a memory block with the given value. The length is in -- elements of type @a@ rather than in bytes. @@ -269,8 +282,13 @@ -- Extracting subvectors -- --------------------- --- | Yield a part of the mutable vector without copying it. -slice :: Storable a => Int -> Int -> MVector s a -> MVector s a +-- | Yield a part of the mutable vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Storable a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> MVector s a + -> MVector s a {-# INLINE slice #-} slice = G.slice @@ -467,7 +485,9 @@ -- copied to a temporary vector and then the temporary vector was copied -- to the target vector. move :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () {-# INLINE move #-} move = G.move diff --git a/Data/Vector/Unboxed.hs b/Data/Vector/Unboxed.hs --- a/Data/Vector/Unboxed.hs +++ b/Data/Vector/Unboxed.hs @@ -125,7 +125,7 @@ takeWhile, dropWhile, -- ** Partitioning - partition, unstablePartition, span, break, + partition, unstablePartition, partitionWith, span, break, -- ** Searching elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, @@ -515,7 +515,7 @@ -- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the -- generator function to the already constructed part of the vector. -- --- > constructN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructN 3 f = let a = f <> ; b = f ; c = f in -- constructN :: Unbox a => Int -> (Vector a -> a) -> Vector a {-# INLINE constructN #-} @@ -525,7 +525,7 @@ -- repeatedly applying the generator function to the already constructed part -- of the vector. -- --- > constructrN 3 f = let a = f <> ; b = f ; c = f in f +-- > constructrN 3 f = let a = f <> ; b = f ; c = f in -- constructrN :: Unbox a => Int -> (Vector a -> a) -> Vector a {-# INLINE constructrN #-} @@ -1035,6 +1035,13 @@ unstablePartition :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) {-# INLINE unstablePartition #-} unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector in two parts, the first one containing the +-- @Right@ elements and the second containing the @Left@ elements. +-- The relative order of the elements is preserved. +partitionWith :: (Unbox a, Unbox b, Unbox c) => (a -> Either b c) -> Vector a -> (Vector b, Vector c) +{-# INLINE partitionWith #-} +partitionWith = G.partitionWith -- | /O(n)/ Split the vector into the longest prefix of elements that satisfy -- the predicate and the rest without copying. diff --git a/Data/Vector/Unboxed/Base.hs b/Data/Vector/Unboxed/Base.hs --- a/Data/Vector/Unboxed/Base.hs +++ b/Data/Vector/Unboxed/Base.hs @@ -2,6 +2,9 @@ #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif {-# OPTIONS_HADDOCK hide #-} -- | @@ -25,15 +28,34 @@ import qualified Data.Vector.Primitive as P -import Control.DeepSeq ( NFData(rnf) ) +import Control.Applicative (Const(..)) +import Control.DeepSeq ( NFData(rnf) +#if MIN_VERSION_deepseq(1,4,3) + , NFData1(liftRnf) +#endif + ) + import Control.Monad.Primitive import Control.Monad ( liftM ) +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Functor.Compose +#endif + import Data.Word ( Word8, Word16, Word32, Word64 ) import Data.Int ( Int8, Int16, Int32, Int64 ) import Data.Complex - +import Data.Monoid (Dual(..),Sum(..),Product(..),All(..),Any(..)) +#if MIN_VERSION_base(4,8,0) +import Data.Monoid (Alt(..)) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Min(..),Max(..),First(..),Last(..),WrappedMonoid(..),Arg(..)) +#endif #if !MIN_VERSION_base(4,8,0) import Data.Word ( Word ) #endif @@ -45,8 +67,8 @@ mkTyCon3 ) #endif - import Data.Data ( Data(..) ) +import GHC.Exts ( Down(..) ) -- Data.Vector.Internal.Check is unused #define NOT_VECTOR_MODULE @@ -65,6 +87,13 @@ instance NFData (Vector a) where rnf !_ = () instance NFData (MVector s a) where rnf !_ = () +#if MIN_VERSION_deepseq(1,4,3) +instance NFData1 Vector where + liftRnf _ !_ = () +instance NFData1 (MVector s) where + liftRnf _ !_ = () +#endif + -- ----------------- -- Data and Typeable -- ----------------- @@ -83,9 +112,9 @@ instance (Data a, Unbox a) => Data (Vector a) where gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Unboxed.Vector" + toConstr _ = G.mkVecConstr "Data.Vector.Unboxed.Vector" + gunfold = G.gunfold + dataTypeOf _ = G.mkVecType "Data.Vector.Unboxed.Vector" dataCast1 = G.dataCast -- ---- @@ -399,6 +428,160 @@ = G.basicUnsafeCopy mv v elemseq _ (x :+ y) z = G.elemseq (undefined :: Vector a) x $ G.elemseq (undefined :: Vector a) y z + +-- ------- +-- Identity +-- ------- +#define newtypeMVector(inst_ctxt,inst_head,tyC,con) \ +instance inst_ctxt => M.MVector MVector (inst_head) where { \ +; {-# INLINE basicLength #-} \ +; {-# INLINE basicUnsafeSlice #-} \ +; {-# INLINE basicOverlaps #-} \ +; {-# INLINE basicUnsafeNew #-} \ +; {-# INLINE basicInitialize #-} \ +; {-# INLINE basicUnsafeReplicate #-} \ +; {-# INLINE basicUnsafeRead #-} \ +; {-# INLINE basicUnsafeWrite #-} \ +; {-# INLINE basicClear #-} \ +; {-# INLINE basicSet #-} \ +; {-# INLINE basicUnsafeCopy #-} \ +; {-# INLINE basicUnsafeGrow #-} \ +; basicLength (con v) = M.basicLength v \ +; basicUnsafeSlice i n (con v) = con $ M.basicUnsafeSlice i n v \ +; basicOverlaps (con v1) (con v2) = M.basicOverlaps v1 v2 \ +; basicUnsafeNew n = con `liftM` M.basicUnsafeNew n \ +; basicInitialize (con v) = M.basicInitialize v \ +; basicUnsafeReplicate n (tyC x) = con `liftM` M.basicUnsafeReplicate n x \ +; basicUnsafeRead (con v) i = tyC `liftM` M.basicUnsafeRead v i \ +; basicUnsafeWrite (con v) i (tyC x) = M.basicUnsafeWrite v i x \ +; basicClear (con v) = M.basicClear v \ +; basicSet (con v) (tyC x) = M.basicSet v x \ +; basicUnsafeCopy (con v1) (con v2) = M.basicUnsafeCopy v1 v2 \ +; basicUnsafeMove (con v1) (con v2) = M.basicUnsafeMove v1 v2 \ +; basicUnsafeGrow (con v) n = con `liftM` M.basicUnsafeGrow v n \ +} +#define newtypeVector(inst_ctxt,inst_head,tyC,con,mcon) \ +instance inst_ctxt => G.Vector Vector (inst_head) where { \ +; {-# INLINE basicUnsafeFreeze #-} \ +; {-# INLINE basicUnsafeThaw #-} \ +; {-# INLINE basicLength #-} \ +; {-# INLINE basicUnsafeSlice #-} \ +; {-# INLINE basicUnsafeIndexM #-} \ +; {-# INLINE elemseq #-} \ +; basicUnsafeFreeze (mcon v) = con `liftM` G.basicUnsafeFreeze v \ +; basicUnsafeThaw (con v) = mcon `liftM` G.basicUnsafeThaw v \ +; basicLength (con v) = G.basicLength v \ +; basicUnsafeSlice i n (con v) = con $ G.basicUnsafeSlice i n v \ +; basicUnsafeIndexM (con v) i = tyC `liftM` G.basicUnsafeIndexM v i \ +; basicUnsafeCopy (mcon mv) (con v) = G.basicUnsafeCopy mv v \ +; elemseq _ (tyC a) = G.elemseq (undefined :: Vector a) a \ +} +#define deriveNewtypeInstances(inst_ctxt,inst_head,rep,tyC,con,mcon) \ +newtype instance MVector s (inst_head) = mcon (MVector s (rep)) ;\ +newtype instance Vector (inst_head) = con (Vector (rep)) ;\ +instance inst_ctxt => Unbox (inst_head) ;\ +newtypeMVector(inst_ctxt, inst_head, tyC, mcon) ;\ +newtypeVector(inst_ctxt, inst_head, tyC, con, mcon) + +#if MIN_VERSION_base(4,8,0) +deriveNewtypeInstances(Unbox a, Identity a, a, Identity, V_Identity, MV_Identity) +#endif + +deriveNewtypeInstances(Unbox a, Down a, a, Down, V_Down, MV_Down) +deriveNewtypeInstances(Unbox a, Dual a, a, Dual, V_Dual, MV_Dual) +deriveNewtypeInstances(Unbox a, Sum a, a, Sum, V_Sum, MV_Sum) +deriveNewtypeInstances(Unbox a, Product a, a, Product, V_Product, MV_Product) + + +-- -------------- +-- Data.Semigroup +-- -------------- + +#if MIN_VERSION_base(4,9,0) +deriveNewtypeInstances(Unbox a, Min a, a, Min, V_Min, MV_Min) +deriveNewtypeInstances(Unbox a, Max a, a, Max, V_Max, MV_Max) +deriveNewtypeInstances(Unbox a, First a, a, First, V_First, MV_First) +deriveNewtypeInstances(Unbox a, Last a, a, Last, V_Last, MV_Last) +deriveNewtypeInstances(Unbox a, WrappedMonoid a, a, WrapMonoid, V_WrappedMonoid, MV_WrappedMonoid) + +-- ------------------ +-- Data.Semigroup.Arg +-- ------------------ + +newtype instance MVector s (Arg a b) = MV_Arg (MVector s (a,b)) +newtype instance Vector (Arg a b) = V_Arg (Vector (a,b)) + +instance (Unbox a, Unbox b) => Unbox (Arg a b) + +instance (Unbox a, Unbox b) => M.MVector MVector (Arg a b) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_Arg v) = M.basicLength v + basicUnsafeSlice i n (MV_Arg v) = MV_Arg $ M.basicUnsafeSlice i n v + basicOverlaps (MV_Arg v1) (MV_Arg v2) = M.basicOverlaps v1 v2 + basicUnsafeNew n = MV_Arg `liftM` M.basicUnsafeNew n + basicInitialize (MV_Arg v) = M.basicInitialize v + basicUnsafeReplicate n (Arg x y) = MV_Arg `liftM` M.basicUnsafeReplicate n (x,y) + basicUnsafeRead (MV_Arg v) i = uncurry Arg `liftM` M.basicUnsafeRead v i + basicUnsafeWrite (MV_Arg v) i (Arg x y) = M.basicUnsafeWrite v i (x,y) + basicClear (MV_Arg v) = M.basicClear v + basicSet (MV_Arg v) (Arg x y) = M.basicSet v (x,y) + basicUnsafeCopy (MV_Arg v1) (MV_Arg v2) = M.basicUnsafeCopy v1 v2 + basicUnsafeMove (MV_Arg v1) (MV_Arg v2) = M.basicUnsafeMove v1 v2 + basicUnsafeGrow (MV_Arg v) n = MV_Arg `liftM` M.basicUnsafeGrow v n + +instance (Unbox a, Unbox b) => G.Vector Vector (Arg a b) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_Arg v) = V_Arg `liftM` G.basicUnsafeFreeze v + basicUnsafeThaw (V_Arg v) = MV_Arg `liftM` G.basicUnsafeThaw v + basicLength (V_Arg v) = G.basicLength v + basicUnsafeSlice i n (V_Arg v) = V_Arg $ G.basicUnsafeSlice i n v + basicUnsafeIndexM (V_Arg v) i = uncurry Arg `liftM` G.basicUnsafeIndexM v i + basicUnsafeCopy (MV_Arg mv) (V_Arg v) + = G.basicUnsafeCopy mv v + elemseq _ (Arg x y) z = G.elemseq (undefined :: Vector a) x + $ G.elemseq (undefined :: Vector b) y z +#endif + +deriveNewtypeInstances((), Any, Bool, Any, V_Any, MV_Any) +deriveNewtypeInstances((), All, Bool, All, V_All, MV_All) + +-- ------- +-- Const +-- ------- + +deriveNewtypeInstances(Unbox a, Const a b, a, Const, V_Const, MV_Const) + +-- --- +-- Alt +-- --- + +#if MIN_VERSION_base(4,8,0) +deriveNewtypeInstances(Unbox (f a), Alt f a, f a, Alt, V_Alt, MV_Alt) +#endif + +-- ------- +-- Compose +-- ------- + +#if MIN_VERSION_base(4,9,0) +deriveNewtypeInstances(Unbox (f (g a)), Compose f g a, f (g a), Compose, V_Compose, MV_Compose) +#endif -- ------ -- Tuples diff --git a/Data/Vector/Unboxed/Mutable.hs b/Data/Vector/Unboxed/Mutable.hs --- a/Data/Vector/Unboxed/Mutable.hs +++ b/Data/Vector/Unboxed/Mutable.hs @@ -83,8 +83,13 @@ -- Extracting subvectors -- --------------------- --- | Yield a part of the mutable vector without copying it. -slice :: Unbox a => Int -> Int -> MVector s a -> MVector s a +-- | Yield a part of the mutable vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Unbox a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> MVector s a + -> MVector s a {-# INLINE slice #-} slice = G.slice @@ -279,7 +284,9 @@ -- copied to a temporary vector and then the temporary vector was copied -- to the target vector. move :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () {-# INLINE move #-} move = G.move @@ -298,7 +305,7 @@ unsafeMove = G.unsafeMove -- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation +-- Returns False when input is the last permutation nextPermutation :: (PrimMonad m,Ord e,Unbox e) => MVector (PrimState m) e -> m Bool {-# INLINE nextPermutation #-} nextPermutation = G.nextPermutation diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -1,6 +1,8 @@ module Main where import Criterion.Main +import Criterion.Main.Options +import Options.Applicative import Algo.ListRank (listRank) import Algo.Rootfix (rootfix) @@ -17,30 +19,64 @@ import Data.Vector.Unboxed ( Vector ) -size :: Int -size = 100000 +import System.Environment +import Data.Word -main = lparens `seq` rparens `seq` - nodes `seq` edges1 `seq` edges2 `seq` - do - as <- randomVector size :: IO (Vector Double) - bs <- randomVector size :: IO (Vector Double) - cs <- randomVector size :: IO (Vector Double) - ds <- randomVector size :: IO (Vector Double) - sp <- randomVector (floor $ sqrt $ fromIntegral size) - :: IO (Vector Double) - as `seq` bs `seq` cs `seq` ds `seq` sp `seq` - defaultMain [ bench "listRank" $ whnf listRank size - , bench "rootfix" $ whnf rootfix (lparens, rparens) - , bench "leaffix" $ whnf leaffix (lparens, rparens) - , bench "awshcc" $ whnf awshcc (nodes, edges1, edges2) - , bench "hybcc" $ whnf hybcc (nodes, edges1, edges2) - , bench "quickhull" $ whnf quickhull (as,bs) - , bench "spectral" $ whnf spectral sp - , bench "tridiag" $ whnf tridiag (as,bs,cs,ds) - ] - where - (lparens, rparens) = parenTree size - (nodes, edges1, edges2) = randomGraph size - +import Data.Word +data BenchArgs = BenchArgs + { seed :: Word32 + , size :: Int + , otherArgs :: Mode + } + +defaultSize :: Int +defaultSize = 2000000 + +defaultSeed :: Word32 +defaultSeed = 42 + +parseBenchArgs :: Parser BenchArgs +parseBenchArgs = BenchArgs + <$> option auto + ( long "seed" + <> metavar "NUM" + <> value defaultSeed + <> help "A value with which to initialize the PRNG" ) + <*> option auto + ( long "size" + <> metavar "NUM" + <> value defaultSize + <> help "A value to use as the default entries in data structures. Benchmarks are broken for very small numbers." ) + <*> parseWith defaultConfig + +main :: IO () +main = do + args <- execParser $ describeWith parseBenchArgs + + let useSeed = seed args + let useSize = size args + + let (lparens, rparens) = parenTree useSize + let (nodes, edges1, edges2) = randomGraph useSeed useSize + lparens `seq` rparens `seq` + nodes `seq` edges1 `seq` edges2 `seq` return () + + as <- randomVector useSeed useSize :: IO (Vector Double) + bs <- randomVector useSeed useSize :: IO (Vector Double) + cs <- randomVector useSeed useSize :: IO (Vector Double) + ds <- randomVector useSeed useSize :: IO (Vector Double) + sp <- randomVector useSeed (floor $ sqrt $ fromIntegral useSize) + :: IO (Vector Double) + as `seq` bs `seq` cs `seq` ds `seq` sp `seq` return () + putStrLn "foo" + runMode (otherArgs args) + [ bench "listRank" $ whnf listRank useSize + , bench "rootfix" $ whnf rootfix (lparens, rparens) + , bench "leaffix" $ whnf leaffix (lparens, rparens) + , bench "awshcc" $ whnf awshcc (nodes, edges1, edges2) + , bench "hybcc" $ whnf hybcc (nodes, edges1, edges2) + , bench "quickhull" $ whnf quickhull (as,bs) + , bench "spectral" $ whnf spectral sp + , bench "tridiag" $ whnf tridiag (as,bs,cs,ds) + ] diff --git a/benchmarks/TestData/Graph.hs b/benchmarks/TestData/Graph.hs --- a/benchmarks/TestData/Graph.hs +++ b/benchmarks/TestData/Graph.hs @@ -7,11 +7,13 @@ import Control.Monad.ST ( ST, runST ) -randomGraph :: Int -> (Int, V.Vector Int, V.Vector Int) -randomGraph e +import Data.Word + +randomGraph :: Word32 -> Int -> (Int, V.Vector Int, V.Vector Int) +randomGraph seed e = runST ( do - g <- create + g <- initialize (V.singleton seed) arr <- STA.newArray (0,n-1) [] :: ST s (STA.STArray s Int [Int]) addRandomEdges n g arr e xs <- STA.getAssocs arr diff --git a/benchmarks/TestData/Random.hs b/benchmarks/TestData/Random.hs --- a/benchmarks/TestData/Random.hs +++ b/benchmarks/TestData/Random.hs @@ -4,10 +4,11 @@ import System.Random.MWC import Control.Monad.ST ( runST ) +import Data.Word -randomVector :: (Variate a, V.Unbox a) => Int -> IO (V.Vector a) -randomVector n = withSystemRandom $ \g -> - do +randomVector :: (Variate a, V.Unbox a) => Word32 -> Int -> IO (V.Vector a) +randomVector seed n = do + g <- initialize (V.singleton seed) xs <- sequence $ replicate n $ uniform g io (return $ V.fromListN n xs) where diff --git a/benchmarks/vector-benchmarks.cabal b/benchmarks/vector-benchmarks.cabal --- a/benchmarks/vector-benchmarks.cabal +++ b/benchmarks/vector-benchmarks.cabal @@ -1,5 +1,5 @@ Name: vector-benchmarks -Version: 0.10.9 +Version: 0.10.10 License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy @@ -12,13 +12,13 @@ Main-Is: Main.hs Build-Depends: base >= 2 && < 5, array, - criterion >= 0.5 && < 0.7, - mwc-random >= 0.5 && < 0.13, - vector == 0.10.9 + criterion >= 1.5.4.0 && < 1.6, + mwc-random >= 0.5 && < 0.15, + vector, optparse-applicative if impl(ghc<6.13) Ghc-Options: -finline-if-enough-args -fno-method-sharing - + Ghc-Options: -O2 Other-Modules: diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,84 +0,0 @@ -Changes in version 0.12.0.3 - * Add support for ghc >=8.8 monad fail -Changes in version 0.12.0.2 - * Fixes issue #220, compact heap operations crashing on boxed vectors constructed - using traverse. - * remove usage of Data.Primitive.Address and clarify the memset Prim Storable - smuggling trick in Vector.Storable.Mutable - * backport injective type family support - -Changes in version 0.12.0.1 - - * Make sure `length` can be inlined - * Include modules that test-suites depend on in other-modules - -Changes in version 0.12.0.0 - - * Documentation fixes/additions - * New functions: createT, iscanl/r, iterateNM, unfoldrM, uniq - * New instances for various vector types: Semigroup, MonadZip - * Made `Storable` vectors respect memory alignment - * Changed some macros to ConstraintKinds - - Dropped compatibility with old GHCs to support this - * Add `Eq1`, `Ord1`, `Show1`, and `Read1` `Vector` instances, and related - helper functions. - * Relax context for `Unbox (Complex a)`. - -Changes in version 0.11.0.0 - - * Define `Applicative` instances for `Data.Vector.Fusion.Util.{Box,Id}` - * Define non-bottom `fail` for `instance Monad Vector` - * New generalized stream fusion framework - * Various safety fixes - - Various overflows due to vector size have been eliminated - - Memory is initialized on creation of unboxed vectors - * Changes to SPEC usage to allow building under more conditions - -Changes in version 0.10.12.3 - - * Allow building with `primitive-0.6` - -Changes in version 0.10.12.2 - - * Add support for `deepseq-1.4.0.0` - -Changes in version 0.10.12.1 - - * Fixed compilation on non-head GHCs - -Changes in version 0.10.12.0 - - * Export MVector constructor from Data.Vector.Primitive to match Vector's - (which was already exported). - - * Fix building on GHC 7.9 by adding Applicative instances for Id and Box - -Changes in version 0.10.11.0 - - * Support OverloadedLists for boxed Vector in GHC >= 7.8 - -Changes in version 0.10.10.0 - - * Minor version bump to rectify PVP violation occured in 0.10.9.3 release - -Changes in version 0.10.9.3 (deprecated) - - * Add support for OverloadedLists in GHC >= 7.8 - -Changes in version 0.10.9.2 - - * Fix compilation with GHC 7.9 - -Changes in version 0.10.9.1 - - * Implement poly-kinded Typeable - -Changes in version 0.10.0.1 - - * Require `primitive` to include workaround for a GHC array copying bug - -Changes in version 0.10 - - * `NFData` instances - * More efficient block fills - * Safe Haskell support removed diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,107 @@ +# Changes in version 0.12.1.0 + * Fix integer overflows in specializations of Bundle/Stream enumFromTo on Integral types + * Fix possibility of OutOfMemory with `take` and very large arguments. + * Fix `slice` function causing segfault and not checking the bounds properly. + * updated specialization rule for EnumFromTo on Float and Double + to make sure it always matches the version in GHC Base (which changed as of 8.6) + Thanks to Aleksey Khudyakov @Shimuuar for this fix. + * fast rejection short circuiting in eqBy operations + * the O2 test suite now has reasonable memory usage on every GHC version, + special thanks to Alexey Kuleshevich (@lehins). + * The `Mutable` type family is now injective on GHC 8.0 or later. + * Using empty `Storable` vectors no longer results in division-by-zero + errors. + * The `Data` instances for `Vector` types now have well defined + implementations for `toConstr`, `gunfold`, and `dataTypeOf`. + * New function: `partitionWith`. + * Add `Unbox` instances for `Identity`, `Const`, `Down`, `Dual`, `Sum`, + `Product`, `Min`, `Max`, `First`, `Last`, `WrappedMonoid`, `Arg`, `Any`, + `All`, `Alt`, and `Compose`. + * Add `NFData1` instances for applicable `Vector` types. + +#Changes in version 0.12.0.3 + * Monad Fail support + +#Changes in version 0.12.0.2 + * Fixes issue #220, compact heap operations crashing on boxed vectors constructed + using traverse. + * backport injective type family support + * Cleanup the memset code internal to storable vector modules to be + compatible with future Primitive releases + + +#Changes in version 0.12.0.1 + + * Make sure `length` can be inlined + * Include modules that test-suites depend on in other-modules + +#Changes in version 0.12.0.0 + + * Documentation fixes/additions + * New functions: createT, iscanl/r, iterateNM, unfoldrM, uniq + * New instances for various vector types: Semigroup, MonadZip + * Made `Storable` vectors respect memory alignment + * Changed some macros to ConstraintKinds + - Dropped compatibility with old GHCs to support this + * Add `Eq1`, `Ord1`, `Show1`, and `Read1` `Vector` instances, and related + helper functions. + * Relax context for `Unbox (Complex a)`. + +#Changes in version 0.11.0.0 + + * Define `Applicative` instances for `Data.Vector.Fusion.Util.{Box,Id}` + * Define non-bottom `fail` for `instance Monad Vector` + * New generalized stream fusion framework + * Various safety fixes + - Various overflows due to vector size have been eliminated + - Memory is initialized on creation of unboxed vectors + * Changes to SPEC usage to allow building under more conditions + +#Changes in version 0.10.12.3 + + * Allow building with `primtive-0.6` + +#Changes in version 0.10.12.2 + + * Add support for `deepseq-1.4.0.0` + +#Changes in version 0.10.12.1 + + * Fixed compilation on non-head GHCs + +#Changes in version 0.10.12.0 + + * Export MVector constructor from Data.Vector.Primitive to match Vector's + (which was already exported). + + * Fix building on GHC 7.9 by adding Applicative instances for Id and Box + +#Changes in version 0.10.11.0 + + * Support OverloadedLists for boxed Vector in GHC >= 7.8 + +#Changes in version 0.10.10.0 + + * Minor version bump to rectify PVP violation occured in 0.10.9.3 release + +#Changes in version 0.10.9.3 (deprecated) + + * Add support for OverloadedLists in GHC >= 7.8 + +#Changes in version 0.10.9.2 + + * Fix compilation with GHC 7.9 + +#Changes in version 0.10.9.1 + + * Implement poly-kinded Typeable + +#Changes in version 0.10.0.1 + + * Require `primitive` to include workaround for a GHC array copying bug + +#Changes in version 0.10 + + * `NFData` instances + * More efficient block fills + * Safe Haskell support removed diff --git a/tests/Boilerplater.hs b/tests/Boilerplater.hs --- a/tests/Boilerplater.hs +++ b/tests/Boilerplater.hs @@ -1,6 +1,6 @@ module Boilerplater where -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty.QuickCheck import Language.Haskell.TH diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -5,10 +5,10 @@ import qualified Tests.Bundle import qualified Tests.Move -import Test.Framework (defaultMain) +import Test.Tasty (defaultMain,testGroup) main :: IO () -main = defaultMain $ Tests.Bundle.tests +main = defaultMain $ testGroup "toplevel" $ Tests.Bundle.tests ++ Tests.Vector.tests ++ Tests.Vector.UnitTests.tests ++ Tests.Move.tests diff --git a/tests/Tests/Bundle.hs b/tests/Tests/Bundle.hs --- a/tests/Tests/Bundle.hs +++ b/tests/Tests/Bundle.hs @@ -1,19 +1,21 @@ module Tests.Bundle ( tests ) where import Boilerplater -import Utilities +import Utilities hiding (limitUnfolds) import qualified Data.Vector.Fusion.Bundle as S import Test.QuickCheck -import Test.Framework -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty +import Test.Tasty.QuickCheck hiding (testProperties) import Text.Show.Functions () import Data.List (foldl', foldl1', unfoldr, find, findIndex) -import System.Random (Random) +-- migration from testframework to tasty +type Test = TestTree + #define COMMON_CONTEXT(a) \ VANILLA_CONTEXT(a) @@ -136,7 +138,7 @@ S.scanl1 `eq` scanl1 prop_scanl1' :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===> S.scanl1' `eq` scanl1 - + prop_concatMap = forAll arbitrary $ \xs -> forAll (sized (\n -> resize (n `div` S.length xs) arbitrary)) $ \f -> unP prop f xs where diff --git a/tests/Tests/Move.hs b/tests/Tests/Move.hs --- a/tests/Tests/Move.hs +++ b/tests/Tests/Move.hs @@ -1,7 +1,7 @@ module Tests.Move (tests) where import Test.QuickCheck -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty.QuickCheck import Test.QuickCheck.Property (Property(..)) import Utilities () diff --git a/tests/Tests/Vector.hs b/tests/Tests/Vector.hs --- a/tests/Tests/Vector.hs +++ b/tests/Tests/Vector.hs @@ -1,728 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} module Tests.Vector (tests) where -import Boilerplater -import Utilities as Util - -import Data.Functor.Identity -import qualified Data.Traversable as T (Traversable(..)) -import Data.Foldable (Foldable(foldMap)) -import Data.Orphans () - -import qualified Data.Vector.Generic as V -import qualified Data.Vector -import qualified Data.Vector.Primitive -import qualified Data.Vector.Storable -import qualified Data.Vector.Unboxed -import qualified Data.Vector.Fusion.Bundle as S - -import Test.QuickCheck - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Text.Show.Functions () -import Data.List -import Data.Monoid -import qualified Control.Applicative as Applicative -import System.Random (Random) - -import Data.Functor.Identity -import Control.Monad.Trans.Writer - -import Control.Monad.Zip - -import Data.Data - -type CommonContext a v = (VanillaContext a, VectorContext a v) -type VanillaContext a = ( Eq a , Show a, Arbitrary a, CoArbitrary a - , TestData a, Model a ~ a, EqTest a ~ Property) -type VectorContext a v = ( Eq (v a), Show (v a), Arbitrary (v a), CoArbitrary (v a) - , TestData (v a), Model (v a) ~ [a], EqTest (v a) ~ Property, V.Vector v a) - --- TODO: implement Vector equivalents of list functions for some of the commented out properties - --- TODO: test and implement some of these other Prelude functions: --- mapM * --- mapM_ * --- sequence --- sequence_ --- sum * --- product * --- scanl * --- scanl1 * --- scanr * --- scanr1 * --- lookup * --- lines --- words --- unlines --- unwords --- NB: this is an exhaustive list of all Prelude list functions that make sense for vectors. --- Ones with *s are the most plausible candidates. - --- TODO: add tests for the other extra functions --- IVector exports still needing tests: --- copy, --- slice, --- (//), update, bpermute, --- prescanl, prescanl', --- new, --- unsafeSlice, unsafeIndex, --- vlength, vnew - --- TODO: test non-IVector stuff? - -testSanity :: forall a v. (CommonContext a v) => v a -> [Test] -testSanity _ = [ - testProperty "fromList.toList == id" prop_fromList_toList, - testProperty "toList.fromList == id" prop_toList_fromList, - testProperty "unstream.stream == id" prop_unstream_stream, - testProperty "stream.unstream == id" prop_stream_unstream - ] - where - prop_fromList_toList (v :: v a) = (V.fromList . V.toList) v == v - prop_toList_fromList (l :: [a]) = ((V.toList :: v a -> [a]) . V.fromList) l == l - prop_unstream_stream (v :: v a) = (V.unstream . V.stream) v == v - prop_stream_unstream (s :: S.Bundle v a) = ((V.stream :: v a -> S.Bundle v a) . V.unstream) s == s - -testPolymorphicFunctions :: forall a v. (CommonContext a v, VectorContext Int v) => v a -> [Test] -testPolymorphicFunctions _ = $(testProperties [ - 'prop_eq, - - -- Length information - 'prop_length, 'prop_null, - - -- Indexing (FIXME) - 'prop_index, 'prop_safeIndex, 'prop_head, 'prop_last, - 'prop_unsafeIndex, 'prop_unsafeHead, 'prop_unsafeLast, - - -- Monadic indexing (FIXME) - {- 'prop_indexM, 'prop_headM, 'prop_lastM, - 'prop_unsafeIndexM, 'prop_unsafeHeadM, 'prop_unsafeLastM, -} - - -- Subvectors (FIXME) - 'prop_slice, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop, - 'prop_splitAt, - {- 'prop_unsafeSlice, 'prop_unsafeInit, 'prop_unsafeTail, - 'prop_unsafeTake, 'prop_unsafeDrop, -} - - -- Initialisation (FIXME) - 'prop_empty, 'prop_singleton, 'prop_replicate, - 'prop_generate, 'prop_iterateN, 'prop_iterateNM, - - -- Monadic initialisation (FIXME) - 'prop_createT, - {- 'prop_replicateM, 'prop_generateM, 'prop_create, -} - - -- Unfolding - 'prop_unfoldr, 'prop_unfoldrN, 'prop_unfoldrM, 'prop_unfoldrNM, - 'prop_constructN, 'prop_constructrN, - - -- Enumeration? (FIXME?) - - -- Concatenation (FIXME) - 'prop_cons, 'prop_snoc, 'prop_append, - 'prop_concat, - - -- Restricting memory usage - 'prop_force, - - - -- Bulk updates (FIXME) - 'prop_upd, - {- 'prop_update, 'prop_update_, - 'prop_unsafeUpd, 'prop_unsafeUpdate, 'prop_unsafeUpdate_, -} - - -- Accumulations (FIXME) - 'prop_accum, - {- 'prop_accumulate, 'prop_accumulate_, - 'prop_unsafeAccum, 'prop_unsafeAccumulate, 'prop_unsafeAccumulate_, -} - - -- Permutations - 'prop_reverse, 'prop_backpermute, - {- 'prop_unsafeBackpermute, -} - - -- Elementwise indexing - {- 'prop_indexed, -} - - -- Mapping - 'prop_map, 'prop_imap, 'prop_concatMap, - - -- Monadic mapping - {- 'prop_mapM, 'prop_mapM_, 'prop_forM, 'prop_forM_, -} - 'prop_imapM, 'prop_imapM_, - - -- Zipping - 'prop_zipWith, 'prop_zipWith3, {- ... -} - 'prop_izipWith, 'prop_izipWith3, {- ... -} - 'prop_izipWithM, 'prop_izipWithM_, - {- 'prop_zip, ... -} - - -- Monadic zipping - {- 'prop_zipWithM, 'prop_zipWithM_, -} - - -- Unzipping - {- 'prop_unzip, ... -} - - -- Filtering - 'prop_filter, 'prop_ifilter, {- prop_filterM, -} - 'prop_uniq, - 'prop_mapMaybe, 'prop_imapMaybe, - 'prop_takeWhile, 'prop_dropWhile, - - -- Paritioning - 'prop_partition, {- 'prop_unstablePartition, -} - 'prop_span, 'prop_break, - - -- Searching - 'prop_elem, 'prop_notElem, - 'prop_find, 'prop_findIndex, 'prop_findIndices, - 'prop_elemIndex, 'prop_elemIndices, - - -- Folding - 'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1', - 'prop_foldr, 'prop_foldr1, 'prop_foldr', 'prop_foldr1', - 'prop_ifoldl, 'prop_ifoldl', 'prop_ifoldr, 'prop_ifoldr', - 'prop_ifoldM, 'prop_ifoldM', 'prop_ifoldM_, 'prop_ifoldM'_, - - -- Specialised folds - 'prop_all, 'prop_any, - {- 'prop_maximumBy, 'prop_minimumBy, - 'prop_maxIndexBy, 'prop_minIndexBy, -} - - -- Monadic folds - {- ... -} - - -- Monadic sequencing - {- ... -} - - -- Scans - 'prop_prescanl, 'prop_prescanl', - 'prop_postscanl, 'prop_postscanl', - 'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1', - 'prop_iscanl, 'prop_iscanl', - - 'prop_prescanr, 'prop_prescanr', - 'prop_postscanr, 'prop_postscanr', - 'prop_scanr, 'prop_scanr', 'prop_scanr1, 'prop_scanr1', - 'prop_iscanr, 'prop_iscanr' - ]) - where - -- Prelude - prop_eq :: P (v a -> v a -> Bool) = (==) `eq` (==) - - prop_length :: P (v a -> Int) = V.length `eq` length - prop_null :: P (v a -> Bool) = V.null `eq` null - - prop_empty :: P (v a) = V.empty `eq` [] - prop_singleton :: P (a -> v a) = V.singleton `eq` singleton - prop_replicate :: P (Int -> a -> v a) - = (\n _ -> n < 1000) ===> V.replicate `eq` replicate - prop_cons :: P (a -> v a -> v a) = V.cons `eq` (:) - prop_snoc :: P (v a -> a -> v a) = V.snoc `eq` snoc - prop_append :: P (v a -> v a -> v a) = (V.++) `eq` (++) - prop_concat :: P ([v a] -> v a) = V.concat `eq` concat - prop_force :: P (v a -> v a) = V.force `eq` id - prop_generate :: P (Int -> (Int -> a) -> v a) - = (\n _ -> n < 1000) ===> V.generate `eq` Util.generate - prop_iterateN :: P (Int -> (a -> a) -> a -> v a) - = (\n _ _ -> n < 1000) ===> V.iterateN `eq` (\n f -> take n . iterate f) - prop_iterateNM :: P (Int -> (a -> Writer [Int] a) -> a -> Writer [Int] (v a)) - = (\n _ _ -> n < 1000) ===> V.iterateNM `eq` Util.iterateNM - prop_createT :: P ((a, v a) -> (a, v a)) - prop_createT = (\v -> V.createT (T.mapM V.thaw v)) `eq` id - - prop_head :: P (v a -> a) = not . V.null ===> V.head `eq` head - prop_last :: P (v a -> a) = not . V.null ===> V.last `eq` last - prop_index = \xs -> - not (V.null xs) ==> - forAll (choose (0, V.length xs-1)) $ \i -> - unP prop xs i - where - prop :: P (v a -> Int -> a) = (V.!) `eq` (!!) - prop_safeIndex :: P (v a -> Int -> Maybe a) = (V.!?) `eq` fn - where - fn xs i = case drop i xs of - x:_ | i >= 0 -> Just x - _ -> Nothing - prop_unsafeHead :: P (v a -> a) = not . V.null ===> V.unsafeHead `eq` head - prop_unsafeLast :: P (v a -> a) = not . V.null ===> V.unsafeLast `eq` last - prop_unsafeIndex = \xs -> - not (V.null xs) ==> - forAll (choose (0, V.length xs-1)) $ \i -> - unP prop xs i - where - prop :: P (v a -> Int -> a) = V.unsafeIndex `eq` (!!) - - prop_slice = \xs -> - forAll (choose (0, V.length xs)) $ \i -> - forAll (choose (0, V.length xs - i)) $ \n -> - unP prop i n xs - where - prop :: P (Int -> Int -> v a -> v a) = V.slice `eq` slice - - prop_tail :: P (v a -> v a) = not . V.null ===> V.tail `eq` tail - prop_init :: P (v a -> v a) = not . V.null ===> V.init `eq` init - prop_take :: P (Int -> v a -> v a) = V.take `eq` take - prop_drop :: P (Int -> v a -> v a) = V.drop `eq` drop - prop_splitAt :: P (Int -> v a -> (v a, v a)) = V.splitAt `eq` splitAt - - prop_accum = \f xs -> - forAll (index_value_pairs (V.length xs)) $ \ps -> - unP prop f xs ps - where - prop :: P ((a -> a -> a) -> v a -> [(Int,a)] -> v a) - = V.accum `eq` accum - - prop_upd = \xs -> - forAll (index_value_pairs (V.length xs)) $ \ps -> - unP prop xs ps - where - prop :: P (v a -> [(Int,a)] -> v a) = (V.//) `eq` (//) - - prop_backpermute = \xs -> - forAll (indices (V.length xs)) $ \is -> - unP prop xs (V.fromList is) - where - prop :: P (v a -> v Int -> v a) = V.backpermute `eq` backpermute - - prop_reverse :: P (v a -> v a) = V.reverse `eq` reverse - - prop_map :: P ((a -> a) -> v a -> v a) = V.map `eq` map - prop_zipWith :: P ((a -> a -> a) -> v a -> v a -> v a) = V.zipWith `eq` zipWith - prop_zipWith3 :: P ((a -> a -> a -> a) -> v a -> v a -> v a -> v a) - = V.zipWith3 `eq` zipWith3 - prop_imap :: P ((Int -> a -> a) -> v a -> v a) = V.imap `eq` imap - prop_imapM :: P ((Int -> a -> Identity a) -> v a -> Identity (v a)) - = V.imapM `eq` imapM - prop_imapM_ :: P ((Int -> a -> Writer [a] ()) -> v a -> Writer [a] ()) - = V.imapM_ `eq` imapM_ - prop_izipWith :: P ((Int -> a -> a -> a) -> v a -> v a -> v a) = V.izipWith `eq` izipWith - prop_izipWithM :: P ((Int -> a -> a -> Identity a) -> v a -> v a -> Identity (v a)) - = V.izipWithM `eq` izipWithM - prop_izipWithM_ :: P ((Int -> a -> a -> Writer [a] ()) -> v a -> v a -> Writer [a] ()) - = V.izipWithM_ `eq` izipWithM_ - prop_izipWith3 :: P ((Int -> a -> a -> a -> a) -> v a -> v a -> v a -> v a) - = V.izipWith3 `eq` izipWith3 - - prop_filter :: P ((a -> Bool) -> v a -> v a) = V.filter `eq` filter - prop_ifilter :: P ((Int -> a -> Bool) -> v a -> v a) = V.ifilter `eq` ifilter - prop_mapMaybe :: P ((a -> Maybe a) -> v a -> v a) = V.mapMaybe `eq` mapMaybe - prop_imapMaybe :: P ((Int -> a -> Maybe a) -> v a -> v a) = V.imapMaybe `eq` imapMaybe - prop_takeWhile :: P ((a -> Bool) -> v a -> v a) = V.takeWhile `eq` takeWhile - prop_dropWhile :: P ((a -> Bool) -> v a -> v a) = V.dropWhile `eq` dropWhile - prop_partition :: P ((a -> Bool) -> v a -> (v a, v a)) - = V.partition `eq` partition - prop_span :: P ((a -> Bool) -> v a -> (v a, v a)) = V.span `eq` span - prop_break :: P ((a -> Bool) -> v a -> (v a, v a)) = V.break `eq` break - - prop_elem :: P (a -> v a -> Bool) = V.elem `eq` elem - prop_notElem :: P (a -> v a -> Bool) = V.notElem `eq` notElem - prop_find :: P ((a -> Bool) -> v a -> Maybe a) = V.find `eq` find - prop_findIndex :: P ((a -> Bool) -> v a -> Maybe Int) - = V.findIndex `eq` findIndex - prop_findIndices :: P ((a -> Bool) -> v a -> v Int) - = V.findIndices `eq` findIndices - prop_elemIndex :: P (a -> v a -> Maybe Int) = V.elemIndex `eq` elemIndex - prop_elemIndices :: P (a -> v a -> v Int) = V.elemIndices `eq` elemIndices - - prop_foldl :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl `eq` foldl - prop_foldl1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldl1 `eq` foldl1 - prop_foldl' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl' `eq` foldl' - prop_foldl1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldl1' `eq` foldl1' - prop_foldr :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr `eq` foldr - prop_foldr1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldr1 `eq` foldr1 - prop_foldr' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr' `eq` foldr - prop_foldr1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldr1' `eq` foldr1 - prop_ifoldl :: P ((a -> Int -> a -> a) -> a -> v a -> a) - = V.ifoldl `eq` ifoldl - prop_ifoldl' :: P ((a -> Int -> a -> a) -> a -> v a -> a) - = V.ifoldl' `eq` ifoldl - prop_ifoldr :: P ((Int -> a -> a -> a) -> a -> v a -> a) - = V.ifoldr `eq` ifoldr - prop_ifoldr' :: P ((Int -> a -> a -> a) -> a -> v a -> a) - = V.ifoldr' `eq` ifoldr - prop_ifoldM :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) - = V.ifoldM `eq` ifoldM - prop_ifoldM' :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) - = V.ifoldM' `eq` ifoldM - prop_ifoldM_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) - = V.ifoldM_ `eq` ifoldM_ - prop_ifoldM'_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) - = V.ifoldM'_ `eq` ifoldM_ - - prop_all :: P ((a -> Bool) -> v a -> Bool) = V.all `eq` all - prop_any :: P ((a -> Bool) -> v a -> Bool) = V.any `eq` any - - prop_prescanl :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanl `eq` prescanl - prop_prescanl' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanl' `eq` prescanl - prop_postscanl :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanl `eq` postscanl - prop_postscanl' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanl' `eq` postscanl - prop_scanl :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanl `eq` scanl - prop_scanl' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanl' `eq` scanl - prop_scanl1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanl1 `eq` scanl1 - prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanl1' `eq` scanl1 - prop_iscanl :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanl `eq` iscanl - prop_iscanl' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanl' `eq` iscanl - - prop_prescanr :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanr `eq` prescanr - prop_prescanr' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanr' `eq` prescanr - prop_postscanr :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanr `eq` postscanr - prop_postscanr' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanr' `eq` postscanr - prop_scanr :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanr `eq` scanr - prop_scanr' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanr' `eq` scanr - prop_iscanr :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanr `eq` iscanr - prop_iscanr' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanr' `eq` iscanr - prop_scanr1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanr1 `eq` scanr1 - prop_scanr1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanr1' `eq` scanr1 - - prop_concatMap = forAll arbitrary $ \xs -> - forAll (sized (\n -> resize (n `div` V.length xs) arbitrary)) $ \f -> unP prop f xs - where - prop :: P ((a -> v a) -> v a -> v a) = V.concatMap `eq` concatMap - - prop_uniq :: P (v a -> v a) - = V.uniq `eq` (map head . group) - --prop_span = (V.span :: (a -> Bool) -> v a -> (v a, v a)) `eq2` span - --prop_break = (V.break :: (a -> Bool) -> v a -> (v a, v a)) `eq2` break - --prop_splitAt = (V.splitAt :: Int -> v a -> (v a, v a)) `eq2` splitAt - --prop_all = (V.all :: (a -> Bool) -> v a -> Bool) `eq2` all - --prop_any = (V.any :: (a -> Bool) -> v a -> Bool) `eq2` any - - -- Data.List - --prop_findIndices = V.findIndices `eq2` (findIndices :: (a -> Bool) -> v a -> v Int) - --prop_isPrefixOf = V.isPrefixOf `eq2` (isPrefixOf :: v a -> v a -> Bool) - --prop_elemIndex = V.elemIndex `eq2` (elemIndex :: a -> v a -> Maybe Int) - --prop_elemIndices = V.elemIndices `eq2` (elemIndices :: a -> v a -> v Int) - -- - --prop_mapAccumL = eq3 - -- (V.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - -- ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - -- - --prop_mapAccumR = eq3 - -- (V.mapAccumR :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - -- ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - - -- Because the vectors are strict, we need to be totally sure that the unfold eventually terminates. This - -- is achieved by injecting our own bit of state into the unfold - the maximum number of unfolds allowed. - limitUnfolds f (theirs, ours) - | ours > 0 - , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) - | otherwise = Nothing - limitUnfoldsM f (theirs, ours) - | ours > 0 = do r <- f theirs - return $ (\(a,b) -> (a,(b,ours - 1))) `fmap` r - | otherwise = return Nothing - - - prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) - = (\n f a -> V.unfoldr (limitUnfolds f) (a, n)) - `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) - prop_unfoldrN :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) - = V.unfoldrN `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) - prop_unfoldrM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) - = (\n f a -> V.unfoldrM (limitUnfoldsM f) (a,n)) - `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) - prop_unfoldrNM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) - = V.unfoldrNM `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) - - prop_constructN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f - where - prop :: P (Int -> (v a -> a) -> v a) = V.constructN `eq` constructN [] - - constructN xs 0 _ = xs - constructN xs n f = constructN (xs ++ [f xs]) (n-1) f - - prop_constructrN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f - where - prop :: P (Int -> (v a -> a) -> v a) = V.constructrN `eq` constructrN [] - - constructrN xs 0 _ = xs - constructrN xs n f = constructrN (f xs : xs) (n-1) f - - - -testTuplyFunctions:: forall a v. (CommonContext a v, VectorContext (a, a) v, VectorContext (a, a, a) v) => v a -> [Test] -testTuplyFunctions _ = $(testProperties [ 'prop_zip, 'prop_zip3 - , 'prop_unzip, 'prop_unzip3 - , 'prop_mzip, 'prop_munzip - ]) - where - prop_zip :: P (v a -> v a -> v (a, a)) = V.zip `eq` zip - prop_zip3 :: P (v a -> v a -> v a -> v (a, a, a)) = V.zip3 `eq` zip3 - prop_unzip :: P (v (a, a) -> (v a, v a)) = V.unzip `eq` unzip - prop_unzip3 :: P (v (a, a, a) -> (v a, v a, v a)) = V.unzip3 `eq` unzip3 - prop_mzip :: P (Data.Vector.Vector a -> Data.Vector.Vector a -> Data.Vector.Vector (a, a)) - = mzip `eq` zip - prop_munzip :: P (Data.Vector.Vector (a, a) -> (Data.Vector.Vector a, Data.Vector.Vector a)) - = munzip `eq` unzip - -testOrdFunctions :: forall a v. (CommonContext a v, Ord a, Ord (v a)) => v a -> [Test] -testOrdFunctions _ = $(testProperties - ['prop_compare, - 'prop_maximum, 'prop_minimum, - 'prop_minIndex, 'prop_maxIndex, - 'prop_maximumBy, 'prop_minimumBy, - 'prop_maxIndexBy, 'prop_minIndexBy]) - where - prop_compare :: P (v a -> v a -> Ordering) = compare `eq` compare - prop_maximum :: P (v a -> a) = not . V.null ===> V.maximum `eq` maximum - prop_minimum :: P (v a -> a) = not . V.null ===> V.minimum `eq` minimum - prop_minIndex :: P (v a -> Int) = not . V.null ===> V.minIndex `eq` minIndex - prop_maxIndex :: P (v a -> Int) = not . V.null ===> V.maxIndex `eq` maxIndex - prop_maximumBy :: P (v a -> a) = - not . V.null ===> V.maximumBy compare `eq` maximum - prop_minimumBy :: P (v a -> a) = - not . V.null ===> V.minimumBy compare `eq` minimum - prop_maxIndexBy :: P (v a -> Int) = - not . V.null ===> V.maxIndexBy compare `eq` maxIndex - prop_minIndexBy :: P (v a -> Int) = - not . V.null ===> V.minIndexBy compare `eq` minIndex - -testEnumFunctions :: forall a v. (CommonContext a v, Enum a, Ord a, Num a, Random a) => v a -> [Test] -testEnumFunctions _ = $(testProperties - [ 'prop_enumFromN, 'prop_enumFromThenN, - 'prop_enumFromTo, 'prop_enumFromThenTo]) - where - prop_enumFromN :: P (a -> Int -> v a) - = (\_ n -> n < 1000) - ===> V.enumFromN `eq` (\x n -> take n $ scanl (+) x $ repeat 1) - - prop_enumFromThenN :: P (a -> a -> Int -> v a) - = (\_ _ n -> n < 1000) - ===> V.enumFromStepN `eq` (\x y n -> take n $ scanl (+) x $ repeat y) - - prop_enumFromTo = \m -> - forAll (choose (-2,100)) $ \n -> - unP prop m (m+n) - where - prop :: P (a -> a -> v a) = V.enumFromTo `eq` enumFromTo - - prop_enumFromThenTo = \i j -> - j /= i ==> - forAll (choose (ks i j)) $ \k -> - unP prop i j k - where - prop :: P (a -> a -> a -> v a) = V.enumFromThenTo `eq` enumFromThenTo - - ks i j | j < i = (i-d*100, i+d*2) - | otherwise = (i-d*2, i+d*100) - where - d = abs (j-i) - -testMonoidFunctions :: forall a v. (CommonContext a v, Monoid (v a)) => v a -> [Test] -testMonoidFunctions _ = $(testProperties - [ 'prop_mempty, 'prop_mappend, 'prop_mconcat ]) - where - prop_mempty :: P (v a) = mempty `eq` mempty - prop_mappend :: P (v a -> v a -> v a) = mappend `eq` mappend - prop_mconcat :: P ([v a] -> v a) = mconcat `eq` mconcat - -testFunctorFunctions :: forall a v. (CommonContext a v, Functor v) => v a -> [Test] -testFunctorFunctions _ = $(testProperties - [ 'prop_fmap ]) - where - prop_fmap :: P ((a -> a) -> v a -> v a) = fmap `eq` fmap - -testMonadFunctions :: forall a v. (CommonContext a v, Monad v) => v a -> [Test] -testMonadFunctions _ = $(testProperties - [ 'prop_return, 'prop_bind ]) - where - prop_return :: P (a -> v a) = return `eq` return - prop_bind :: P (v a -> (a -> v a) -> v a) = (>>=) `eq` (>>=) - -testApplicativeFunctions :: forall a v. (CommonContext a v, V.Vector v (a -> a), Applicative.Applicative v) => v a -> [Test] -testApplicativeFunctions _ = $(testProperties - [ 'prop_applicative_pure, 'prop_applicative_appl ]) - where - prop_applicative_pure :: P (a -> v a) - = Applicative.pure `eq` Applicative.pure - prop_applicative_appl :: [a -> a] -> P (v a -> v a) - = \fs -> (Applicative.<*>) (V.fromList fs) `eq` (Applicative.<*>) fs - -testAlternativeFunctions :: forall a v. (CommonContext a v, Applicative.Alternative v) => v a -> [Test] -testAlternativeFunctions _ = $(testProperties - [ 'prop_alternative_empty, 'prop_alternative_or ]) - where - prop_alternative_empty :: P (v a) = Applicative.empty `eq` Applicative.empty - prop_alternative_or :: P (v a -> v a -> v a) - = (Applicative.<|>) `eq` (Applicative.<|>) - -testBoolFunctions :: forall v. (CommonContext Bool v) => v Bool -> [Test] -testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or]) - where - prop_and :: P (v Bool -> Bool) = V.and `eq` and - prop_or :: P (v Bool -> Bool) = V.or `eq` or - -testNumFunctions :: forall a v. (CommonContext a v, Num a) => v a -> [Test] -testNumFunctions _ = $(testProperties ['prop_sum, 'prop_product]) - where - prop_sum :: P (v a -> a) = V.sum `eq` sum - prop_product :: P (v a -> a) = V.product `eq` product - -testNestedVectorFunctions :: forall a v. (CommonContext a v) => v a -> [Test] -testNestedVectorFunctions _ = $(testProperties []) - where - -- Prelude - --prop_concat = (V.concat :: [v a] -> v a) `eq1` concat - - -- Data.List - --prop_transpose = V.transpose `eq1` (transpose :: [v a] -> [v a]) - --prop_group = V.group `eq1` (group :: v a -> [v a]) - --prop_inits = V.inits `eq1` (inits :: v a -> [v a]) - --prop_tails = V.tails `eq1` (tails :: v a -> [v a]) - -testDataFunctions :: forall a v. (CommonContext a v, Data a, Data (v a)) => v a -> [Test] -testDataFunctions _ = $(testProperties ['prop_glength]) - where - prop_glength :: P (v a -> Int) = glength `eq` glength - where - glength :: Data b => b -> Int - glength xs = gmapQl (+) 0 toA xs - - toA :: Data b => b -> Int - toA x = maybe (glength x) (const 1) (cast x :: Maybe a) - -testGeneralBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a, Data a) => Data.Vector.Vector a -> [Test] -testGeneralBoxedVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testTuplyFunctions, - testNestedVectorFunctions, - testMonoidFunctions, - testFunctorFunctions, - testMonadFunctions, - testApplicativeFunctions, - testAlternativeFunctions, - testDataFunctions - ] - -testBoolBoxedVector dummy = concatMap ($ dummy) - [ - testGeneralBoxedVector - , testBoolFunctions - ] - -testNumericBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Vector a -> [Test] -testNumericBoxedVector dummy = concatMap ($ dummy) - [ - testGeneralBoxedVector - , testNumFunctions - , testEnumFunctions - ] - - -testGeneralPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a, Data a) => Data.Vector.Primitive.Vector a -> [Test] -testGeneralPrimitiveVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testMonoidFunctions, - testDataFunctions - ] - -testNumericPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Primitive.Vector a -> [Test] -testNumericPrimitiveVector dummy = concatMap ($ dummy) - [ - testGeneralPrimitiveVector - , testNumFunctions - , testEnumFunctions - ] - - -testGeneralStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a, Data a) => Data.Vector.Storable.Vector a -> [Test] -testGeneralStorableVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testMonoidFunctions, - testDataFunctions - ] - -testNumericStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Storable.Vector a -> [Test] -testNumericStorableVector dummy = concatMap ($ dummy) - [ - testGeneralStorableVector - , testNumFunctions - , testEnumFunctions - ] - - -testGeneralUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Data a) => Data.Vector.Unboxed.Vector a -> [Test] -testGeneralUnboxedVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testMonoidFunctions, - testDataFunctions - ] - -testUnitUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector - ] - -testBoolUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector - , testBoolFunctions - ] - -testNumericUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Unboxed.Vector a -> [Test] -testNumericUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector - , testNumFunctions - , testEnumFunctions - ] +import Test.Tasty (testGroup) +import qualified Tests.Vector.Boxed +import qualified Tests.Vector.Primitive +import qualified Tests.Vector.Storable +import qualified Tests.Vector.Unboxed -testTupleUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Data a) => Data.Vector.Unboxed.Vector a -> [Test] -testTupleUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector +tests = + [ testGroup "Tests.Vector.Boxed" Tests.Vector.Boxed.tests + , testGroup "Tests.Vector.Primitive" Tests.Vector.Primitive.tests + , testGroup "Tests.Vector.Storable" Tests.Vector.Storable.tests + , testGroup "Tests.Vector.Unboxed" Tests.Vector.Unboxed.tests ] - -tests = [ - testGroup "Data.Vector.Vector (Bool)" (testBoolBoxedVector (undefined :: Data.Vector.Vector Bool)), - testGroup "Data.Vector.Vector (Int)" (testNumericBoxedVector (undefined :: Data.Vector.Vector Int)), - - testGroup "Data.Vector.Primitive.Vector (Int)" (testNumericPrimitiveVector (undefined :: Data.Vector.Primitive.Vector Int)), - testGroup "Data.Vector.Primitive.Vector (Double)" (testNumericPrimitiveVector (undefined :: Data.Vector.Primitive.Vector Double)), - - testGroup "Data.Vector.Storable.Vector (Int)" (testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Int)), - testGroup "Data.Vector.Storable.Vector (Double)" (testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Double)), - - testGroup "Data.Vector.Unboxed.Vector ()" (testUnitUnboxedVector (undefined :: Data.Vector.Unboxed.Vector ())), - testGroup "Data.Vector.Unboxed.Vector (Bool)" (testBoolUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Bool)), - testGroup "Data.Vector.Unboxed.Vector (Int)" (testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Int)), - testGroup "Data.Vector.Unboxed.Vector (Double)" (testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Double)), - testGroup "Data.Vector.Unboxed.Vector (Int,Bool)" (testTupleUnboxedVector (undefined :: Data.Vector.Unboxed.Vector (Int,Bool))), - testGroup "Data.Vector.Unboxed.Vector (Int,Bool,Int)" (testTupleUnboxedVector (undefined :: Data.Vector.Unboxed.Vector (Int,Bool,Int))) - - ] diff --git a/tests/Tests/Vector/Boxed.hs b/tests/Tests/Vector/Boxed.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Vector/Boxed.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ConstraintKinds #-} +module Tests.Vector.Boxed (tests) where + +import Test.Tasty +import qualified Data.Vector +import Tests.Vector.Property + +import GHC.Exts (inline) + + +testGeneralBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a, Data a) => Data.Vector.Vector a -> [Test] +testGeneralBoxedVector dummy = concatMap ($ dummy) + [ + testSanity + , inline testPolymorphicFunctions + , testOrdFunctions + , testTuplyFunctions + , testNestedVectorFunctions + , testMonoidFunctions + , testFunctorFunctions + , testMonadFunctions + , testApplicativeFunctions + , testAlternativeFunctions + , testDataFunctions + ] + +testBoolBoxedVector dummy = concatMap ($ dummy) + [ + testGeneralBoxedVector + , testBoolFunctions + ] + +testNumericBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Vector a -> [Test] +testNumericBoxedVector dummy = concatMap ($ dummy) + [ + testGeneralBoxedVector + , testNumFunctions + , testEnumFunctions + ] + +tests = + [ testGroup "Bool" $ + testBoolBoxedVector (undefined :: Data.Vector.Vector Bool) + , testGroup "Int" $ + testNumericBoxedVector (undefined :: Data.Vector.Vector Int) + ] diff --git a/tests/Tests/Vector/Primitive.hs b/tests/Tests/Vector/Primitive.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Vector/Primitive.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ConstraintKinds #-} +module Tests.Vector.Primitive (tests) where + +import Test.Tasty +import qualified Data.Vector.Primitive +import Tests.Vector.Property + +import GHC.Exts (inline) + +testGeneralPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a, Data a) => Data.Vector.Primitive.Vector a -> [Test] +testGeneralPrimitiveVector dummy = concatMap ($ dummy) + [ + testSanity + , inline testPolymorphicFunctions + , testOrdFunctions + , testMonoidFunctions + , testDataFunctions + ] + +testNumericPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Primitive.Vector a -> [Test] +testNumericPrimitiveVector dummy = concatMap ($ dummy) + [ + testGeneralPrimitiveVector + , testNumFunctions + , testEnumFunctions + ] + +tests = + [ testGroup "Int" $ + testNumericPrimitiveVector (undefined :: Data.Vector.Primitive.Vector Int) + , testGroup "Double" $ + testNumericPrimitiveVector + (undefined :: Data.Vector.Primitive.Vector Double) + ] diff --git a/tests/Tests/Vector/Property.hs b/tests/Tests/Vector/Property.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Vector/Property.hs @@ -0,0 +1,682 @@ +{-# LANGUAGE ConstraintKinds #-} +module Tests.Vector.Property + ( CommonContext + , VanillaContext + , VectorContext + , testSanity + , testPolymorphicFunctions + , testTuplyFunctions + , testOrdFunctions + , testEnumFunctions + , testMonoidFunctions + , testFunctorFunctions + , testMonadFunctions + , testApplicativeFunctions + , testAlternativeFunctions + , testBoolFunctions + , testNumFunctions + , testNestedVectorFunctions + , testDataFunctions + -- re-exports + , Data + , Random + ,Test + ) where + +import Boilerplater +import Utilities as Util hiding (limitUnfolds) + +import Data.Functor.Identity +import qualified Data.Traversable as T (Traversable(..)) +import Data.Foldable (Foldable(foldMap)) +import Data.Orphans () + +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Fusion.Bundle as S + +import Test.QuickCheck + +import Test.Tasty +import Test.Tasty.QuickCheck hiding (testProperties) + +import Text.Show.Functions () +import Data.List + + +import qualified Control.Applicative as Applicative +import System.Random (Random) + +import Data.Functor.Identity +import Control.Monad.Trans.Writer + +import Control.Monad.Zip + +import Data.Data + +import qualified Data.List.NonEmpty as DLE +import Data.Semigroup (Semigroup(..)) + +type CommonContext a v = (VanillaContext a, VectorContext a v) +type VanillaContext a = ( Eq a , Show a, Arbitrary a, CoArbitrary a + , TestData a, Model a ~ a, EqTest a ~ Property) +type VectorContext a v = ( Eq (v a), Show (v a), Arbitrary (v a), CoArbitrary (v a) + , TestData (v a), Model (v a) ~ [a], EqTest (v a) ~ Property, V.Vector v a) + +-- | migration hack for moving from TestFramework to Tasty +type Test = TestTree +-- TODO: implement Vector equivalents of list functions for some of the commented out properties + +-- TODO: test and implement some of these other Prelude functions: +-- mapM * +-- mapM_ * +-- sequence +-- sequence_ +-- sum * +-- product * +-- scanl * +-- scanl1 * +-- scanr * +-- scanr1 * +-- lookup * +-- lines +-- words +-- unlines +-- unwords +-- NB: this is an exhaustive list of all Prelude list functions that make sense for vectors. +-- Ones with *s are the most plausible candidates. + +-- TODO: add tests for the other extra functions +-- IVector exports still needing tests: +-- copy, +-- slice, +-- (//), update, bpermute, +-- prescanl, prescanl', +-- new, +-- unsafeSlice, unsafeIndex, +-- vlength, vnew + +-- TODO: test non-IVector stuff? + +testSanity :: forall a v. (CommonContext a v) => v a -> [Test] +{-# INLINE testSanity #-} +testSanity _ = [ + testProperty "fromList.toList == id" prop_fromList_toList, + testProperty "toList.fromList == id" prop_toList_fromList, + testProperty "unstream.stream == id" prop_unstream_stream, + testProperty "stream.unstream == id" prop_stream_unstream + ] + where + prop_fromList_toList (v :: v a) = (V.fromList . V.toList) v == v + prop_toList_fromList (l :: [a]) = ((V.toList :: v a -> [a]) . V.fromList) l == l + prop_unstream_stream (v :: v a) = (V.unstream . V.stream) v == v + prop_stream_unstream (s :: S.Bundle v a) = ((V.stream :: v a -> S.Bundle v a) . V.unstream) s == s + +testPolymorphicFunctions :: forall a v. (CommonContext a v, VectorContext Int v) => v a -> [Test] +-- FIXME: inlining of unboxed properties blows up the memory during compilation. See #272 +--{-# INLINE testPolymorphicFunctions #-} +testPolymorphicFunctions _ = $(testProperties [ + 'prop_eq, + + -- Length information + 'prop_length, 'prop_null, + + -- Indexing (FIXME) + 'prop_index, 'prop_safeIndex, 'prop_head, 'prop_last, + 'prop_unsafeIndex, 'prop_unsafeHead, 'prop_unsafeLast, + + -- Monadic indexing (FIXME) + {- 'prop_indexM, 'prop_headM, 'prop_lastM, + 'prop_unsafeIndexM, 'prop_unsafeHeadM, 'prop_unsafeLastM, -} + + -- Subvectors (FIXME) + 'prop_slice, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop, + 'prop_splitAt, + {- 'prop_unsafeSlice, 'prop_unsafeInit, 'prop_unsafeTail, + 'prop_unsafeTake, 'prop_unsafeDrop, -} + + -- Initialisation (FIXME) + 'prop_empty, 'prop_singleton, 'prop_replicate, + 'prop_generate, 'prop_iterateN, 'prop_iterateNM, + + -- Monadic initialisation (FIXME) + 'prop_createT, + {- 'prop_replicateM, 'prop_generateM, 'prop_create, -} + + -- Unfolding + 'prop_unfoldr, 'prop_unfoldrN, 'prop_unfoldrM, 'prop_unfoldrNM, + 'prop_constructN, 'prop_constructrN, + + -- Enumeration? (FIXME?) + + -- Concatenation (FIXME) + 'prop_cons, 'prop_snoc, 'prop_append, + 'prop_concat, + + -- Restricting memory usage + 'prop_force, + + + -- Bulk updates (FIXME) + 'prop_upd, + {- 'prop_update, 'prop_update_, + 'prop_unsafeUpd, 'prop_unsafeUpdate, 'prop_unsafeUpdate_, -} + + -- Accumulations (FIXME) + 'prop_accum, + {- 'prop_accumulate, 'prop_accumulate_, + 'prop_unsafeAccum, 'prop_unsafeAccumulate, 'prop_unsafeAccumulate_, -} + + -- Permutations + 'prop_reverse, 'prop_backpermute, + {- 'prop_unsafeBackpermute, -} + + -- Elementwise indexing + {- 'prop_indexed, -} + + -- Mapping + 'prop_map, 'prop_imap, 'prop_concatMap, + + -- Monadic mapping + {- 'prop_mapM, 'prop_mapM_, 'prop_forM, 'prop_forM_, -} + 'prop_imapM, 'prop_imapM_, + + -- Zipping + 'prop_zipWith, 'prop_zipWith3, {- ... -} + 'prop_izipWith, 'prop_izipWith3, {- ... -} + 'prop_izipWithM, 'prop_izipWithM_, + {- 'prop_zip, ... -} + + -- Monadic zipping + {- 'prop_zipWithM, 'prop_zipWithM_, -} + + -- Unzipping + {- 'prop_unzip, ... -} + + -- Filtering + 'prop_filter, 'prop_ifilter, {- prop_filterM, -} + 'prop_uniq, + 'prop_mapMaybe, 'prop_imapMaybe, + 'prop_takeWhile, 'prop_dropWhile, + + -- Paritioning + 'prop_partition, {- 'prop_unstablePartition, -} + 'prop_partitionWith, + 'prop_span, 'prop_break, + + -- Searching + 'prop_elem, 'prop_notElem, + 'prop_find, 'prop_findIndex, 'prop_findIndices, + 'prop_elemIndex, 'prop_elemIndices, + + -- Folding + 'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1', + 'prop_foldr, 'prop_foldr1, 'prop_foldr', 'prop_foldr1', + 'prop_ifoldl, 'prop_ifoldl', 'prop_ifoldr, 'prop_ifoldr', + 'prop_ifoldM, 'prop_ifoldM', 'prop_ifoldM_, 'prop_ifoldM'_, + + -- Specialised folds + 'prop_all, 'prop_any, + {- 'prop_maximumBy, 'prop_minimumBy, + 'prop_maxIndexBy, 'prop_minIndexBy, -} + + -- Monadic folds + {- ... -} + + -- Monadic sequencing + {- ... -} + + -- Scans + 'prop_prescanl, 'prop_prescanl', + 'prop_postscanl, 'prop_postscanl', + 'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1', + 'prop_iscanl, 'prop_iscanl', + + 'prop_prescanr, 'prop_prescanr', + 'prop_postscanr, 'prop_postscanr', + 'prop_scanr, 'prop_scanr', 'prop_scanr1, 'prop_scanr1', + 'prop_iscanr, 'prop_iscanr' + ]) + where + -- Prelude + prop_eq :: P (v a -> v a -> Bool) = (==) `eq` (==) + + prop_length :: P (v a -> Int) = V.length `eq` length + prop_null :: P (v a -> Bool) = V.null `eq` null + + prop_empty :: P (v a) = V.empty `eq` [] + prop_singleton :: P (a -> v a) = V.singleton `eq` singleton + prop_replicate :: P (Int -> a -> v a) + = (\n _ -> n < 1000) ===> V.replicate `eq` replicate + prop_cons :: P (a -> v a -> v a) = V.cons `eq` (:) + prop_snoc :: P (v a -> a -> v a) = V.snoc `eq` snoc + prop_append :: P (v a -> v a -> v a) = (V.++) `eq` (++) + prop_concat :: P ([v a] -> v a) = V.concat `eq` concat + prop_force :: P (v a -> v a) = V.force `eq` id + prop_generate :: P (Int -> (Int -> a) -> v a) + = (\n _ -> n < 1000) ===> V.generate `eq` Util.generate + prop_iterateN :: P (Int -> (a -> a) -> a -> v a) + = (\n _ _ -> n < 1000) ===> V.iterateN `eq` (\n f -> take n . iterate f) + prop_iterateNM :: P (Int -> (a -> Writer [Int] a) -> a -> Writer [Int] (v a)) + = (\n _ _ -> n < 1000) ===> V.iterateNM `eq` Util.iterateNM + prop_createT :: P ((a, v a) -> (a, v a)) + prop_createT = (\v -> V.createT (T.mapM V.thaw v)) `eq` id + + prop_head :: P (v a -> a) = not . V.null ===> V.head `eq` head + prop_last :: P (v a -> a) = not . V.null ===> V.last `eq` last + prop_index = \xs -> + not (V.null xs) ==> + forAll (choose (0, V.length xs-1)) $ \i -> + unP prop xs i + where + prop :: P (v a -> Int -> a) = (V.!) `eq` (!!) + prop_safeIndex :: P (v a -> Int -> Maybe a) = (V.!?) `eq` fn + where + fn xs i = case drop i xs of + x:_ | i >= 0 -> Just x + _ -> Nothing + prop_unsafeHead :: P (v a -> a) = not . V.null ===> V.unsafeHead `eq` head + prop_unsafeLast :: P (v a -> a) = not . V.null ===> V.unsafeLast `eq` last + prop_unsafeIndex = \xs -> + not (V.null xs) ==> + forAll (choose (0, V.length xs-1)) $ \i -> + unP prop xs i + where + prop :: P (v a -> Int -> a) = V.unsafeIndex `eq` (!!) + + prop_slice = \xs -> + forAll (choose (0, V.length xs)) $ \i -> + forAll (choose (0, V.length xs - i)) $ \n -> + unP prop i n xs + where + prop :: P (Int -> Int -> v a -> v a) = V.slice `eq` slice + + prop_tail :: P (v a -> v a) = not . V.null ===> V.tail `eq` tail + prop_init :: P (v a -> v a) = not . V.null ===> V.init `eq` init + prop_take :: P (Int -> v a -> v a) = V.take `eq` take + prop_drop :: P (Int -> v a -> v a) = V.drop `eq` drop + prop_splitAt :: P (Int -> v a -> (v a, v a)) = V.splitAt `eq` splitAt + + prop_accum = \f xs -> + forAll (index_value_pairs (V.length xs)) $ \ps -> + unP prop f xs ps + where + prop :: P ((a -> a -> a) -> v a -> [(Int,a)] -> v a) + = V.accum `eq` accum + + prop_upd = \xs -> + forAll (index_value_pairs (V.length xs)) $ \ps -> + unP prop xs ps + where + prop :: P (v a -> [(Int,a)] -> v a) = (V.//) `eq` (//) + + prop_backpermute = \xs -> + forAll (indices (V.length xs)) $ \is -> + unP prop xs (V.fromList is) + where + prop :: P (v a -> v Int -> v a) = V.backpermute `eq` backpermute + + prop_reverse :: P (v a -> v a) = V.reverse `eq` reverse + + prop_map :: P ((a -> a) -> v a -> v a) = V.map `eq` map + prop_zipWith :: P ((a -> a -> a) -> v a -> v a -> v a) = V.zipWith `eq` zipWith + prop_zipWith3 :: P ((a -> a -> a -> a) -> v a -> v a -> v a -> v a) + = V.zipWith3 `eq` zipWith3 + prop_imap :: P ((Int -> a -> a) -> v a -> v a) = V.imap `eq` imap + prop_imapM :: P ((Int -> a -> Identity a) -> v a -> Identity (v a)) + = V.imapM `eq` imapM + prop_imapM_ :: P ((Int -> a -> Writer [a] ()) -> v a -> Writer [a] ()) + = V.imapM_ `eq` imapM_ + prop_izipWith :: P ((Int -> a -> a -> a) -> v a -> v a -> v a) = V.izipWith `eq` izipWith + prop_izipWithM :: P ((Int -> a -> a -> Identity a) -> v a -> v a -> Identity (v a)) + = V.izipWithM `eq` izipWithM + prop_izipWithM_ :: P ((Int -> a -> a -> Writer [a] ()) -> v a -> v a -> Writer [a] ()) + = V.izipWithM_ `eq` izipWithM_ + prop_izipWith3 :: P ((Int -> a -> a -> a -> a) -> v a -> v a -> v a -> v a) + = V.izipWith3 `eq` izipWith3 + + prop_filter :: P ((a -> Bool) -> v a -> v a) = V.filter `eq` filter + prop_ifilter :: P ((Int -> a -> Bool) -> v a -> v a) = V.ifilter `eq` ifilter + prop_mapMaybe :: P ((a -> Maybe a) -> v a -> v a) = V.mapMaybe `eq` mapMaybe + prop_imapMaybe :: P ((Int -> a -> Maybe a) -> v a -> v a) = V.imapMaybe `eq` imapMaybe + prop_takeWhile :: P ((a -> Bool) -> v a -> v a) = V.takeWhile `eq` takeWhile + prop_dropWhile :: P ((a -> Bool) -> v a -> v a) = V.dropWhile `eq` dropWhile + prop_partition :: P ((a -> Bool) -> v a -> (v a, v a)) + = V.partition `eq` partition + prop_partitionWith :: P ((a -> Either a a) -> v a -> (v a, v a)) + = V.partitionWith `eq` partitionWith + prop_span :: P ((a -> Bool) -> v a -> (v a, v a)) = V.span `eq` span + prop_break :: P ((a -> Bool) -> v a -> (v a, v a)) = V.break `eq` break + + prop_elem :: P (a -> v a -> Bool) = V.elem `eq` elem + prop_notElem :: P (a -> v a -> Bool) = V.notElem `eq` notElem + prop_find :: P ((a -> Bool) -> v a -> Maybe a) = V.find `eq` find + prop_findIndex :: P ((a -> Bool) -> v a -> Maybe Int) + = V.findIndex `eq` findIndex + prop_findIndices :: P ((a -> Bool) -> v a -> v Int) + = V.findIndices `eq` findIndices + prop_elemIndex :: P (a -> v a -> Maybe Int) = V.elemIndex `eq` elemIndex + prop_elemIndices :: P (a -> v a -> v Int) = V.elemIndices `eq` elemIndices + + prop_foldl :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl `eq` foldl + prop_foldl1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldl1 `eq` foldl1 + prop_foldl' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl' `eq` foldl' + prop_foldl1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldl1' `eq` foldl1' + prop_foldr :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr `eq` foldr + prop_foldr1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldr1 `eq` foldr1 + prop_foldr' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr' `eq` foldr + prop_foldr1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldr1' `eq` foldr1 + prop_ifoldl :: P ((a -> Int -> a -> a) -> a -> v a -> a) + = V.ifoldl `eq` ifoldl + prop_ifoldl' :: P ((a -> Int -> a -> a) -> a -> v a -> a) + = V.ifoldl' `eq` ifoldl + prop_ifoldr :: P ((Int -> a -> a -> a) -> a -> v a -> a) + = V.ifoldr `eq` ifoldr + prop_ifoldr' :: P ((Int -> a -> a -> a) -> a -> v a -> a) + = V.ifoldr' `eq` ifoldr + prop_ifoldM :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) + = V.ifoldM `eq` ifoldM + prop_ifoldM' :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) + = V.ifoldM' `eq` ifoldM + prop_ifoldM_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) + = V.ifoldM_ `eq` ifoldM_ + prop_ifoldM'_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) + = V.ifoldM'_ `eq` ifoldM_ + + prop_all :: P ((a -> Bool) -> v a -> Bool) = V.all `eq` all + prop_any :: P ((a -> Bool) -> v a -> Bool) = V.any `eq` any + + prop_prescanl :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanl `eq` prescanl + prop_prescanl' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanl' `eq` prescanl + prop_postscanl :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanl `eq` postscanl + prop_postscanl' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanl' `eq` postscanl + prop_scanl :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanl `eq` scanl + prop_scanl' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanl' `eq` scanl + prop_scanl1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanl1 `eq` scanl1 + prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanl1' `eq` scanl1 + prop_iscanl :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanl `eq` iscanl + prop_iscanl' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanl' `eq` iscanl + + prop_prescanr :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanr `eq` prescanr + prop_prescanr' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanr' `eq` prescanr + prop_postscanr :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanr `eq` postscanr + prop_postscanr' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanr' `eq` postscanr + prop_scanr :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanr `eq` scanr + prop_scanr' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanr' `eq` scanr + prop_iscanr :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanr `eq` iscanr + prop_iscanr' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanr' `eq` iscanr + prop_scanr1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanr1 `eq` scanr1 + prop_scanr1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanr1' `eq` scanr1 + + prop_concatMap = forAll arbitrary $ \xs -> + forAll (sized (\n -> resize (n `div` V.length xs) arbitrary)) $ \f -> unP prop f xs + where + prop :: P ((a -> v a) -> v a -> v a) = V.concatMap `eq` concatMap + + prop_uniq :: P (v a -> v a) + = V.uniq `eq` (map head . group) + --prop_span = (V.span :: (a -> Bool) -> v a -> (v a, v a)) `eq2` span + --prop_break = (V.break :: (a -> Bool) -> v a -> (v a, v a)) `eq2` break + --prop_splitAt = (V.splitAt :: Int -> v a -> (v a, v a)) `eq2` splitAt + --prop_all = (V.all :: (a -> Bool) -> v a -> Bool) `eq2` all + --prop_any = (V.any :: (a -> Bool) -> v a -> Bool) `eq2` any + + -- Data.List + --prop_findIndices = V.findIndices `eq2` (findIndices :: (a -> Bool) -> v a -> v Int) + --prop_isPrefixOf = V.isPrefixOf `eq2` (isPrefixOf :: v a -> v a -> Bool) + --prop_elemIndex = V.elemIndex `eq2` (elemIndex :: a -> v a -> Maybe Int) + --prop_elemIndices = V.elemIndices `eq2` (elemIndices :: a -> v a -> v Int) + -- + --prop_mapAccumL = eq3 + -- (V.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) + -- ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) + -- + --prop_mapAccumR = eq3 + -- (V.mapAccumR :: (X -> W -> (X,W)) -> X -> B -> (X, B)) + -- ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) + + -- Because the vectors are strict, we need to be totally sure that the unfold eventually terminates. This + -- is achieved by injecting our own bit of state into the unfold - the maximum number of unfolds allowed. + limitUnfolds f (theirs, ours) + | ours > 0 + , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) + | otherwise = Nothing + limitUnfoldsM f (theirs, ours) + | ours > 0 = do r <- f theirs + return $ (\(a,b) -> (a,(b,ours - 1))) `fmap` r + | otherwise = return Nothing + + + prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) + = (\n f a -> V.unfoldr (limitUnfolds f) (a, n)) + `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) + prop_unfoldrN :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) + = V.unfoldrN `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) + prop_unfoldrM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) + = (\n f a -> V.unfoldrM (limitUnfoldsM f) (a,n)) + `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) + prop_unfoldrNM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) + = V.unfoldrNM `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) + + prop_constructN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f + where + prop :: P (Int -> (v a -> a) -> v a) = V.constructN `eq` constructN [] + + constructN xs 0 _ = xs + constructN xs n f = constructN (xs ++ [f xs]) (n-1) f + + prop_constructrN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f + where + prop :: P (Int -> (v a -> a) -> v a) = V.constructrN `eq` constructrN [] + + constructrN xs 0 _ = xs + constructrN xs n f = constructrN (f xs : xs) (n-1) f + +-- copied from GHC source code +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +partitionWith _ [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs + +testTuplyFunctions :: forall a v. (CommonContext a v, VectorContext (a, a) v, VectorContext (a, a, a) v) => v a -> [Test] +{-# INLINE testTuplyFunctions #-} +testTuplyFunctions _ = $(testProperties [ 'prop_zip, 'prop_zip3 + , 'prop_unzip, 'prop_unzip3 + ]) + where + prop_zip :: P (v a -> v a -> v (a, a)) = V.zip `eq` zip + prop_zip3 :: P (v a -> v a -> v a -> v (a, a, a)) = V.zip3 `eq` zip3 + prop_unzip :: P (v (a, a) -> (v a, v a)) = V.unzip `eq` unzip + prop_unzip3 :: P (v (a, a, a) -> (v a, v a, v a)) = V.unzip3 `eq` unzip3 + +testOrdFunctions :: forall a v. (CommonContext a v, Ord a, Ord (v a)) => v a -> [Test] +{-# INLINE testOrdFunctions #-} +testOrdFunctions _ = $(testProperties + ['prop_compare, + 'prop_maximum, 'prop_minimum, + 'prop_minIndex, 'prop_maxIndex, + 'prop_maximumBy, 'prop_minimumBy, + 'prop_maxIndexBy, 'prop_minIndexBy, + 'prop_ListLastMaxIndexWins ]) + where + prop_compare :: P (v a -> v a -> Ordering) = compare `eq` compare + prop_maximum :: P (v a -> a) = not . V.null ===> V.maximum `eq` maximum + prop_minimum :: P (v a -> a) = not . V.null ===> V.minimum `eq` minimum + prop_minIndex :: P (v a -> Int) = not . V.null ===> V.minIndex `eq` minIndex + prop_maxIndex :: P (v a -> Int) = not . V.null ===> V.maxIndex `eq` listMaxIndexFMW + prop_maximumBy :: P (v a -> a) = + not . V.null ===> V.maximumBy compare `eq` maximum + prop_minimumBy :: P (v a -> a) = + not . V.null ===> V.minimumBy compare `eq` minimum + prop_maxIndexBy :: P (v a -> Int) = + not . V.null ===> V.maxIndexBy compare `eq` listMaxIndexFMW + --- (maxIndex) + prop_ListLastMaxIndexWins :: P (v a -> Int) = + not . V.null ===> ( maxIndex . V.toList) `eq` listMaxIndexLMW + prop_FalseListFirstMaxIndexWinsDesc :: P (v a -> Int) = + (\x -> not $ V.null x && (V.uniq x /= x ) )===> ( maxIndex . V.toList) `eq` listMaxIndexFMW + prop_FalseListFirstMaxIndexWins :: Property + prop_FalseListFirstMaxIndexWins = expectFailure prop_FalseListFirstMaxIndexWinsDesc + prop_minIndexBy :: P (v a -> Int) = + not . V.null ===> V.minIndexBy compare `eq` minIndex + +listMaxIndexFMW :: Ord a => [a] -> Int +listMaxIndexFMW = ( fst . extractFMW . sconcat . DLE.fromList . fmap FMW . zip [0 :: Int ..]) + +listMaxIndexLMW :: Ord a => [a] -> Int +listMaxIndexLMW = ( fst . extractLMW . sconcat . DLE.fromList . fmap LMW . zip [0 :: Int ..]) + +newtype LastMaxWith a i = LMW {extractLMW:: (i,a)} + deriving(Eq,Show,Read) +instance (Ord a) => Semigroup (LastMaxWith a i) where + (<>) x y | snd (extractLMW x) > snd (extractLMW y) = x + | snd (extractLMW x) < snd (extractLMW y) = y + | otherwise = y +newtype FirstMaxWith a i = FMW {extractFMW:: (i,a)} + deriving(Eq,Show,Read) +instance (Ord a) => Semigroup (FirstMaxWith a i) where + (<>) x y | snd (extractFMW x) > snd (extractFMW y) = x + | snd (extractFMW x) < snd (extractFMW y) = y + | otherwise = x + + +testEnumFunctions :: forall a v. (CommonContext a v, Enum a, Ord a, Num a, Random a) => v a -> [Test] +{-# INLINE testEnumFunctions #-} +testEnumFunctions _ = $(testProperties + [ 'prop_enumFromN, 'prop_enumFromThenN, + 'prop_enumFromTo, 'prop_enumFromThenTo]) + where + prop_enumFromN :: P (a -> Int -> v a) + = (\_ n -> n < 1000) + ===> V.enumFromN `eq` (\x n -> take n $ scanl (+) x $ repeat 1) + + prop_enumFromThenN :: P (a -> a -> Int -> v a) + = (\_ _ n -> n < 1000) + ===> V.enumFromStepN `eq` (\x y n -> take n $ scanl (+) x $ repeat y) + + prop_enumFromTo = \m -> + forAll (choose (-2,100)) $ \n -> + unP prop m (m+n) + where + prop :: P (a -> a -> v a) = V.enumFromTo `eq` enumFromTo + + prop_enumFromThenTo = \i j -> + j /= i ==> + forAll (choose (ks i j)) $ \k -> + unP prop i j k + where + prop :: P (a -> a -> a -> v a) = V.enumFromThenTo `eq` enumFromThenTo + + ks i j | j < i = (i-d*100, i+d*2) + | otherwise = (i-d*2, i+d*100) + where + d = abs (j-i) + +testMonoidFunctions :: forall a v. (CommonContext a v, Monoid (v a)) => v a -> [Test] +{-# INLINE testMonoidFunctions #-} +testMonoidFunctions _ = $(testProperties + [ 'prop_mempty, 'prop_mappend, 'prop_mconcat ]) + where + prop_mempty :: P (v a) = mempty `eq` mempty + prop_mappend :: P (v a -> v a -> v a) = mappend `eq` mappend + prop_mconcat :: P ([v a] -> v a) = mconcat `eq` mconcat + +testFunctorFunctions :: forall a v. (CommonContext a v, Functor v) => v a -> [Test] +{-# INLINE testFunctorFunctions #-} +testFunctorFunctions _ = $(testProperties + [ 'prop_fmap ]) + where + prop_fmap :: P ((a -> a) -> v a -> v a) = fmap `eq` fmap + +testMonadFunctions :: forall a v. (CommonContext a v, VectorContext (a, a) v, MonadZip v) => v a -> [Test] +{-# INLINE testMonadFunctions #-} +testMonadFunctions _ = $(testProperties [ 'prop_return, 'prop_bind + , 'prop_mzip, 'prop_munzip]) + where + prop_return :: P (a -> v a) = return `eq` return + prop_bind :: P (v a -> (a -> v a) -> v a) = (>>=) `eq` (>>=) + prop_mzip :: P (v a -> v a -> v (a, a)) = mzip `eq` zip + prop_munzip :: P (v (a, a) -> (v a, v a)) = munzip `eq` unzip + +testApplicativeFunctions :: forall a v. (CommonContext a v, V.Vector v (a -> a), Applicative.Applicative v) => v a -> [Test] +{-# INLINE testApplicativeFunctions #-} +testApplicativeFunctions _ = $(testProperties + [ 'prop_applicative_pure, 'prop_applicative_appl ]) + where + prop_applicative_pure :: P (a -> v a) + = Applicative.pure `eq` Applicative.pure + prop_applicative_appl :: [a -> a] -> P (v a -> v a) + = \fs -> (Applicative.<*>) (V.fromList fs) `eq` (Applicative.<*>) fs + +testAlternativeFunctions :: forall a v. (CommonContext a v, Applicative.Alternative v) => v a -> [Test] +{-# INLINE testAlternativeFunctions #-} +testAlternativeFunctions _ = $(testProperties + [ 'prop_alternative_empty, 'prop_alternative_or ]) + where + prop_alternative_empty :: P (v a) = Applicative.empty `eq` Applicative.empty + prop_alternative_or :: P (v a -> v a -> v a) + = (Applicative.<|>) `eq` (Applicative.<|>) + +testBoolFunctions :: forall v. (CommonContext Bool v) => v Bool -> [Test] +{-# INLINE testBoolFunctions #-} +testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or]) + where + prop_and :: P (v Bool -> Bool) = V.and `eq` and + prop_or :: P (v Bool -> Bool) = V.or `eq` or + +testNumFunctions :: forall a v. (CommonContext a v, Num a) => v a -> [Test] +{-# INLINE testNumFunctions #-} +testNumFunctions _ = $(testProperties ['prop_sum, 'prop_product]) + where + prop_sum :: P (v a -> a) = V.sum `eq` sum + prop_product :: P (v a -> a) = V.product `eq` product + +testNestedVectorFunctions :: forall a v. (CommonContext a v) => v a -> [Test] +{-# INLINE testNestedVectorFunctions #-} +testNestedVectorFunctions _ = $(testProperties []) + where + -- Prelude + --prop_concat = (V.concat :: [v a] -> v a) `eq1` concat + + -- Data.List + --prop_transpose = V.transpose `eq1` (transpose :: [v a] -> [v a]) + --prop_group = V.group `eq1` (group :: v a -> [v a]) + --prop_inits = V.inits `eq1` (inits :: v a -> [v a]) + --prop_tails = V.tails `eq1` (tails :: v a -> [v a]) + +testDataFunctions :: forall a v. (CommonContext a v, Data a, Data (v a)) => v a -> [Test] +{-# INLINE testDataFunctions #-} +testDataFunctions _ = $(testProperties ['prop_glength]) + where + prop_glength :: P (v a -> Int) = glength `eq` glength + where + glength :: Data b => b -> Int + glength xs = gmapQl (+) 0 toA xs + + toA :: Data b => b -> Int + toA x = maybe (glength x) (const 1) (cast x :: Maybe a) diff --git a/tests/Tests/Vector/Storable.hs b/tests/Tests/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Vector/Storable.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ConstraintKinds #-} +module Tests.Vector.Storable (tests) where + +import Test.Tasty +import qualified Data.Vector.Storable +import Tests.Vector.Property + +import GHC.Exts (inline) + +testGeneralStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a, Data a) => Data.Vector.Storable.Vector a -> [Test] +testGeneralStorableVector dummy = concatMap ($ dummy) + [ + testSanity + , inline testPolymorphicFunctions + , testOrdFunctions + , testMonoidFunctions + , testDataFunctions + ] + +testNumericStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Storable.Vector a -> [Test] +testNumericStorableVector dummy = concatMap ($ dummy) + [ + testGeneralStorableVector + , testNumFunctions + , testEnumFunctions + ] + +tests = + [ testGroup "Data.Vector.Storable.Vector (Int)" $ + testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Int) + , testGroup "Data.Vector.Storable.Vector (Double)" $ + testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Double) + ] diff --git a/tests/Tests/Vector/Unboxed.hs b/tests/Tests/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Vector/Unboxed.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ConstraintKinds #-} +module Tests.Vector.Unboxed (tests) where + +import Test.Tasty +import qualified Data.Vector.Unboxed +import Tests.Vector.Property + + + +testGeneralUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Data a) => Data.Vector.Unboxed.Vector a -> [Test] +testGeneralUnboxedVector dummy = concatMap ($ dummy) + [ + testSanity + , testPolymorphicFunctions + , testOrdFunctions + , testMonoidFunctions + , testDataFunctions + ] + +testUnitUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + ] + +testBoolUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + , testBoolFunctions + ] + +testNumericUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Num a, Enum a, Random a, Data a) => Data.Vector.Unboxed.Vector a -> [Test] +testNumericUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + , testNumFunctions + , testEnumFunctions + ] + +testTupleUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Data a) => Data.Vector.Unboxed.Vector a -> [Test] +testTupleUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + ] + +tests = + [ testGroup "()" $ + testUnitUnboxedVector (undefined :: Data.Vector.Unboxed.Vector ()) + , testGroup "(Bool)" $ + testBoolUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Bool) + , testGroup "(Int)" $ + testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Int) + , testGroup "(Float)" $ + testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Float) + , testGroup "(Double)" $ + testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Double) + , testGroup "(Int,Bool)" $ + testTupleUnboxedVector (undefined :: Data.Vector.Unboxed.Vector (Int, Bool)) + , testGroup "(Int,Bool,Int)" $ + testTupleUnboxedVector + (undefined :: Data.Vector.Unboxed.Vector (Int, Bool, Int)) + ] diff --git a/tests/Tests/Vector/UnitTests.hs b/tests/Tests/Vector/UnitTests.hs --- a/tests/Tests/Vector/UnitTests.hs +++ b/tests/Tests/Vector/UnitTests.hs @@ -4,16 +4,25 @@ module Tests.Vector.UnitTests (tests) where import Control.Applicative as Applicative +import Control.Exception import Control.Monad.Primitive +import Data.Int +import Data.Word +import Data.Typeable +import qualified Data.List as List import qualified Data.Vector.Generic as Generic +import qualified Data.Vector as Boxed +import qualified Data.Vector.Primitive as Primitive import qualified Data.Vector.Storable as Storable +import qualified Data.Vector.Unboxed as Unboxed +import qualified Data.Vector as Vector import Foreign.Ptr import Foreign.Storable import Text.Printf -import Test.Framework -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assertBool) +import Test.Tasty +import Test.Tasty.HUnit (testCase,Assertion, assertBool, (@=?), assertFailure) +-- import Test.HUnit () newtype Aligned a = Aligned { getAligned :: a } @@ -34,7 +43,7 @@ dummy :: a dummy = undefined -tests :: [Test] +tests :: [TestTree] tests = [ testGroup "Data.Vector.Storable.Vector Alignment" [ testCase "Aligned Double" $ @@ -42,7 +51,98 @@ , testCase "Aligned Int" $ checkAddressAlignment alignedIntVec ] + , testGroup "Regression tests" + [ testGroup "enumFromTo crash #188" + [ regression188 ([] :: [Word8]) + , regression188 ([] :: [Word16]) + , regression188 ([] :: [Word32]) + , regression188 ([] :: [Word64]) + , regression188 ([] :: [Word]) + , regression188 ([] :: [Int8]) + , regression188 ([] :: [Int16]) + , regression188 ([] :: [Int32]) + , regression188 ([] :: [Int64]) + , regression188 ([] :: [Int]) + , regression188 ([] :: [Char]) + ] + ] + , testGroup "Negative tests" + [ testGroup "slice out of bounds #257" + [ testGroup "Boxed" $ testsSliceOutOfBounds Boxed.slice + , testGroup "Primitive" $ testsSliceOutOfBounds Primitive.slice + , testGroup "Storable" $ testsSliceOutOfBounds Storable.slice + , testGroup "Unboxed" $ testsSliceOutOfBounds Unboxed.slice + ] + , testGroup "take #282" + [ testCase "Boxed" $ testTakeOutOfMemory Boxed.take + , testCase "Primitive" $ testTakeOutOfMemory Primitive.take + , testCase "Storable" $ testTakeOutOfMemory Storable.take + , testCase "Unboxed" $ testTakeOutOfMemory Unboxed.take + ] + ] ] + +testsSliceOutOfBounds :: + (Show (v Int), Generic.Vector v Int) => (Int -> Int -> v Int -> v Int) -> [TestTree] +testsSliceOutOfBounds sliceWith = + [ testCase "Negative ix" $ sliceTest sliceWith (-2) 2 xs + , testCase "Negative size" $ sliceTest sliceWith 2 (-2) xs + , testCase "Negative ix and size" $ sliceTest sliceWith (-2) (-1) xs + , testCase "Too large ix" $ sliceTest sliceWith 6 2 xs + , testCase "Too large size" $ sliceTest sliceWith 2 6 xs + , testCase "Too large ix and size" $ sliceTest sliceWith 6 6 xs + , testCase "Overflow" $ sliceTest sliceWith 1 maxBound xs + , testCase "OutOfMemory" $ sliceTest sliceWith 1 (maxBound `div` intSize) xs + ] + where + intSize = sizeOf (undefined :: Int) + xs = [1, 2, 3, 4, 5] :: [Int] +{-# INLINE testsSliceOutOfBounds #-} + +sliceTest :: + (Show (v Int), Generic.Vector v Int) + => (Int -> Int -> v Int -> v Int) + -> Int + -> Int + -> [Int] + -> Assertion +sliceTest sliceWith i m xs = do + let vec = Generic.fromList xs + eRes <- try (pure $! sliceWith i m vec) + case eRes of + Right v -> + assertFailure $ + "Data.Vector.Internal.Check.checkSlice failed to check: " ++ show v + Left (ErrorCall err) -> + let assertMsg = + List.concat + [ "Expected slice function to produce an 'error' ending with: \"" + , errSuffix + , "\" instead got: \"" + , err + ] + in assertBool assertMsg (errSuffix `List.isSuffixOf` err) + where + errSuffix = + "(slice): invalid slice (" ++ + show i ++ "," ++ show m ++ "," ++ show (List.length xs) ++ ")" +{-# INLINE sliceTest #-} + +testTakeOutOfMemory :: + (Show (v Int), Eq (v Int), Generic.Vector v Int) => (Int -> v Int -> v Int) -> Assertion +testTakeOutOfMemory takeWith = + takeWith (maxBound `div` intSize) (Generic.fromList xs) @=? Generic.fromList xs + where + intSize = sizeOf (undefined :: Int) + xs = [1, 2, 3, 4, 5] :: [Int] +{-# INLINE testTakeOutOfMemory #-} + +regression188 + :: forall proxy a. (Typeable a, Enum a, Bounded a, Eq a, Show a) + => proxy a -> TestTree +regression188 _ = testCase (show (typeOf (undefined :: a))) + $ Vector.fromList [maxBound::a] @=? Vector.enumFromTo maxBound maxBound +{-# INLINE regression188 #-} alignedDoubleVec :: Storable.Vector (Aligned Double) alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] diff --git a/tests/Utilities.hs b/tests/Utilities.hs --- a/tests/Utilities.hs +++ b/tests/Utilities.hs @@ -231,7 +231,7 @@ index_value_pairs m = sized $ \n -> do len <- choose (0,n) - is <- sequence [choose (0,m-1) | i <- [1..len]] + is <- sequence [choose (0,m-1) | _i <- [1..len]] xs <- vector len return $ zip is xs @@ -240,7 +240,7 @@ indices m = sized $ \n -> do len <- choose (0,n) - sequence [choose (0,m-1) | i <- [1..len]] + sequence [choose (0,m-1) | _i <- [1..len]] -- Additional list functions @@ -259,9 +259,9 @@ where ps' = sortBy (\p q -> compare (fst p) (fst q)) ps - go (x:xs) ((i,y) : ps) j - | i == j = go (f x y : xs) ps j - go (x:xs) ps j = x : go xs ps (j+1) + go (x:xxs) ((i,y) : pps) j + | i == j = go (f x y : xxs) pps j + go (x:xxs) pps j = x : go xxs pps (j+1) go [] _ _ = [] (//) :: [a] -> [(Int, a)] -> [a] @@ -269,9 +269,9 @@ where ps' = sortBy (\p q -> compare (fst p) (fst q)) ps - go (x:xs) ((i,y) : ps) j - | i == j = go (y:xs) ps j - go (x:xs) ps j = x : go xs ps (j+1) + go (_x:xxs) ((i,y) : pps) j + | i == j = go (y:xxs) pps j + go (x:xxs) pps j = x : go xxs pps (j+1) go [] _ _ = [] @@ -336,7 +336,7 @@ maxIndex :: Ord a => [a] -> Int maxIndex = fst . foldr1 imax . zip [0..] where - imax (i,x) (j,y) | x >= y = (i,x) + imax (i,x) (j,y) | x > y = (i,x) | otherwise = (j,y) iterateNM :: Monad m => Int -> (a -> m a) -> a -> m [a] diff --git a/vector.cabal b/vector.cabal --- a/vector.cabal +++ b/vector.cabal @@ -1,5 +1,5 @@ Name: vector -Version: 0.12.0.3 +Version: 0.12.1.0 -- don't forget to update the changelog file! License: BSD3 License-File: LICENSE @@ -39,13 +39,19 @@ GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, - GHC == 8.0.1 + GHC == 8.0.2, + GHC == 8.2.2, + GHC == 8.4.4, + GHC == 8.6.5, + GHC == 8.8.1, + GHC == 8.10.1 + Cabal-Version: >=1.10 Build-Type: Simple Extra-Source-Files: - changelog + changelog.md README.md tests/LICENSE tests/Setup.hs @@ -65,10 +71,11 @@ benchmarks/TestData/Graph.hs benchmarks/TestData/ParenTree.hs benchmarks/TestData/Random.hs - changelog internal/GenUnboxTuple.hs internal/unbox-tuple-instances + + Flag BoundsChecks Description: Enable bounds checking Default: True @@ -91,6 +98,7 @@ Default: False Manual: True + Library Default-Language: Haskell2010 Other-Extensions: @@ -144,13 +152,13 @@ Install-Includes: vector.h - Build-Depends: base >= 4.5 && < 4.13 + Build-Depends: base >= 4.5 && < 4.15 , primitive >= 0.5.0.1 && < 0.8 - , ghc-prim >= 0.2 && < 0.6 + , ghc-prim >= 0.2 && < 0.7 , deepseq >= 1.1 && < 1.5 if !impl(ghc > 8.0) Build-Depends: fail == 4.9.* - , semigroups >= 0.18 && < 0.19 + , semigroups >= 0.18 && < 0.20 Ghc-Options: -O2 -Wall @@ -184,14 +192,19 @@ Tests.Bundle Tests.Move Tests.Vector + Tests.Vector.Property + Tests.Vector.Boxed + Tests.Vector.Storable + Tests.Vector.Primitive + Tests.Vector.Unboxed Tests.Vector.UnitTests Utilities hs-source-dirs: tests Build-Depends: base >= 4.5 && < 5, template-haskell, base-orphans >= 0.6, vector, - random, primitive, - QuickCheck >= 2.9 && < 2.10 , HUnit, test-framework, - test-framework-hunit, test-framework-quickcheck2, + primitive, random, + QuickCheck >= 2.9 && < 2.14 , HUnit, tasty, + tasty-hunit, tasty-quickcheck, transformers >= 0.2.0.0 default-extensions: CPP, @@ -204,7 +217,7 @@ TypeFamilies, TemplateHaskell - Ghc-Options: -O0 + Ghc-Options: -O0 -threaded Ghc-Options: -Wall if !flag(Wall) @@ -222,14 +235,19 @@ Tests.Bundle Tests.Move Tests.Vector + Tests.Vector.Property + Tests.Vector.Boxed + Tests.Vector.Storable + Tests.Vector.Primitive + Tests.Vector.Unboxed Tests.Vector.UnitTests Utilities hs-source-dirs: tests Build-Depends: base >= 4.5 && < 5, template-haskell, base-orphans >= 0.6, vector, - random, primitive, - QuickCheck >= 2.9 && < 2.10 , HUnit, test-framework, - test-framework-hunit, test-framework-quickcheck2, + primitive, random, + QuickCheck >= 2.9 && < 2.14 , HUnit, tasty, + tasty-hunit, tasty-quickcheck, transformers >= 0.2.0.0 default-extensions: CPP, @@ -242,8 +260,9 @@ TypeFamilies, TemplateHaskell - Ghc-Options: -O2 -Wall + Ghc-Options: -Wall + Ghc-Options: -O2 -threaded if !flag(Wall) Ghc-Options: -fno-warn-orphans -fno-warn-missing-signatures if impl(ghc >= 8.0) && impl(ghc < 8.1)