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