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
|
{-# LANGUAGE
DataKinds,
DeriveGeneric,
FlexibleContexts,
FlexibleInstances,
LambdaCase,
TypeFamilies,
UndecidableInstances #-}
import Control.Monad (replicateM)
import Control.DeepSeq (NFData, force)
import GHC.Generics (Generic)
import System.Timeout (timeout)
import Test.QuickCheck
import Generic.Random
-- Binary trees
data B = BL | BN B B
deriving (Eq, Ord, Show, Generic)
size :: B -> Int
size (BN l r) = 1 + size l + size r
size BL = 0
instance Arbitrary B where
arbitrary = genericArbitrary ((9 :: W "BL") % (3 :: W "BN") % ())
instance NFData B
-- Messing with base cases
newtype T a = W a deriving (Generic, Show)
instance (Arbitrary a, BaseCase (T a)) => Arbitrary (T a) where
arbitrary = genericArbitrary' uniform
instance NFData a => NFData (T a)
-- Rose tree for testing the custom list generator that's inserted by default.
data NTree = Leaf | Node [NTree] deriving (Generic, Show)
instance Arbitrary NTree where
arbitrary = genericArbitraryU'
instance NFData NTree
eval :: NFData a => String -> Gen a -> IO ()
eval name g = do
x <- timeout (10 ^ (6 :: Int)) $ do
xs <- generate (replicateM 100 g)
return $! force xs
case x of
Just _ -> return ()
Nothing -> fail $ name ++ ": did not finish on time"
-- Tests for ConstrGen
data Tree2 = Leaf2 Int | Node2 Tree2 Tree2 deriving (Generic, Show)
instance Arbitrary Tree2 where
arbitrary = genericArbitraryUG (ConstrGen (Leaf2 <$> arbitrary) :: ConstrGen "Node2" 1 Tree2)
isLeftBiased :: Tree2 -> Bool
isLeftBiased (Leaf2 _) = True
isLeftBiased (Node2 t (Leaf2 _)) = isLeftBiased t
isLeftBiased _ = False
main :: IO ()
main = do
eval "B" (arbitrary :: Gen B)
eval "T" (arbitrary :: Gen (T (T Int)))
eval "NTree" (arbitrary :: Gen NTree)
quickCheck . whenFail (putStrLn "Tree2") $ isLeftBiased
|
