diff options
| -rw-r--r-- | tests/Properties.hs | 166 |
1 files changed, 166 insertions, 0 deletions
diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 index 0000000..715cf8e --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,166 @@ + +import StackSet + +import System.Environment +import Control.Exception (assert) +import Control.Monad +import Test.QuickCheck +import System.IO +import System.Random +import Text.Printf +import Data.List (sort,group,sort,intersperse) + +-- --------------------------------------------------------------------- +-- QuickCheck properties for the StackSet + +-- | Height of stack 'n' +height :: Int -> StackSet a -> Int +height i w = case index w i of + Nothing -> error $ "height: i out of range: " ++ show i + Just ss -> length ss + +-- build (non-empty) StackSets with between 1 and 100 stacks +instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where + arbitrary = do + sz <- choose (1,20) + n <- choose (0,sz-1) + ls <- vector sz + return $ fromList (n,ls) + coarbitrary = error "no coarbitrary for StackSet" + +prop_id x = fromList (toList x) == x + where _ = x :: StackSet Int + +prop_uniq_pushpop i x = not (member i x) ==> + (pop . push i) x == x + where _ = x :: StackSet Int + +prop_pushpop i x = + (pop . push i) x == delete i x + where _ = x :: StackSet Int + +-- popping an empty stack leaves an empty stack +prop_popempty x = height (cursor x) x == 0 ==> pop x == x + where _ = x :: StackSet Int + +prop_popone x = + let l = height (cursor x) x + in l > 0 ==> height (cursor x) (pop x) == l-1 + where _ = x :: StackSet Int + +prop_delete_uniq i x = not (member i x) ==> + delete i x == x + where _ = x :: StackSet Int + +prop_delete2 i x = + delete i x == delete i (delete i x) + where _ = x :: StackSet Int + +prop_uniq_insertdelete i n x = not (member i x) ==> + delete i (insert i n x) == x + where _ = x :: StackSet Int + +prop_insertdelete i n x = + delete i (insert i n x) == delete i x + where _ = x :: StackSet Int + +prop_rotaterotate x = rotate LT (rotate GT x) == x + where _ = x :: StackSet Int + +prop_viewview r x = + let n = cursor x + sz = size x + i = r `mod` sz + in + view n (view i x) == x + + where _ = x :: StackSet Int + +prop_shiftshift r x = + let n = cursor x + in + shift n (shift r x) == x + where _ = x :: StackSet Int + +------------------------------------------------------------------------ + +main :: IO () +main = do + args <- getArgs + let n = if null args then 100 else read (head args) + mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests + where + n = 100 + + tests = + [("fromList.toList ", mytest prop_id) + ,("pop/push ", mytest prop_uniq_pushpop) + ,("pop/push/delete ", mytest prop_pushpop) + ,("pop/empty ", mytest prop_popempty) + ,("delete/not.member", mytest prop_delete_uniq) + ,("delete idempotent", mytest prop_delete2) + ,("delete/insert new", mytest prop_uniq_insertdelete) + ,("delete/insert ", mytest prop_insertdelete) + ,("rotate/rotate ", mytest prop_rotaterotate) + ,("pop one ", mytest prop_popone) + ,("view/view ", mytest prop_viewview) + ] + +debug = False + +mytest :: Testable a => a -> Int -> IO () +mytest a n = mycheck defaultConfig + { configMaxTest=n + , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + +mycheck :: Testable a => Config -> a -> IO () +mycheck config a = do + rnd <- newStdGen + mytests config (evaluate a) rnd 0 0 [] + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +mytests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = do done "OK," ntest stamps + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | otherwise = + do putStr (configEvery config ntest (arguments result)) >> hFlush stdout + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + putStr ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) >> hFlush stdout + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +------------------------------------------------------------------------ |