git.iko.soy/text
on 94df678 help sign in
text/tests/QuickCheckUtils.hs
120 lines 4.0 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
3module QuickCheckUtils where
5import Data.List
6import Data.Word
7import qualified Data.Text as T
8import System.IO
9import System.Random
10import Test.QuickCheck
11import qualified Data.ByteString as B
13integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
14integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
15 fromIntegral b :: Integer) g of
16 (x,g) -> (fromIntegral x, g)
18instance Random Word8 where
19 randomR = integralRandomR
20 random = randomR (minBound,maxBound)
22instance Arbitrary Word8 where
23 arbitrary = choose (minBound,maxBound)
24 coarbitrary c = variant (fromEnum c `rem` 4)
26instance Arbitrary B.ByteString where
27 arbitrary = B.pack `fmap` arbitrary
28 coarbitrary s = coarbitrary (B.unpack s)
30instance Random Word16 where
31 randomR = integralRandomR
32 random = randomR (minBound,maxBound)
34instance Arbitrary Word16 where
35 arbitrary = choose (minBound,maxBound)
36 coarbitrary c = variant (fromEnum c `rem` 4)
38instance Arbitrary Char where
39 arbitrary = oneof [choose ('\0','\55295'), choose ('\57334','\1114111')]
40 coarbitrary c = variant (fromEnum c `rem` 4)
42instance Arbitrary T.Text where
43 arbitrary = T.pack `fmap` arbitrary
44 coarbitrary s = coarbitrary (T.unpack s)
46newtype NotEmpty a = NotEmpty { notEmpty :: a }
47 deriving (Eq, Ord, Show)
49instance Functor NotEmpty where
50 fmap f (NotEmpty a) = NotEmpty (f a)
52instance Arbitrary a => Arbitrary (NotEmpty [a]) where
53 arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
54 coarbitrary = coarbitrary . notEmpty
56instance Arbitrary (NotEmpty T.Text) where
57 arbitrary = (fmap T.pack) `fmap` arbitrary
58 coarbitrary = coarbitrary . notEmpty
60instance Arbitrary (NotEmpty B.ByteString) where
61 arbitrary = (fmap B.pack) `fmap` arbitrary
62 coarbitrary = coarbitrary . notEmpty
64debug = False
66mytest :: Testable a => a -> Int -> IO (Bool, Int)
67mytest a n = mycheck defaultConfig
68 { configMaxTest=n
69 , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
71mycheck :: Testable a => Config -> a -> IO (Bool, Int)
72mycheck config a =
73 do rnd <- newStdGen
74 mytests config (evaluate a) rnd 0 0 []
76mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int)
77mytests config gen rnd0 ntest nfail stamps
78 | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest)
79 | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest)
80 | otherwise =
81 do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
82 case ok result of
83 Nothing ->
84 mytests config gen rnd1 ntest (nfail+1) stamps
85 Just True ->
86 mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
87 Just False ->
88 putStr ( "Falsifiable after "
89 ++ show ntest
90 ++ " tests:\n"
91 ++ unlines (arguments result)
92 ) >> hFlush stdout >> return (False, ntest)
93 where
94 result = generate (configSize config ntest) rnd2 gen
95 (rnd1,rnd2) = split rnd0
97done :: String -> Int -> [[String]] -> IO ()
98done mesg ntest stamps =
99 do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
100 where
101 table = display
102 . map entry
103 . reverse
104 . sort
105 . map pairLength
106 . group
107 . sort
108 . filter (not . null)
109 $ stamps
111 display [] = ".\n"
112 display [x] = " (" ++ x ++ ").\n"
113 display xs = ".\n" ++ unlines (map (++ ".") xs)
115 pairLength xss@(xs:_) = (length xss, xs)
116 entry (n, xs) = percentage n ntest
117 ++ " "
118 ++ concat (intersperse ", " xs)
120 percentage n m = show ((100 * n) `div` m) ++ "%"