[commit: dph] master: Prevent permute tests from exhausting. (7652618)

[Ben Lippmeier]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/dph

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/765261806b5f306d869578f35bc4c9143321adb6

>---------------------------------------------------------------

commit 765261806b5f306d869578f35bc4c9143321adb6
Author: George Roldugin <groldugin at cse.unsw.edu.au>
Date:   Mon May 30 08:44:24 2011 +1000

    Prevent permute tests from exhausting.

>---------------------------------------------------------------

 examples/quickcheck/Makefile                   |    7 +++-
 examples/quickcheck/Testsuite/Utils.hs         |   22 +---------------
 examples/quickcheck/tests/Unlifted_Permutes.hs |   32 ++++++++++++++---------
 3 files changed, 25 insertions(+), 36 deletions(-)

diff --git a/examples/quickcheck/Makefile b/examples/quickcheck/Makefile
index 27c74de..1345154 100644
--- a/examples/quickcheck/Makefile
+++ b/examples/quickcheck/Makefile
@@ -52,13 +52,16 @@ $(TEST_OBJS) : testsuite
 	@:
 
 %-unopt:
-	@echo "======== Testing  $(patsubst %-unopt,%,$@) (interpreted) ========"
+	@echo "======== Testing  $(patsubst %-unopt,%,$@) (parallel, interpreted) ========"
 	@$(HC) -e $(TESTMAIN) $(patsubst %-unopt,tests/%.hs,$@) $(HCFLAGS) $(PARFLAGS) \
 		| tee $@.log | { grep -v '\.\.\. pass' || true; }
+	@echo "======== Finished $(patsubst %-unopt,%,$@) (parallel, interpreted) ========"
+	@echo "======== Testing  $(patsubst %-unopt,%,$@) (sequential, interpreted) ========"
 	@$(HC) -e $(TESTMAIN) $(patsubst %-unopt,tests/%.hs,$@) $(HCFLAGS) $(SEQFLAGS) \
 		| tee $@.log | { grep -v '\.\.\. pass' || true; }
-	@echo "======== Finished $(patsubst %-unopt,%,$@) (interpreted) ========"
+	@echo "======== Finished $(patsubst %-unopt,%,$@) (sequential, interpreted) ========"
 
+# Throws warnings
 %-opt: tests/%-opt.o
 	@echo "======== Testing  $(patsubst %-opt,%,$@) (optimised) ========"
 	@$(HC) -o tst $(HCFLAGS) $(PARFLAGS) $< $(TESTSUITE_OBJS)
diff --git a/examples/quickcheck/Testsuite/Utils.hs b/examples/quickcheck/Testsuite/Utils.hs
index 7a28aeb..13b39f2 100644
--- a/examples/quickcheck/Testsuite/Utils.hs
+++ b/examples/quickcheck/Testsuite/Utils.hs
@@ -1,5 +1,5 @@
 module Testsuite.Utils (
-  Len(..), Perm(..), BPerm(..), DftPerm(..)
+  Len(..), Perm(..)
 
 --gvector, gdist, gtype, vtype
 ) where
@@ -23,12 +23,6 @@ newtype Len = Len Int deriving (Eq,Ord,Enum,Show,Num)
 -- permutation of [0..n-1] with all values appearing exactly once
 newtype Perm = Perm (Array Int) deriving (Eq,Show)
 
--- array of elements taken from [0..n-1]
-newtype BPerm = BPerm (Array Int) deriving (Eq,Show)
-
--- array of index-value pairs with indices taken from [0..n-1]
-newtype DftPerm a = DftPerm (Array (Int, a)) deriving (Eq, Show)
-
 {-
 instance Arbitrary Char where
   arbitrary   = fmap chr . sized $ \n -> choose (0,n)
@@ -47,15 +41,6 @@ instance Arbitrary Len where
 instance Arbitrary Perm where
   arbitrary   = Perm `fmap` (sized $ \n -> elements $ P.map fromList (permutations [0..n-1]))
 
-instance Arbitrary BPerm where
-  arbitrary   = sized $ \n -> (BPerm . fromList . P.map (`mod` n)) `fmap` enlarge n arbitrary
-  
-instance (Elt a, Arbitrary a) => Arbitrary (DftPerm a) where
-  arbitrary   = do
-                  BPerm idxs <- arbitrary                        -- :: Gen BPerm
-                  vals       <- sized $ \n -> enlarge n arbitrary -- :: Gen (Array a)
-                  return $ DftPerm (U.zip idxs vals)
-
 {-
 instance Arbitrary a => Arbitrary (MaybeS a) where
   arbitrary = frequency [(1, return NothingS), (3, liftM JustS arbitrary)]
@@ -76,11 +61,6 @@ instance Arbitrary Gang where
   coarbitrary = coarbitrary . gangSize
 -}
 
--- wrapper to Test.QuickCheck.resize facilitating the generation of
--- longer permutations while keeping indices within bounds
-enlarge n = resize $ case n of 0 -> 0    -- potential corner cases
-                               1 -> 1    -- these too
-                               n -> 2*n
 {-
 gvector :: Arbitrary a => Gang -> Gen [a]
 gvector = vector . gangSize
diff --git a/examples/quickcheck/tests/Unlifted_Permutes.hs b/examples/quickcheck/tests/Unlifted_Permutes.hs
index 6037080..c113012 100644
--- a/examples/quickcheck/tests/Unlifted_Permutes.hs
+++ b/examples/quickcheck/tests/Unlifted_Permutes.hs
@@ -15,23 +15,29 @@ $(testcases [ ""        <@ [t| ( Bool, Int ) |]
   prop_permute arr (Perm is) = (U.length arr == U.length is)
     ==> permute arr is == U.map (arr!:) is
                   
-  prop_bpermute :: (Elt a, Eq a) => Array a -> BPerm -> Property
-  prop_bpermute arr (BPerm is) =
-    (is == empty) || (maximum $ toList is) < U.length arr
-    ==> bpermute arr is == U.map (arr!:) is
+  prop_bpermute :: (Elt a, Eq a) => Array a -> Array Int -> Bool
+  prop_bpermute arr ixs = 
+    bpermute arr ixs' == U.map (arr!:) ixs'
+    where ixs' = if U.length arr == 0 then empty -- no permutations for an empty array
+                                      else U.map (`mod` (U.length arr)) ixs
 
-  prop_mbpermute :: (Elt a, Eq b, Elt b) => (a -> b) -> Array a -> BPerm -> Property
-  prop_mbpermute f arr (BPerm is) =
-    (is == empty) || (maximum $ toList is) < U.length arr
-    ==> mbpermute f arr is == U.map (\i -> f (arr!:i)) is
+  prop_mbpermute :: (Elt a, Eq b, Elt b) => (a -> b) -> Array a -> Array Int -> Bool
+  prop_mbpermute f arr ixs =
+    mbpermute f arr ixs' == U.map (\i -> f (arr!:i)) ixs'
+    where ixs' = if U.length arr == 0 then empty -- no permutations for an empty array
+                                      else U.map (`mod` (U.length arr)) ixs
 
-  prop_bpermuteDft :: (Elt a, Eq a) => Len -> (Int -> a) -> DftPerm a -> Property
-  prop_bpermuteDft (Len n) init (DftPerm pairs) =
-    (pairs == empty) || (maximum (toList $ fsts pairs) < n)
-    ==> toList (bpermuteDft n init pairs) == update (P.map init [0..n-1]) (toList pairs)
-    where set xs i x = (P.take i xs) ++ [x] ++ (P.drop (i+1) xs)
+  prop_bpermuteDft :: (Elt a, Eq a) => Len -> (Int -> a) -> Array (Int, a) -> Bool
+  prop_bpermuteDft (Len n) init pairs =
+    toList (bpermuteDft n init pairs') == update (P.map init [0..n-1]) (toList pairs')
+    where
        -- update :: [a] -> [(Int, a)] -> [a]
           update xs []         = xs
           update xs ((i,x):ps) = update (set xs i x) ps
+       -- set :: [a] -> Int -> a -> [a]
+          set xs i x = (P.take i xs) ++ [x] ++ (P.drop (i+1) xs)
+
+          pairs' = if n <= 0 then U.zip empty empty
+                             else U.map (\(i,x) -> (i `mod` n, x)) pairs
  |])