Source file quickcheck.ml
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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
open! Import
open Quickcheck_intf
open Base_quickcheck
module Float = Base.Float
module Int = Base.Int
module List = Base.List
module Option = Base.Option
module Set = Base.Set
module Sexp = Base.Sexp
module Polymorphic_types = struct
type ('a, 'b) variant2 =
[ `A of 'a
| `B of 'b
]
[@@deriving quickcheck]
type ('a, 'b, 'c) variant3 =
[ `A of 'a
| `B of 'b
| `C of 'c
]
[@@deriving quickcheck]
type ('a, 'b, 'c, 'd) variant4 =
[ `A of 'a
| `B of 'b
| `C of 'c
| `D of 'd
]
[@@deriving quickcheck]
type ('a, 'b, 'c, 'd, 'e) variant5 =
[ `A of 'a
| `B of 'b
| `C of 'c
| `D of 'd
| `E of 'e
]
[@@deriving quickcheck]
type ('a, 'b, 'c, 'd, 'e, 'f) variant6 =
[ `A of 'a
| `B of 'b
| `C of 'c
| `D of 'd
| `E of 'e
| `F of 'f
]
[@@deriving quickcheck]
type ('a, 'b) tuple2 = 'a * 'b [@@deriving quickcheck]
type ('a, 'b, 'c) tuple3 = 'a * 'b * 'c [@@deriving quickcheck]
type ('a, 'b, 'c, 'd) tuple4 = 'a * 'b * 'c * 'd [@@deriving quickcheck]
type ('a, 'b, 'c, 'd, 'e) tuple5 = 'a * 'b * 'c * 'd * 'e [@@deriving quickcheck]
type ('a, 'b, 'c, 'd, 'e, 'f) tuple6 = 'a * 'b * 'c * 'd * 'e * 'f
[@@deriving quickcheck]
type (-'a, -'b, 'r) fn2 = 'a -> 'b -> 'r [@@deriving quickcheck]
type (-'a, -'b, -'c, 'r) fn3 = 'a -> 'b -> 'c -> 'r [@@deriving quickcheck]
type (-'a, -'b, -'c, -'d, 'r) fn4 = 'a -> 'b -> 'c -> 'd -> 'r [@@deriving quickcheck]
type (-'a, -'b, -'c, -'d, -'e, 'r) fn5 = 'a -> 'b -> 'c -> 'd -> 'e -> 'r
[@@deriving quickcheck]
type (-'a, -'b, -'c, -'d, -'e, -'f, 'r) fn6 = 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'r
[@@deriving quickcheck]
end
module Observer = struct
include Observer
let of_hash (type a) (module M : Deriving_hash with type t = a) =
of_hash_fold M.hash_fold_t
;;
let variant2 = Polymorphic_types.quickcheck_observer_variant2
let variant3 = Polymorphic_types.quickcheck_observer_variant3
let variant4 = Polymorphic_types.quickcheck_observer_variant4
let variant5 = Polymorphic_types.quickcheck_observer_variant5
let variant6 = Polymorphic_types.quickcheck_observer_variant6
let tuple2 = Polymorphic_types.quickcheck_observer_tuple2
let tuple3 = Polymorphic_types.quickcheck_observer_tuple3
let tuple4 = Polymorphic_types.quickcheck_observer_tuple4
let tuple5 = Polymorphic_types.quickcheck_observer_tuple5
let tuple6 = Polymorphic_types.quickcheck_observer_tuple6
let of_predicate a b ~f = unmap (variant2 a b) ~f:(fun x -> if f x then `A x else `B x)
let singleton () = opaque
let doubleton f = of_predicate (singleton ()) (singleton ()) ~f
let enum _ ~f = unmap int ~f
let of_list list ~equal =
let f x =
match List.findi list ~f:(fun _ y -> equal x y) with
| None -> failwith "Quickcheck.Observer.of_list: value not found"
| Some (i, _) -> i
in
enum (List.length list) ~f
;;
let of_fun f = create (fun x ~size ~hash -> observe (f ()) x ~size ~hash)
let comparison ~compare ~eq ~lt ~gt =
unmap
(variant3 lt (singleton ()) gt)
~f:(fun x ->
let c = compare x eq in
if c < 0 then `A x else if c > 0 then `C x else `B x)
;;
end
module Generator = struct
include Generator
open Let_syntax
let singleton = return
let doubleton x y =
create (fun ~size:_ ~random -> if Splittable_random.bool random then x else y)
;;
let of_fun f = create (fun ~size ~random -> generate (f ()) ~size ~random)
let of_sequence ~p seq =
if Float.( <= ) p 0. || Float.( > ) p 1.
then
failwith (Printf.sprintf "Generator.of_sequence: probability [%f] out of bounds" p);
Sequence.delayed_fold
seq
~init:()
~finish:(fun () -> failwith "Generator.of_sequence: ran out of values")
~f:(fun () x ~k -> weighted_union [ p, singleton x; 1. -. p, of_fun k ])
;;
let geometric = Generator.int_geometric
let small_non_negative_int = small_positive_or_zero_int
let small_positive_int = small_strictly_positive_int
let list_with_length length t = list_with_length t ~length
let variant2 = Polymorphic_types.quickcheck_generator_variant2
let variant3 = Polymorphic_types.quickcheck_generator_variant3
let variant4 = Polymorphic_types.quickcheck_generator_variant4
let variant5 = Polymorphic_types.quickcheck_generator_variant5
let variant6 = Polymorphic_types.quickcheck_generator_variant6
let tuple2 = Polymorphic_types.quickcheck_generator_tuple2
let tuple3 = Polymorphic_types.quickcheck_generator_tuple3
let tuple4 = Polymorphic_types.quickcheck_generator_tuple4
let tuple5 = Polymorphic_types.quickcheck_generator_tuple5
let tuple6 = Polymorphic_types.quickcheck_generator_tuple6
let fn2 = Polymorphic_types.quickcheck_generator_fn2
let fn3 = Polymorphic_types.quickcheck_generator_fn3
let fn4 = Polymorphic_types.quickcheck_generator_fn4
let fn5 = Polymorphic_types.quickcheck_generator_fn5
let fn6 = Polymorphic_types.quickcheck_generator_fn6
let compare_fn dom =
fn dom int >>| fun get_index x y -> [%compare: int] (get_index x) (get_index y)
;;
let equal_fn dom = compare_fn dom >>| fun cmp x y -> Int.( = ) (cmp x y) 0
end
module Shrinker = struct
include Shrinker
let empty () = atomic
let variant2 = Polymorphic_types.quickcheck_shrinker_variant2
let variant3 = Polymorphic_types.quickcheck_shrinker_variant3
let variant4 = Polymorphic_types.quickcheck_shrinker_variant4
let variant5 = Polymorphic_types.quickcheck_shrinker_variant5
let variant6 = Polymorphic_types.quickcheck_shrinker_variant6
let tuple2 = Polymorphic_types.quickcheck_shrinker_tuple2
let tuple3 = Polymorphic_types.quickcheck_shrinker_tuple3
let tuple4 = Polymorphic_types.quickcheck_shrinker_tuple4
let tuple5 = Polymorphic_types.quickcheck_shrinker_tuple5
let tuple6 = Polymorphic_types.quickcheck_shrinker_tuple6
end
module Let_syntax = struct
module Let_syntax = struct
include Generator
module Open_on_rhs = Generator
end
include Generator.Monad_infix
let return = Generator.return
end
module Configure (Config : Quickcheck_config) = struct
include Config
let nondeterministic_state = lazy (Random.State.make_self_init ())
let random_state_of_seed seed =
match seed with
| `Nondeterministic -> Splittable_random.State.create (force nondeterministic_state)
| `Deterministic str -> Splittable_random.State.of_int ([%hash: string] str)
;;
let make_seed seed : Test.Config.Seed.t =
match seed with
| `Nondeterministic -> Nondeterministic
| `Deterministic string -> Deterministic string
;;
let make_shrink_count = function
| `Exhaustive -> Int.max_value
| `Limit n -> n
;;
let make_config ~seed ~sizes ~trials ~shrink_attempts : Test.Config.t =
{ seed = make_seed (Option.value seed ~default:default_seed)
; sizes = Option.value sizes ~default:default_sizes
; test_count = Option.value trials ~default:default_trial_count
; shrink_count =
make_shrink_count (Option.value shrink_attempts ~default:default_shrink_attempts)
}
;;
let make_test_m (type a) ~gen ~shrinker ~sexp_of : (module Test.S with type t = a) =
let module M = struct
type t = a
let quickcheck_generator = gen
let quickcheck_shrinker = Option.value shrinker ~default:Shrinker.atomic
let sexp_of_t = Option.value sexp_of ~default:[%sexp_of: _]
end
in
(module M)
;;
let random_value ?(seed = default_seed) ?(size = 30) gen =
let random = random_state_of_seed seed in
Generator.generate gen ~size ~random
;;
let random_sequence ?seed ?sizes gen =
let config =
make_config ~seed ~sizes ~trials:(Some Int.max_value) ~shrink_attempts:None
in
let return = ref Sequence.empty in
Test.with_sample_exn ~config gen ~f:(fun sequence -> return := sequence);
!return
;;
let iter ?seed ?sizes ?trials gen ~f =
let config = make_config ~seed ~sizes ~trials ~shrink_attempts:None in
Test.with_sample_exn ~config gen ~f:(fun sequence -> Sequence.iter sequence ~f)
;;
let test ?seed ?sizes ?trials ?shrinker ?shrink_attempts ?sexp_of ?examples gen ~f =
let config = make_config ~seed ~sizes ~trials ~shrink_attempts in
let test_m = make_test_m ~gen ~shrinker ~sexp_of in
Test.run_exn ~config ?examples ~f test_m
;;
let test_or_error
?seed
?sizes
?trials
?shrinker
?shrink_attempts
?sexp_of
?examples
gen
~f
=
let config = make_config ~seed ~sizes ~trials ~shrink_attempts in
let test_m = make_test_m ~gen ~shrinker ~sexp_of in
Test.run ~config ?examples ~f test_m
;;
let test_distinct_values
(type key)
?seed
?sizes
?sexp_of
gen
~trials
~distinct_values
~compare
=
let module M = struct
type t = key
let (compare : t -> t -> int) = compare
let sexp_of_t =
match sexp_of with
| Some sexp_of -> sexp_of
| None -> sexp_of_opaque
;;
include (val Comparator.make ~compare ~sexp_of_t)
end
in
let fail set =
let expect_count = distinct_values in
let actual_count = Set.length set in
let values =
match sexp_of with
| None -> None
| Some sexp_of_elt -> Some [%sexp (Set.to_list set : elt list)]
in
raise_s
[%message
"insufficient distinct values"
(trials : int)
(expect_count : int)
(actual_count : int)
(values : (Sexp.t option[@sexp.option]))]
in
with_return (fun r ->
let set = ref (Set.empty (module M)) in
iter ?seed ?sizes ~trials gen ~f:(fun elt ->
set := Set.add !set elt;
if Set.length !set >= distinct_values then r.return ());
fail !set)
;;
let test_can_generate
?seed
?sizes
?(trials = default_can_generate_trial_count)
?sexp_of
gen
~f
=
let r = ref [] in
let f_and_enqueue return x = if f x then return `Can_generate else r := x :: !r in
match
With_return.with_return (fun return ->
iter ?seed ?sizes ~trials gen ~f:(f_and_enqueue return.return);
`Cannot_generate)
with
| `Can_generate -> ()
| `Cannot_generate ->
(match sexp_of with
| None -> failwith "cannot generate"
| Some sexp_of_value ->
Error.raise_s [%message "cannot generate" ~attempts:(!r : value list)])
;;
end
include Configure (struct
let default_seed = `Deterministic "an arbitrary but deterministic string"
let default_trial_count =
match Word_size.word_size with
| W64 -> 10_000
| W32 -> 1_000
;;
let default_can_generate_trial_count = 10_000
let default_shrink_attempts = `Limit 1000
let default_sizes =
Sequence.cycle_list_exn (List.range 0 30 ~stop:`inclusive)
;;
end)
module type S = S
module type S1 = S1
module type S2 = S2
module type S_int = S_int
module type S_range = S_range
type nonrec seed = seed
type nonrec shrink_attempts = shrink_attempts
module type Quickcheck_config = Quickcheck_config
module type Quickcheck_configured = Quickcheck_configured