package base_quickcheck

  1. Overview
  2. Docs
Randomized testing framework, designed for compatibility with Base

Install

Dune Dependency

Authors

Maintainers

Sources

base_quickcheck-v0.15.0.tar.gz
sha256=360e6b8f3660398936ec88fecb9e7761370ee63acf8372d3208d4d31c00181f2

doc/src/base_quickcheck/generator.ml.html

Source file generator.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
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
open! Base

module T : sig
  type +'a t

  val create : (size:int -> random:Splittable_random.State.t -> 'a) -> 'a t
  val generate : 'a t -> size:int -> random:Splittable_random.State.t -> 'a
end = struct
  type 'a t = (size:int -> random:Splittable_random.State.t -> 'a) Staged.t

  let create f : _ t = Staged.stage f

  let generate (t : _ t) ~size ~random =
    if size < 0
    then raise_s [%message "Base_quickcheck.Generator.generate: size < 0" (size : int)]
    else Staged.unstage t ~size ~random
  ;;
end

include T

let size = create (fun ~size ~random:_ -> size)

let fn dom rng =
  create (fun ~size ~random ->
    let random = Splittable_random.State.split random in
    fun x ->
      let hash = Observer0.observe dom x ~size ~hash:(Hash.alloc ()) in
      let random = Splittable_random.State.copy random in
      Splittable_random.State.perturb random (Hash.get_hash_value hash);
      generate rng ~size ~random)
;;

let with_size t ~size = create (fun ~size:_ ~random -> generate t ~size ~random)

let perturb t salt =
  create (fun ~size ~random ->
    Splittable_random.State.perturb random salt;
    generate t ~size ~random)
;;

let filter_map t ~f =
  let rec loop ~size ~random =
    let x = generate t ~size ~random in
    match f x with
    | Some y -> y
    | None -> loop ~size:(size + 1) ~random
  in
  create loop
;;

let filter t ~f = filter_map t ~f:(fun x -> if f x then Some x else None)
let return x = create (fun ~size:_ ~random:_ -> x)
let map t ~f = create (fun ~size ~random -> f (generate t ~size ~random))

let apply tf tx =
  create (fun ~size ~random ->
    let f = generate tf ~size ~random in
    let x = generate tx ~size ~random in
    f x)
;;

let bind t ~f =
  create (fun ~size ~random ->
    let x = generate t ~size ~random in
    generate (f x) ~size ~random)
;;

let all list = create (fun ~size ~random -> List.map list ~f:(generate ~size ~random))

let all_unit list =
  create (fun ~size ~random -> List.iter list ~f:(generate ~size ~random))
;;

module For_applicative = Applicative.Make (struct
    type nonrec 'a t = 'a t

    let return = return
    let apply = apply
    let map = `Custom map
  end)

let both = For_applicative.both
let map2 = For_applicative.map2
let map3 = For_applicative.map3

module Applicative_infix = For_applicative.Applicative_infix
include Applicative_infix

module For_monad = Monad.Make (struct
    type nonrec 'a t = 'a t

    let return = return
    let bind = bind
    let map = `Custom map
  end)

let ignore_m = For_monad.ignore_m
let join = For_monad.join

module Monad_infix = For_monad.Monad_infix
include Monad_infix
module Let_syntax = For_monad.Let_syntax
open Let_syntax

let of_list list =
  if List.is_empty list
  then Error.raise_s [%message "Base_quickcheck.Generator.of_list: empty list"];
  let array = Array.of_list list in
  let lo = 0 in
  let hi = Array.length array - 1 in
  create (fun ~size:_ ~random ->
    let index = Splittable_random.int random ~lo ~hi in
    array.(index))
;;

let union list = join (of_list list)

let of_weighted_list alist =
  if List.is_empty alist
  then Error.raise_s [%message "Base_quickcheck.Generator.of_weighted_list: empty list"];
  let weights, values = List.unzip alist in
  let value_array = Array.of_list values in
  let total_weight, cumulative_weight_array =
    let array = Array.init (Array.length value_array) ~f:(fun _ -> 0.) in
    let sum =
      List.foldi weights ~init:0. ~f:(fun index acc weight ->
        if not (Float.is_finite weight)
        then
          Error.raise_s
            [%message
              "Base_quickcheck.Generator.of_weighted_list: weight is not finite"
                (weight : float)];
        if Float.( < ) weight 0.
        then
          Error.raise_s
            [%message
              "Base_quickcheck.Generator.of_weighted_list: weight is negative"
                (weight : float)];
        let cumulative = acc +. weight in
        array.(index) <- cumulative;
        cumulative)
    in
    if Float.( <= ) sum 0.
    then
      Error.raise_s
        [%message "Base_quickcheck.Generator.of_weighted_list: total weight is zero"];
    sum, array
  in
  create (fun ~size:_ ~random ->
    let choice = Splittable_random.float random ~lo:0. ~hi:total_weight in
    match
      Array.binary_search
        cumulative_weight_array
        ~compare:Float.compare
        `First_greater_than_or_equal_to
        choice
    with
    | Some index -> value_array.(index)
    | None -> assert false)
;;

let weighted_union alist = join (of_weighted_list alist)
let of_lazy lazy_t = create (fun ~size ~random -> generate (force lazy_t) ~size ~random)

let fixed_point of_generator =
  let rec lazy_t = lazy (of_generator (of_lazy lazy_t)) in
  force lazy_t
;;

let weighted_recursive_union nonrec_list ~f =
  fixed_point (fun self ->
    let rec_list =
      List.map (f self) ~f:(fun (w, t) ->
        ( w
        , let%bind n = size in
          with_size ~size:(n - 1) t ))
    in
    if List.is_empty nonrec_list || List.is_empty rec_list
    then
      raise_s
        [%message
          "Base_quickcheck.Generator.weighted_recursive_union: lists must be non-empty"];
    let nonrec_gen = weighted_union nonrec_list in
    let rec_gen = weighted_union (nonrec_list @ rec_list) in
    match%bind size with
    | 0 -> nonrec_gen
    | _ -> rec_gen)
;;

let recursive_union nonrec_list ~f =
  let weighted list = List.map list ~f:(fun t -> 1., t) in
  weighted_recursive_union (weighted nonrec_list) ~f:(fun self -> weighted (f self))
;;

let sizes ?(min_length = 0) ?(max_length = Int.max_value) () =
  create (fun ~size ~random ->
    assert (min_length <= max_length);
    let upper_bound = min_length + size in
    let max_length =
      if upper_bound >= min_length (* guard against overflow *)
      then min max_length upper_bound
      else max_length
    in
    (* pick a length, weighted low so that most of the size is spent on elements *)
    let len = Splittable_random.Log_uniform.int random ~lo:min_length ~hi:max_length in
    (* if there are no elements return an empty array, otherwise return a non-empty array
       with the size distributed among the elements *)
    if len = 0
    then []
    else (
      let sizes = Array.init len ~f:(fun _ -> 0) in
      let remaining = size - (len - min_length) in
      let max_index = len - 1 in
      for _ = 1 to remaining do
        (* pick an index, weighted low so that we see unbalanced distributions often *)
        let index = Splittable_random.Log_uniform.int random ~lo:0 ~hi:max_index in
        sizes.(index) <- sizes.(index) + 1
      done;
      (* permute the array so that no index is favored over another *)
      for i = 0 to max_index - 1 do
        let j = Splittable_random.int random ~lo:i ~hi:max_index in
        Array.swap sizes i j
      done;
      assert (Array.sum (module Int) sizes ~f:Fn.id + (len - min_length) = size);
      Array.to_list sizes))
;;

let unit = return ()
let bool = create (fun ~size:_ ~random -> Splittable_random.bool random)
let option value_t = union [ return None; map value_t ~f:Option.return ]
let either fst_t snd_t = union [ map fst_t ~f:Either.first; map snd_t ~f:Either.second ]

let result ok_t err_t =
  map (either ok_t err_t) ~f:(function
    | First ok -> Ok ok
    | Second err -> Error err)
;;

let list_generic ?min_length ?max_length elt_gen =
  let%bind sizes = sizes ?min_length ?max_length () in
  List.map sizes ~f:(fun size -> with_size ~size elt_gen) |> all
;;

let list elt_gen = list_generic elt_gen
let list_non_empty elt_gen = list_generic ~min_length:1 elt_gen

let list_with_length elt_gen ~length =
  list_generic ~min_length:length ~max_length:length elt_gen
;;

let list_filtered elts =
  let elts = Array.of_list elts in
  let length_of_input = Array.length elts in
  create (fun ~size:_ ~random ->
    let length_of_output = Splittable_random.int random ~lo:0 ~hi:length_of_input in
    let indices = Array.init length_of_input ~f:Fn.id in
    (* Choose [length_of_output] random values in the prefix of [indices]. *)
    for i = 0 to length_of_output - 1 do
      let j = Splittable_random.int random ~lo:i ~hi:(length_of_input - 1) in
      Array.swap indices i j
    done;
    (* Sort the chosen indices because we don't want to reorder them. *)
    Array.sort indices ~pos:0 ~len:length_of_output ~compare:Int.compare;
    (* Return the chosen elements. *)
    List.init length_of_output ~f:(fun i -> elts.(indices.(i))))
;;

let list_permutations list =
  create (fun ~size:_ ~random ->
    let array = Array.of_list list in
    for i = 1 to Array.length array - 1 do
      let j = Splittable_random.int random ~lo:0 ~hi:i in
      Array.swap array i j
    done;
    Array.to_list array)
;;

let array t = map (list t) ~f:Array.of_list
let ref t = map t ~f:Ref.create
let lazy_t t = map t ~f:Lazy.from_val

let char_uniform_inclusive lo hi =
  create (fun ~size:_ ~random ->
    Splittable_random.int random ~lo:(Char.to_int lo) ~hi:(Char.to_int hi)
    |> Char.unsafe_of_int)
;;

let char_uppercase = char_uniform_inclusive 'A' 'Z'
let char_lowercase = char_uniform_inclusive 'a' 'z'
let char_digit = char_uniform_inclusive '0' '9'
let char_print_uniform = char_uniform_inclusive ' ' '~'
let char_uniform = char_uniform_inclusive Char.min_value Char.max_value
let char_alpha = union [ char_lowercase; char_uppercase ]

let char_alphanum =
  weighted_union
    (* Most people probably expect this to be a uniform distribution, not weighted
       toward digits like we would get with [union] (since there are fewer digits than
       letters). *)
    [ 52., char_alpha; 10., char_digit ]
;;

let char_whitespace = of_list (List.filter Char.all ~f:Char.is_whitespace)
let char_print = weighted_union [ 10., char_alphanum; 1., char_print_uniform ]

let char =
  weighted_union
    [ 100., char_print
    ; 10., char_uniform
    ; 1., return Char.min_value
    ; 1., return Char.max_value
    ]
;;

(* Produces a number from 0 or 1 to size + 1, weighted high. We have found this
   distribution empirically useful for string lengths. *)
let small_int ~allow_zero =
  create (fun ~size ~random ->
    let lower_bound = if allow_zero then 0 else 1 in
    let upper_bound = size + 1 in
    let weighted_low =
      Splittable_random.Log_uniform.int random ~lo:0 ~hi:(upper_bound - lower_bound)
    in
    let weighted_high = upper_bound - weighted_low in
    weighted_high)
;;

let small_positive_or_zero_int = small_int ~allow_zero:true
let small_strictly_positive_int = small_int ~allow_zero:false

module type Int_with_random = sig
  include Int.S

  val uniform : Splittable_random.State.t -> lo:t -> hi:t -> t
  val log_uniform : Splittable_random.State.t -> lo:t -> hi:t -> t
end

module For_integer (Integer : Int_with_random) = struct
  let uniform_inclusive lo hi =
    create (fun ~size:_ ~random -> Integer.uniform random ~lo ~hi)
  ;;

  let log_uniform_inclusive lo hi =
    create (fun ~size:_ ~random -> Integer.log_uniform random ~lo ~hi)
  ;;

  let non_uniform f lo hi =
    weighted_union [ 0.05, return lo; 0.05, return hi; 0.9, f lo hi ]
  ;;

  let inclusive = non_uniform uniform_inclusive
  let log_inclusive = non_uniform log_uniform_inclusive
  let uniform_all = uniform_inclusive Integer.min_value Integer.max_value

  let all =
    [%map
      let negative = bool
      and magnitude = log_inclusive Integer.zero Integer.max_value in
      if negative then Integer.bit_not magnitude else magnitude]
  ;;
end

module For_int = For_integer (struct
    include Int

    let uniform = Splittable_random.int
    let log_uniform = Splittable_random.Log_uniform.int
  end)

let int = For_int.all
let int_uniform = For_int.uniform_all
let int_inclusive = For_int.inclusive
let int_uniform_inclusive = For_int.uniform_inclusive
let int_log_inclusive = For_int.log_inclusive
let int_log_uniform_inclusive = For_int.log_uniform_inclusive

module For_int32 = For_integer (struct
    include Int32

    let uniform = Splittable_random.int32
    let log_uniform = Splittable_random.Log_uniform.int32
  end)

let int32 = For_int32.all
let int32_uniform = For_int32.uniform_all
let int32_inclusive = For_int32.inclusive
let int32_uniform_inclusive = For_int32.uniform_inclusive
let int32_log_inclusive = For_int32.log_inclusive
let int32_log_uniform_inclusive = For_int32.log_uniform_inclusive

module For_int63 = For_integer (struct
    include Int63

    let uniform = Splittable_random.int63
    let log_uniform = Splittable_random.Log_uniform.int63
  end)

let int63 = For_int63.all
let int63_uniform = For_int63.uniform_all
let int63_inclusive = For_int63.inclusive
let int63_uniform_inclusive = For_int63.uniform_inclusive
let int63_log_inclusive = For_int63.log_inclusive
let int63_log_uniform_inclusive = For_int63.log_uniform_inclusive

module For_int64 = For_integer (struct
    include Int64

    let uniform = Splittable_random.int64
    let log_uniform = Splittable_random.Log_uniform.int64
  end)

let int64 = For_int64.all
let int64_uniform = For_int64.uniform_all
let int64_inclusive = For_int64.inclusive
let int64_uniform_inclusive = For_int64.uniform_inclusive
let int64_log_inclusive = For_int64.log_inclusive
let int64_log_uniform_inclusive = For_int64.log_uniform_inclusive

module For_nativeint = For_integer (struct
    include Nativeint

    let uniform = Splittable_random.nativeint
    let log_uniform = Splittable_random.Log_uniform.nativeint
  end)

let nativeint = For_nativeint.all
let nativeint_uniform = For_nativeint.uniform_all
let nativeint_inclusive = For_nativeint.inclusive
let nativeint_uniform_inclusive = For_nativeint.uniform_inclusive
let nativeint_log_inclusive = For_nativeint.log_inclusive
let nativeint_log_uniform_inclusive = For_nativeint.log_uniform_inclusive
let float_zero_exponent = Float.ieee_exponent 0.
let float_zero_mantissa = Float.ieee_mantissa 0.

let float_max_positive_subnormal_value =
  Float.one_ulp `Down Float.min_positive_normal_value
;;

let float_subnormal_exponent = Float.ieee_exponent Float.min_positive_subnormal_value
let float_min_subnormal_mantissa = Float.ieee_mantissa Float.min_positive_subnormal_value
let float_max_subnormal_mantissa = Float.ieee_mantissa float_max_positive_subnormal_value
let float_max_positive_normal_value = Float.max_finite_value
let float_min_normal_exponent = Float.ieee_exponent Float.min_positive_normal_value
let float_max_normal_exponent = Float.ieee_exponent float_max_positive_normal_value
let float_max_normal_mantissa = Float.ieee_mantissa float_max_positive_normal_value
let float_inf_exponent = Float.ieee_exponent Float.infinity
let float_inf_mantissa = Float.ieee_mantissa Float.infinity
let float_nan_exponent = Float.ieee_exponent Float.nan
let float_min_nan_mantissa = Int63.succ float_inf_mantissa
let float_max_nan_mantissa = float_max_normal_mantissa
let float_num_mantissa_bits = 52

(* We weight mantissas so that "integer-like" values, and values with only a few digits
   past the decimal, are reasonably common. *)
let float_normal_mantissa =
  let%bind num_bits = For_int.uniform_inclusive 0 float_num_mantissa_bits in
  let%map bits =
    For_int63.inclusive Int63.zero (Int63.pred (Int63.shift_left Int63.one num_bits))
  in
  Int63.shift_left bits (Int.( - ) float_num_mantissa_bits num_bits)
;;

let float_exponent_weighted_low lower_bound upper_bound =
  let%map offset = For_int.log_inclusive 0 (Int.( - ) upper_bound lower_bound) in
  Int.( + ) lower_bound offset
;;

let float_exponent_weighted_high lower_bound upper_bound =
  let%map offset = For_int.log_inclusive 0 (Int.( - ) upper_bound lower_bound) in
  Int.( - ) upper_bound offset
;;

(* We weight exponents such that values near 1 are more likely. *)
let float_exponent =
  let midpoint = Float.ieee_exponent 1. in
  union
    [ float_exponent_weighted_high float_min_normal_exponent midpoint
    ; float_exponent_weighted_low midpoint float_max_normal_exponent
    ]
;;

let float_zero =
  let%map negative = bool in
  Float.create_ieee_exn
    ~negative
    ~exponent:float_zero_exponent
    ~mantissa:float_zero_mantissa
;;

let float_subnormal =
  let%map negative = bool
  and exponent = return float_subnormal_exponent
  and mantissa =
    For_int63.log_inclusive float_min_subnormal_mantissa float_max_subnormal_mantissa
  in
  Float.create_ieee_exn ~negative ~exponent ~mantissa
;;

let float_normal =
  let%map negative = bool
  and exponent = float_exponent
  and mantissa = float_normal_mantissa in
  Float.create_ieee_exn ~negative ~exponent ~mantissa
;;

let float_infinite =
  let%map negative = bool in
  Float.create_ieee_exn
    ~negative
    ~exponent:float_inf_exponent
    ~mantissa:float_inf_mantissa
;;

let float_nan =
  let%map negative = bool
  and exponent = return float_nan_exponent
  and mantissa = For_int63.inclusive float_min_nan_mantissa float_max_nan_mantissa in
  Float.create_ieee_exn ~negative ~exponent ~mantissa
;;

let float_of_class c =
  match (c : Float.Class.t) with
  | Zero -> float_zero
  | Subnormal -> float_subnormal
  | Normal -> float_normal
  | Infinite -> float_infinite
  | Nan -> float_nan
;;

let float_weight_of_class c =
  match (c : Float.Class.t) with
  | Zero -> 1.
  | Subnormal -> 10.
  | Normal -> 100.
  | Infinite -> 1.
  | Nan -> 1.
;;

let float_matching_classes filter =
  List.filter_map Float.Class.all ~f:(fun c ->
    if filter c then Some (float_weight_of_class c, float_of_class c) else None)
  |> weighted_union
;;

let float_finite =
  float_matching_classes (function
    | Zero | Subnormal | Normal -> true
    | Infinite | Nan -> false)
;;

let float_without_nan =
  float_matching_classes (function
    | Zero | Subnormal | Normal | Infinite -> true
    | Nan -> false)
;;

let float = float_matching_classes (fun _ -> true)

let float_finite_non_zero =
  float_matching_classes (function
    | Subnormal | Normal -> true
    | Zero | Infinite | Nan -> false)
;;

let float_strictly_positive =
  let%map t = float_finite_non_zero in
  Float.abs t
;;

let float_strictly_negative =
  let%map t = float_finite_non_zero in
  ~-.(Float.abs t)
;;

let float_positive_or_zero =
  let%map t = float_finite in
  Float.abs t
;;

let float_negative_or_zero =
  let%map t = float_finite in
  ~-.(Float.abs t)
;;

let float_uniform_exclusive lower_bound upper_bound =
  let open Float.O in
  if (not (Float.is_finite lower_bound)) || not (Float.is_finite upper_bound)
  then
    raise_s
      [%message
        "Float.uniform_exclusive: bounds are not finite"
          (lower_bound : float)
          (upper_bound : float)];
  let lower_inclusive = Float.one_ulp `Up lower_bound in
  let upper_inclusive = Float.one_ulp `Down upper_bound in
  if lower_inclusive > upper_inclusive
  then
    raise_s
      [%message
        "Float.uniform_exclusive: requested range is empty"
          (lower_bound : float)
          (upper_bound : float)];
  create (fun ~size:_ ~random ->
    Splittable_random.float random ~lo:lower_inclusive ~hi:upper_inclusive)
;;

let float_inclusive lower_bound upper_bound =
  if Float.equal lower_bound upper_bound
  then return lower_bound
  else if Float.( = ) (Float.one_ulp `Up lower_bound) upper_bound
  then union [ return lower_bound; return upper_bound ]
  else
    weighted_union
      [ 0.05, return lower_bound
      ; 0.05, return upper_bound
      ; 0.9, float_uniform_exclusive lower_bound upper_bound
      ]
;;

let string_with_length_of char_gen ~length =
  list_with_length char_gen ~length |> map ~f:String.of_char_list
;;

let string_of char_gen =
  bind small_positive_or_zero_int ~f:(fun length ->
    string_with_length_of char_gen ~length)
;;

let string_non_empty_of char_gen =
  bind small_strictly_positive_int ~f:(fun length ->
    string_with_length_of char_gen ~length)
;;

let string = string_of char
let string_non_empty = string_non_empty_of char
let string_with_length ~length = string_with_length_of char ~length
let bytes = map string ~f:Bytes.of_string

let sexp_of atom =
  fixed_point (fun self ->
    let%bind size = size in
    (* choose a number weighted low so we have a decreasing, but not vanishing, chance
       to generate atoms as size grows *)
    match%bind For_int.log_uniform_inclusive 0 (size + 1) with
    (* generate an atom using the given size *)
    | 0 ->
      let%map atom = atom in
      Sexp.Atom atom
    (* relying on [List.gen] to distribute [size] over sub-sexps *)
    | _ ->
      let%map list = list self in
      Sexp.List list)
;;

let sexp = sexp_of string

let map_tree_using_comparator ~comparator key_gen data_gen =
  let%bind keys = list key_gen in
  let keys = List.dedup_and_sort keys ~compare:comparator.Comparator.compare in
  let%bind data = list_with_length data_gen ~length:(List.length keys) in
  return (Map.Using_comparator.Tree.of_alist_exn ~comparator (List.zip_exn keys data))
;;

let set_tree_using_comparator ~comparator elt_gen =
  map (list elt_gen) ~f:(Set.Using_comparator.Tree.of_list ~comparator)
;;

let comparator_of_m
      (type a c)
      (module M : Comparator.S with type t = a and type comparator_witness = c)
  =
  M.comparator
;;

let map_t_m m key_gen data_gen =
  let comparator = comparator_of_m m in
  map_tree_using_comparator ~comparator key_gen data_gen
  |> map ~f:(Map.Using_comparator.of_tree ~comparator)
;;

let set_t_m m elt_gen =
  let comparator = comparator_of_m m in
  set_tree_using_comparator ~comparator elt_gen
  |> map ~f:(Set.Using_comparator.of_tree ~comparator)
;;

let bigarray1 t kind layout =
  let%map elts = list t in
  let elts = Array.of_list elts in
  let dim = Array.length elts in
  let offset = Bigarray_helpers.Layout.offset layout in
  Bigarray_helpers.Array1.init kind layout dim ~f:(fun i -> elts.(i - offset))
;;

let bigstring = bigarray1 char Char C_layout
let float32_vec = bigarray1 float Float32 Fortran_layout
let float64_vec = bigarray1 float Float64 Fortran_layout

let bigarray2_dim =
  match%bind size with
  | 0 -> return (0, 0)
  | max_total_size ->
    let%bind a =
      (* choose a dimension up to [max_total_size], weighted low to give the other
         dimension a good chance of being comparatively high *)
      int_log_uniform_inclusive 1 max_total_size
    in
    let%bind b =
      (* choose a dimension up to [max_total_size / a], weighted high to reach close to
         [max_total_size] most of the time *)
      let max_b = max_total_size / a in
      let%map b_weighted_low = int_log_uniform_inclusive 0 max_b in
      max_b - b_weighted_low
    in
    (* avoid any skew of a vs b by randomly swapping *)
    if%map bool then a, b else b, a
;;

let bigarray2 t kind layout =
  let%bind dim1, dim2 = bigarray2_dim in
  let%map elts = list_with_length ~length:dim1 (list_with_length ~length:dim2 t) in
  let elts = Array.of_list_map ~f:Array.of_list elts in
  let offset = Bigarray_helpers.Layout.offset layout in
  Bigarray_helpers.Array2.init kind layout dim1 dim2 ~f:(fun i j ->
    elts.(i - offset).(j - offset))
;;

let float32_mat = bigarray2 float Float32 Fortran_layout
let float64_mat = bigarray2 float Float64 Fortran_layout

module Debug = struct
  let coverage
        (type k cmp)
        (module Cmp : Comparator.S with type t = k and type comparator_witness = cmp)
        sample
    =
    Sequence.fold
      sample
      ~init:(Map.empty (module Cmp))
      ~f:(fun counts value ->
        Map.update counts value ~f:(function
          | None -> 1
          | Some prev -> prev + 1))
  ;;

  let monitor t ~f =
    map t ~f:(fun value ->
      f value;
      value)
  ;;
end
OCaml

Innovation. Community. Security.