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
|
{-# LANGUAGE DeriveFunctor #-}
-- | This QC doesn't shrink :(
module MiniQC where
import Control.Monad (ap)
import Data.Int (Int32, Int64)
import Data.Word (Word32, Word64)
import Test.Framework.Providers.API (Test, TestName)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (assertFailure)
import System.Random.SplitMix
newtype Gen a = Gen { unGen :: SMGen -> a }
deriving (Functor)
instance Applicative Gen where
pure x = Gen (const x)
(<*>) = ap
instance Monad Gen where
return = pure
m >>= k = Gen $ \g ->
let (g1, g2) = splitSMGen g
in unGen (k (unGen m g1)) g2
class Arbitrary a where
arbitrary :: Gen a
instance Arbitrary Word32 where
arbitrary = Gen $ \g -> fst (nextWord32 g)
instance Arbitrary Word64 where
arbitrary = Gen $ \g -> fst (nextWord64 g)
instance Arbitrary Int32 where
arbitrary = Gen $ \g -> fromIntegral (fst (nextWord32 g))
instance Arbitrary Int64 where
arbitrary = Gen $ \g -> fromIntegral (fst (nextWord64 g))
instance Arbitrary Double where
arbitrary = Gen $ \g -> fst (nextDouble g)
newtype Property = Property { unProperty :: Gen ([String], Bool) }
class Testable a where
property :: a -> Property
instance Testable Property where
property = id
instance Testable Bool where
property b = Property $ pure ([show b], b)
instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
property f = Property $ do
x <- arbitrary
(xs, b) <- unProperty (property (f x))
return (show x : xs, b)
forAllBlind :: Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind g f = Property $ do
x <- g
(xs, b) <- unProperty (property (f x))
return ("<blind>" : xs, b)
counterexample :: Testable prop => String -> prop -> Property
counterexample msg prop = Property $ do
(xs, b) <- unProperty (property prop)
return (msg : xs, b)
testMiniProperty :: Testable prop => TestName -> prop -> Test
testMiniProperty name prop = testCase name $ do
g <- newSMGen
go (100 :: Int) g
where
go n _ | n <= 0 = return ()
go n g = do
let (g1, g2) = splitSMGen g
case unGen (unProperty (property prop)) g1 of
(_, True) -> return ()
(xs, False) -> assertFailure (unlines (reverse xs))
go (pred n) g2
|
