@@ -1,17 +1,73 @@
11module QuickCheckUtils where
22
3+import Data.List
4+import qualified Data.Text as T
5+import System.IO
6+import System.Random
37import Test.QuickCheck
4−import Test.QuickCheck.Batch
5−
6−import Data.Char
7−
8−import Data.Text
9−import Data.Text.Internal
108
119instance Arbitrary Char where
1210 arbitrary = oneof [choose ('\0','\55295'), choose ('\57334','\1114111')]
13− coarbitrary c = variant (ord c `rem` 4)
11+ coarbitrary c = variant (fromEnum c `rem` 4)
12+
13+instance Arbitrary T.Text where
14+ arbitrary = T.pack `fmap` arbitrary
15+ coarbitrary s = coarbitrary (T.unpack s)
16+
17+debug = False
18+
19+mytest :: Testable a => a -> Int -> IO (Bool, Int)
20+mytest a n = mycheck defaultConfig
21+ { configMaxTest=n
22+ , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
23+
24+mycheck :: Testable a => Config -> a -> IO (Bool, Int)
25+mycheck config a =
26+ do rnd <- newStdGen
27+ mytests config (evaluate a) rnd 0 0 []
28+
29+mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)
30+mytests config gen rnd0 ntest nfail stamps
31+ | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)
32+ | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)
33+ | otherwise =
34+ do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
35+ case ok result of
36+ Nothing ->
37+ mytests config gen rnd1 ntest (nfail+1) stamps
38+ Just True ->
39+ mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
40+ Just False ->
41+ putStr ( "Falsifiable after "
42+ ++ show ntest
43+ ++ " tests:\n"
44+ ++ unlines (arguments result)
45+ ) >> hFlush stdout >> return (False, ntest)
46+ where
47+ result = generate (configSize config ntest) rnd2 gen
48+ (rnd1,rnd2) = split rnd0
49+
50+done :: String -> Int -> [[String]] -> IO ()
51+done mesg ntest stamps =
52+ do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
53+ where
54+ table = display
55+ . map entry
56+ . reverse
57+ . sort
58+ . map pairLength
59+ . group
60+ . sort
61+ . filter (not . null)
62+ $ stamps
63+
64+ display [] = ".\n"
65+ display [x] = " (" ++ x ++ ").\n"
66+ display xs = ".\n" ++ unlines (map (++ ".") xs)
67+
68+ pairLength xss@(xs:_) = (length xss, xs)
69+ entry (n, xs) = percentage n ntest
70+ ++ " "
71+ ++ concat (intersperse ", " xs)
1472
15−instance Arbitrary Text where
16− arbitrary = pack `fmap` arbitrary
17− coarbitrary s = coarbitrary (unpack s)
73+ percentage n m = show ((100 * n) `div` m) ++ "%"