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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}
{-# LANGUAGE
BangPatterns,
DataKinds,
DeriveGeneric,
ScopedTypeVariables,
TypeOperators,
RebindableSyntax,
TypeApplications #-}
import Control.Monad (replicateM)
import Control.Exception
import System.Exit (exitFailure)
import Data.Foldable (find, traverse_)
import Data.Maybe (catMaybes)
import GHC.Generics ( Generic )
import Test.QuickCheck (Arbitrary (..), Gen, sample, generate)
import Prelude
import Generic.Random
-- @T0@, @T1@: Override the @Int@ generator in the presence of a type parameter @a@.
-- Counterexample that's not supposed to type check.
-- Use BangPatterns so we can force it with just seq.
data T0 a = N0 !a !Int
deriving (Generic, Show)
instance Arbitrary a => Arbitrary (T0 a) where
arbitrary = genericArbitraryWith
(setGenerators customGens cohSizedOpts)
uniform
where
customGens :: Gen Int
customGens = pure 33
-- This one works.
data T1 a = N1 a Int
deriving (Generic, Show)
instance Arbitrary a => Arbitrary (T1 a) where
arbitrary = genericArbitraryWith
(setGenerators customGens cohSizedOpts)
uniform
where
customGens :: Incoherent (Gen a) :+ Gen Int
customGens = Incoherent arbitrary :+ pure 33
check1 :: T1 a -> Bool
check1 (N1 _ n) = n == 33
-- A bigger example to cover the remaining generator types.
data T2 a = N2
{ f2a :: a
, f2b :: Int
, f2c :: [Int]
, f2d :: Maybe Int
, f2e :: Int
, f2g :: Int
, f2h :: [a]
} deriving (Show, Generic)
instance Arbitrary a => Arbitrary (T2 a) where
arbitrary = genericArbitraryWith
(setGenerators customGens cohSizedOpts)
uniform
where
-- Hack to allow annotating each generator in the list while avoiding parentheses
(>>) = (:+)
customGens = do
Incoherent arbitrary :: Incoherent (Gen a)
Incoherent (FieldGen ((: []) <$> arbitrary))
:: Incoherent (FieldGen "f2h" [a])
Gen1_ (pure Nothing) :: Gen1_ Maybe
Gen1 (fmap (\x -> [x, x])) :: Gen1 []
ConstrGen (pure 88) :: ConstrGen "N2" 4 Int
FieldGen (pure 77) :: FieldGen "f2g" Int
pure 33 :: Gen Int
check2 :: T2 a -> Bool
check2 t =
f2b t == 33
&& length (f2c t) == 2
&& f2d t == Nothing
&& f2e t == 88
&& f2g t == 77
&& length (f2h t) == 1
type Error = String
expectTypeError :: IO a -> IO (Maybe Error)
expectTypeError gen = do
r <- try (gen >>= evaluate)
case r of
Left (e :: TypeError) -> pure Nothing -- success
Right _ -> (pure . Just) "Unexpected evaluation (expected a type error)"
sample_ :: Show a => (a -> Bool) -> Gen a -> IO (Maybe Error)
sample_ check g = do
xs <- generate (replicateM 100 g)
case find (not . check) xs of
Nothing -> pure Nothing
Just x -> (pure . Just) ("Invalid value: " ++ show x)
collectErrors :: [IO (Maybe Error)] -> IO ()
collectErrors xs = do
es <- sequence xs
case catMaybes es of
[] -> pure ()
es@(_ : _) -> do
putStrLn "Test failed. Errors:"
traverse_ putStrLn es
exitFailure
main :: IO ()
main = collectErrors
[ expectTypeError (generate (arbitrary :: Gen (T0 ())))
, sample_ check1 (arbitrary :: Gen (T1 ()))
, sample_ check2 (arbitrary :: Gen (T2 ()))
]
|
