-
Notifications
You must be signed in to change notification settings - Fork 158
/
QuickCheckUtils.hs
111 lines (90 loc) · 3.58 KB
/
QuickCheckUtils.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
{-# LANGUAGE FlexibleInstances #-}
module QuickCheckUtils where
import Data.List
import Data.Word
import qualified Data.Text as T
import System.IO
import System.Random
import Test.QuickCheck
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
fromIntegral b :: Integer) g of
(x,g) -> (fromIntegral x, g)
instance Random Word8 where
randomR = integralRandomR
random = randomR (minBound,maxBound)
instance Arbitrary Word8 where
arbitrary = choose (minBound,maxBound)
coarbitrary c = variant (fromEnum c `rem` 4)
instance Random Word16 where
randomR = integralRandomR
random = randomR (minBound,maxBound)
instance Arbitrary Word16 where
arbitrary = choose (minBound,maxBound)
coarbitrary c = variant (fromEnum c `rem` 4)
instance Arbitrary Char where
arbitrary = oneof [choose ('\0','\55295'), choose ('\57334','\1114111')]
coarbitrary c = variant (fromEnum c `rem` 4)
instance Arbitrary T.Text where
arbitrary = T.pack `fmap` arbitrary
coarbitrary s = coarbitrary (T.unpack s)
newtype NotEmpty a = NotEmpty { notEmpty :: a }
deriving (Eq, Ord, Show)
instance Functor NotEmpty where
fmap f (NotEmpty a) = NotEmpty (f a)
instance Arbitrary a => Arbitrary (NotEmpty [a]) where
arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
coarbitrary = coarbitrary . notEmpty
instance Arbitrary (NotEmpty T.Text) where
arbitrary = (fmap T.pack) `fmap` arbitrary
coarbitrary = coarbitrary . notEmpty
debug = False
mytest :: Testable a => a -> Int -> IO (Bool, Int)
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 (Bool, Int)
mycheck config a =
do rnd <- newStdGen
mytests config (evaluate a) rnd 0 0 []
mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)
mytests config gen rnd0 ntest nfail stamps
| ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)
| nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)
| 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 >> return (False, ntest)
where
result = generate (configSize config ntest) rnd2 gen
(rnd1,rnd2) = split rnd0
done :: String -> Int -> [[String]] -> IO ()
done mesg ntest stamps =
do 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) ++ "%"