Big refactoring to testsuite, test more properties
authorMax Bolingbroke <batterseapower@hotmail.com>
Sun, 8 Feb 2009 23:14:47 +0000 (23:14 +0000)
committerMax Bolingbroke <batterseapower@hotmail.com>
Sun, 8 Feb 2009 23:14:47 +0000 (23:14 +0000)
tests/Properties.hs
tests/Utilities.hs
tests/vector-tests.cabal

index c717f66..f4e1faa 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, Rank2Types, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, FlexibleContexts, Rank2Types, ScopedTypeVariables, PatternGuards #-}
 
 module Properties (tests) where
 
@@ -7,6 +7,7 @@ import Utilities
 import qualified Data.Vector.IVector as V
 import qualified Data.Vector
 import qualified Data.Vector.Unboxed
+import qualified Data.Vector.Fusion.Stream as S
 
 import Test.QuickCheck
 
@@ -14,21 +15,41 @@ import Test.Framework
 import Test.Framework.Providers.QuickCheck
 
 import Text.Show.Functions
-import Data.List (foldl', foldl1', unfoldr)
+import Data.List (foldl', foldl1', unfoldr, find, findIndex)
 
-testVersusLists :: forall a v.
-                    (Eq a,     Ord a,
-                     Eq (v a), Ord (v a),
-                     Show a,        Arbitrary a,        Model a a,
-                     -- This would be slightly nicer if we could put forall quantifiers in the class requirements!
-                     Show (v a),    Arbitrary (v a),    Model (v a) [a],       V.IVector v a,
-                     Show (v Bool), Arbitrary (v Bool), Model (v Bool) [Bool], V.IVector v Bool)
-                     => v a
-                     -> [Test]
+#define HUGE_CLASS_CONTEXT(a, v) \
+  Enum a, \
+  Eq a,     Ord a, \
+  Eq (v a), Ord (v a), \
+  Show a,        Arbitrary a,        Model a a, \
+  Show (v a),    Arbitrary (v a),    Model (v a) [a],       V.IVector v a, \
+  Show (v Bool), Arbitrary (v Bool), Model (v Bool) [Bool], V.IVector v Bool
+
+
+testVectorType :: forall a v. (HUGE_CLASS_CONTEXT(a, v)) => v a -> [Test]
+testVectorType dummy = [
+        testGroup "Sanity checks"                (testSanity dummy),
+        testGroup "Semantics should match lists" (testVersusLists dummy),
+        testGroup "Non-list functions correct"   (testExtraFunctions dummy)
+    ]
+
+testSanity :: forall a v. (HUGE_CLASS_CONTEXT(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.Stream a) = ((V.stream :: v a -> S.Stream a) . V.unstream) s == s
+
+testVersusLists :: forall a v. (HUGE_CLASS_CONTEXT(a, v)) => v a -> [Test]
 testVersusLists _ = [
         testGroup "Prelude"   prelude_tests,
-        testGroup "Data.List" data_list_tests,
-        testGroup "Extras"    extra_tests
+        testGroup "Data.List" data_list_tests
     ]
   where
     prelude_tests = [
@@ -43,6 +64,7 @@ testVersusLists _ = [
             testProperty "(++)"         prop_append,
             --testProperty "break"        prop_break,
             testProperty "concatMap"    prop_concatMap,
+            testProperty "[]"           prop_empty,
             testProperty "(:)"          prop_cons,
             testProperty "drop"         prop_drop,
             testProperty "dropWhile"    prop_dropWhile,
@@ -50,6 +72,7 @@ testVersusLists _ = [
             testProperty "takeWhile"    prop_takeWhile,
             testProperty "filter"       prop_filter,
             testProperty "map"          prop_map,
+            testProperty "zipWith"      prop_zipWith,
             testProperty "replicate"    prop_replicate,
             --testProperty "span"         prop_span,
             --testProperty "splitAt"      prop_splitAt,
@@ -84,6 +107,7 @@ testVersusLists _ = [
     prop_append       = ((V.++) :: v a -> v a -> v a)                 `eq2` (++)
     --prop_break        = (V.break :: (a -> Bool) -> v a -> (v a, v a)) `eq2` break
     prop_concatMap    = (V.concatMap :: (a -> v a) -> v a -> v a)     `eq2` concatMap
+    prop_empty        = (V.empty :: v a)                              `eq0` []
     prop_cons         = (V.cons :: a -> v a -> v a)                   `eq2` (:)
     prop_drop         = (V.drop :: Int -> v a -> v a)                 `eq2` drop
     prop_dropWhile    = (V.dropWhile :: (a -> Bool) -> v a -> v a)    `eq2` dropWhile
@@ -91,6 +115,7 @@ testVersusLists _ = [
     prop_takeWhile    = (V.takeWhile :: (a -> Bool) -> v a -> v a)    `eq2` takeWhile
     prop_filter       = (V.filter :: (a -> Bool) -> v a -> v a)       `eq2` filter
     prop_map          = (V.map :: (a -> a) -> v a -> v a)             `eq2` map
+    prop_zipWith      = (V.zipWith :: (a -> a -> a) -> v a -> v a -> v a) `eq3` zipWith
     prop_replicate    = (V.replicate :: Int -> a -> v a)              `eq2` replicate
     --prop_span         = (V.span :: (a -> Bool) -> v a -> (v a, v a))  `eq2` span
     --prop_splitAt      = (V.splitAt :: Int -> v a -> (v a, v a))       `eq2` splitAt
@@ -109,18 +134,20 @@ testVersusLists _ = [
     --prop_minimum      = (V.minimum :: v a -> a)                       `eqNotNull1` minimum
     prop_eq           = ((==) :: v a -> v a -> Bool)                  `eq2` (==)
     prop_compare      = (compare :: v a -> v a -> Ordering)           `eq2` compare
+    prop_enumFromTo   = (V.enumFromTo :: a -> a -> v a)               `eq2` enumFromTo
+    prop_enumFromThenTo = (V.enumFromThenTo :: a -> a -> a -> v a)    `eq3` enumFromThenTo
     
     data_list_tests = [
             testProperty "foldl'"       prop_foldl',
             testProperty "foldl1'"      prop_foldl1',
-            testProperty "unfoldr"      prop_unfoldr
+            testProperty "unfoldr"      prop_unfoldr,
+            testProperty "find"         prop_find,
+            testProperty "findIndex"    prop_findIndex
             --testProperty "transpose"    prop_transpose,
             --testProperty "group"        prop_group,
             --testProperty "inits"        prop_inits,
             --testProperty "tails"        prop_tails,
-            --testProperty "find"         prop_find,
             --testProperty "findIndices"  prop_findIndices,
-            --testProperty "findIndex"    prop_findIndex,
             --testProperty "isPrefixOf"   prop_isPrefixOf,
             --testProperty "elemIndex"    prop_elemIndex,
             --testProperty "elemIndices"  prop_elemIndices,
@@ -129,15 +156,15 @@ testVersusLists _ = [
         ]
     
     -- TODO: implement Vector equivalents for some of the commented out list functions from Data.List
-    prop_foldl'       = (V.foldl' :: (a -> a -> a) -> a -> v a -> a)  `eq3` foldl'
-    prop_foldl1'      = (V.foldl1' :: (a -> a -> a) -> v a -> a)      `eqNotNull2` foldl1'
+    prop_foldl'       = (V.foldl' :: (a -> a -> a) -> a -> v a -> a)     `eq3` foldl'
+    prop_foldl1'      = (V.foldl1' :: (a -> a -> a) -> v a -> a)         `eqNotNull2` foldl1'
+    prop_find         = (V.find :: (a -> Bool) -> v a -> Maybe a)        `eq2` find
+    prop_findIndex    = (V.findIndex :: (a -> Bool) -> v a -> Maybe Int) `eq2` findIndex
     --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])
-    --prop_find         = V.find        `eq2` (find        :: (a -> Bool) -> v a -> Maybe a)
     --prop_findIndices  = V.findIndices `eq2` (findIndices :: (a -> Bool) -> v a -> [Int])
-    --prop_findIndex    = V.findIndex   `eq2` (findIndex   :: (a -> Bool) -> v a -> Maybe 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 -> [Int])
@@ -158,16 +185,33 @@ testVersusLists _ = [
     prop_unfoldr      = ((\n f a -> V.unfoldr (limitUnfolds f) (a, n)) :: Int -> ((Int, Int) -> Maybe (a, (Int, Int))) -> (Int, Int) -> v a)
                         `eq3` (\n f a -> unfoldr (limitUnfolds f) (a, n))
 
-    extra_tests = [
-            testProperty "snoc"         prop_snoc
-        ]
-
-    -- TODO: add tests for the other extra functions
+testExtraFunctions :: forall a v. (HUGE_CLASS_CONTEXT(a, v)) => v a -> [Test]
+testExtraFunctions _ =  [
+        testProperty "singleton"    prop_singleton,
+        testProperty "snoc"         prop_snoc
+    ]
+  where
+    singleton x = [x]
+    prop_singleton = (V.singleton :: a -> v a) `eq1` singleton
+    
     snoc xs x = xs ++ [x]
-    prop_snoc = (V.snoc :: v a -> a -> v a)                   `eq2` snoc
+    prop_snoc = (V.snoc :: v a -> a -> v a) `eq2` snoc
+    
+    -- TODO: add tests for the other extra functions
+    -- IVector exports still needing tests:
+    --  copy,
+    --  (!),
+    --  slice,
+    --  (//), update, bpermute,
+    --  zip,
+    --  prescanl, prescanl',
+    --  new,
+    --  unsafeSlice, unsafeIndex,
+    --  vlength, vnew
 
+-- TODO: test non-IVector stuff?
 tests = [
-        testGroup "Data.Vector.Vector"                (testVersusLists (undefined :: Data.Vector.Vector Int)),
-        testGroup "Data.Vector.Unboxed.Vector (Int)"  (testVersusLists (undefined :: Data.Vector.Unboxed.Vector Int)),
-        testGroup "Data.Vector.Unboxed.Vector (Bool)" (testVersusLists (undefined :: Data.Vector.Unboxed.Vector Bool))
+        testGroup "Data.Vector.Vector"                (testVectorType (undefined :: Data.Vector.Vector Int)),
+        testGroup "Data.Vector.Unboxed.Vector (Int)"  (testVectorType (undefined :: Data.Vector.Unboxed.Vector Int)),
+        testGroup "Data.Vector.Unboxed.Vector (Bool)" (testVectorType (undefined :: Data.Vector.Unboxed.Vector Bool))
     ]
\ No newline at end of file
index 671a1cf..83490db 100644 (file)
@@ -1,31 +1,40 @@
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, UndecidableInstances #-}
 
 module Utilities where
 
 import Test.QuickCheck
 
 import qualified Data.Vector as DV
-import qualified Data.Vector.Unboxed as DVU
 import qualified Data.Vector.IVector as DVI
-import Data.Vector.Unboxed.Unbox (Unbox)
+import qualified Data.Vector.Unboxed as DVU
+import qualified Data.Vector.Unboxed.Unbox as DVUU
+import qualified Data.Vector.Fusion.Stream as S
+
+
+instance Show a => Show (S.Stream a) where
+    show s = "Data.Vector.Fusion.Stream.fromList " ++ show (S.toList s)
 
 
 instance Arbitrary a => Arbitrary (DV.Vector a) where
     arbitrary = fmap DV.fromList arbitrary
     coarbitrary = coarbitrary . DV.toList
 
-instance (Arbitrary a, Unbox a) => Arbitrary (DVU.Vector a) where
+instance (Arbitrary a, DVUU.Unbox a) => Arbitrary (DVU.Vector a) where
     arbitrary = fmap DVU.fromList arbitrary
     coarbitrary = coarbitrary . DVU.toList
 
+instance Arbitrary a => Arbitrary (S.Stream a) where
+    arbitrary = fmap S.fromList arbitrary
+    coarbitrary = coarbitrary . S.toList
+
 
 class Model a b | a -> b where
   -- | Convert a concrete value into an abstract model
   model :: a -> b
 
 -- The meat of the models
-instance            Model (DV.Vector a)  [a] where model = DV.toList
-instance Unbox a => Model (DVU.Vector a) [a] where model = DVU.toList
+instance                 Model (DV.Vector a)  [a] where model = DV.toList
+instance DVUU.Unbox a => Model (DVU.Vector a) [a] where model = DVU.toList
 
 -- Identity models
 instance Model Bool     Bool     where model = id
@@ -39,6 +48,7 @@ instance (Model a c, Model b d) => Model (a, b) (c, d)       where model (a, b)
 instance (Model c a, Model b d) => Model (a -> b) (c -> d)   where model f = model . f . model
 
 
+eq0 f g =           model f         == g
 eq1 f g = \a     -> model (f a)     == g (model a)
 eq2 f g = \a b   -> model (f a b)   == g (model a) (model b)
 eq3 f g = \a b c -> model (f a b c) == g (model a) (model b) (model c)
index 52ca0d7..7b9b5c5 100644 (file)
@@ -17,12 +17,18 @@ Build-Type:     Simple
 Executable "vector-tests"
   Main-Is:  Main.hs
 
-  Extensions: ScopedTypeVariables,
+  Extensions: CPP,
+              ScopedTypeVariables,
+              PatternGuards,
               MultiParamTypeClasses,
               FlexibleContexts,
               Rank2Types,
               FunctionalDependencies,
+              TypeSynonymInstances,
               UndecidableInstances
 
   Build-Depends: base, vector, QuickCheck,
-                 test-framework, test-framework-quickcheck
\ No newline at end of file
+                 test-framework, test-framework-quickcheck
+
+  -- Don't let fusion occur or GHC will make our tests less informative in some cases :-)
+  Ghc-Options: -O0
\ No newline at end of file