diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/vector/tests')
9 files changed, 1391 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs new file mode 100644 index 0000000000..5506209ebc --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs @@ -0,0 +1,27 @@ +module Boilerplater where + +import Test.Framework.Providers.QuickCheck2 + +import Language.Haskell.TH + + +testProperties :: [Name] -> Q Exp +testProperties nms = fmap ListE $ sequence [[| testProperty $(stringE prop_name) $(varE nm) |] + | nm <- nms + , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]] + +-- This nice clean solution doesn't quite work since I need to use lexically-scoped type +-- variables, which aren't supported by Template Haskell. Argh! +-- testProperties :: Q [Dec] -> Q Exp +-- testProperties mdecs = do +-- decs <- mdecs +-- property_exprs <- sequence [[| testProperty "$prop_name" $(return $ VarE nm) |] +-- | FunD nm _clauses <- decs +-- , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]] +-- return $ LetE decs (ListE property_exprs) + +stripPrefix_maybe :: String -> String -> Maybe String +stripPrefix_maybe prefix what + | what_start == prefix = Just what_end + | otherwise = Nothing + where (what_start, what_end) = splitAt (length prefix) what diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE b/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE new file mode 100644 index 0000000000..43c0cee637 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009, Max Bolingbroke and Roman Leshchinskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs new file mode 100644 index 0000000000..6642888323 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import qualified Tests.Vector +import qualified Tests.Vector.UnitTests +import qualified Tests.Bundle +import qualified Tests.Move + +import Test.Framework (defaultMain) + +main :: IO () +main = defaultMain $ Tests.Bundle.tests + ++ Tests.Vector.tests + ++ Tests.Vector.UnitTests.tests + ++ Tests.Move.tests + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs new file mode 100644 index 0000000000..200a2e51d0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs new file mode 100644 index 0000000000..09368a1999 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs @@ -0,0 +1,163 @@ +module Tests.Bundle ( tests ) where + +import Boilerplater +import Utilities + +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 (foldl', foldl1', unfoldr, find, findIndex) +import System.Random (Random) + +#define COMMON_CONTEXT(a) \ + VANILLA_CONTEXT(a) + +#define VANILLA_CONTEXT(a) \ + Eq a, Show a, Arbitrary a, CoArbitrary a, TestData a, Model a ~ a, EqTest a ~ Property + +testSanity :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] +testSanity _ = [ + testProperty "fromList.toList == id" prop_fromList_toList, + testProperty "toList.fromList == id" prop_toList_fromList + ] + where + prop_fromList_toList :: P (S.Bundle v a -> S.Bundle v a) + = (S.fromList . S.toList) `eq` id + prop_toList_fromList :: P ([a] -> [a]) + = (S.toList . (S.fromList :: [a] -> S.Bundle v a)) `eq` id + +testPolymorphicFunctions :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] +testPolymorphicFunctions _ = $(testProperties [ + 'prop_eq, + + 'prop_length, 'prop_null, + + 'prop_empty, 'prop_singleton, 'prop_replicate, + 'prop_cons, 'prop_snoc, 'prop_append, + + 'prop_head, 'prop_last, 'prop_index, + + 'prop_extract, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop, + + 'prop_map, 'prop_zipWith, 'prop_zipWith3, + 'prop_filter, 'prop_takeWhile, 'prop_dropWhile, + + 'prop_elem, 'prop_notElem, + 'prop_find, 'prop_findIndex, + + 'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1', + 'prop_foldr, 'prop_foldr1, + + 'prop_prescanl, 'prop_prescanl', + 'prop_postscanl, 'prop_postscanl', + 'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1', + + 'prop_concatMap, + 'prop_unfoldr + ]) + where + -- Prelude + prop_eq :: P (S.Bundle v a -> S.Bundle v a -> Bool) = (==) `eq` (==) + + prop_length :: P (S.Bundle v a -> Int) = S.length `eq` length + prop_null :: P (S.Bundle v a -> Bool) = S.null `eq` null + prop_empty :: P (S.Bundle v a) = S.empty `eq` [] + prop_singleton :: P (a -> S.Bundle v a) = S.singleton `eq` singleton + prop_replicate :: P (Int -> a -> S.Bundle v a) + = (\n _ -> n < 1000) ===> S.replicate `eq` replicate + prop_cons :: P (a -> S.Bundle v a -> S.Bundle v a) = S.cons `eq` (:) + prop_snoc :: P (S.Bundle v a -> a -> S.Bundle v a) = S.snoc `eq` snoc + prop_append :: P (S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = (S.++) `eq` (++) + + prop_head :: P (S.Bundle v a -> a) = not . S.null ===> S.head `eq` head + prop_last :: P (S.Bundle v a -> a) = not . S.null ===> S.last `eq` last + prop_index = \xs -> + not (S.null xs) ==> + forAll (choose (0, S.length xs-1)) $ \i -> + unP prop xs i + where + prop :: P (S.Bundle v a -> Int -> a) = (S.!!) `eq` (!!) + + prop_extract = \xs -> + forAll (choose (0, S.length xs)) $ \i -> + forAll (choose (0, S.length xs - i)) $ \n -> + unP prop i n xs + where + prop :: P (Int -> Int -> S.Bundle v a -> S.Bundle v a) = S.slice `eq` slice + + prop_tail :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.tail `eq` tail + prop_init :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.init `eq` init + prop_take :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.take `eq` take + prop_drop :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.drop `eq` drop + + prop_map :: P ((a -> a) -> S.Bundle v a -> S.Bundle v a) = S.map `eq` map + prop_zipWith :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = S.zipWith `eq` zipWith + prop_zipWith3 :: P ((a -> a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a) + = S.zipWith3 `eq` zipWith3 + + prop_filter :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.filter `eq` filter + prop_takeWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.takeWhile `eq` takeWhile + prop_dropWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.dropWhile `eq` dropWhile + + prop_elem :: P (a -> S.Bundle v a -> Bool) = S.elem `eq` elem + prop_notElem :: P (a -> S.Bundle v a -> Bool) = S.notElem `eq` notElem + prop_find :: P ((a -> Bool) -> S.Bundle v a -> Maybe a) = S.find `eq` find + prop_findIndex :: P ((a -> Bool) -> S.Bundle v a -> Maybe Int) + = S.findIndex `eq` findIndex + + prop_foldl :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl `eq` foldl + prop_foldl1 :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> + S.foldl1 `eq` foldl1 + prop_foldl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl' `eq` foldl' + prop_foldl1' :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> + S.foldl1' `eq` foldl1' + prop_foldr :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldr `eq` foldr + prop_foldr1 :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> + S.foldr1 `eq` foldr1 + + prop_prescanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.prescanl `eq` prescanl + prop_prescanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.prescanl' `eq` prescanl + prop_postscanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.postscanl `eq` postscanl + prop_postscanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.postscanl' `eq` postscanl + prop_scanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.scanl `eq` scanl + prop_scanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.scanl' `eq` scanl + prop_scanl1 :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===> + 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 + prop :: P ((a -> S.Bundle v a) -> S.Bundle v a -> S.Bundle v a) = S.concatMap `eq` concatMap + + limitUnfolds f (theirs, ours) | ours >= 0 + , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) + | otherwise = Nothing + prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> S.Bundle v a) + = (\n f a -> S.unfoldr (limitUnfolds f) (a, n)) + `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) + +testBoolFunctions :: forall v. S.Bundle v Bool -> [Test] +testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or ]) + where + prop_and :: P (S.Bundle v Bool -> Bool) = S.and `eq` and + prop_or :: P (S.Bundle v Bool -> Bool) = S.or `eq` or + +testBundleFunctions = testSanity (undefined :: S.Bundle v Int) + ++ testPolymorphicFunctions (undefined :: S.Bundle v Int) + ++ testBoolFunctions (undefined :: S.Bundle v Bool) + +tests = [ testGroup "Data.Vector.Fusion.Bundle" testBundleFunctions ] + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs new file mode 100644 index 0000000000..60ea8d3346 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs @@ -0,0 +1,49 @@ +module Tests.Move (tests) where + +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck.Property (Property(..)) + +import Utilities () + +import Control.Monad (replicateM) +import Control.Monad.ST (runST) +import Data.List (sort,permutations) + +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M + +import qualified Data.Vector as V +import qualified Data.Vector.Primitive as P +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Unboxed as U + +basicMove :: G.Vector v a => v a -> Int -> Int -> Int -> v a +basicMove v dstOff srcOff len + | len > 0 = G.modify (\ mv -> G.copy (M.slice dstOff len mv) (G.slice srcOff len v)) v + | otherwise = v + +testMove :: (G.Vector v a, Show (v a), Eq (v a)) => v a -> Property +testMove v = G.length v > 0 ==> (MkProperty $ do + dstOff <- choose (0, G.length v - 1) + srcOff <- choose (0, G.length v - 1) + len <- choose (1, G.length v - max dstOff srcOff) + expected <- return $ basicMove v dstOff srcOff len + actual <- return $ G.modify (\ mv -> M.move (M.slice dstOff len mv) (M.slice srcOff len mv)) v + unProperty $ counterexample ("Move: " ++ show (v, dstOff, srcOff, len)) (expected == actual)) + +checkPermutations :: Int -> Bool +checkPermutations n = runST $ do + vec <- U.thaw (U.fromList [1..n]) + res <- replicateM (product [1..n]) $ M.nextPermutation vec >> U.freeze vec >>= return . U.toList + return $! ([1..n] : res) == sort (permutations [1..n]) ++ [[n,n-1..1]] + +testPermutations :: Bool +testPermutations = all checkPermutations [1..7] + +tests = + [testProperty "Data.Vector.Mutable (Move)" (testMove :: V.Vector Int -> Property), + testProperty "Data.Vector.Primitive.Mutable (Move)" (testMove :: P.Vector Int -> Property), + testProperty "Data.Vector.Unboxed.Mutable (Move)" (testMove :: U.Vector Int -> Property), + testProperty "Data.Vector.Storable.Mutable (Move)" (testMove :: S.Vector Int -> Property), + testProperty "Data.Vector.Generic.Mutable (nextPermutation)" testPermutations] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs new file mode 100644 index 0000000000..46569d9095 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs @@ -0,0 +1,706 @@ +{-# 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 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 + +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? + +#if !MIN_VERSION_base(4,7,0) +instance Foldable ((,) a) where + foldMap f (_, b) = f b + +instance T.Traversable ((,) a) where + traverse f (a, b) = fmap ((,) a) $ f b +#endif + +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 ]) + 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 + +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]) + +testGeneralBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a) => Data.Vector.Vector a -> [Test] +testGeneralBoxedVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testTuplyFunctions, + testNestedVectorFunctions, + testMonoidFunctions, + testFunctorFunctions, + testMonadFunctions, + testApplicativeFunctions, + testAlternativeFunctions + ] + +testBoolBoxedVector dummy = concatMap ($ dummy) + [ + testGeneralBoxedVector + , testBoolFunctions + ] + +testNumericBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a, Num a, Enum a, Random 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.Vector.Primitive.Vector a -> [Test] +testGeneralPrimitiveVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testMonoidFunctions + ] + +testNumericPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a, Num a, Enum a, Random 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.Vector.Storable.Vector a -> [Test] +testGeneralStorableVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testMonoidFunctions + ] + +testNumericStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a, Num a, Enum a, Random 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.Vector.Unboxed.Vector a -> [Test] +testGeneralUnboxedVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testMonoidFunctions + ] + +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.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.Vector.Unboxed.Vector a -> [Test] +testTupleUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + ] + +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/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs new file mode 100644 index 0000000000..5827640d84 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Tests.Vector.UnitTests (tests) where + +import Control.Applicative as Applicative +import qualified Data.Vector.Storable as Storable +import Foreign.Ptr +import Foreign.Storable +import Text.Printf + +import Test.Framework +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertBool) + +newtype Aligned a = Aligned { getAligned :: a } + +instance (Storable a) => Storable (Aligned a) where + sizeOf _ = sizeOf (undefined :: a) + alignment _ = 128 + peek ptr = Aligned Applicative.<$> peek (castPtr ptr) + poke ptr = poke (castPtr ptr) . getAligned + +checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion +checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do + let ptr' = ptrToWordPtr ptr + msg = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr') + align :: WordPtr + align = fromIntegral $ alignment dummy + assertBool msg $ (ptr' `mod` align) == 0 + where + dummy :: a + dummy = undefined + +tests :: [Test] +tests = + [ testGroup "Data.Vector.Storable.Vector Alignment" + [ testCase "Aligned Double" $ + checkAddressAlignment alignedDoubleVec + , testCase "Aligned Int" $ + checkAddressAlignment alignedIntVec + ] + ] + +alignedDoubleVec :: Storable.Vector (Aligned Double) +alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] + +alignedIntVec :: Storable.Vector (Aligned Int) +alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs new file mode 100644 index 0000000000..86a4f2c324 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE FlexibleInstances, GADTs #-} +module Utilities where + +import Test.QuickCheck + +import qualified Data.Vector as DV +import qualified Data.Vector.Generic as DVG +import qualified Data.Vector.Primitive as DVP +import qualified Data.Vector.Storable as DVS +import qualified Data.Vector.Unboxed as DVU +import qualified Data.Vector.Fusion.Bundle as S + +import Control.Monad (foldM, foldM_, zipWithM, zipWithM_) +import Control.Monad.Trans.Writer +import Data.Function (on) +import Data.Functor.Identity +import Data.List ( sortBy ) +import Data.Monoid +import Data.Maybe (catMaybes) + +instance Show a => Show (S.Bundle v a) where + show s = "Data.Vector.Fusion.Bundle.fromList " ++ show (S.toList s) + + +instance Arbitrary a => Arbitrary (DV.Vector a) where + arbitrary = fmap DV.fromList arbitrary + +instance CoArbitrary a => CoArbitrary (DV.Vector a) where + coarbitrary = coarbitrary . DV.toList + +instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where + arbitrary = fmap DVP.fromList arbitrary + +instance (CoArbitrary a, DVP.Prim a) => CoArbitrary (DVP.Vector a) where + coarbitrary = coarbitrary . DVP.toList + +instance (Arbitrary a, DVS.Storable a) => Arbitrary (DVS.Vector a) where + arbitrary = fmap DVS.fromList arbitrary + +instance (CoArbitrary a, DVS.Storable a) => CoArbitrary (DVS.Vector a) where + coarbitrary = coarbitrary . DVS.toList + +instance (Arbitrary a, DVU.Unbox a) => Arbitrary (DVU.Vector a) where + arbitrary = fmap DVU.fromList arbitrary + +instance (CoArbitrary a, DVU.Unbox a) => CoArbitrary (DVU.Vector a) where + coarbitrary = coarbitrary . DVU.toList + +instance Arbitrary a => Arbitrary (S.Bundle v a) where + arbitrary = fmap S.fromList arbitrary + +instance CoArbitrary a => CoArbitrary (S.Bundle v a) where + coarbitrary = coarbitrary . S.toList + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Writer a b) where + arbitrary = do b <- arbitrary + a <- arbitrary + return $ writer (b,a) + +instance CoArbitrary a => CoArbitrary (Writer a ()) where + coarbitrary = coarbitrary . runWriter + +class (Testable (EqTest a), Conclusion (EqTest a)) => TestData a where + type Model a + model :: a -> Model a + unmodel :: Model a -> a + + type EqTest a + equal :: a -> a -> EqTest a + +instance Eq a => TestData (S.Bundle v a) where + type Model (S.Bundle v a) = [a] + model = S.toList + unmodel = S.fromList + + type EqTest (S.Bundle v a) = Property + equal x y = property (x == y) + +instance Eq a => TestData (DV.Vector a) where + type Model (DV.Vector a) = [a] + model = DV.toList + unmodel = DV.fromList + + type EqTest (DV.Vector a) = Property + equal x y = property (x == y) + +instance (Eq a, DVP.Prim a) => TestData (DVP.Vector a) where + type Model (DVP.Vector a) = [a] + model = DVP.toList + unmodel = DVP.fromList + + type EqTest (DVP.Vector a) = Property + equal x y = property (x == y) + +instance (Eq a, DVS.Storable a) => TestData (DVS.Vector a) where + type Model (DVS.Vector a) = [a] + model = DVS.toList + unmodel = DVS.fromList + + type EqTest (DVS.Vector a) = Property + equal x y = property (x == y) + +instance (Eq a, DVU.Unbox a) => TestData (DVU.Vector a) where + type Model (DVU.Vector a) = [a] + model = DVU.toList + unmodel = DVU.fromList + + type EqTest (DVU.Vector a) = Property + equal x y = property (x == y) + +#define id_TestData(ty) \ +instance TestData ty where { \ + type Model ty = ty; \ + model = id; \ + unmodel = id; \ + \ + type EqTest ty = Property; \ + equal x y = property (x == y) } + +id_TestData(()) +id_TestData(Bool) +id_TestData(Int) +id_TestData(Float) +id_TestData(Double) +id_TestData(Ordering) + +-- Functorish models +-- All of these need UndecidableInstances although they are actually well founded. Oh well. +instance (Eq a, TestData a) => TestData (Maybe a) where + type Model (Maybe a) = Maybe (Model a) + model = fmap model + unmodel = fmap unmodel + + type EqTest (Maybe a) = Property + equal x y = property (x == y) + +instance (Eq a, TestData a) => TestData [a] where + type Model [a] = [Model a] + model = fmap model + unmodel = fmap unmodel + + type EqTest [a] = Property + equal x y = property (x == y) + +instance (Eq a, TestData a) => TestData (Identity a) where + type Model (Identity a) = Identity (Model a) + model = fmap model + unmodel = fmap unmodel + + type EqTest (Identity a) = Property + equal = (property .) . on (==) runIdentity + +instance (Eq a, TestData a, Eq b, TestData b, Monoid a) => TestData (Writer a b) where + type Model (Writer a b) = Writer (Model a) (Model b) + model = mapWriter model + unmodel = mapWriter unmodel + + type EqTest (Writer a b) = Property + equal = (property .) . on (==) runWriter + +instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where + type Model (a,b) = (Model a, Model b) + model (a,b) = (model a, model b) + unmodel (a,b) = (unmodel a, unmodel b) + + type EqTest (a,b) = Property + equal x y = property (x == y) + +instance (Eq a, Eq b, Eq c, TestData a, TestData b, TestData c) => TestData (a,b,c) where + type Model (a,b,c) = (Model a, Model b, Model c) + model (a,b,c) = (model a, model b, model c) + unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c) + + type EqTest (a,b,c) = Property + equal x y = property (x == y) + +instance (Arbitrary a, Show a, TestData a, TestData b) => TestData (a -> b) where + type Model (a -> b) = Model a -> Model b + model f = model . f . unmodel + unmodel f = unmodel . f . model + + type EqTest (a -> b) = a -> EqTest b + equal f g x = equal (f x) (g x) + +newtype P a = P { unP :: EqTest a } + +instance TestData a => Testable (P a) where + property (P a) = property a + +infix 4 `eq` +eq :: TestData a => a -> Model a -> P a +eq x y = P (equal x (unmodel y)) + +class Conclusion p where + type Predicate p + + predicate :: Predicate p -> p -> p + +instance Conclusion Property where + type Predicate Property = Bool + + predicate = (==>) + +instance Conclusion p => Conclusion (a -> p) where + type Predicate (a -> p) = a -> Predicate p + + predicate f p = \x -> predicate (f x) (p x) + +infixr 0 ===> +(===>) :: TestData a => Predicate (EqTest a) -> P a -> P a +p ===> P a = P (predicate p a) + +notNull2 _ xs = not $ DVG.null xs +notNullS2 _ s = not $ S.null s + +-- Generators +index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)] +index_value_pairs 0 = return [] +index_value_pairs m = sized $ \n -> + do + len <- choose (0,n) + is <- sequence [choose (0,m-1) | i <- [1..len]] + xs <- vector len + return $ zip is xs + +indices :: Int -> Gen [Int] +indices 0 = return [] +indices m = sized $ \n -> + do + len <- choose (0,n) + sequence [choose (0,m-1) | i <- [1..len]] + + +-- Additional list functions +singleton x = [x] +snoc xs x = xs ++ [x] +generate n f = [f i | i <- [0 .. n-1]] +slice i n xs = take n (drop i xs) +backpermute xs is = map (xs!!) is +prescanl f z = init . scanl f z +postscanl f z = tail . scanl f z +prescanr f z = tail . scanr f z +postscanr f z = init . scanr f z + +accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a] +accum f xs ps = go xs ps' 0 + 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 [] _ _ = [] + +(//) :: [a] -> [(Int, a)] -> [a] +xs // ps = go xs ps' 0 + 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 [] _ _ = [] + + +withIndexFirst m f = m (uncurry f) . zip [0..] + +imap :: (Int -> a -> a) -> [a] -> [a] +imap = withIndexFirst map + +imapM :: Monad m => (Int -> a -> m a) -> [a] -> m [a] +imapM = withIndexFirst mapM + +imapM_ :: Monad m => (Int -> a -> m b) -> [a] -> m () +imapM_ = withIndexFirst mapM_ + +izipWith :: (Int -> a -> a -> a) -> [a] -> [a] -> [a] +izipWith = withIndexFirst zipWith + +izipWithM :: Monad m => (Int -> a -> a -> m a) -> [a] -> [a] -> m [a] +izipWithM = withIndexFirst zipWithM + +izipWithM_ :: Monad m => (Int -> a -> a -> m b) -> [a] -> [a] -> m () +izipWithM_ = withIndexFirst zipWithM_ + +izipWith3 :: (Int -> a -> a -> a -> a) -> [a] -> [a] -> [a] -> [a] +izipWith3 = withIndexFirst zipWith3 + +ifilter :: (Int -> a -> Bool) -> [a] -> [a] +ifilter f = map snd . withIndexFirst filter f + +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe f = catMaybes . map f + +imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b] +imapMaybe f = catMaybes . withIndexFirst map f + +indexedLeftFold fld f z = fld (uncurry . f) z . zip [0..] + +ifoldl :: (a -> Int -> a -> a) -> a -> [a] -> a +ifoldl = indexedLeftFold foldl + +iscanl :: (Int -> a -> b -> a) -> a -> [b] -> [a] +iscanl f z = scanl (\a (i, b) -> f i a b) z . zip [0..] + +iscanr :: (Int -> a -> b -> b) -> b -> [a] -> [b] +iscanr f z = scanr (uncurry f) z . zip [0..] + +ifoldr :: (Int -> a -> b -> b) -> b -> [a] -> b +ifoldr f z = foldr (uncurry f) z . zip [0..] + +ifoldM :: Monad m => (a -> Int -> a -> m a) -> a -> [a] -> m a +ifoldM = indexedLeftFold foldM + +ifoldM_ :: Monad m => (b -> Int -> a -> m b) -> b -> [a] -> m () +ifoldM_ = indexedLeftFold foldM_ + +minIndex :: Ord a => [a] -> Int +minIndex = fst . foldr1 imin . zip [0..] + where + imin (i,x) (j,y) | x <= y = (i,x) + | otherwise = (j,y) + +maxIndex :: Ord a => [a] -> Int +maxIndex = fst . foldr1 imax . zip [0..] + where + imax (i,x) (j,y) | x >= y = (i,x) + | otherwise = (j,y) + +iterateNM :: Monad m => Int -> (a -> m a) -> a -> m [a] +iterateNM n f x + | n <= 0 = return [] + | n == 1 = return [x] + | otherwise = do x' <- f x + xs <- iterateNM (n-1) f x' + return (x : xs) + +unfoldrM :: Monad m => (b -> m (Maybe (a,b))) -> b -> m [a] +unfoldrM step b0 = do + r <- step b0 + case r of + Nothing -> return [] + Just (a,b) -> do as <- unfoldrM step b + return (a : as) + + +limitUnfolds f (theirs, ours) + | ours >= 0 + , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) + | otherwise = Nothing |