aboutsummaryrefslogtreecommitdiffstats
path: root/tests/Properties.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--tests/Properties.hs166
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) ++ "%"
+
+------------------------------------------------------------------------